diff --git a/MANIFEST b/MANIFEST index 20548634b26c..9a85a1b19062 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5634,6 +5634,10 @@ t/lib/feature/nonesuch Tests for enabling/disabling nonexistent feature t/lib/feature/removed Tests for enabling/disabling removed feature t/lib/feature/say Tests for enabling/disabling say feature t/lib/feature/switch Tests for enabling/disabling switch feature +t/lib/GH_15109/Apack.pm test Module for caller.t +t/lib/GH_15109/Bpack.pm test Module for caller.t +t/lib/GH_15109/Cpack.pm test Module for caller.t +t/lib/GH_15109/Foo.pm test Module for caller.t t/lib/h2ph.h Test header file for h2ph t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison t/lib/locale/latin1 Part of locale.t in Latin 1 diff --git a/op.c b/op.c index 594d4ee9c329..1ff359ec6adb 100644 --- a/op.c +++ b/op.c @@ -11800,10 +11800,31 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, (void)CvGV(cv); if (floor) LEAVE_SCOPE(floor); ENTER; + + SAVEVPTR(PL_curcop); + if (PL_curcop == &PL_compiling) { + /* Avoid pushing the "global" &PL_compiling onto the + * context stack. For example, a stack trace inside + * nested use's would show all calls coming from whoever + * most recently updated PL_compiling.cop_file and + * cop_line. So instead, temporarily set PL_curcop to a + * private copy of &PL_compiling. PL_curcop will soon be + * set to point back to &PL_compiling anyway but only + * after the temp value has been pushed onto the context + * stack as blk_oldcop. + * This is slightly hacky, but necessary. Note also + * that in the brief window before PL_curcop is set back + * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME + * will give the wrong answer. + */ + PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL); + CopLINE_set(PL_curcop, CopLINE(&PL_compiling)); + SAVEFREEOP(PL_curcop); + } + PUSHSTACKi(PERLSI_REQUIRE); SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); - SAVEVPTR(PL_curcop); DEBUG_x( dump_sub(gv) ); Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 2c295ddbd2ff..ffbb09e79c1b 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -1879,6 +1879,10 @@ It has the same scoping as the C<$^H> and C<%^H> variables. The exact values are considered internal to the L pragma and may change between versions of Perl. +Each time a statement completes being compiled, the current value of +C<${^WARNING_BITS}> is stored with that statement, and can later be +retrieved via C<(caller($level))[9]>. + This variable was added in Perl v5.6.0. =item $OS_ERROR @@ -2175,6 +2179,10 @@ This variable contains compile-time hints for the Perl interpreter. At the end of compilation of a BLOCK the value of this variable is restored to the value when the interpreter started to compile the BLOCK. +Each time a statement completes being compiled, the current value of +C<$^H> is stored with that statement, and can later be retrieved via +C<(caller($level))[8]>. + When perl begins to parse any block construct that provides a lexical scope (e.g., eval body, required file, subroutine body, loop body, or conditional block), the existing value of C<$^H> is saved, but its value is left unchanged. @@ -2223,6 +2231,10 @@ L. All the entries are stringified when accessed at runtime, so only simple values can be accommodated. This means no pointers to objects, for example. +Each time a statement completes being compiled, the current value of +C<%^H> is stored with that statement, and can later be retrieved via +C<(caller($level))[10]>. + When putting items into C<%^H>, in order to avoid conflicting with other users of the hash there is a convention regarding which keys to use. A module should use only keys that begin with the module's name (the diff --git a/t/lib/GH_15109/Apack.pm b/t/lib/GH_15109/Apack.pm new file mode 100644 index 000000000000..fa52ec8b537a --- /dev/null +++ b/t/lib/GH_15109/Apack.pm @@ -0,0 +1,4 @@ +# for use by caller.t for GH #15109 +package Apack; +use Bpack; +1; diff --git a/t/lib/GH_15109/Bpack.pm b/t/lib/GH_15109/Bpack.pm new file mode 100644 index 000000000000..f9421c813fc2 --- /dev/null +++ b/t/lib/GH_15109/Bpack.pm @@ -0,0 +1,4 @@ +# for use by caller.t for GH #15109 +package Bpack; +use Cpack; +1; diff --git a/t/lib/GH_15109/Cpack.pm b/t/lib/GH_15109/Cpack.pm new file mode 100644 index 000000000000..94c409b05ce3 --- /dev/null +++ b/t/lib/GH_15109/Cpack.pm @@ -0,0 +1,11 @@ +# for use by caller.t for GH #15109 +package Cpack; + + +my $i = 0; + +while (my ($package, $file, $line) = caller($i++)) { + push @Cpack::callers, "$file:$line"; +} + +1; diff --git a/t/lib/GH_15109/Foo.pm b/t/lib/GH_15109/Foo.pm new file mode 100644 index 000000000000..1af25470c6ab --- /dev/null +++ b/t/lib/GH_15109/Foo.pm @@ -0,0 +1,9 @@ +# for use by caller.t for GH #15109 + +package Foo; + +sub import { + use warnings; # restore default warnings + () = caller(1); # this used to cause valgrind errors +} +1; diff --git a/t/op/caller.t b/t/op/caller.t index 564d140cc0c2..865b005bf50a 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; require './test.pl'; set_up_inc('../lib'); - plan( tests => 97 ); # some tests are run in a BEGIN block + plan( tests => 111 ); # some tests are run in a BEGIN block } my @c; @@ -335,16 +335,45 @@ $::testing_caller = 1; do './op/caller.pl' or die $@; +# GH #15109 +# See that callers within a nested series of 'use's gets the right +# filenames. +{ + local @INC = 'lib/GH_15109/'; + # Apack use's Bpack which use's Cpack which populates @Cpack::caller + # with the file:N of all the callers + eval 'use Apack; 1'; + is($@, "", "GH #15109 - eval"); + is (scalar(@Cpack::callers), 10, "GH #15109 - callers count"); + like($Cpack::callers[$_], qr{GH_15109/Bpack.pm:3}, "GH #15109 level $_") for 0..2; + like($Cpack::callers[$_], qr{GH_15109/Apack.pm:3}, "GH #15109 level $_") for 3..5; + like($Cpack::callers[$_], qr{\(eval \d+\):1}, "GH #15109 level $_") for 6..8; + like($Cpack::callers[$_], qr{caller\.t}, "GH #15109 level $_") for 9; + + # GH #15109 followup - the original fix wasn't saving cop_warnings + # correctly and this code used to crash or fail valgrind + + my $w = 0; + local $SIG{__WARN__} = sub { $w++ }; + eval q{ + use warnings; + no warnings 'numeric'; # ensure custom cop_warnings + use Foo; # this used to mess up warnings flags + BEGIN { my $x = "foo" + 1; } # potential "numeric" warning + }; + is ($@, "", "GH #15109 - eval okay"); + is ($w, 0, "GH #15109 - warnings restored"); +} + { package RT129239; BEGIN { my ($pkg, $file, $line) = caller; ::is $file, 'virtually/op/caller.t', "BEGIN block sees correct caller filename"; ::is $line, 12345, "BEGIN block sees correct caller line"; - TODO: { - local $::TODO = "BEGIN blocks have wrong caller package [perl #129239]"; - ::is $pkg, 'RT129239', "BEGIN block sees correct caller package"; - } + ::is $pkg, 'RT129239', "BEGIN block sees correct caller package"; #line 12345 "virtually/op/caller.t" } + } +