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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -1067,6 +1067,15 @@ Returns the package name of a stash.  See C<SvSTASH>, C<CvSTASH>.
 =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<SvIV> 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<SvIV()>.
 
-       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<SvIV()>.
+Coerces the given SV to an integer and returns it. Guarantees to evaluate
+sv only once. Use the more efficient C<SvIV> 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 (file)
--- 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<Devel::Peek>, L<re> which may change this).

diff --git a/proto.h b/proto.h
index b6a584c..5e30627 100644 (file)
--- 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