develooper Front page | perl.perl5.porters | Postings from August 2003

[PATCH] Re: Storable Error

Thread Previous | Thread Next
From:
Nicholas Clark
Date:
August 8, 2003 16:35
Subject:
[PATCH] Re: Storable Error
Message ID:
20030809003535.C20130@plum.flirble.org
Not a solution yet, but

On Thu, Aug 07, 2003 at 03:08:35AM +0530, Abhijit Menon-Sen wrote:
> At 2003-07-23 16:01:19 -0400, vbono@vinny.org wrote:
> >
> > Assertion flags == 0 failed: file "Storable.xs", line 2336
> 
> The appended patch (relative to Storable 2.07) appears to paper over the
> problem. I have no convenient way to investigate this further, so could
> someone please:

I find that I can create hashes where key flags are set but HASKFLAGS is not
with the appended patch, and running t/op/utfhash.t with -DA

I'm not sure if this patch is a good idea. It adds 2 new debug flags
  -DA calls sanity checking assert routines
  -Dq suppresses the "EXECUTING..." line, without which regression tests fail.
and a new routine
  Perl_hv_assert, which checks the consistency of hashes

I didn't make the compilation of Perl_hv_assert conditional on -DDEBUGGING
because it may be useful to call it from a debugger session, in a similar
fashion to Perl_sv_dump.

I've run out of time today to find the true bug, but at least I can
create an "impossible" hash

Hash has HASKFLAGS off but I count 1 key(s) with flags
SV = PVHV(0x81a6dd8) at 0x81e7774
  REFCNT = 1
  FLAGS = (PADBUSY,PADMY,SHAREKEYS)
  IV = 1
  NV = 0
  ARRAY = 0x8261c38  (0:7, 1:1)
  hash quality = 100.0%
  KEYS = 1
  FILL = 1
  MAX = 7
  RITER = -1
  EITER = 0x0

Running the regression tests with export PERL5OPT=-DAq
and this patch causes 2 failures:

t/op/local...........................Can't locate object method "FIRSTKEY" via package "TH" at op/local.t line 140.
FAILED at test 42
t/op/split...........................# Failed at op/split.t line 58
FAILED at test 11

I don't understand why, as I pinched the iterator save/restore code
straight out of Storable. If it's not working, it suggests (another)
subtle Storable bug.

Nicholas Clark

--- ./pod/perlrun.pod.orig	2003-07-27 22:51:12.000000000 +0100
+++ ./pod/perlrun.pod	2003-08-08 21:57:13.000000000 +0100
@@ -382,6 +382,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).
--- ./hv.c.orig	2003-07-27 22:25:45.000000000 +0100
+++ ./hv.c	2003-08-08 23:39:51.000000000 +0100
@@ -1691,6 +1691,8 @@ Perl_hv_clear(pTHX_ HV *hv)
     if (!hv)
 	return;
 
+    DEBUG_A(Perl_hv_assert(aTHX_ hv));
+
     xhv = (XPVHV*)SvANY(hv);
 
     if (SvREADONLY(hv)) {
@@ -1783,6 +1785,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) */);
@@ -2285,3 +2288,73 @@ S_share_hek_flags(pTHX_ const char *str,
 
     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;
+}
--- ./perl.h.orig	2003-08-05 14:57:16.000000000 +0100
+++ ./perl.h	2003-08-08 21:58:19.000000000 +0100
@@ -2547,7 +2547,10 @@ Gid_t getegid (void);
 #define DEBUG_R_FLAG		0x00040000 /* 262144 */
 #define DEBUG_J_FLAG		0x00080000 /* 524288 */
 #define DEBUG_v_FLAG		0x00100000 /*1048576 */
-#define DEBUG_MASK		0x001FEFFF /* mask of all the standard flags */
+/* 5.9.0 has C at 0x0020000  */
+#define DEBUG_A_FLAG		0x00400000 /*4194304 */
+#define DEBUG_q_FLAG		0x00800000 /8388608*/
+#define DEBUG_MASK		0x00DFEFFF /* mask of all the standard flags */
 
 #define DEBUG_DB_RECURSE_FLAG	0x40000000
 #define DEBUG_TOP_FLAG		0x80000000 /* XXX what's this for ??? Signal
@@ -2573,6 +2576,8 @@ Gid_t getegid (void);
 #  define DEBUG_R_TEST_ (PL_debug & DEBUG_R_FLAG)
 #  define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG)
 #  define DEBUG_v_TEST_ (PL_debug & DEBUG_v_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_)
 
 
@@ -2602,6 +2607,8 @@ Gid_t getegid (void);
 #  define DEBUG_R_TEST DEBUG_R_TEST_
 #  define DEBUG_J_TEST DEBUG_J_TEST_
 #  define DEBUG_v_TEST DEBUG_v_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
@@ -2643,6 +2650,8 @@ Gid_t getegid (void);
 #  define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a)
 #  define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a)
 #  define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a)
+#  define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a)
+#  define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a)
 
 #else /* DEBUGGING */
 
@@ -2667,6 +2676,8 @@ Gid_t getegid (void);
 #  define DEBUG_R_TEST (0)
 #  define DEBUG_J_TEST (0)
 #  define DEBUG_v_TEST (0)
+#  define DEBUG_A_TEST (0)
+#  define DEBUG_q_TEST (0)
 
 #  define PERL_DEB(a)
 #  define PERL_DEBUG(a)
@@ -2690,6 +2701,8 @@ Gid_t getegid (void);
 #  define DEBUG_T(a)
 #  define DEBUG_R(a)
 #  define DEBUG_v(a)
+#  define DEBUG_A(a)
+#  define DEBUG_q(a)
 #endif /* DEBUGGING */
 
 
--- ./embed.fnc.orig	2003-07-23 15:29:18.000000000 +0100
+++ ./embed.fnc	2003-08-08 20:55:17.000000000 +0100
@@ -1407,8 +1407,8 @@ p	|void	|free_tied_hv_pool
 #if defined(DEBUGGING)
 p	|int	|get_debug_opts	|char **s
 #endif
+Apod	|void	|hv_assert	|HV* tb
 
 
 
 END_EXTERN_C
-
--- ./perl.c.orig	2003-08-05 14:57:16.000000000 +0100
+++ ./perl.c	2003-08-08 21:59:40.000000000 +0100
@@ -1794,7 +1794,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)));
 
@@ -2416,7 +2417,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);

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About