$0 mofifying part I

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

p4raw-id: //depot/perl@18229

diff --git a/ext/threads/t/join.t b/ext/threads/t/join.t
index f2c88d5..892f48d 100644 (file)
--- 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 564ded0..3813b9f 100644 (file)
--- 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 64f6497..69bb521 100644 (file)
--- 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 11da315..bc0c28b 100644 (file)
--- 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 258645e..1a71142 100644 (file)
--- 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 9597a8a..90a99df 100644 (file)
--- 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 f6958fd..cbf8564 100755 (executable)
--- 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 1d33161..1b57ebe 100644 (file)
--- 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