$0 mofifying part I

Subject: [PATCH] $0 modifying
Message-ID: <20021130181651.GA5876@kosh.hut.fi>

p4raw-id: //depot/perl@18229

8 files changed, 53 insertions, 28 deletions

diff --git a/ext/threads/t/join.t b/ext/threads/t/join.t
index f2c88d524b..892f48d055 100644
--- a/ext/threads/t/join.t
+++ b/ext/threads/t/join.t
@@ -11,7 +11,7 @@ BEGIN {
 
 use ExtUtils::testlib;
 use strict;
-BEGIN { print "1..10\n" };
+BEGIN { print "1..11\n" };
 use threads;
 use threads::shared;
 
@@ -87,3 +87,30 @@ ok(1,"");
     })->join();
     ok(1,"");
 }
+
+if ($^O eq 'linux') { # We parse ps output so this is OS-dependent.
+
+  # First modify $0 in a subthread.
+  print "# 1a: \$0 = $0\n";
+  join( threads->new( sub {
+	print "# 2a: \$0 = $0\n";
+	$0 = "foobar";
+	print "# 2b: \$0 = $0\n" } ) );
+  print "# 1b: \$0 = $0\n";
+  if (open PS, "ps -f |") {
+    my $ok;
+    while (<PS>) {
+      print "# $_";
+      if (/^\S+\s+$$\s.+\sfoobar\s*$/) {
+	$ok++;
+	last;
+      }
+    }
+    close PS;
+    ok($ok, 'altering $0 is effective');
+  } else {
+    skip("\$0 check: opening 'ps -f |' failed: $!");
+  }
+} else {
+  skip("\$0 check: only on Linux");
+}
diff --git a/makedef.pl b/makedef.pl
index 564ded0f76..3813b9f67a 100644
--- a/makedef.pl
+++ b/makedef.pl
@@ -643,6 +643,7 @@ unless ($define{'USE_ITHREADS'}) {
 		    PL_regex_padav
 		    PL_sharedsv_space
 		    PL_sharedsv_space_mutex
+		    PL_dollarzero_mutex
 		    Perl_dirp_dup
 		    Perl_cx_dup
 		    Perl_si_dup
diff --git a/mg.c b/mg.c
index 64f64978a2..69bb521363 100644
--- a/mg.c
+++ b/mg.c
@@ -2207,6 +2207,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	break;
 #ifndef MACOS_TRADITIONAL
     case '0':
+	LOCK_DOLLARZERO_MUTEX;
 #ifdef HAS_SETPROCTITLE
 	/* The BSDs don't show the argv[] in ps(1) output, they
 	 * show a string from the process struct and provide
@@ -2286,6 +2287,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    for (i = 1; i < PL_origargc; i++)
 		PL_origargv[i] = Nullch;
 	}
+	UNLOCK_DOLLARZERO_MUTEX;
 	break;
 #endif
     }
diff --git a/perl.c b/perl.c
index 11da3153c5..bc0c28b55d 100644
--- a/perl.c
+++ b/perl.c
@@ -489,11 +489,6 @@ perl_destruct(pTHXx)
 	PL_e_script = Nullsv;
     }
 
-    while (--PL_origargc >= 0) {
-        Safefree(PL_origargv[PL_origargc]);
-    }
-    Safefree(PL_origargv);
-
     /* magical thingies */
 
     SvREFCNT_dec(PL_ofs_sv);	/* $, */
@@ -897,21 +892,7 @@ setuid perl scripts securely.\n");
 #endif
 
     PL_origargc = argc;
-    {
-        /* we copy rather than point to argv
-         * since perl_clone will copy and perl_destruct
-         * has no way of knowing if we've made a copy or
-         * just point to argv
-         */
-        int i = PL_origargc;
-        New(0, PL_origargv, i+1, char*);
-        PL_origargv[i] = '\0';
-        while (i-- > 0) {
-            PL_origargv[i] = savepv(argv[i]);
-        }
-    }
-
-
+    PL_origargv = argv;
 
     if (PL_do_undump) {
 
@@ -937,6 +918,10 @@ setuid perl scripts securely.\n");
     oldscope = PL_scopestack_ix;
     PL_dowarn = G_WARN_OFF;
 
+#ifdef USE_ITHREADS
+    MUTEX_INIT(&PL_dollarzero_mutex);
+#endif
+
 #ifdef PERL_FLEXIBLE_EXCEPTIONS
     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
 #else
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 258645e80a..1a71142fea 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -869,6 +869,10 @@ from the ps(1) output.  For example, setting C<$0> to C<"foobar"> will
 result in C<"perl: foobar (perl)">.  This is an operating system
 feature.
 
+In multithreaded scripts Perl coordinates the threads so that any
+thread may modify its copy of the C<$0> and the change becomes visible
+to ps(1) (assuming the operating system plays along).
+
 =item $[
 
 The index of the first element in an array, and of the first character
diff --git a/sv.c b/sv.c
index 9597a8ac36..90a99dfd62 100644
--- a/sv.c
+++ b/sv.c
@@ -10233,12 +10233,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     /* pseudo environmental stuff */
     PL_origargc		= proto_perl->Iorigargc;
-    i = PL_origargc;
-    New(0, PL_origargv, i+1, char*);
-    PL_origargv[i] = '\0';
-    while (i-- > 0) {
-	PL_origargv[i]	= SAVEPV(proto_perl->Iorigargv[i]);
-    }
+    PL_origargv		= proto_perl->Iorigargv;
 
     param->stashes      = newAV();  /* Setup array of objects to call clone on */
 
diff --git a/t/op/magic.t b/t/op/magic.t
index f6958fd5dd..cbf8564497 100755
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -257,7 +257,7 @@ else {
 	    open CMDLINE, "/proc/$$/cmdline") {
 	    chomp(my $line = scalar <CMDLINE>);
 	    my $me = (split /\0/, $line)[0];
-	    ok($me eq $0, 'altering $0 is effective', 'PL_origarg{c,v} copy breaks this');
+	    ok($me eq $0, 'altering $0 is effective');
 	    close CMDLINE;
 	} else {
 	    skip("\$0 check only on Linux and FreeBSD with /proc");
diff --git a/thread.h b/thread.h
index 1d331616b7..1b57ebe9dc 100644
--- a/thread.h
+++ b/thread.h
@@ -326,6 +326,9 @@
 #  define THREAD_RET_CAST(p)	((void *)(p))
 #endif /* THREAD_RET */
 
+#  define LOCK_DOLLARZERO_MUTEX		MUTEX_LOCK(&PL_dollarzero_mutex)
+#  define UNLOCK_DOLLARZERO_MUTEX	MUTEX_UNLOCK(&PL_dollarzero_mutex)
+
 #endif /* USE_ITHREADS */
 
 #ifndef MUTEX_LOCK
@@ -404,6 +407,14 @@
 #  define UNLOCK_SV_LOCK_MUTEX
 #endif
 
+#ifndef LOCK_DOLLARZERO_MUTEX
+#  define LOCK_DOLLARZERO_MUTEX
+#endif
+
+#ifndef UNLOCK_DOLLARZERO_MUTEX
+#  define UNLOCK_DOLLARZERO_MUTEX
+#endif
+
 /* THR, SET_THR, and dTHR are there for compatibility with old versions */
 #ifndef THR
 #  define THR		PERL_GET_THX