summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Porting/pumpkin.pod3
-rw-r--r--embed.h4
-rwxr-xr-xembed.pl1
-rw-r--r--hv.c30
-rw-r--r--perl.c39
-rw-r--r--proto.h1
-rw-r--r--sv.c117
-rwxr-xr-xt/op/ord.t2
-rw-r--r--t/pragma/warnings.t2
9 files changed, 137 insertions, 62 deletions
diff --git a/Porting/pumpkin.pod b/Porting/pumpkin.pod
index 55c1eb84b4..99776b50d2 100644
--- a/Porting/pumpkin.pod
+++ b/Porting/pumpkin.pod
@@ -701,7 +701,7 @@ supports dynamic loading, you can also test static loading with
You can also hand-tweak your config.h to try out different #ifdef
branches.
-=head1 Purify runs
+=head1 Running Purify
Purify is a commercial tool that is helpful in identifying memory
overruns, wild pointers, memory leaks and other such badness. Perl
@@ -715,6 +715,7 @@ Use the following commands to test perl with Purify:
make all pureperl
cd t
ln -s ../pureperl perl
+ setenv PERL_DESTRUCT_LEVEL 5
./perl TEST
Disabling Perl's malloc allows Purify to monitor allocations and leaks
diff --git a/embed.h b/embed.h
index 028153b5ea..91cd7c2571 100644
--- a/embed.h
+++ b/embed.h
@@ -1033,7 +1033,6 @@
#define sv_unglob S_sv_unglob
#define not_a_number S_not_a_number
#define visit S_visit
-#define my_safemalloc S_my_safemalloc
#define sv_add_backref S_sv_add_backref
#define sv_del_backref S_sv_del_backref
# if defined(DEBUGGING)
@@ -2440,7 +2439,6 @@
#define sv_unglob(a) S_sv_unglob(aTHX_ a)
#define not_a_number(a) S_not_a_number(aTHX_ a)
#define visit(a) S_visit(aTHX_ a)
-#define my_safemalloc S_my_safemalloc
#define sv_add_backref(a,b) S_sv_add_backref(aTHX_ a,b)
#define sv_del_backref(a) S_sv_del_backref(aTHX_ a)
# if defined(DEBUGGING)
@@ -4753,8 +4751,6 @@
#define not_a_number S_not_a_number
#define S_visit CPerlObj::S_visit
#define visit S_visit
-#define S_my_safemalloc CPerlObj::S_my_safemalloc
-#define my_safemalloc S_my_safemalloc
#define S_sv_add_backref CPerlObj::S_sv_add_backref
#define sv_add_backref S_sv_add_backref
#define S_sv_del_backref CPerlObj::S_sv_del_backref
diff --git a/embed.pl b/embed.pl
index 7848e8d28a..ce4312ba1d 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2385,7 +2385,6 @@ s |void |del_xrv |XRV* p
s |void |sv_unglob |SV* sv
s |void |not_a_number |SV *sv
s |void |visit |SVFUNC_t f
-ns |void* |my_safemalloc |MEM_SIZE size
s |void |sv_add_backref |SV *tsv|SV *sv
s |void |sv_del_backref |SV *sv
# if defined(DEBUGGING)
diff --git a/hv.c b/hv.c
index 435b10d85e..fd2c2d7c6f 100644
--- a/hv.c
+++ b/hv.c
@@ -52,6 +52,18 @@ S_more_he(pTHX)
HeNEXT(he) = 0;
}
+#ifdef PURIFY
+
+#define new_HE() (HE*)safemalloc(sizeof(HE))
+#define del_HE(p) safefree((char*)p)
+
+#else
+
+#define new_HE() new_he()
+#define del_HE(p) del_he(p)
+
+#endif
+
STATIC HEK *
S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
{
@@ -87,7 +99,7 @@ Perl_he_dup(pTHX_ HE *e, bool shared)
return ret;
/* create anew and remember what it is */
- ret = new_he();
+ ret = new_HE();
ptr_table_store(PL_ptr_table, e, ret);
HeNEXT(ret) = he_dup(HeNEXT(e),shared);
@@ -393,7 +405,7 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has
return &HeVAL(entry);
}
- entry = new_he();
+ entry = new_HE();
if (HvSHAREKEYS(hv))
HeKEY_hek(entry) = share_hek(key, klen, hash);
else /* gotta do the real thing */
@@ -494,7 +506,7 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
return entry;
}
- entry = new_he();
+ entry = new_HE();
if (HvSHAREKEYS(hv))
HeKEY_hek(entry) = share_hek(key, klen, hash);
else /* gotta do the real thing */
@@ -1062,7 +1074,7 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
unshare_hek(HeKEY_hek(entry));
else
Safefree(HeKEY_hek(entry));
- del_he(entry);
+ del_HE(entry);
}
void
@@ -1081,7 +1093,7 @@ Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
unshare_hek(HeKEY_hek(entry));
else
Safefree(HeKEY_hek(entry));
- del_he(entry);
+ del_HE(entry);
}
/*
@@ -1236,7 +1248,7 @@ Perl_hv_iternext(pTHX_ HV *hv)
char *k;
HEK *hek;
- xhv->xhv_eiter = entry = new_he(); /* one HE per MAGICAL hash */
+ xhv->xhv_eiter = entry = new_HE(); /* one HE per MAGICAL hash */
Zero(entry, 1, HE);
Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
hek = (HEK*)k;
@@ -1252,7 +1264,7 @@ Perl_hv_iternext(pTHX_ HV *hv)
if (HeVAL(entry))
SvREFCNT_dec(HeVAL(entry));
Safefree(HeKEY_hek(entry));
- del_he(entry);
+ del_HE(entry);
xhv->xhv_eiter = Null(HE*);
return Null(HE*);
}
@@ -1426,7 +1438,7 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
if (i && !*oentry)
xhv->xhv_fill--;
Safefree(HeKEY_hek(entry));
- del_he(entry);
+ del_HE(entry);
--xhv->xhv_keys;
}
break;
@@ -1473,7 +1485,7 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
break;
}
if (!found) {
- entry = new_he();
+ entry = new_HE();
HeKEY_hek(entry) = save_hek(str, len, hash);
HeVAL(entry) = Nullsv;
HeNEXT(entry) = *oentry;
diff --git a/perl.c b/perl.c
index bab92b855d..f50cc2077d 100644
--- a/perl.c
+++ b/perl.c
@@ -442,10 +442,10 @@ perl_destruct(pTHXx)
/* magical thingies */
- Safefree(PL_ofs); /* $, */
+ Safefree(PL_ofs); /* $, */
PL_ofs = Nullch;
- Safefree(PL_ors); /* $\ */
+ Safefree(PL_ors); /* $\ */
PL_ors = Nullch;
SvREFCNT_dec(PL_rs); /* $/ */
@@ -454,7 +454,9 @@ perl_destruct(pTHXx)
SvREFCNT_dec(PL_nrs); /* $/ helper */
PL_nrs = Nullsv;
- PL_multiline = 0; /* $* */
+ PL_multiline = 0; /* $* */
+ Safefree(PL_osname); /* $^O */
+ PL_osname = Nullch;
SvREFCNT_dec(PL_statname);
PL_statname = Nullsv;
@@ -504,8 +506,6 @@ perl_destruct(pTHXx)
SvREFCNT_dec(PL_argvout_stack);
PL_argvout_stack = Nullav;
- SvREFCNT_dec(PL_fdpid);
- PL_fdpid = Nullav;
SvREFCNT_dec(PL_modglobal);
PL_modglobal = Nullhv;
SvREFCNT_dec(PL_preambleav);
@@ -522,6 +522,13 @@ perl_destruct(pTHXx)
PL_bodytarget = Nullsv;
PL_formtarget = Nullsv;
+ /* free locale stuff */
+ Safefree(PL_collation_name);
+ PL_collation_name = Nullch;
+
+ Safefree(PL_numeric_name);
+ PL_numeric_name = Nullch;
+
/* clear utf8 character classes */
SvREFCNT_dec(PL_utf8_alnum);
SvREFCNT_dec(PL_utf8_alnumc);
@@ -593,14 +600,20 @@ perl_destruct(pTHXx)
/* Now absolutely destruct everything, somehow or other, loops or no. */
last_sv_count = 0;
+ SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
last_sv_count = PL_sv_count;
sv_clean_all();
}
+ SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
+ SvFLAGS(PL_fdpid) |= SVt_PVAV;
SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
SvFLAGS(PL_strtab) |= SVt_PVHV;
-
+
+ SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
+ PL_fdpid = Nullav;
+
/* Destruct the global string table. */
{
/* Yell and reset the HeVAL() slots that are still holding refcounts,
@@ -632,6 +645,16 @@ perl_destruct(pTHXx)
}
SvREFCNT_dec(PL_strtab);
+ /* free special SVs */
+
+ SvREFCNT(&PL_sv_yes) = 0;
+ sv_clear(&PL_sv_yes);
+ SvANY(&PL_sv_yes) = NULL;
+
+ SvREFCNT(&PL_sv_no) = 0;
+ sv_clear(&PL_sv_no);
+ SvANY(&PL_sv_no) = NULL;
+
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
@@ -665,7 +688,7 @@ perl_destruct(pTHXx)
Safefree(PL_thrsv);
PL_thrsv = Nullsv;
#endif /* USE_THREADS */
-
+
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
@@ -1459,6 +1482,8 @@ Perl_call_method(pTHX_ const char *methname, I32 flags)
XPUSHs(sv_2mortal(newSVpv(methname,0)));
PUTBACK;
pp_method();
+ if (PL_op == &myop)
+ PL_op = Nullop;
return call_sv(*PL_stack_sp--, flags);
}
diff --git a/proto.h b/proto.h
index 80da72746b..958f36e738 100644
--- a/proto.h
+++ b/proto.h
@@ -1154,7 +1154,6 @@ STATIC void S_del_xrv(pTHX_ XRV* p);
STATIC void S_sv_unglob(pTHX_ SV* sv);
STATIC void S_not_a_number(pTHX_ SV *sv);
STATIC void S_visit(pTHX_ SVFUNC_t f);
-STATIC void* S_my_safemalloc(MEM_SIZE size);
STATIC void S_sv_add_backref(pTHX_ SV *tsv, SV *sv);
STATIC void S_sv_del_backref(pTHX_ SV *sv);
# if defined(DEBUGGING)
diff --git a/sv.c b/sv.c
index e3696b0147..9376540a8a 100644
--- a/sv.c
+++ b/sv.c
@@ -700,59 +700,100 @@ S_more_xpvbm(pTHX)
xpvbm->xpv_pv = 0;
}
-#define new_XIV() (void*)new_xiv()
-#define del_XIV(p) del_xiv((XPVIV*) p)
+#ifdef LEAKTEST
+# define my_safemalloc(s) (void*)safexmalloc(717,s)
+# define my_safefree(p) safexfree((char*)p)
+#else
+# define my_safemalloc(s) (void*)safemalloc(s)
+# define my_safefree(p) safefree((char*)p)
+#endif
-#define new_XNV() (void*)new_xnv()
-#define del_XNV(p) del_xnv((XPVNV*) p)
+#ifdef PURIFY
-#define new_XRV() (void*)new_xrv()
-#define del_XRV(p) del_xrv((XRV*) p)
+#define new_XIV() my_safemalloc(sizeof(XPVIV))
+#define del_XIV(p) my_safefree(p)
-#define new_XPV() (void*)new_xpv()
-#define del_XPV(p) del_xpv((XPV *)p)
+#define new_XNV() my_safemalloc(sizeof(XPVNV))
+#define del_XNV(p) my_safefree(p)
-STATIC void*
-S_my_safemalloc(MEM_SIZE size)
-{
- char *p;
- New(717, p, size, char);
- return (void*)p;
-}
-# define my_safefree(s) Safefree(s)
+#define new_XRV() my_safemalloc(sizeof(XRV))
+#define del_XRV(p) my_safefree(p)
-#define new_XPVIV() (void*)new_xpviv()
-#define del_XPVIV(p) del_xpviv((XPVIV *)p)
+#define new_XPV() my_safemalloc(sizeof(XPV))
+#define del_XPV(p) my_safefree(p)
-#define new_XPVNV() (void*)new_xpvnv()
-#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
+#define new_XPVIV() my_safemalloc(sizeof(XPVIV))
+#define del_XPVIV(p) my_safefree(p)
-#define new_XPVCV() (void*)new_xpvcv()
-#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
+#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
+#define del_XPVNV(p) my_safefree(p)
-#define new_XPVAV() (void*)new_xpvav()
-#define del_XPVAV(p) del_xpvav((XPVAV *)p)
+#define new_XPVCV() my_safemalloc(sizeof(XPVCV))
+#define del_XPVCV(p) my_safefree(p)
-#define new_XPVHV() (void*)new_xpvhv()
-#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
+#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
+#define del_XPVAV(p) my_safefree(p)
+
+#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
+#define del_XPVHV(p) my_safefree(p)
-#define new_XPVMG() (void*)new_xpvmg()
-#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
+#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
+#define del_XPVMG(p) my_safefree(p)
+
+#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
+#define del_XPVLV(p) my_safefree(p)
+
+#define new_XPVBM() my_safemalloc(sizeof(XPVBM))
+#define del_XPVBM(p) my_safefree(p)
+
+#else /* !PURIFY */
+
+#define new_XIV() (void*)new_xiv()
+#define del_XIV(p) del_xiv((XPVIV*) p)
-#define new_XPVLV() (void*)new_xpvlv()
-#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
+#define new_XNV() (void*)new_xnv()
+#define del_XNV(p) del_xnv((XPVNV*) p)
-#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) my_safefree((char*)p)
+#define new_XRV() (void*)new_xrv()
+#define del_XRV(p) del_xrv((XRV*) p)
+
+#define new_XPV() (void*)new_xpv()
+#define del_XPV(p) del_xpv((XPV *)p)
+
+#define new_XPVIV() (void*)new_xpviv()
+#define del_XPVIV(p) del_xpviv((XPVIV *)p)
+
+#define new_XPVNV() (void*)new_xpvnv()
+#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
+
+#define new_XPVCV() (void*)new_xpvcv()
+#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
+
+#define new_XPVAV() (void*)new_xpvav()
+#define del_XPVAV(p) del_xpvav((XPVAV *)p)
+
+#define new_XPVHV() (void*)new_xpvhv()
+#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
-#define new_XPVBM() (void*)new_xpvbm()
-#define del_XPVBM(p) del_xpvbm((XPVBM *)p)
+#define new_XPVMG() (void*)new_xpvmg()
+#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
+
+#define new_XPVLV() (void*)new_xpvlv()
+#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
+
+#define new_XPVBM() (void*)new_xpvbm()
+#define del_XPVBM(p) del_xpvbm((XPVBM *)p)
-#define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
-#define del_XPVFM(p) my_safefree((char*)p)
+#endif /* PURIFY */
+
+#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
+#define del_XPVGV(p) my_safefree(p)
+
+#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
+#define del_XPVFM(p) my_safefree(p)
-#define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
-#define del_XPVIO(p) my_safefree((char*)p)
+#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
+#define del_XPVIO(p) my_safefree(p)
/*
=for apidoc sv_upgrade
diff --git a/t/op/ord.t b/t/op/ord.t
index bc6d924554..b1dc062a1f 100755
--- a/t/op/ord.t
+++ b/t/op/ord.t
@@ -13,4 +13,4 @@ if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n
$x = 'ABC';
if (ord($x) == 65 || ord($x) == 193) {print "ok 2\n";} else {print "not ok 2\n";}
-if (chr 65 == 'A' || chr 193 == 'A') {print "ok 3\n";} else {print "not ok 3\n";}
+if (chr 65 eq 'A' || chr 193 eq 'A') {print "ok 3\n";} else {print "not ok 3\n";}
diff --git a/t/pragma/warnings.t b/t/pragma/warnings.t
index 73e4c8d1a8..41324e68cc 100644
--- a/t/pragma/warnings.t
+++ b/t/pragma/warnings.t
@@ -88,6 +88,8 @@ for (@prgs){
# bison says 'parse error' instead of 'syntax error',
# various yaccs may or may not capitalize 'syntax'.
$results =~ s/^(syntax|parse) error/syntax error/mig;
+ # allow all tests to run when there are leaks
+ $results =~ s/Scalars leaked: \d+\n//g;
$expected =~ s/\n+$//;
my $prefix = ($results =~ s/^PREFIX\n//) ;
# any special options? (OPTIONS foo bar zap)