diff options
| -rw-r--r-- | gv.c | 4 | ||||
| -rw-r--r-- | mg.c | 19 | ||||
| -rw-r--r-- | pod/perldelta.pod | 21 | ||||
| -rw-r--r-- | t/op/magic.t | 20 |
4 files changed, 50 insertions, 14 deletions
@@ -1470,9 +1470,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, #endif goto magicalize; - case '$': /* $$ */ - SvREADONLY_on(GvSVn(gv)); - goto magicalize; case '!': /* $! */ GvMULTI_on(gv); /* If %! has been used, automatically load Errno.pm. */ @@ -1544,6 +1541,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '>': /* $> */ case '\\': /* $\ */ case '/': /* $/ */ + case '$': /* $$ */ case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -1080,7 +1080,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_copypv(sv, PL_ors_sv); break; case '$': /* $$ */ - sv_setiv(sv, (IV)PerlProc_getpid()); + { + IV const pid = (IV)PerlProc_getpid(); + if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) + /* never set manually, or at least not since last fork */ + sv_setiv(sv, pid); + /* else a value has been assigned manually, so do nothing */ + } break; case '!': @@ -2881,6 +2887,17 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case ':': PL_chopset = SvPV_force(sv,len); break; + case '$': /* $$ */ + /* Store the pid in mg->mg_obj so we can tell when a fork has + occurred. mg->mg_obj points to *$ by default, so clear it. */ + if (isGV(mg->mg_obj)) { + if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ + SvREFCNT_dec(mg->mg_obj); + mg->mg_flags |= MGf_REFCOUNTED; + mg->mg_obj = newSViv((IV)PerlProc_getpid()); + } + else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); + break; case '0': LOCK_DOLLARZERO_MUTEX; #ifdef HAS_SETPROCTITLE diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 9f718c32ed..86841579b6 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -42,6 +42,14 @@ here, but most should go in the L</Performance Enhancements> section. The C<CORE::> prefix can now be used on keywords enabled by L<feature.pm|feature>, even outside the scope of C<use feature>. +=head2 C<$$> can be assigned to + +C<$$> was made read-only in Perl 5.8.0. But only sometimes: C<local $$> +would make it writable again. Some CPAN modules were using C<local $$> or +XS code to bypass the read-only check, so there is no reason to keep C<$$> +read-only. (This change also allowed a bug to be fixed while maintaining +backward compatibility.) + =head1 Security XXX Any security-related notices go here. In particular, any security @@ -54,13 +62,6 @@ L</Selected Bug Fixes> section. [ List each incompatible change as a =head2 entry ] -=head2 C<$$> no longer caches PID - -Previously, if one embeds Perl or uses XS and calls fork(3) from C, Perls -notion of C<$$> could go out of sync with what getpid() returns. By always -fetching the value of C<$$> via getpid(), this potential bug is eliminated. -Code that depends on the caching behavior will break. - =head1 Deprecations XXX Any deprecated features, syntax, modules etc. should be listed here. @@ -987,6 +988,12 @@ fixed [RT #85026]. =item * +Previously, if one embeds Perl or uses XS and calls fork(3) from C, Perl's +notion of C<$$> could go out of sync with what getpid() returns. By always +fetching the value of C<$$> via getpid(), this potential bug is eliminated. + +=item * + Passing the same constant subroutine to both C<index> and C<formline> no longer causes one or the other to fail [RT #89218]. diff --git a/t/op/magic.t b/t/op/magic.t index 31286877ef..585cc40cb5 100644 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -12,7 +12,7 @@ BEGIN { use warnings; use Config; -plan (tests => 87); +plan (tests => 88); $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; @@ -169,8 +169,22 @@ eval { die "foo\n" }; is $@, "foo\n"; cmp_ok($$, '>', 0); -eval { $$++ }; -like ($@, qr/^Modification of a read-only value attempted/); +eval { $$ = 42 }; +is $$, 42, '$$ can be modified'; +SKIP: { + skip "no fork", 1 unless $Config{d_fork}; + (my $kidpid = open my $fh, "-|") // skip "cannot fork: $!", 1; + if($kidpid) { # parent + my $kiddollars = <$fh>; + close $fh or die "cannot close pipe from kid proc: $!"; + is $kiddollars, $kidpid, '$$ is reset on fork'; + } + else { # child + print $$; + $::NO_ENDING = 1; # silence "Looks like you only ran..." + exit; + } +} # $^X and $0 { |