In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/781fa0f4588fedaa5faa25afbf2adfa74a85d24b?hp=ed5958d4d0be98bffc846ce92d77c382457feea0>
- Log ----------------------------------------------------------------- commit 781fa0f4588fedaa5faa25afbf2adfa74a85d24b Author: Father Chrysostomos <[email protected]> Date: Thu Apr 12 06:38:59 2012 -0700 [perl #107636] Make Carp::longmess work inside die override When PL_last_in_gv (and hence $.) is set, Carp::longmess uses eval { die } to find out what handle and line number perl will append to the error message. It was not qualifying the die with CORE::, so a CORE::GLOBAL::die override that itself calls Carp::longmess would result in infinite recursion if that override were installed before Carp loaded. This broke Class::Scaffoldâs tests, which began to hang. M dist/Carp/lib/Carp.pm M dist/Carp/t/Carp.t commit cc336327ca70797fda607b15c125e7d157b03e68 Author: Father Chrysostomos <[email protected]> Date: Thu Apr 12 14:50:47 2012 -0700 Increase $Carp::Heavy::VERSION to 1.26 M dist/Carp/lib/Carp/Heavy.pm commit efbca4494726c8dcd5bd82b86144a2e02e739497 Author: Father Chrysostomos <[email protected]> Date: Thu Apr 12 06:39:50 2012 -0700 Increase $Carp::VERSION to 1.26 M dist/Carp/lib/Carp.pm commit 707475cd74fef60149c3f020c29472b1814b3e9b Author: Father Chrysostomos <[email protected]> Date: Sun Apr 8 23:04:38 2012 -0700 Make strict vars respect âpackage ĵ; *õ::bar = [];â In this particular case, the name of the current package in UTF-8 (it cannot be expressed in Latin-1) is the same byte sequence as the name of the package being assigned to in Latin-1. Some of the logic in stashpv_hvname_match was faulty. It worked for a Latin-1 current package assigning to a glob in a UTF-8 package, but not the other way around. M t/lib/strict/vars M util.c commit 6379d4a9afb32e86e55704579c9ac81237309672 Author: Father Chrysostomos <[email protected]> Date: Sun Apr 8 20:25:52 2012 -0700 [perl #112316] Make strict vars respect assignment from null pkg Under threads, strict vars was not respecting glob assignment from a package with a null in its name if the name of the package assigned to was equal to the prefix of the current package up to the null. M cop.h M embed.fnc M gv.c M op.c M proto.h M scope.h M t/lib/strict/vars M util.c commit 862504fb08ed24a37a327d325e83ceac76cf05cf Author: Father Chrysostomos <[email protected]> Date: Sun Apr 8 14:51:57 2012 -0700 [perl #112316] Make strict vars respect assignment to null pkg Under threads, strict vars was not respecting assignment to a package with a null in its name if the name of the package assigned from was equal to the prefix of the destination package up to the null. M t/lib/strict/vars M util.c ----------------------------------------------------------------------- Summary of changes: cop.h | 35 +++++++++++++++++++++-------------- dist/Carp/lib/Carp.pm | 4 ++-- dist/Carp/lib/Carp/Heavy.pm | 2 +- dist/Carp/t/Carp.t | 16 +++++++++++++++- embed.fnc | 5 ++++- gv.c | 6 ++++-- op.c | 1 + proto.h | 5 +---- scope.h | 3 ++- t/lib/strict/vars | 27 +++++++++++++++++++++++++++ util.c | 15 +++++++++------ 11 files changed, 87 insertions(+), 32 deletions(-) diff --git a/cop.h b/cop.h index 8690494..0cfeb44 100644 --- a/cop.h +++ b/cop.h @@ -389,7 +389,7 @@ struct cop { #ifdef USE_ITHREADS char * cop_stashpv; /* package line was compiled in */ char * cop_file; /* file name the following line # is from */ - U32 cop_stashflags; /* currently only SVf_UTF8 */ + I32 cop_stashlen; /* negative for UTF8 */ #else HV * cop_stash; /* package line was compiled in */ GV * cop_filegv; /* file the following line # is from */ @@ -429,25 +429,32 @@ struct cop { # define CopSTASHPV(c) ((c)->cop_stashpv) # ifdef NETWARE -# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL)) +# define CopSTASHPV_set(c,pv,n) ((c)->cop_stashpv = \ + ((pv) ? savepvn(pv,n) : NULL)) # else -# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savesharedpv(pv)) +# define CopSTASHPV_set(c,pv,n) ((c)->cop_stashpv = (pv) \ + ? savesharedpvn(pv,n) : NULL) # endif -# define CopSTASH_flags(c) ((c)->cop_stashflags) -# define CopSTASH_flags_set(c,flags) ((c)->cop_stashflags = flags) +# define CopSTASH_len_set(c,n) ((c)->cop_stashlen = (n)) +# define CopSTASH_len(c) ((c)->cop_stashlen) # define CopSTASH(c) (CopSTASHPV(c) \ - ? gv_stashpv(CopSTASHPV(c), \ - GV_ADD|(CopSTASH_flags(c) \ - ? CopSTASH_flags(c): 0 )) \ + ? gv_stashpvn(CopSTASHPV(c), \ + CopSTASH_len(c) < 0 \ + ? -CopSTASH_len(c) \ + : CopSTASH_len(c), \ + GV_ADD|SVf_UTF8*(CopSTASH_len(c) < 0) \ + ) \ : NULL) -# define CopSTASH_set(c,hv) (CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL), \ - CopSTASH_flags_set(c, \ - ((hv) && HvNAME_HEK(hv) && \ - HvNAMEUTF8(hv)) \ - ? SVf_UTF8 \ - : 0)) +# define CopSTASH_set(c,hv) (CopSTASHPV_set(c, \ + (hv) ? HvNAME_get(hv) : NULL, \ + (hv) ? HvNAMELEN(hv) : 0), \ + CopSTASH_len_set(c, \ + (hv) ? HvNAMEUTF8(hv) \ + ? -HvNAMELEN(hv) \ + : HvNAMELEN(hv) \ + : 0)) # define CopSTASH_eq(c,hv) ((hv) && stashpv_hvname_match(c,hv)) # ifdef NETWARE # define CopSTASH_free(c) SAVECOPSTASH_FREE(c) diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm index fc2eab3..51df862 100644 --- a/dist/Carp/lib/Carp.pm +++ b/dist/Carp/lib/Carp.pm @@ -24,7 +24,7 @@ BEGIN { } } -our $VERSION = '1.25'; +our $VERSION = '1.26'; our $MaxEvalLen = 0; our $Verbose = 0; @@ -291,7 +291,7 @@ sub ret_backtrace { local $@ = ''; local $SIG{__DIE__}; eval { - die; + CORE::die; }; if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) { $mess .= $1; diff --git a/dist/Carp/lib/Carp/Heavy.pm b/dist/Carp/lib/Carp/Heavy.pm index 8094e85..3147d9b 100644 --- a/dist/Carp/lib/Carp/Heavy.pm +++ b/dist/Carp/lib/Carp/Heavy.pm @@ -2,7 +2,7 @@ package Carp::Heavy; use Carp (); -our $VERSION = '1.25'; +our $VERSION = '1.26'; 1; diff --git a/dist/Carp/t/Carp.t b/dist/Carp/t/Carp.t index 803ec0a..815139d 100644 --- a/dist/Carp/t/Carp.t +++ b/dist/Carp/t/Carp.t @@ -3,7 +3,7 @@ no warnings "once"; use Config; use IPC::Open3 1.0103 qw(open3); -use Test::More tests => 59; +use Test::More tests => 60; sub runperl { my(%args) = @_; @@ -430,6 +430,20 @@ $@ =~ s/\n.*//; # just check first line is $@, "heek at ".__FILE__." line ".(__LINE__-2).", <DATA> line 2.\n", 'last handle line num is mentioned'; +like( + runperl( + prog => q< + open FH, q-Makefile.PL-; + <FH>; # set PL_last_in_gv + BEGIN { *CORE::GLOBAL::die = sub { die Carp::longmess(@_) } }; + use Carp; + die fumpts; + >, + ), + qr 'fumpts', + 'Carp::longmess works inside CORE::GLOBAL::die', +); + # New tests go here diff --git a/embed.fnc b/embed.fnc index 17d5bcf..ab2b2f8 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1111,7 +1111,10 @@ p |I32 |same_dirent |NN const char* a|NN const char* b Apda |char* |savepv |NULLOK const char* pv Apda |char* |savepvn |NULLOK const char* pv|I32 len Apda |char* |savesharedpv |NULLOK const char* pv -Apda |char* |savesharedpvn |NN const char *const pv|const STRLEN len + +: NULLOK only to suppress a compiler warning +Apda |char* |savesharedpvn |NULLOK const char *const pv \ + |const STRLEN len Apda |char* |savesharedsvpv |NN SV *sv Apda |char* |savesvpv |NN SV* sv Ap |void |savestack_grow diff --git a/gv.c b/gv.c index a61c34f..f51fe05 100644 --- a/gv.c +++ b/gv.c @@ -911,8 +911,10 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags) sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); #ifdef USE_ITHREADS av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop), - strlen(CopSTASHPV(PL_curcop)), - CopSTASH_flags(PL_curcop) + CopSTASH_len(PL_curcop) < 0 + ? -CopSTASH_len(PL_curcop) + : CopSTASH_len(PL_curcop), + SVf_UTF8*(CopSTASH_len(PL_curcop) < 0) )); #else av_push(superisa, newSVhek(CopSTASH(PL_curcop) diff --git a/op.c b/op.c index 4c3d6d0..3deb025 100644 --- a/op.c +++ b/op.c @@ -10007,6 +10007,7 @@ Perl_rpeep(pTHX_ register OP *o) firstcop->cop_line = secondcop->cop_line; #ifdef USE_ITHREADS firstcop->cop_stashpv = secondcop->cop_stashpv; + firstcop->cop_stashlen = secondcop->cop_stashlen; firstcop->cop_file = secondcop->cop_file; #else firstcop->cop_stash = secondcop->cop_stash; diff --git a/proto.h b/proto.h index a9bd7c5..11a7d1b 100644 --- a/proto.h +++ b/proto.h @@ -3556,10 +3556,7 @@ PERL_CALLCONV char* Perl_savesharedpv(pTHX_ const char* pv) PERL_CALLCONV char* Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) __attribute__malloc__ - __attribute__warn_unused_result__ - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_SAVESHAREDPVN \ - assert(pv) + __attribute__warn_unused_result__; PERL_CALLCONV char* Perl_savesharedsvpv(pTHX_ SV *sv) __attribute__malloc__ diff --git a/scope.h b/scope.h index 22407e1..aa04a79 100644 --- a/scope.h +++ b/scope.h @@ -235,7 +235,8 @@ scope has the given name. Name must be a literal string. #define SAVEPARSER(p) save_pushptr((p), SAVEt_PARSER) #ifdef USE_ITHREADS -# define SAVECOPSTASH(c) SAVEPPTR(CopSTASHPV(c)) +# define SAVECOPSTASH(c) (SAVEPPTR(CopSTASHPV(c)), \ + SAVEI32(CopSTASH_len(c))) # define SAVECOPSTASH_FREE(c) SAVESHAREDPV(CopSTASHPV(c)) # define SAVECOPFILE(c) SAVEPPTR(CopFILE(c)) # define SAVECOPFILE_FREE(c) SAVESHAREDPV(CopFILE(c)) diff --git a/t/lib/strict/vars b/t/lib/strict/vars index fdd7af3..b8c6d1f 100644 --- a/t/lib/strict/vars +++ b/t/lib/strict/vars @@ -536,3 +536,30 @@ use strict 'vars'; no warnings; eval q/$dweck/; EXPECT +######## +# [perl #112316] strict vars getting confused by nulls +# Assigning to a package whose name contains a null +BEGIN { *Foo:: = *{"foo\0bar::"} } +package foo; +*Foo::bar = []; +use strict; +eval 'package Foo; @bar = 1' or die; +EXPECT +######## +# [perl #112316] strict vars getting confused by nulls +# Assigning from within a package whose name contains a null +BEGIN { *Foo:: = *{"foo\0bar::"} } +package Foo; +*foo::bar = []; +use strict; +eval 'package foo; @bar = 1' or die; +EXPECT +######## +# UTF8 and Latin1 package names equivalent at the byte level +use utf8; +# ĵ in UTF-8 is the same as õ in Latin-1 +package ĵ; +*õ::bar = []; +use strict; +eval 'package õ; @bar = 1' or die; +EXPECT diff --git a/util.c b/util.c index d147e9e..716944d 100644 --- a/util.c +++ b/util.c @@ -1182,7 +1182,7 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) { char *const newaddr = (char*)PerlMemShared_malloc(len + 1); - PERL_ARGS_ASSERT_SAVESHAREDPVN; + /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ if (!newaddr) { return write_no_mem(); @@ -5854,25 +5854,28 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) { const char * stashpv = CopSTASHPV(c); const char * name = HvNAME_get(hv); + const bool utf8 = CopSTASH_len(c) < 0; + const I32 len = utf8 ? -CopSTASH_len(c) : CopSTASH_len(c); PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH; if (!stashpv || !name) return stashpv == name; - if ( HvNAMEUTF8(hv) && !(CopSTASH_flags(c) & SVf_UTF8 ? 1 : 0) ) { - if (CopSTASH_flags(c) & SVf_UTF8) { + if ( !HvNAMEUTF8(hv) != !utf8 ) { + if (utf8) { return (bytes_cmp_utf8( - (const U8*)stashpv, strlen(stashpv), + (const U8*)stashpv, len, (const U8*)name, HEK_LEN(HvNAME_HEK(hv))) == 0); } else { return (bytes_cmp_utf8( (const U8*)name, HEK_LEN(HvNAME_HEK(hv)), - (const U8*)stashpv, strlen(stashpv)) == 0); + (const U8*)stashpv, len) == 0); } } else return (stashpv == name - || strEQ(stashpv, name)); + || (HEK_LEN(HvNAME_HEK(hv)) == len + && strEQ(stashpv, name))); /*NOTREACHED*/ return FALSE; } -- Perl5 Master Repository
