diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | op.c | 46 | ||||
| -rw-r--r-- | op.h | 10 | ||||
| -rw-r--r-- | pod/perlapi.pod | 97 | ||||
| -rw-r--r-- | pp_ctl.c | 40 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | sv.c | 5 | ||||
| -rwxr-xr-x | t/op/anonsub.t | 93 |
10 files changed, 216 insertions, 82 deletions
@@ -1538,6 +1538,7 @@ t/lib/tie-substrhash.t Test for Tie::SubstrHash t/lib/timelocal.t See if Time::Local works t/lib/trig.t See if Math::Trig works t/op/64bitint.t See if 64 bit integers work +t/op/anonsub.t See if anonymous subroutines work t/op/append.t See if . works t/op/args.t See if operations on @_ work t/op/arith.t See if arithmetic works @@ -982,7 +982,6 @@ #define dopoptoloop S_dopoptoloop #define dopoptosub S_dopoptosub #define dopoptosub_at S_dopoptosub_at -#define free_closures S_free_closures #define save_lines S_save_lines #define doeval S_doeval #define doopen_pmc S_doopen_pmc @@ -2465,7 +2464,6 @@ #define dopoptoloop(a) S_dopoptoloop(aTHX_ a) #define dopoptosub(a) S_dopoptosub(aTHX_ a) #define dopoptosub_at(a,b) S_dopoptosub_at(aTHX_ a,b) -#define free_closures() S_free_closures(aTHX) #define save_lines(a,b) S_save_lines(aTHX_ a,b) #define doeval(a,b) S_doeval(aTHX_ a,b) #define doopen_pmc(a,b) S_doopen_pmc(aTHX_ a,b) @@ -4806,8 +4804,6 @@ #define dopoptosub S_dopoptosub #define S_dopoptosub_at CPerlObj::S_dopoptosub_at #define dopoptosub_at S_dopoptosub_at -#define S_free_closures CPerlObj::S_free_closures -#define free_closures S_free_closures #define S_save_lines CPerlObj::S_save_lines #define save_lines S_save_lines #define S_doeval CPerlObj::S_doeval @@ -2357,7 +2357,6 @@ s |I32 |dopoptolabel |char *label s |I32 |dopoptoloop |I32 startingblock s |I32 |dopoptosub |I32 startingblock s |I32 |dopoptosub_at |PERL_CONTEXT* cxstk|I32 startingblock -s |void |free_closures s |void |save_lines |AV *array|SV *sv s |OP* |doeval |int gimme|OP** startop s |PerlIO *|doopen_pmc |const char *name|const char *mode @@ -4158,14 +4158,19 @@ Perl_cv_undef(pTHX_ CV *cv) SAVEVPTR(PL_curpad); PL_curpad = 0; - if (!CvCLONED(cv)) - op_free(CvROOT(cv)); + op_free(CvROOT(cv)); CvROOT(cv) = Nullop; LEAVE; } SvPOK_off((SV*)cv); /* forget prototype */ CvGV(cv) = Nullgv; - SvREFCNT_dec(CvOUTSIDE(cv)); + /* Since closure prototypes have the same lifetime as the containing + * CV, they don't hold a refcount on the outside CV. This avoids + * the refcount loop between the outer CV (which keeps a refcount to + * the closure prototype in the pad entry for pp_anoncode()) and the + * closure prototype, and the ensuing memory leak. --GSAR */ + if (!CvANON(cv) || CvCLONED(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = Nullcv; if (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); @@ -4279,7 +4284,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) CvFILE(cv) = CvFILE(proto); CvGV(cv) = CvGV(proto); CvSTASH(cv) = CvSTASH(proto); - CvROOT(cv) = CvROOT(proto); + CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); CvSTART(cv) = CvSTART(proto); if (outside) CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); @@ -4675,8 +4680,30 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvOUTSIDE(PL_compcv) = 0; CvPADLIST(cv) = CvPADLIST(PL_compcv); CvPADLIST(PL_compcv) = 0; - if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */ - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv); + /* inner references to PL_compcv must be fixed up ... */ + { + AV *padlist = CvPADLIST(cv); + AV *comppad_name = (AV*)AvARRAY(padlist)[0]; + AV *comppad = (AV*)AvARRAY(padlist)[1]; + SV **namepad = AvARRAY(comppad_name); + SV **curpad = AvARRAY(comppad); + for (ix = AvFILLp(comppad_name); ix > 0; ix--) { + SV *namesv = namepad[ix]; + if (namesv && namesv != &PL_sv_undef + && *SvPVX(namesv) == '&') + { + CV *innercv = (CV*)curpad[ix]; + if (CvOUTSIDE(innercv) == PL_compcv) { + CvOUTSIDE(innercv) = cv; + if (!CvANON(innercv) || CvCLONED(innercv)) { + (void)SvREFCNT_inc(cv); + SvREFCNT_dec(PL_compcv); + } + } + } + } + } + /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); } else { @@ -4779,6 +4806,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } + /* If a potential closure prototype, don't keep a refcount on outer CV. + * This is okay as the lifetime of the prototype is tied to the + * lifetime of the outer CV. Avoids memory leak due to reference + * loop. --GSAR */ + if (!name) + SvREFCNT_dec(CvOUTSIDE(cv)); + if (name || aname) { char *s; char *tname = (name ? name : aname); @@ -413,19 +413,17 @@ struct loop { # define OP_REFCNT_LOCK MUTEX_LOCK(&PL_op_mutex) # define OP_REFCNT_UNLOCK MUTEX_UNLOCK(&PL_op_mutex) # define OP_REFCNT_TERM MUTEX_DESTROY(&PL_op_mutex) -# define OpREFCNT_set(o,n) ((o)->op_targ = (n)) -# define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop) -# define OpREFCNT_dec(o) (--(o)->op_targ) #else # define OP_REFCNT_INIT NOOP # define OP_REFCNT_LOCK NOOP # define OP_REFCNT_UNLOCK NOOP # define OP_REFCNT_TERM NOOP -# define OpREFCNT_set(o,n) NOOP -# define OpREFCNT_inc(o) (o) -# define OpREFCNT_dec(o) 0 #endif +#define OpREFCNT_set(o,n) ((o)->op_targ = (n)) +#define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop) +#define OpREFCNT_dec(o) (--(o)->op_targ) + /* flags used by Perl_load_module() */ #define PERL_LOADMOD_DENY 0x1 #define PERL_LOADMOD_NOIMPORT 0x2 diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 1cb3a0c1e9..3454eddfcb 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -1039,7 +1039,7 @@ Tests if some arbitrary number of bytes begins in a valid UTF-8 character. Note that an ASCII character is a valid UTF-8 character. The actual number of bytes in the UTF-8 character will be returned if it is valid, otherwise 0. - + STRLEN is_utf8_char(U8 *p) =for hackers @@ -3268,6 +3268,44 @@ Converts the specified character to uppercase. =for hackers Found in file handy.h +=item utf8n_to_uvchr + +Returns the native character value of the first character in the string C<s> +which is assumed to be in UTF8 encoding; C<retlen> will be set to the +length, in bytes, of that character. + +Allows length and flags to be passed to low level routine. + + UV utf8n_to_uvchr(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags) + +=for hackers +Found in file utf8.c + +=item utf8n_to_uvuni + +Bottom level UTF-8 decode routine. +Returns the unicode code point value of the first character in the string C<s> +which is assumed to be in UTF8 encoding and no longer than C<curlen>; +C<retlen> will be set to the length, in bytes, of that character. + +If C<s> does not point to a well-formed UTF8 character, the behaviour +is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY, +it is assumed that the caller will raise a warning, and this function +will silently just set C<retlen> to C<-1> and return zero. If the +C<flags> does not contain UTF8_CHECK_ONLY, warnings about +malformations will be given, C<retlen> will be set to the expected +length of the UTF-8 character in bytes, and zero will be returned. + +The C<flags> can also contain various flags to allow deviations from +the strict UTF-8 encoding (see F<utf8.h>). + +Most code should use utf8_to_uvchr() rather than call this directly. + + UV utf8n_to_uvuni(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags) + +=for hackers +Found in file utf8.c + =item utf8_distance Returns the number of UTF8 characters between the UTF-8 pointers C<a> @@ -3321,56 +3359,69 @@ removed without notice. =for hackers Found in file utf8.c -=item utf8_to_uv +=item utf8_to_uvchr -Returns the character value of the first character in the string C<s> -which is assumed to be in UTF8 encoding and no longer than C<curlen>; -C<retlen> will be set to the length, in bytes, of that character. - -If C<s> does not point to a well-formed UTF8 character, the behaviour -is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY, -it is assumed that the caller will raise a warning, and this function -will silently just set C<retlen> to C<-1> and return zero. If the -C<flags> does not contain UTF8_CHECK_ONLY, warnings about -malformations will be given, C<retlen> will be set to the expected -length of the UTF-8 character in bytes, and zero will be returned. +Returns the native character value of the first character in the string C<s> +which is assumed to be in UTF8 encoding; C<retlen> will be set to the +length, in bytes, of that character. -The C<flags> can also contain various flags to allow deviations from -the strict UTF-8 encoding (see F<utf8.h>). +If C<s> does not point to a well-formed UTF8 character, zero is +returned and retlen is set, if possible, to -1. - UV utf8_to_uv(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags) + UV utf8_to_uvchr(U8 *s, STRLEN* retlen) =for hackers Found in file utf8.c -=item utf8_to_uv_simple +=item utf8_to_uvuni -Returns the character value of the first character in the string C<s> +Returns the Unicode code point of the first character in the string C<s> which is assumed to be in UTF8 encoding; C<retlen> will be set to the length, in bytes, of that character. +This function should only be used when returned UV is considered +an index into the Unicode semantic tables (e.g. swashes). + If C<s> does not point to a well-formed UTF8 character, zero is returned and retlen is set, if possible, to -1. - UV utf8_to_uv_simple(U8 *s, STRLEN* retlen) + UV utf8_to_uvuni(U8 *s, STRLEN* retlen) + +=for hackers +Found in file utf8.c + +=item uvchr_to_utf8 + +Adds the UTF8 representation of the Native codepoint C<uv> to the end +of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free +bytes available. The return value is the pointer to the byte after the +end of the new character. In other words, + + d = uvchr_to_utf8(d, uv); + +is the recommended wide native character-aware way of saying + + *(d++) = uv; + + U8* uvchr_to_utf8(U8 *d, UV uv) =for hackers Found in file utf8.c -=item uv_to_utf8 +=item uvuni_to_utf8 Adds the UTF8 representation of the Unicode codepoint C<uv> to the end of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free bytes available. The return value is the pointer to the byte after the -end of the new character. In other words, +end of the new character. In other words, - d = uv_to_utf8(d, uv); + d = uvuni_to_utf8(d, uv); is the recommended Unicode-aware way of saying *(d++) = uv; - U8* uv_to_utf8(U8 *d, UV uv) + U8* uvuni_to_utf8(U8 *d, UV uv) =for hackers Found in file utf8.c @@ -1380,41 +1380,6 @@ Perl_dounwind(pTHX_ I32 cxix) } } -/* - * Closures mentioned at top level of eval cannot be referenced - * again, and their presence indirectly causes a memory leak. - * (Note that the fact that compcv and friends are still set here - * is, AFAIK, an accident.) --Chip - * - * XXX need to get comppad et al from eval's cv rather than - * relying on the incidental global values. - */ -STATIC void -S_free_closures(pTHX) -{ - SV **svp = AvARRAY(PL_comppad_name); - I32 ix; - for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) { - SV *sv = svp[ix]; - if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') { - SvREFCNT_dec(sv); - svp[ix] = &PL_sv_undef; - - sv = PL_curpad[ix]; - if (CvCLONE(sv)) { - SvREFCNT_dec(CvOUTSIDE(sv)); - CvOUTSIDE(sv) = Nullcv; - } - else { - SvREFCNT_dec(sv); - sv = NEWSV(0,0); - SvPADTMP_on(sv); - PL_curpad[ix] = sv; - } - } - } -} - void Perl_qerror(pTHX_ SV *err) { @@ -1951,8 +1916,6 @@ PP(pp_return) POPEVAL(cx); if (CxTRYBLOCK(cx)) break; - if (AvFILLp(PL_comppad_name) >= 0) - free_closures(); lex_end(); if (optype == OP_REQUIRE && (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) @@ -3507,9 +3470,6 @@ PP(pp_leaveeval) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - if (AvFILLp(PL_comppad_name) >= 0) - free_closures(); - #ifdef DEBUGGING assert(CvDEPTH(PL_compcv) == 1); #endif @@ -1095,7 +1095,6 @@ STATIC I32 S_dopoptolabel(pTHX_ char *label); STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock); STATIC I32 S_dopoptosub(pTHX_ I32 startingblock); STATIC I32 S_dopoptosub_at(pTHX_ PERL_CONTEXT* cxstk, I32 startingblock); -STATIC void S_free_closures(pTHX); STATIC void S_save_lines(pTHX_ AV *array, SV *sv); STATIC OP* S_doeval(pTHX_ int gimme, OP** startop); STATIC PerlIO * S_doopen_pmc(pTHX_ const char *name, const char *mode); @@ -8179,7 +8179,10 @@ dup_pvcv: } else CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); - CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + if (!CvANON(sstr) || CvCLONED(sstr)) + CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + else + CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr)); CvFLAGS(dstr) = CvFLAGS(sstr); break; default: diff --git a/t/op/anonsub.t b/t/op/anonsub.t new file mode 100755 index 0000000000..17889d9d2f --- /dev/null +++ b/t/op/anonsub.t @@ -0,0 +1,93 @@ +#!./perl + +chdir 't' if -d 't'; +@INC = '../lib'; +$Is_VMS = $^O eq 'VMS'; +$Is_MSWin32 = $^O eq 'MSWin32'; +$ENV{PERL5LIB} = "../lib" unless $Is_VMS; + +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "asubtmp000"; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile; } } + +for (@prgs){ + my $switch = ""; + if (s/^\s*(-\w+)//){ + $switch = $1; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + open TEST, ">$tmpfile"; + print TEST "$prog\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `./perl $switch $tmpfile 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/runltmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + if ($results ne $expected) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +__END__ +sub X { + my $n = "ok 1\n"; + sub { print $n }; +} +my $x = X(); +undef &X; +$x->(); +EXPECT +ok 1 +######## +sub X { + my $n = "ok 1\n"; + sub { + my $dummy = $n; # eval can't close on $n without internal reference + eval 'print $n'; + die $@ if $@; + }; +} +my $x = X(); +undef &X; +$x->(); +EXPECT +ok 1 +######## +sub X { + my $n = "ok 1\n"; + eval 'sub { print $n }'; +} +my $x = X(); +die $@ if $@; +undef &X; +$x->(); +EXPECT +ok 1 +######## +sub X; +sub X { + my $n = "ok 1\n"; + eval 'sub Y { my $p = shift; $p->() }'; + die $@ if $@; + Y(sub { print $n }); +} +X(); +EXPECT +ok 1 |