From: Nick Ing-Simmons Date: Mon, 8 Jan 2001 23:54:33 +0000 (+0000) Subject: Fix "scalars leaked" bugs caused by overload magic X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d460ef459c7692518f607c250b9843bea7e01dd6;p=p5sagit%2Fp5-mst-13.2.git Fix "scalars leaked" bugs caused by overload magic (Highlighted by Ilya's DESTROY optimization.) p4raw-id: //depot/perlio@8371 --- diff --git a/embed.h b/embed.h index 414a642..24320e9 100644 --- a/embed.h +++ b/embed.h @@ -343,6 +343,7 @@ #define magic_clearsig Perl_magic_clearsig #define magic_existspack Perl_magic_existspack #define magic_freeregexp Perl_magic_freeregexp +#define magic_freeovrld Perl_magic_freeovrld #define magic_get Perl_magic_get #define magic_getarylen Perl_magic_getarylen #define magic_getdefelem Perl_magic_getdefelem @@ -1818,6 +1819,7 @@ #define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b) #define magic_existspack(a,b) Perl_magic_existspack(aTHX_ a,b) #define magic_freeregexp(a,b) Perl_magic_freeregexp(aTHX_ a,b) +#define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b) #define magic_get(a,b) Perl_magic_get(aTHX_ a,b) #define magic_getarylen(a,b) Perl_magic_getarylen(aTHX_ a,b) #define magic_getdefelem(a,b) Perl_magic_getdefelem(aTHX_ a,b) @@ -3567,6 +3569,8 @@ #define magic_existspack Perl_magic_existspack #define Perl_magic_freeregexp CPerlObj::Perl_magic_freeregexp #define magic_freeregexp Perl_magic_freeregexp +#define Perl_magic_freeovrld CPerlObj::Perl_magic_freeovrld +#define magic_freeovrld Perl_magic_freeovrld #define Perl_magic_get CPerlObj::Perl_magic_get #define magic_get Perl_magic_get #define Perl_magic_getarylen CPerlObj::Perl_magic_getarylen diff --git a/embed.pl b/embed.pl index 7b83635..d834e4f 100755 --- a/embed.pl +++ b/embed.pl @@ -1662,6 +1662,7 @@ p |int |magic_clearpack|SV* sv|MAGIC* mg p |int |magic_clearsig |SV* sv|MAGIC* mg p |int |magic_existspack|SV* sv|MAGIC* mg p |int |magic_freeregexp|SV* sv|MAGIC* mg +p |int |magic_freeovrld|SV* sv|MAGIC* mg p |int |magic_get |SV* sv|MAGIC* mg p |int |magic_getarylen|SV* sv|MAGIC* mg p |int |magic_getdefelem|SV* sv|MAGIC* mg diff --git a/gv.c b/gv.c index f2931ae..8ee3f76 100644 --- a/gv.c +++ b/gv.c @@ -1155,6 +1155,23 @@ register GV *gv; } #endif /* Microport 2.4 hack */ +int +Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) +{ + AMT *amtp = (AMT*)mg->mg_ptr; + if (amtp && AMT_AMAGIC(amtp)) { + int i; + for (i = 1; i < NofAMmeth; i++) { + CV *cv = amtp->table[i]; + if (cv != Nullcv) { + SvREFCNT_dec((SV *) cv); + amtp->table[i] = Nullcv; + } + } + } + return 0; +} + /* Updates and caches the CV's */ bool @@ -1170,18 +1187,11 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) if (mg && amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == PL_sub_generation) return AMT_OVERLOADED(amtp); - if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ - int i; - for (i=1; itable[i]) { - SvREFCNT_dec(amtp->table[i]); - } - } - } sv_unmagic((SV*)stash, 'c'); DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) ); + Zero(&amt,1,AMT); amt.was_ok_am = PL_amagic_generation; amt.was_ok_sub = PL_sub_generation; amt.fallback = AMGfallNO; diff --git a/mg.c b/mg.c index 99600a4..3a61655 100644 --- a/mg.c +++ b/mg.c @@ -313,11 +313,12 @@ Perl_mg_free(pTHX_ SV *sv) moremagic = mg->mg_moremagic; if (vtbl && vtbl->svt_free) CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != 'g') + if (mg->mg_ptr && mg->mg_type != 'g') { if (mg->mg_len >= 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); + } if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); @@ -326,6 +327,7 @@ Perl_mg_free(pTHX_ SV *sv) return 0; } + #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include #endif diff --git a/perl.h b/perl.h index 6a545e6..e33067d 100644 --- a/perl.h +++ b/perl.h @@ -11,9 +11,9 @@ #ifdef PERL_FOR_X2P /* - * This file is being used for x2p stuff. + * This file is being used for x2p stuff. * Above symbol is defined via -D in 'x2p/Makefile.SH' - * Decouple x2p stuff from some of perls more extreme eccentricities. + * Decouple x2p stuff from some of perls more extreme eccentricities. */ #undef MULTIPLICITY #undef USE_STDIO @@ -21,7 +21,7 @@ #endif /* PERL_FOR_X2P */ #define VOIDUSED 1 -#ifdef PERL_MICRO +#ifdef PERL_MICRO # include "uconfig.h" #else # include "config.h" @@ -266,8 +266,8 @@ struct perl_thread; # define END_EXTERN_C } # define EXTERN_C extern "C" #else -# define START_EXTERN_C -# define END_EXTERN_C +# define START_EXTERN_C +# define END_EXTERN_C # define EXTERN_C extern #endif @@ -367,7 +367,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); #define TAINT_ENV() if (PL_tainting) { taint_env(); } #define TAINT_PROPER(s) if (PL_tainting) { taint_proper(Nullch, s); } -/* XXX All process group stuff is handled in pp_sys.c. Should these +/* XXX All process group stuff is handled in pp_sys.c. Should these defines move there? If so, I could simplify this a lot. --AD 9/96. */ /* Process group stuff changed from traditional BSD to POSIX. @@ -407,7 +407,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # define HAS_GETPGRP /* Well, effectively it does . . . */ #endif -/* These are not exact synonyms, since setpgrp() and getpgrp() may +/* These are not exact synonyms, since setpgrp() and getpgrp() may have different behaviors, but perl.h used to define USE_BSDPGRP (prior to 5.003_05) so some extension might depend on it. */ @@ -741,7 +741,7 @@ typedef struct perl_mstats perl_mstats_t; # undef INCLUDE_PROTOTYPES # undef PERL_SOCKS_NEED_PROTOTYPES # endif -# endif +# endif # ifdef I_NETDB # include # endif @@ -989,15 +989,15 @@ typedef struct perl_mstats perl_mstats_t; #ifndef S_IRWXU # define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR) -#endif +#endif #ifndef S_IRWXG # define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP) -#endif +#endif #ifndef S_IRWXO # define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH) -#endif +#endif #ifndef S_IREAD # define S_IREAD S_IRUSR @@ -1089,7 +1089,7 @@ typedef UVTYPE UV; #define PERL_PRESERVE_IVUV #endif -/* +/* * The macros INT2PTR and NUM2PTR are (despite their names) * bi-directional: they will convert int/float to or from pointers. * However the conversion to int/float are named explicitly: @@ -1103,7 +1103,7 @@ typedef UVTYPE UV; # define PTRV UV # define INT2PTR(any,d) (any)(d) #else -# if PTRSIZE == LONGSIZE +# if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned @@ -1114,12 +1114,12 @@ typedef UVTYPE UV; #define PTR2IV(p) INT2PTR(IV,p) #define PTR2UV(p) INT2PTR(UV,p) #define PTR2NV(p) NUM2PTR(NV,p) -#if PTRSIZE == LONGSIZE +#if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) #else # define PTR2ul(p) INT2PTR(unsigned long,p) #endif - + #ifdef USE_LONG_DOUBLE # if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE # define LONG_DOUBLE_EQUALS_DOUBLE @@ -1282,7 +1282,7 @@ typedef NVTYPE NV; #endif #if !defined(Perl_atof) && defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) -# if !defined(Perl_atof) && defined(HAS_STRTOLD) +# if !defined(Perl_atof) && defined(HAS_STRTOLD) # define Perl_atof(s) (NV)strtold(s, (char**)NULL) # endif # if !defined(Perl_atof) && defined(HAS_ATOLF) @@ -1300,7 +1300,7 @@ typedef NVTYPE NV; # define Perl_atof2(s,f) ((f) = (NV)Perl_atof(s)) #endif -/* Previously these definitions used hardcoded figures. +/* Previously these definitions used hardcoded figures. * It is hoped these formula are more portable, although * no data one way or another is presently known to me. * The "PERL_" names are used because these calculated constants @@ -1351,7 +1351,7 @@ typedef NVTYPE NV; # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif #endif - + /* * CHAR_MIN and CHAR_MAX are not included here, as the (char) type may be * ambiguous. It may be equivalent to (signed char) or (unsigned char) @@ -1558,7 +1558,7 @@ typedef struct ptr_tbl PTR_TBL_t; # define FSEEKSIZE LSEEKSIZE # else # define FSEEKSIZE LONGSIZE -# endif +# endif #endif #if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_STDIO) @@ -1719,7 +1719,7 @@ typedef struct ptr_tbl PTR_TBL_t; # endif #endif -/* +/* * USE_THREADS needs to be after unixish.h as includes * which defines NSIG - which will stop inclusion of * this results in many functions being undeclared which bothers C++ @@ -1878,7 +1878,7 @@ typedef pthread_key_t perl_key; # define SVf "p" # else # define SVf "_" -# endif +# endif #endif #ifndef UVf @@ -1886,7 +1886,7 @@ typedef pthread_key_t perl_key; # define UVf UVuf # else # define UVf "Vu" -# endif +# endif #endif #ifndef VDf @@ -1894,7 +1894,7 @@ typedef pthread_key_t perl_key; # define VDf "p" # else # define VDf "vd" -# endif +# endif #endif /* Some unistd.h's give a prototype for pause() even though @@ -2352,7 +2352,7 @@ EXT char *** environ_pointer; # if !defined(DONT_DECLARE_STD) || \ (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \ defined(__sgi) || \ - defined(__DGUX) + defined(__DGUX) extern char ** environ; /* environment variables supplied via exec */ # endif # endif @@ -2757,9 +2757,9 @@ struct perl_vars *PL_VarsPtr; #endif /* PERL_GLOBAL_STRUCT */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) -/* If we have multiple interpreters define a struct +/* If we have multiple interpreters define a struct holding variables which must be per-interpreter - If we don't have threads anything that would have + If we don't have threads anything that would have be per-thread is per-interpreter. */ @@ -2808,7 +2808,7 @@ typedef void *Thread; #ifndef PERL_CALLCONV # define PERL_CALLCONV -#endif +#endif #ifndef NEXT30_NO_ATTRIBUTE # ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */ @@ -2845,11 +2845,11 @@ typedef void *Thread; # include "embedvar.h" #endif -/* Now include all the 'global' variables +/* Now include all the 'global' variables * If we don't have threads or multiple interpreters - * these include variables that would have been their struct-s + * these include variables that would have been their struct-s */ - + #define PERLVAR(var,type) EXT type PL_##var; #define PERLVARA(var,n,type) EXT type PL_##var[n]; #define PERLVARI(var,type,init) EXT type PL_##var INIT(init); @@ -2984,6 +2984,9 @@ EXT MGVTBL PL_vtbl_amagicelem = {0, MEMBER_TO_FPTR(Perl_magic_setamagic), EXT MGVTBL PL_vtbl_backref = {0, 0, 0, 0, MEMBER_TO_FPTR(Perl_magic_killbackrefs)}; +EXT MGVTBL PL_vtbl_ovrld = {0, 0, + 0, 0, MEMBER_TO_FPTR(Perl_magic_freeovrld)}; + #else /* !DOINIT */ EXT MGVTBL PL_vtbl_sv; @@ -3007,6 +3010,7 @@ EXT MGVTBL PL_vtbl_pos; EXT MGVTBL PL_vtbl_bm; EXT MGVTBL PL_vtbl_fm; EXT MGVTBL PL_vtbl_uvar; +EXT MGVTBL PL_vtbl_ovrld; #ifdef USE_THREADS EXT MGVTBL PL_vtbl_mutex; @@ -3060,7 +3064,7 @@ enum { copy_amg, neg_amg, to_sv_amg, to_av_amg, to_hv_amg, to_gv_amg, - to_cv_amg, iter_amg, + to_cv_amg, iter_amg, DESTROY_amg, max_amg_code /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */ }; @@ -3292,9 +3296,9 @@ typedef struct am_table_short AMTS; #endif #if !defined(PERLIO_IS_STDIO) && defined(HASATTRIBUTE) -/* - * Now we have __attribute__ out of the way - * Remap printf +/* + * Now we have __attribute__ out of the way + * Remap printf */ #undef printf #define printf PerlIO_stdoutf @@ -3477,7 +3481,7 @@ typedef struct am_table_short AMTS; #undef PERL_PATCHLEVEL_H_IMPLICIT /* Mention - + NV_PRESERVES_UV HAS_ICONV diff --git a/proto.h b/proto.h index 4c5499e..55ee5aa 100644 --- a/proto.h +++ b/proto.h @@ -401,6 +401,7 @@ PERL_CALLCONV int Perl_magic_clearpack(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_clearsig(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_existspack(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_freeregexp(pTHX_ SV* sv, MAGIC* mg); +PERL_CALLCONV int Perl_magic_freeovrld(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_get(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_getarylen(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_getdefelem(pTHX_ SV* sv, MAGIC* mg); diff --git a/sv.c b/sv.c index 0da17e1..0ece5a7 100644 --- a/sv.c +++ b/sv.c @@ -1322,10 +1322,10 @@ Perl_sv_setuv(pTHX_ register SV *sv, UV u) { /* With these two if statements: u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 - + without u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 - + If you wish to remove them, please benchmark to see what the effect is */ if (u <= (UV)IV_MAX) { @@ -1350,10 +1350,10 @@ Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { /* With these two if statements: u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 - + without u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 - + If you wish to remove them, please benchmark to see what the effect is */ if (u <= (UV)IV_MAX) { @@ -1527,7 +1527,7 @@ S_not_a_number(pTHX_ SV *sv) Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning changes - now IV and NV together means that the two are interchangeable SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; - + The benefit of this is operations such as pp_add know that if SvIOK is true for both left and right operands, then integer addition can be used instead of floating point. (for cases where the result won't @@ -1792,7 +1792,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) (NV)UVX == NVX are both true, but the values differ. :-( Hopefully for 2s complement IV_MIN is something like 0x8000000000000000 which will be exact. NWC */ - } + } else { SvUVX(sv) = U_V(SvNVX(sv)); if ( @@ -2043,7 +2043,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) (NV)UVX == NVX are both true, but the values differ. :-( Hopefully for 2s complement IV_MIN is something like 0x8000000000000000 which will be exact. NWC */ - } + } else { SvUVX(sv) = U_V(SvNVX(sv)); if ( @@ -2090,7 +2090,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) UV u; char *num_begin = SvPVX(sv); int save_errno = errno; - + /* seems that strtoul taking numbers that start with - is implementation dependant, and can't be relied upon. */ if (numtype & IS_NUMBER_NEG) { @@ -2101,7 +2101,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (*num_begin == '-') num_begin++; } - + /* Is it an integer that we could convert with strtoul? So try it, and if it doesn't set errno then it's pukka. This should be faster than going atof and then thinking. */ @@ -2110,7 +2110,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) && ((errno = 0), 1) /* always true */ && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */ && (errno == 0) - /* If known to be negative, check it didn't undeflow IV + /* If known to be negative, check it didn't undeflow IV XXX possibly we should put more negative values as NVs direct rather than go via atof below */ && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) { @@ -2417,7 +2417,7 @@ S_asUV(pTHX_ SV *sv) * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should * do this, and vendors have had 11 years to get it right. * However, will try to make it still work with only atol - * + * * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX @@ -2471,7 +2471,7 @@ Perl_looks_like_number(pTHX_ SV *sv) nbegin = s; /* - * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to + * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you * will need (int)atof(). @@ -3923,7 +3923,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam mg->mg_virtual = &PL_vtbl_amagicelem; break; case 'c': - mg->mg_virtual = 0; + mg->mg_virtual = &PL_vtbl_ovrld; break; case 'B': mg->mg_virtual = &PL_vtbl_bm; @@ -4292,7 +4292,7 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ SvREFCNT(&tmpref) = 1; - do { + do { stash = SvSTASH(sv); destructor = StashHANDLER(stash,DESTROY); if (destructor) { @@ -5220,7 +5220,7 @@ Perl_sv_inc(pTHX_ register SV *sv) if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) { /* It's (privately or publicly) a float, but not tested as an integer, so test it to see. */ - (void) SvIV(sv); + (void) SvIV(sv); flags = SvFLAGS(sv); } if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { @@ -5271,7 +5271,7 @@ Perl_sv_inc(pTHX_ register SV *sv) so $a="9.22337203685478e+18"; $a+0; $a++ needs to be the same as $a="9.22337203685478e+18"; $a++ or we go insane. */ - + (void) sv_2iv(sv); if (SvIOK(sv)) goto oops_its_int; @@ -5414,7 +5414,7 @@ Perl_sv_dec(pTHX_ register SV *sv) so $a="9.22337203685478e+18"; $a+0; $a-- needs to be the same as $a="9.22337203685478e+18"; $a-- or we go insane. */ - + (void) sv_2iv(sv); if (SvIOK(sv)) goto oops_its_int;