This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix small interpreter leaks identified by Purify
authorGurusamy Sarathy <gsar@cpan.org>
Mon, 14 Feb 2000 18:26:08 +0000 (18:26 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Mon, 14 Feb 2000 18:26:08 +0000 (18:26 +0000)
p4raw-id: //depot/perl@5084

Porting/pumpkin.pod
embed.h
embed.pl
hv.c
perl.c
proto.h
sv.c
t/op/ord.t
t/pragma/warnings.t

index 55c1eb8..99776b5 100644 (file)
@@ -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 028153b..91cd7c2 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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)
 #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)
 #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
index 7848e8d..ce4312b 100755 (executable)
--- 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 435b10d..fd2c2d7 100644 (file)
--- 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 bab92b8..f50cc20 100644 (file)
--- 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 80da727..958f36e 100644 (file)
--- 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 e3696b0..9376540 100644 (file)
--- 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
index bc6d924..b1dc062 100755 (executable)
@@ -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";}
index 73e4c8d..41324e6 100644 (file)
@@ -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)