fix small interpreter leaks identified by Purify

p4raw-id: //depot/perl@5084

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)