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
#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
#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)
#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
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
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);
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);
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 {
}
}
+ /* 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);
# 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
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
=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>
=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
}
}
-/*
- * 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)
{
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))) )
}
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
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);
}
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:
--- /dev/null
+#!./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
projects / p5sagit/p5-mst-13.2.git / commitdiff