From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Sat, 30 Nov 2002 20:16:51 +0000 (+0200)
Subject: $0 mofifying part I
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e297595301ee5f3b0643be0fb1fffae9b6b548a0;p=p5sagit%2Fp5-mst-13.2.git
$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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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