In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/49bb71aec3ca9a185f018c6b8f85bad3580522af?hp=fc2b2dcaa051537d8d92ccf366f291581b26024b>
- Log ----------------------------------------------------------------- commit 49bb71aec3ca9a185f018c6b8f85bad3580522af Author: Father Chrysostomos <[email protected]> Date: Sun Dec 9 06:15:20 2012 -0800 Fix problems with -Dr during global destruction $ cat foo my $x = '(?{1})'; BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'" "a" =~ /a$_/ for $x; If I run this under PERL_DESTRUCT_LEVEL=2 with the -Dr flag on a non- threaded build, the output ends with this: during global destruction. during global destruction. during global destruction. during global destruction. during global destruction. Attempt to free temp prematurely: SV 0x822610 during global destruction. Attempt to free temp prematurely: SV 0x802340 during global destruction. Attempt to free temp prematurely: SV 0x8222d0 during global destruction. Attempt to free temp prematurely: SV 0x822490 during global destruction. Attempt to free temp prematurely: SV 0x8224f0 during global destruction. Scalars leaked: 5 And sometimes I even get assertion failures. (I suspect hash random- isation gives me the inconsistent results.) t/re/recompile.t happened to trigger this bug, producing noisy output. Since the assertion failures were in sub-processes, the tests passed anyway. In this commit I have changed the test to check the status of the sub-processes, too, before reporting a pass. This bug appears to have started happening in v5.17.0-424-gd24ca0c, but I donât know why. I suspect it was a latent bug waiting to happen. During global destruction, all objects are freed, the main stash is freed, and then various SVs in interpreter variables are also freed. Finally, if PERL_DESTRUCT_LEVEL is set, there is one last sweep of all remaining SVs. It is during that sweep that this bug occurs. When the -Dr flag is present, freeing a regular expression causes the ${^RE_DEBUG_FLAGS} flags variable to be looked up. Symbol lookup can trigger the âGlobal symbol requires package nameâ error (which becomes a warning here, due to the way pp_ctl.c:qerror works). The code that produces that error assumes that if there is no stash then the preceding code has detected an attempted stricture violation. The preceding code actually tries to provide PL_defstash (aka %main::) as the stash to look in, since this is a punctuation variable. But PL_defstash has been set to null. The logic that no stash equals a stricture violation is there- fore faulty. The attempt to output that error message uses a temporary scalar which is placed on the mortals stack. Freeing of the items on the mortals stack happens before this SV sweep, and not during or afterwards, so the SV sweep ends up trying to free those mortals itself. There is a check in sv_free2, enabled under debugging builds, to see whether the SV is on the mortals stacking. If it is, a warning is emitted and the SV is not freed. My initial attempt at fixing this was to try to avoid putting a mortal on the stack in this case. The code in question doesnât actually need to use the mortals stack, since Perl_mess isnât going to croak, so it can free the SV itself. That takes care of the âAttempt to free temp prematurelyâ warnings and the final âScalars leakedâ. It doesnât solve the âduring global destructionâ message, but I decided to leave it in place anyway, since creating an SV and freeing it is a little more efficient that creating it, pushing it on to the mortals stack, and having FREETMPS free it later. That âduring global destructionâ message is supposed to say âGlobal symbol...â, but diagnostic messages during global destruction use the same SV, so itâs not suprising that it gets stomped on before it makes its way to qerror. Iâm not sure where it gets stomped on, but itâs not relevant; we need to get rid of the message altogether. The final solution is to skip the âGlobal symbol...â error altogether while sv_clean_all (the final SV sweep) is being called, which we can detect based on whether PL_in_clean_all is set. M gv.c M t/re/recompile.t commit 11ddfebc6e521f916fd05108e3faa74e7ed132b8 Author: Father Chrysostomos <[email protected]> Date: Sun Dec 9 06:05:22 2012 -0800 Donât leak when partly iterated glob op is freed File::Glob keeps its own hash of arrays of file names. Each array corresponds to one call site. When iteration finishes, it deletes the array. But if iteration never finishes, and the op at the call site is freed, the array remains. So eval "scalar<*>" will cause a memory leak. We already have a mechanism for hooking the freeing of ops. So File::Glob can use that. M ext/File-Glob/Glob.xs M t/op/svleak.t commit 6e2f1cd4c88b28bee7c3d0d21ce95d5b9fc4f991 Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 18:24:12 2012 -0800 Increase $File::Glob::VERSION to 1.19 M ext/File-Glob/Glob.pm commit fc99edcf6b3d3de59f7bdefc42a09167fd8b96f5 Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 16:52:37 2012 -0800 Remove the second param to tryAMAGICunTARGETlist This parameter is no longer used. Its value is always 0. M pp.h M pp_hot.c M pp_sys.c commit 05fbd38ddf3c46a4eef17ff66379724f742f015f Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 16:48:32 2012 -0800 pp.h: Remove tryAMAGICunTARGET This macro is unused on CPAN and completely undocumented, so this change should be safe. M pp.h commit 8936b48a49448f4e7b8a0b9849a085b48ac700ff Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 16:43:00 2012 -0800 Zap PL_glob_index As of the previous commit, nothing is using it. M embedvar.h M intrpvar.h M sv.c commit c58b680b06b94939ee921d7062cd14927136ae30 Author: Father Chrysostomos <[email protected]> Date: Sat Apr 28 00:18:30 2012 -0700 Stop using PL_glob_index for PL_globhook If Glob.xs just uses the address of PL_op as its iterator key all the time (when called via PL_globhook too, not just via a glob override), the code is simpler. M ext/File-Glob/Glob.xs M op.c M pp_sys.c commit 9423a867e1bcf854b0ed9fff9eacaadd6f48ca8d Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 16:38:59 2012 -0800 Donât pass PL_glob_index to glob overrides This magic second argument is undocumented and unused on CPAN and in the core (as of the last few commits). It could also get in the way of making glob truly overridable in the future (e.g., allowing File::Glob to take a list). M op.c M pp_sys.c commit f01818e214428dd68e3cb9d9c7cead608216ffa5 Author: Father Chrysostomos <[email protected]> Date: Fri Apr 27 17:08:15 2012 -0700 File::Glob: Donât use the magic 2nd arg to glob See the previous commit. The same applies to File::Glob as well. In short, the easiest way to fix a memory leak involves using the address of the glob op rather than a special glob index. M ext/File-Glob/Glob.pm M ext/File-Glob/Glob.xs commit c619428f3ddd8b400d932fe55a95dbfa57c647fc Author: Father Chrysostomos <[email protected]> Date: Fri Apr 27 16:48:36 2012 -0700 DosGlob: Donât use the magic 2nd arg to glob Use the address of the glob op instead. This argument is going away, because it is undocumented, unused on CPAN outside of the core, and may get in the way of allowing glob() to be overridden properly. Another reason is that File::DosGlob leaks memory, because a glob op freed before iteration has finished will leave File::DosGlob still holding on to the remainder of the list of files. The easiest way to fix that will involve using an op address instead of a special index, so there will be no reason to keep it. M MANIFEST A ext/File-DosGlob/DosGlob.xs M ext/File-DosGlob/lib/File/DosGlob.pm M ext/File-DosGlob/t/DosGlob.t commit e2f137a79fc59f85f7323ded9b1a55055d085f0c Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 10:29:55 2012 -0800 Increase $File::DosGlob::VERSION to 1.09 M ext/File-DosGlob/lib/File/DosGlob.pm commit 005b65f96d123f08200523d5fe667d7ec9a1793c Author: Father Chrysostomos <[email protected]> Date: Fri Apr 27 14:05:39 2012 -0700 Move File::DosGlob from lib to ext M MANIFEST M Porting/Maintainers.pl A ext/File-DosGlob/lib/File/DosGlob.pm A ext/File-DosGlob/t/DosGlob.t D lib/File/DosGlob.pm D lib/File/DosGlob.t commit d4f87935b315c22d0c227786e8c86afa52067dc7 Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 09:58:31 2012 -0800 hv.c: hv_undef: Donât set mro fields to null before freeing There is no point in modifying a struct just before freeing it. This was my mistake, in commit 47f1cf7702, when I moved the code from S_hfreeentries to hv_undef. M hv.c commit e7881358a40c0c95ec67889ca179bd8ca552060a Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 06:14:42 2012 -0800 Use SvREFCNT_dec_NN in gv.c Various SvREFCNT_dec calls in gv.c are never given null pointers, so there is no need to check for them. I added one const mostly for code documentation purposes (so one can see at a glance that the variable wonât change). M gv.c commit 5f95447316b04ae4c8e2a2f94e998de5feb87e31 Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 06:06:11 2012 -0800 Switch dump.c over to using SvREFCNT_dec_NN No uses of SvREFCNT_dec in dump.c are ever passed null SVs, so donât check for that. M dump.c commit 8e217d4af45bd3ca441339d3a0ca39d1d1b14293 Author: Father Chrysostomos <[email protected]> Date: Sat Dec 8 06:00:28 2012 -0800 doio.c: Use SvREFCNT_dec_NN The sole use of SvREFCNT_dec in doio.c is on a variable than is never null (setdefout would fail an assertion otherwise), so no need to check whether it is. M doio.c ----------------------------------------------------------------------- Summary of changes: MANIFEST | 5 ++- Porting/Maintainers.pl | 2 +- doio.c | 2 +- dump.c | 28 +++++++++--------- embedvar.h | 1 - ext/File-DosGlob/DosGlob.xs | 18 ++++++++++++ {lib => ext/File-DosGlob/lib}/File/DosGlob.pm | 10 +++--- {lib/File => ext/File-DosGlob/t}/DosGlob.t | 7 ++++- ext/File-Glob/Glob.pm | 4 +- ext/File-Glob/Glob.xs | 37 +++++++++++++++---------- gv.c | 24 +++++++++------- hv.c | 12 +++----- intrpvar.h | 2 - op.c | 7 +---- pp.h | 14 +++------ pp_hot.c | 2 +- pp_sys.c | 15 +++++----- sv.c | 1 - t/op/svleak.t | 6 +++- t/re/recompile.t | 2 +- 20 files changed, 111 insertions(+), 88 deletions(-) create mode 100644 ext/File-DosGlob/DosGlob.xs rename {lib => ext/File-DosGlob/lib}/File/DosGlob.pm (98%) rename {lib/File => ext/File-DosGlob/t}/DosGlob.t (94%) diff --git a/MANIFEST b/MANIFEST index 587f9cc..a8ff0e6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3742,6 +3742,9 @@ ext/FileCache/t/04twoarg.t See if FileCache works ext/FileCache/t/05override.t See if FileCache works ext/FileCache/t/06export.t See if FileCache exporting works ext/FileCache/t/07noimport.t See if FileCache works without importing +ext/File-DosGlob/DosGlob.xs Win32 DOS-globbing module +ext/File-DosGlob/lib/File/DosGlob.pm Win32 DOS-globbing module +ext/File-DosGlob/t/DosGlob.t See if File::DosGlob works ext/File-Glob/bsd_glob.c File::Glob extension run time code ext/File-Glob/bsd_glob.h File::Glob extension header file ext/File-Glob/Changes File::Glob extension changelog @@ -4273,8 +4276,6 @@ lib/File/Compare.pm Emulation of cmp command lib/File/Compare.t See if File::Compare works lib/File/Copy.pm Emulation of cp command lib/File/Copy.t See if File::Copy works -lib/File/DosGlob.pm Win32 DOS-globbing module -lib/File/DosGlob.t See if File::DosGlob works lib/File/Find.pm Routines to do a find lib/File/Find/t/find.t See if File::Find works lib/File/Find/t/taint.t See if File::Find works with taint diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 9fffb42..0315215 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -805,7 +805,7 @@ use File::Glob qw(:case); 'File::DosGlob' => { 'MAINTAINER' => 'p5p', - 'FILES' => q[lib/File/DosGlob.{pm,t}], + 'FILES' => q[ext/File-DosGlob], 'UPSTREAM' => 'blead', }, diff --git a/doio.c b/doio.c index 08ed433..1cc0e41 100644 --- a/doio.c +++ b/doio.c @@ -908,7 +908,7 @@ Perl_nextargv(pTHX_ GV *gv) { GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); setdefout(oldout); - SvREFCNT_dec(oldout); + SvREFCNT_dec_NN(oldout); return NULL; } setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO)); diff --git a/dump.c b/dump.c index 15beb69..9d5811c 100644 --- a/dump.c +++ b/dump.c @@ -560,7 +560,7 @@ Perl_sv_peek(pTHX_ SV *sv) Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", sv_uni_display(tmp, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ)); - SvREFCNT_dec(tmp); + SvREFCNT_dec_NN(tmp); } } else if (SvNOKp(sv)) { @@ -624,7 +624,7 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { SV * const tmpsv = pm_description(pm); Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); - SvREFCNT_dec(tmpsv); + SvREFCNT_dec_NN(tmpsv); } Perl_dump_indent(aTHX_ level-1, file, "}\n"); @@ -865,7 +865,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) { else \ PerlIO_printf(file, " flags=\"%s\"", \ SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \ - SvREFCNT_dec(tmpsv); \ + SvREFCNT_dec_NN(tmpsv); \ } #if !defined(PERL_MAD) @@ -953,7 +953,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) { } else if (!xml) \ Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \ (UV)oppriv); \ - SvREFCNT_dec(tmpsv); \ + SvREFCNT_dec_NN(tmpsv); \ } @@ -1046,7 +1046,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) level--; Perl_dump_indent(aTHX_ level, file, "}\n"); - SvREFCNT_dec(tmpsv); + SvREFCNT_dec_NN(tmpsv); } #endif @@ -1281,7 +1281,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 if (mg->mg_type != PERL_MAGIC_utf8) { SV * const sv = newSVpvs(""); PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); - SvREFCNT_dec(sv); + SvREFCNT_dec_NN(sv); } } else if (mg->mg_len == HEf_SVKEY) { @@ -1586,12 +1586,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_printf(file, "%s%s\n", svtypenames[type], s); if (type == SVt_NULL) { - SvREFCNT_dec(d); + SvREFCNT_dec_NN(d); return; } } else { PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s); - SvREFCNT_dec(d); + SvREFCNT_dec_NN(d); return; } @@ -1645,7 +1645,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } if (type < SVt_PV) { - SvREFCNT_dec(d); + SvREFCNT_dec_NN(d); return; } @@ -2136,7 +2136,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } break; } - SvREFCNT_dec(d); + SvREFCNT_dec_NN(d); } void @@ -2225,7 +2225,7 @@ Perl_debop(pTHX_ const OP *o) #endif gv_fullname3(sv, cGVOPo_gv, NULL); PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv)); - SvREFCNT_dec(sv); + SvREFCNT_dec_NN(sv); } else PerlIO_printf(Perl_debug_log, "(NULL)"); @@ -2801,7 +2801,7 @@ Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) sv_catxmlsv(tmpsv, MUTABLE_SV(r)); Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n", SvPVX(tmpsv)); - SvREFCNT_dec(tmpsv); + SvREFCNT_dec_NN(tmpsv); Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n", (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP"); } @@ -2810,7 +2810,7 @@ Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { SV * const tmpsv = pm_description(pm); Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); - SvREFCNT_dec(tmpsv); + SvREFCNT_dec_NN(tmpsv); } level--; @@ -3033,7 +3033,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) level--; Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n"); - SvREFCNT_dec(tmpsv); + SvREFCNT_dec_NN(tmpsv); } switch (optype) { diff --git a/embedvar.h b/embedvar.h index 05438e2..9fc6709 100644 --- a/embedvar.h +++ b/embedvar.h @@ -178,7 +178,6 @@ #define PL_formtarget (vTHX->Iformtarget) #define PL_generation (vTHX->Igeneration) #define PL_gensym (vTHX->Igensym) -#define PL_glob_index (vTHX->Iglob_index) #define PL_globalstash (vTHX->Iglobalstash) #define PL_globhook (vTHX->Iglobhook) #define PL_hintgv (vTHX->Ihintgv) diff --git a/ext/File-DosGlob/DosGlob.xs b/ext/File-DosGlob/DosGlob.xs new file mode 100644 index 0000000..b8a0612 --- /dev/null +++ b/ext/File-DosGlob/DosGlob.xs @@ -0,0 +1,18 @@ +#define PERL_NO_GET_CONTEXT + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +MODULE = File::DosGlob PACKAGE = File::DosGlob + +PROTOTYPES: DISABLE + +SV * +_callsite(...) + CODE: + RETVAL = newSVpvn( + (char *)&cxstack[cxstack_ix].blk_sub.retop, sizeof(OP *) + ); + OUTPUT: + RETVAL diff --git a/lib/File/DosGlob.pm b/ext/File-DosGlob/lib/File/DosGlob.pm similarity index 98% rename from lib/File/DosGlob.pm rename to ext/File-DosGlob/lib/File/DosGlob.pm index 8208f67..792944b 100644 --- a/lib/File/DosGlob.pm +++ b/ext/File-DosGlob/lib/File/DosGlob.pm @@ -6,10 +6,13 @@ package File::DosGlob; -our $VERSION = '1.08'; +our $VERSION = '1.09'; use strict; use warnings; +require XSLoader; +XSLoader::load(); + sub doglob { my $cond = shift; my @retval = (); @@ -103,15 +106,12 @@ sub doglob { my %entries; sub glob { - my($pat,$cxix) = @_; + my($pat,$cxix) = ($_[0], _callsite()); my @pat; # glob without args defaults to $_ $pat = $_ unless defined $pat; - # assume global context if not provided one - $cxix = '_G_' unless defined $cxix; - # if we're just beginning, do it all first if (!$entries{$cxix}) { # extract patterns diff --git a/lib/File/DosGlob.t b/ext/File-DosGlob/t/DosGlob.t similarity index 94% rename from lib/File/DosGlob.t rename to ext/File-DosGlob/t/DosGlob.t index 9227cb9..1e4f7f3 100644 --- a/lib/File/DosGlob.t +++ b/ext/File-DosGlob/t/DosGlob.t @@ -4,8 +4,13 @@ # test glob() in File::DosGlob # +# Make sure it can load before other XS extensions +use File::DosGlob; + +use FindBin; +use File::Spec::Functions; BEGIN { - chdir 't' if -d 't'; + chdir catfile $FindBin::Bin, (updir)x3, 't'; @INC = '../lib'; } diff --git a/ext/File-Glob/Glob.pm b/ext/File-Glob/Glob.pm index 89dd420..a9c5a97 100644 --- a/ext/File-Glob/Glob.pm +++ b/ext/File-Glob/Glob.pm @@ -38,7 +38,7 @@ pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob" @EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob'); -$VERSION = '1.18'; +$VERSION = '1.19'; sub import { require Exporter; @@ -71,7 +71,7 @@ if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) { # File::Glob::glob() is deprecated because its prototype is different from # CORE::glob() (use bsd_glob() instead) sub glob { - splice @_, 1; # don't pass PL_glob_index as flags! + splice @_, 1; # no flags goto &bsd_glob; } diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs index d74e7a4..4c08776 100644 --- a/ext/File-Glob/Glob.xs +++ b/ext/File-Glob/Glob.xs @@ -67,19 +67,13 @@ iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, SV *patsv)) dSP; dMY_CXT; - SV * const cxixsv = POPs; - const char *cxixpv; - STRLEN cxixlen; + const char * const cxixpv = (char *)&PL_op; + STRLEN const cxixlen = sizeof(OP *); AV *entries; U32 const gimme = GIMME_V; SV *patsv = POPs; bool on_stack = FALSE; - /* assume global context if not provided one */ - SvGETMAGIC(cxixsv); - if (SvOK(cxixsv)) cxixpv = SvPV_nomg(cxixsv, cxixlen); - else cxixpv = "_G_", cxixlen = 3; - if (!MY_CXT.x_GLOB_ENTRIES) MY_CXT.x_GLOB_ENTRIES = newHV(); entries = (AV *)*(hv_fetch(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 1)); @@ -318,6 +312,19 @@ doglob_iter_wrapper(pTHX_ AV *entries, SV *patsv) return FALSE; } +static Perl_ophook_t old_ophook; + +static void +glob_ophook(pTHX_ OP *o) +{ + dMY_CXT; + if (MY_CXT.x_GLOB_ENTRIES + && (o->op_type == OP_GLOB || o->op_type == OP_ENTERSUB)) + hv_delete(MY_CXT.x_GLOB_ENTRIES, (char *)&o, sizeof(OP *), + G_DISCARD); + if (old_ophook) old_ophook(aTHX_ o); +} + MODULE = File::Glob PACKAGE = File::Glob int @@ -355,13 +362,11 @@ void csh_glob(...) PPCODE: /* For backward-compatibility with the original Perl function, we sim- - * ply take the first two arguments, regardless of how many there are. + * ply take the first argument, regardless of how many there are. */ - if (items >= 2) SP += 2; + if (items) SP ++; else { - SP += items; XPUSHs(&PL_sv_undef); - if (!items) XPUSHs(&PL_sv_undef); } PUTBACK; csh_glob_iter(aTHX); @@ -370,11 +375,9 @@ PPCODE: void bsd_glob_override(...) PPCODE: - if (items >= 2) SP += 2; + if (items) SP ++; else { - SP += items; XPUSHs(&PL_sv_undef); - if (!items) XPUSHs(&PL_sv_undef); } PUTBACK; iterate(aTHX_ doglob_iter_wrapper); @@ -395,6 +398,10 @@ BOOT: dMY_CXT; MY_CXT.x_GLOB_ENTRIES = NULL; } + OP_REFCNT_LOCK; + old_ophook = PL_opfreehook; + PL_opfreehook = glob_ophook; + OP_REFCNT_UNLOCK; } INCLUDE: const-xs.inc diff --git a/gv.c b/gv.c index 8aa2ace..c1618c2 100644 --- a/gv.c +++ b/gv.c @@ -225,7 +225,7 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) if (oldgv) { if (CvCVGV_RC(cv)) { - SvREFCNT_dec(oldgv); + SvREFCNT_dec_NN(oldgv); CvCVGV_RC_off(cv); } else { @@ -697,7 +697,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, } else { /* stale cache entry, junk it and move on */ - SvREFCNT_dec(cand_cv); + SvREFCNT_dec_NN(cand_cv); GvCV_set(topgv, NULL); cand_cv = NULL; GvCVGEN(topgv) = 0; @@ -1159,7 +1159,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) */ CvSTASH_set(cv, stash); if (SvPOK(cv)) { /* Ouch! */ - SV *tmpsv = newSVpvn_flags(name, len, is_utf8); + SV * const tmpsv = newSVpvn_flags(name, len, is_utf8); STRLEN ulen; const char *proto = CvPROTO(cv); assert(proto); @@ -1173,7 +1173,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) SvTEMP_on(tmpsv); /* Allow theft */ sv_setsv_nomg((SV *)cv, tmpsv); SvTEMP_off(tmpsv); - SvREFCNT_dec(tmpsv); + SvREFCNT_dec_NN(tmpsv); SvLEN(cv) = SvCUR(cv) + 1; SvCUR(cv) = ulen; } @@ -1264,7 +1264,7 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp type, varname, SVfARG(namesv), methpv); LEAVE; } - else SvREFCNT_dec(namesv); + else SvREFCNT_dec_NN(namesv); return stash; } @@ -1588,14 +1588,16 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* By this point we should have a stash and a name */ if (!stash) { - if (add) { + if (add && !PL_in_clean_all) { + SV * const namesv = newSVpvn_flags(name, len, is_utf8); SV * const err = Perl_mess(aTHX_ "Global symbol \"%s%"SVf"\" requires explicit package name", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" - : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8))); + : ""), SVfARG(namesv)); GV *gv; + SvREFCNT_dec_NN(namesv); if (USE_UTF8_IN_NAMES) SvUTF8_on(err); qerror(err); @@ -2016,7 +2018,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))) )) (void)hv_store(stash,name,len,(SV *)gv,0); - else SvREFCNT_dec(gv), gv = NULL; + else SvREFCNT_dec_NN(gv), gv = NULL; } if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); return gv; @@ -2125,7 +2127,7 @@ Perl_gp_ref(pTHX_ GP *gp) /* If the GP they asked for a reference to contains a method cache entry, clear it first, so that we don't infect them with our cached entry */ - SvREFCNT_dec(gp->gp_cv); + SvREFCNT_dec_NN(gp->gp_cv); gp->gp_cv = NULL; gp->gp_cvgen = 0; } @@ -2227,7 +2229,7 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) for (i = 1; i < NofAMmeth; i++) { CV * const cv = amtp->table[i]; if (cv) { - SvREFCNT_dec(MUTABLE_SV(cv)); + SvREFCNT_dec_NN(MUTABLE_SV(cv)); amtp->table[i] = NULL; } } @@ -2948,7 +2950,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { SvRV_set(left, rv_copy); SvSETMAGIC(left); - SvREFCNT_dec(tmpRef); + SvREFCNT_dec_NN(tmpRef); } } diff --git a/hv.c b/hv.c index 23130cc..e9e3b27 100644 --- a/hv.c +++ b/hv.c @@ -1753,16 +1753,14 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) } if((meta = aux->xhv_mro_meta)) { if (meta->mro_linear_all) { - SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all)); - meta->mro_linear_all = NULL; - /* This is just acting as a shortcut pointer. */ - meta->mro_linear_current = NULL; - } else if (meta->mro_linear_current) { + SvREFCNT_dec_NN(meta->mro_linear_all); + /* mro_linear_current is just acting as a shortcut pointer, + hence the else. */ + } + else /* Only the current MRO is stored, so this owns the data. */ SvREFCNT_dec(meta->mro_linear_current); - meta->mro_linear_current = NULL; - } SvREFCNT_dec(meta->mro_nextmethod); SvREFCNT_dec(meta->isa); Safefree(meta); diff --git a/intrpvar.h b/intrpvar.h index d905208..004989c 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -764,8 +764,6 @@ PERLVAR(I, custom_ops, HV *) /* custom op registrations */ /* Hook for File::Glob */ PERLVARI(I, globhook, globhook_t, NULL) -PERLVARI(I, glob_index, int, 0) - PERLVAR(I, reentrant_retint, int) /* Integer return value from reentrant functions */ /* The last unconditional member of the interpreter structure when 5.10.0 was diff --git a/op.c b/op.c index 6240225..fd114b1 100644 --- a/op.c +++ b/op.c @@ -8980,12 +8980,10 @@ Perl_ck_glob(pTHX_ OP *o) * \ mark - glob - rv2cv * | \ gv(CORE::GLOBAL::glob) * | - * \ null - const(wildcard) - const(ix) + * \ null - const(wildcard) */ o->op_flags |= OPf_SPECIAL; o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); - op_append_elem(OP_GLOB, o, - newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); o = newLISTOP(OP_LIST, 0, o, NULL); o = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, o, @@ -9007,9 +9005,6 @@ Perl_ck_glob(pTHX_ OP *o) gv = (GV *)newSV(0); gv_init(gv, 0, "", 0, 0); gv_IOadd(gv); -#ifndef PERL_EXTERNAL_GLOB - sv_setiv(GvSVn(gv),PL_glob_index++); -#endif op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); SvREFCNT_dec_NN(gv); /* newGVOP increased it */ scalarkids(o); diff --git a/pp.h b/pp.h index 4d5eeec..377d489 100644 --- a/pp.h +++ b/pp.h @@ -420,25 +420,21 @@ Does not use C<TARG>. See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>. /* No longer used in core. Use AMG_CALLunary instead */ #define AMG_CALLun(sv,meth) AMG_CALLunary(sv, CAT2(meth,_amg)) -#define tryAMAGICunTARGET(meth, shift, jump) \ - tryAMAGICunTARGET_flags(meth, shift, jump, 0) -#define tryAMAGICunTARGETlist(meth, shift, jump) \ - tryAMAGICunTARGET_flags(meth, shift, jump, AMGf_want_list) -#define tryAMAGICunTARGET_flags(meth, shift, jump, flags) \ +#define tryAMAGICunTARGETlist(meth, jump) \ STMT_START { \ dSP; \ SV *tmpsv; \ - SV *arg= sp[shift]; \ + SV *arg= *sp; \ int gimme = GIMME_V; \ if (SvAMAGIC(arg) && \ (tmpsv = amagic_call(arg, &PL_sv_undef, meth, \ - flags | AMGf_noright | AMGf_unary))) { \ + AMGf_want_list | AMGf_noright \ + |AMGf_unary))) { \ SPAGAIN; \ - sp += shift; \ if (gimme == G_VOID) { \ (void)POPs; /* XXX ??? */ \ } \ - else if ((flags & AMGf_want_list) && gimme == G_ARRAY) { \ + else if (gimme == G_ARRAY) { \ int i; \ I32 len; \ assert(SvTYPE(tmpsv) == SVt_PVAV); \ diff --git a/pp_hot.c b/pp_hot.c index 5998110..feba395 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -425,7 +425,7 @@ PP(pp_readline) dSP; if (TOPs) { SvGETMAGIC(TOPs); - tryAMAGICunTARGETlist(iter_amg, 0, 0); + tryAMAGICunTARGETlist(iter_amg, 0); PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); } else PL_last_in_gv = PL_argvgv, PL_stack_sp--; diff --git a/pp_sys.c b/pp_sys.c index 06699d9..8bf9fa7 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -359,23 +359,24 @@ PP(pp_glob) dVAR; OP *result; dSP; + GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs; + + PUTBACK; + /* make a copy of the pattern if it is gmagical, to ensure that magic * is called once and only once */ - if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s)); + if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs)); - tryAMAGICunTARGETlist(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL)); + tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL)); if (PL_op->op_flags & OPf_SPECIAL) { /* call Perl-level glob function instead. Stack args are: - * MARK, wildcard, csh_glob context index + * MARK, wildcard * and following OPs should be: gv(CORE::GLOBAL::glob), entersub * */ return NORMAL; } - /* stack args are: wildcard, gv(_GEN_n) */ - if (PL_globhook) { - SETs(GvSV(TOPs)); PL_globhook(aTHX); return NORMAL; } @@ -398,7 +399,7 @@ PP(pp_glob) #endif /* !VMS */ SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */ - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + PL_last_in_gv = gv; SAVESPTR(PL_rs); /* This is not permanent, either. */ PL_rs = newSVpvs_flags("\000", SVs_TEMP); diff --git a/sv.c b/sv.c index 16585ea..73fa710 100644 --- a/sv.c +++ b/sv.c @@ -13298,7 +13298,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_last_swash_tmps = (U8*)NULL; PL_last_swash_slen = 0; - PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; if (flags & CLONEf_COPY_STACKS) { diff --git a/t/op/svleak.t b/t/op/svleak.t index 13c800f..e7c5988 100644 --- a/t/op/svleak.t +++ b/t/op/svleak.t @@ -15,7 +15,7 @@ BEGIN { use Config; -plan tests => 111; +plan tests => 112; # run some code N times. If the number of SVs at the end of loop N is # greater than (N-1)*delta at the end of loop 1, we've got a leak @@ -107,6 +107,10 @@ eleak(2, 0, "$all v111111111111111111111111111111111111111111111111", 'vstring num overflow with fatal warnings'); eleak(2, 0, 'sub{<*>}'); +# Use a random number of ops, so that the glob op does not reuse the same +# address each time, giving us false passes. +leak(2, 0, sub { eval '$x+'x(rand() * 100) . '<*>'; }, + 'freeing partly iterated glob'); eleak(2, 0, 'goto sub {}', 'goto &sub in eval'); eleak(2, 0, '() = sort { goto sub {} } 1,2', 'goto &sub in sort'); diff --git a/t/re/recompile.t b/t/re/recompile.t index 785dcdb..ad00df8 100644 --- a/t/re/recompile.t +++ b/t/re/recompile.t @@ -61,7 +61,7 @@ sub _comp_n { my $status = $?; my $count = () = $results =~ /Final program:/g; - if ($count == $n) { + if ($count == $n && !$status) { pass($desc); } else { -- Perl5 Master Repository
