From: Nicholas Clark Date: Sat, 9 Aug 2003 00:35:36 +0000 (+0100) Subject: Re: Storable Error X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ecae49c0159ae97ce603c12b29343825a18c1cf1;p=p5sagit%2Fp5-mst-13.2.git Re: Storable Error Message-ID: <20030809003535.C20130@plum.flirble.org> p4raw-id: //depot/perl@21729 --- diff --git a/embed.fnc b/embed.fnc index ca50143..eb8756a 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1393,8 +1393,7 @@ p |void |free_tied_hv_pool p |int |get_debug_opts |char **s #endif Ap |void |save_set_svflags|SV* sv|U32 mask|U32 val - - +Apod |void |hv_assert |HV* tb END_EXTERN_C diff --git a/hv.c b/hv.c index 53bfa1f..457fd5a 100644 --- a/hv.c +++ b/hv.c @@ -1845,6 +1845,8 @@ Perl_hv_clear(pTHX_ HV *hv) if (!hv) return; + DEBUG_A(Perl_hv_assert(aTHX_ hv)); + xhv = (XPVHV*)SvANY(hv); if (SvREADONLY(hv)) { @@ -1938,6 +1940,7 @@ Perl_hv_undef(pTHX_ HV *hv) register XPVHV* xhv; if (!hv) return; + DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); hfreeentries(hv); Safefree(xhv->xhv_array /* HvARRAY(hv) */); @@ -2456,3 +2459,73 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) return HeKEY_hek(entry); } + + +/* +=for apidoc hv_assert + +Check that a hash is in an internally consistent state. + +=cut +*/ + +void +Perl_hv_assert(pTHX_ HV *hv) +{ + HE* entry; + int withflags = 0; + int placeholders = 0; + int real = 0; + int bad = 0; + I32 riter = HvRITER(hv); + HE *eiter = HvEITER(hv); + + (void)hv_iterinit(hv); + + while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { + /* sanity check the values */ + if (HeVAL(entry) == &PL_sv_placeholder) { + placeholders++; + } else { + real++; + } + /* sanity check the keys */ + if (HeSVKEY(entry)) { + /* Don't know what to check on SV keys. */ + } else if (HeKUTF8(entry)) { + withflags++; + if (HeKWASUTF8(entry)) { + PerlIO_printf(Perl_debug_log, + "hash key has both WASUFT8 and UTF8: '%.*s'\n", + (int) HeKLEN(entry), HeKEY(entry)); + bad = 1; + } + } else if (HeKWASUTF8(entry)) { + withflags++; + } + } + if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { + if (HvUSEDKEYS(hv) != real) { + PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n", + (int) real, (int) HvUSEDKEYS(hv)); + bad = 1; + } + if (HvPLACEHOLDERS(hv) != placeholders) { + PerlIO_printf(Perl_debug_log, + "Count %d placeholder(s), but hash reports %d\n", + (int) placeholders, (int) HvPLACEHOLDERS(hv)); + bad = 1; + } + } + if (withflags && ! HvHASKFLAGS(hv)) { + PerlIO_printf(Perl_debug_log, + "Hash has HASKFLAGS off but I count %d key(s) with flags\n", + withflags); + bad = 1; + } + if (bad) { + sv_dump((SV *)hv); + } + HvRITER(hv) = riter; /* Restore hash iterator state */ + HvEITER(hv) = eiter; +} diff --git a/perl.c b/perl.c index 897cd72..c03ea6a 100644 --- a/perl.c +++ b/perl.c @@ -1699,7 +1699,8 @@ S_run_body(pTHX_ I32 oldscope) if (!PL_restartop) { DEBUG_x(dump_all()); - PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); + if (!DEBUG_q_TEST) + PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n", PTR2UV(thr))); @@ -2321,7 +2322,7 @@ Perl_get_debug_opts(pTHX_ char **s) int i = 0; if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ - static char debopts[] = "psltocPmfrxu HXDSTRJvC"; + static char debopts[] = "psltocPmfrxu HXDSTRJvCAq"; for (; isALNUM(**s); (*s)++) { char *d = strchr(debopts,**s); diff --git a/perl.h b/perl.h index 16198df..8fe1848 100644 --- a/perl.h +++ b/perl.h @@ -2508,7 +2508,9 @@ Gid_t getegid (void); #define DEBUG_J_FLAG 0x00080000 /* 524288 */ #define DEBUG_v_FLAG 0x00100000 /*1048576 */ #define DEBUG_C_FLAG 0x00200000 /*2097152 */ -#define DEBUG_MASK 0x003FEFFF /* mask of all the standard flags */ +#define DEBUG_A_FLAG 0x00400000 /*4194304 */ +#define DEBUG_q_FLAG 0x00800000 /8388608*/ +#define DEBUG_MASK 0x00FFEFFF /* mask of all the standard flags */ #define DEBUG_DB_RECURSE_FLAG 0x40000000 #define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? Signal @@ -2535,6 +2537,8 @@ Gid_t getegid (void); # define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG) # define DEBUG_v_TEST_ (PL_debug & DEBUG_v_FLAG) # define DEBUG_C_TEST_ (PL_debug & DEBUG_C_FLAG) +# define DEBUG_A_TEST_ (PL_debug & DEBUG_A_FLAG) +# define DEBUG_q_TEST_ (PL_debug & DEBUG_q_FLAG) # define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_) #ifdef DEBUGGING @@ -2564,6 +2568,8 @@ Gid_t getegid (void); # define DEBUG_J_TEST DEBUG_J_TEST_ # define DEBUG_v_TEST DEBUG_v_TEST_ # define DEBUG_C_TEST DEBUG_C_TEST_ +# define DEBUG_A_TEST DEBUG_A_TEST_ +# define DEBUG_q_TEST DEBUG_A_TEST_ # define PERL_DEB(a) a # define PERL_DEBUG(a) if (PL_debug) a @@ -2602,6 +2608,8 @@ Gid_t getegid (void); # define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a) # define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a) # define DEBUG_C(a) DEBUG__(DEBUG_C_TEST, a) +# define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a) +# define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a) #else /* DEBUGGING */ @@ -2627,6 +2635,8 @@ Gid_t getegid (void); # define DEBUG_J_TEST (0) # define DEBUG_v_TEST (0) # define DEBUG_C_TEST (0) +# define DEBUG_A_TEST (0) +# define DEBUG_q_TEST (0) # define PERL_DEB(a) # define PERL_DEBUG(a) @@ -2651,6 +2661,8 @@ Gid_t getegid (void); # define DEBUG_R(a) # define DEBUG_v(a) # define DEBUG_C(a) +# define DEBUG_A(a) +# define DEBUG_q(a) #endif /* DEBUGGING */ diff --git a/pod/perlapi.pod b/pod/perlapi.pod index f111d0e..44e83be 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -1067,6 +1067,15 @@ Returns the package name of a stash. See C, C. =for hackers Found in file hv.h +=item hv_assert + +Check that a hash is in an internally consistent state. + + void hv_assert(HV* tb) + +=for hackers +Found in file hv.c + =item hv_clear Clears a hash, making it empty. @@ -2870,22 +2879,22 @@ version which guarantees to evaluate sv only once. =for hackers Found in file sv.h -=item SvIVx +=item SvIVX -Coerces the given SV to an integer and returns it. Guarantees to evaluate -sv only once. Use the more efficient C otherwise. +Returns the raw value in the SV's IV slot, without checks or conversions. +Only use when you are sure SvIOK is true. See also C. - IV SvIVx(SV* sv) + IV SvIVX(SV* sv) =for hackers Found in file sv.h -=item SvIVX +=item SvIVx -Returns the raw value in the SV's IV slot, without checks or conversions. -Only use when you are sure SvIOK is true. See also C. +Coerces the given SV to an integer and returns it. Guarantees to evaluate +sv only once. Use the more efficient C otherwise. - IV SvIVX(SV* sv) + IV SvIVx(SV* sv) =for hackers Found in file sv.h diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 18ddbd5..4c74581 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -390,6 +390,8 @@ B<-D14> is equivalent to B<-Dtls>): 524288 J Do not s,t,P-debug (Jump over) opcodes within package DB 1048576 v Verbose: use in conjunction with other flags 2097152 C Copy On Write + 4194304 A Consistency checks on internal structures + 8388608 q quiet - currently only suppressed the "EXECUTING" message All these flags require B<-DDEBUGGING> when you compile the Perl executable (but see L, L which may change this). diff --git a/proto.h b/proto.h index b6a584c..5e30627 100644 --- a/proto.h +++ b/proto.h @@ -1333,8 +1333,7 @@ PERL_CALLCONV void Perl_free_tied_hv_pool(pTHX); PERL_CALLCONV int Perl_get_debug_opts(pTHX_ char **s); #endif PERL_CALLCONV void Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val); - - +PERL_CALLCONV void Perl_hv_assert(pTHX_ HV* tb); END_EXTERN_C