From:	timbo@cvs.perl.org	Date:	Mon Jun 16 12:59:57 2008
Subject:	[svn:dbi] r11430 - in dbi/trunk: . t

Author: timbo
Date: Mon Jun 16 11:59:57 2008
New Revision: 11430

Modified:
   dbi/trunk/Changes
   dbi/trunk/DBI.pm
   dbi/trunk/DBI.xs
   dbi/trunk/t/01basics.t

Log:
Changed trace levels 1..4 to show less information at lower levels.


Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes	(original)
+++ dbi/trunk/Changes	Mon Jun 16 11:59:57 2008
@@ -75,9 +75,12 @@
 
   Increased default $DBI::neat_maxlen from 400 to 1000.
   Increased timeout on tests to accomodate very slow systems.
-  Clarified docs re ":N" style placeholders.
+  Changed behaviour of trace levels 1..4 to show less information
+    at lower levels.
   Changed the format of the key used for $h->{CachedKids}
     (which is undocumented so you shouldn't depend on it anyway)
+  Changed gofer error handling to avoid duplicate error text in errstr.
+  Clarified docs re ":N" style placeholders.
   Improved gofer retry-on-error logic and refactored to aid subclassing.
   Improved gofer trace output in assorted ways.
 

Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm	(original)
+++ dbi/trunk/DBI.pm	Mon Jun 16 11:59:57 2008
@@ -6991,16 +6991,17 @@
 Trace I<levels> are as follows:
 
   0 - Trace disabled.
-  1 - Trace DBI method calls returning with results or errors.
-  2 - Trace method entry with parameters and returning with results.
+  1 - Trace top-level DBI method calls returning with results or errors.
+  2 - As above, adding tracing of top-level method entry with parameters.
   3 - As above, adding some high-level information from the driver
       and some internal information from the DBI.
   4 - As above, adding more detailed information from the driver.
-  5 to 15 - As above but with more and more obscure information.
+      This is the first level to trace all the rows being fetched.
+  5 to 15 - As above but with more and more internal information.
 
 Trace level 1 is best for a simple overview of what's happening.
-Trace level 2 is a good choice for general purpose tracing.
-Levels 3 and above are best reserved for investigating a specific
+Trace levels 2 thru 4 a good choice for general purpose tracing.
+Levels 5 and above are best reserved for investigating a specific
 problem, when you need to see "inside" the driver and DBI.
 
 The trace output is detailed and typically very useful. Much of the

Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs	(original)
+++ dbi/trunk/DBI.xs	Mon Jun 16 11:59:57 2008
@@ -492,7 +492,7 @@
 
     /* try to do the right thing with magical values			*/
     if (SvMAGICAL(sv)) {
-	if (DBIS_TRACE_LEVEL >= 3) {	/* add magic details to help debugging	*/
+	if (DBIS_TRACE_LEVEL >= 5) {	/* add magic details to help debugging	*/
 	    MAGIC* mg;
 	    infosv = sv_2mortal(newSVpv(" (magic-",0));
 	    if (SvSMAGICAL(sv)) sv_catpvn(infosv,"s",1);
@@ -611,7 +611,6 @@
 set_err_sv(SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method)
 {
     dTHX;
-    dPERINTERP;
     SV *h_err;
     SV *h_errstr;
     SV *h_state;
@@ -630,7 +629,7 @@
 	if (SvREADONLY(errstr))	errstr = sv_mortalcopy(errstr);
 	if (SvREADONLY(state))	state  = sv_mortalcopy(state);
 	if (SvREADONLY(method))	method = sv_mortalcopy(method);
-	if (DBIS_TRACE_LEVEL >= 2)
+	if (DBIc_TRACE_LEVEL(imp_xxh) >= 2)
 	    PerlIO_printf(DBIc_LOGPIO(imp_xxh),"    -> HandleSetErr(%s, err=%s, errstr=%s, state=%s, %s)\n",
 		neatsvpv(h,0), neatsvpv(err,0), neatsvpv(errstr,0), neatsvpv(state,0),
 		neatsvpv(method,0)
@@ -646,7 +645,7 @@
 	SPAGAIN;
 	response_sv = (items) ? POPs : &sv_undef;
 	PUTBACK;
-	if (DBIS_TRACE_LEVEL >= 1)
+	if (DBIc_TRACE_LEVEL(imp_xxh) >= 1)
 	    PerlIO_printf(DBIc_LOGPIO(imp_xxh),"    <- HandleSetErr= %s (err=%s, errstr=%s, state=%s, %s)\n",
 		neatsvpv(response_sv,0), neatsvpv(err,0), neatsvpv(errstr,0), neatsvpv(state,0),
 		neatsvpv(method,0)
@@ -1010,7 +1009,6 @@
 static SV *
 dbih_setup_attrib(pTHX_ SV *h, imp_xxh_t *imp_xxh, char *attrib, SV *parent, int read_only, int optional)
 {
-    dPERINTERP;
     STRLEN len = strlen(attrib);
     SV **asvp;
 
@@ -1035,7 +1033,7 @@
 		    neatsvpv(h,0), attrib);
 	}
     }
-    if (DBIS_TRACE_LEVEL >= 5) {
+    if (DBIc_TRACE_LEVEL(imp_xxh) >= 5) {
 	PerlIO *logfp = DBIc_LOGPIO(imp_xxh);
 	PerlIO_printf(logfp,"    dbih_setup_attrib(%s, %s, %s)",
 	    neatsvpv(h,0), attrib, neatsvpv(parent,0));
@@ -1064,7 +1062,7 @@
     if (imp_size < sizeof(imp_fdh_t) || cn_len<10 || strNE("::fd",&col_name[cn_len-4]))
 	croak("panic: dbih_makefdsv %s '%s' imp_size %ld invalid",
 		imp_class, col_name, (long)imp_size);
-    if (DBIS_TRACE_LEVEL >= 3)
+    if (DBIc_TRACE_LEVEL(imp_sth) >= 5)
 	PerlIO_printf(DBILOGFP,"    dbih_make_fdsv(%s, %s, %ld, '%s')\n",
 		neatsvpv(sth,0), imp_class, (long)imp_size, col_name);
     fdsv = dbih_make_com(sth, (imp_xxh_t*)imp_sth, imp_class, imp_size, cn_len+2, 0);
@@ -1103,7 +1101,7 @@
 	}
     }
 
-    if (DBIS_TRACE_LEVEL >= 3)
+    if ((p_imp_xxh ? DBIc_TRACE_LEVEL(p_imp_xxh) : DBIS_TRACE_LEVEL) >= 5)
 	PerlIO_printf(DBILOGFP,"    dbih_make_com(%s, %p, %s, %ld, %p) thr#%p\n",
 	    neatsvpv(p_h,0), (void*)p_imp_xxh, imp_class, (long)imp_size, (void*)imp_templ, (void*)PERL_GET_THX);
 
@@ -1205,7 +1203,7 @@
     parent = dbih_inner(aTHX_ parent, NULL);	/* check parent valid (& inner)	*/
     parent_imp = (parent) ? DBIh_COM(parent) : NULL;
 
-    if (DBIS_TRACE_LEVEL >= 3)
+    if ((parent_imp ? DBIc_TRACE_LEVEL(parent_imp) : DBIS_TRACE_LEVEL) >= 5)
 	PerlIO_printf(DBILOGFP,"    dbih_setup_handle(%s=>%s, %s, %lx, %s)\n",
 	    neatsvpv(orv,0), neatsvpv(h,0), imp_class, (long)parent, neatsvpv(imp_datasv,0));
 
@@ -1547,14 +1545,14 @@
         if (av_len(av)+1 == i)  /* is existing array the right size? */
             return av;
         /* we need to adjust the size of the array */
-        if (DBIc_TRACE_LEVEL(imp_sth) >= 3)
+        if (DBIc_TRACE_LEVEL(imp_sth) >= 2)
             PerlIO_printf(DBILOGFP,"    dbih_setup_fbav realloc from %ld to %ld fields\n", av_len(av)+1, i);
         SvREADONLY_off(av);
         if (i < av_len(av)+1) /* trim to size if too big */
             av_fill(av, i-1);
     }
     else {
-        if (DBIc_TRACE_LEVEL(imp_sth) >= 3)
+        if (DBIc_TRACE_LEVEL(imp_sth) >= 5)
             PerlIO_printf(DBILOGFP,"    dbih_setup_fbav alloc for %ld fields\n", i);
         av = newAV();
         DBIc_FIELDS_AV(imp_sth) = av;
@@ -1635,7 +1633,7 @@
     if ( (av = DBIc_FIELDS_AV(imp_sth)) == Nullav)
 	av = dbih_setup_fbav(imp_sth);
 
-    if (DBIS_TRACE_LEVEL >= 3)
+    if (DBIc_TRACE_LEVEL(imp_sth) >= 5)
 	PerlIO_printf(DBILOGFP,"    dbih_sth_bind_col %s => %s %s\n",
 		neatsvpv(col,0), neatsvpv(ref,0), neatsvpv(attribs,0));
 
@@ -1709,7 +1707,7 @@
     int    cacheit = 0;
     (void)dbikey;
 
-    if (DBIS_TRACE_LEVEL >= 3)
+    if (DBIc_TRACE_LEVEL(imp_xxh) >= 3)
 	PerlIO_printf(DBILOGFP,"    STORE %s %s => %s\n",
 		neatsvpv(h,0), neatsvpv(keysv,0), neatsvpv(valuesv,0));
 
@@ -1916,7 +1914,7 @@
 	/* This is designed to make life easier for people subclassing	*/
 	/* the DBI classes and may be of use to simple perl DBD's.	*/
 	if (strnNE(key,"private_",8) && strnNE(key,"dbd_",4) && strnNE(key,"dbi_",4)) {
-	    if (DBIS_TRACE_LEVEL) { /* change to DBIc_WARN(imp_xxh) once we can validate prefix against registry */
+	    if (DBIc_TRACE_LEVEL(imp_xxh)) { /* change to DBIc_WARN(imp_xxh) once we can validate prefix against registry */
 		PerlIO_printf(DBILOGFP,"$h->{%s}=%s ignored for invalid driver-specific attribute\n",
 			neatsvpv(keysv,0), neatsvpv(valuesv,0));
 	    }
@@ -2242,7 +2240,7 @@
     if (cacheit) {
 	hv_store((HV*)SvRV(h), key, keylen, newSVsv(valuesv), 0);
     }
-    if (DBIS_TRACE_LEVEL >= 3)
+    if (DBIc_TRACE_LEVEL(imp_xxh) >= 3)
 	PerlIO_printf(DBILOGFP,"    .. FETCH %s %s = %s%s\n", neatsvpv(h,0),
 	    neatsvpv(keysv,0), neatsvpv(valuesv,0), cacheit?" (cached)":"");
     if (valuesv == &sv_yes || valuesv == &sv_no || valuesv == &sv_undef)
@@ -2863,13 +2861,13 @@
 #endif
 	    if (imp_xxh && DBIc_TYPE(imp_xxh) <= DBIt_DB)
 		clear_cached_kids(aTHX_ mg->mg_obj, imp_xxh, meth_name, trace_level);
+            /* XXX might be better to move this down to after call_depth has been
+             * incremented and then also SvREFCNT_dec(mg->mg_obj) to force an immediate
+             * DESTROY of the inner handle if there are no other refs to it.
+             * That way the inner DESTROY is properly flagged as a nested call,
+             * and the outer DESTROY gets profiled more accurately, and callbacks work.
+             */
 	    if (trace_level >= 3) {
-                /* XXX might be better to move this down to after call_depth has been
-                 * incremented and then also SvREFCNT_dec(mg->mg_obj) to force an immediate
-                 * DESTROY of the inner handle if there are no other refs to it.
-                 * That way the inner DESTROY is properly flagged as a nested call,
-                 * and the outer DESTROY gets profiled more accurately, and callbacks work.
-                 */
                 PerlIO_printf(DBILOGFP,
 		    "%c   <> DESTROY(%s) ignored for outer handle (inner %s has ref cnt %ld)\n",
 		    (dirty?'!':' '), neatsvpv(h,0), neatsvpv(mg->mg_obj,0),
@@ -2899,7 +2897,7 @@
 	    GV *gv = gv_fetchmethod_autoload(gv_stashsv(orig_h,FALSE), can_meth, FALSE);
 	    if (gv && isGV(gv))
 		rv = sv_2mortal(newRV((SV*)GvCV(gv)));
-	    if (trace_level >= 3) {
+	    if (trace_level >= 1) {
 		PerlIO_printf(DBILOGFP,"    <- %s(%s) = %p\n", meth_name, can_meth, neatsvpv(rv,0));
 	    }
 	    ST(0) = rv;
@@ -2934,7 +2932,7 @@
 	/* XXX could call a 'handle clone' method here?, for dbh's at least */
 	if (is_DESTROY) {
     is_DESTROY_wrong_thread:
-	    if (trace_level >= 2) {
+	    if (trace_level >= 3) {
 		PerlIO_printf(DBILOGFP,"    DESTROY ignored because DBI %sh handle (%s) is owned by thread %p not current thread %p\n",
 		      dbih_htype_name(DBIc_TYPE(imp_xxh)), HvNAME(DBIc_IMP_STASH(imp_xxh)),
 		      (void*)DBIc_THR_USER(imp_xxh), (void*)my_perl) ;
@@ -2967,7 +2965,7 @@
 			if (gv && isGV(gv))
 			    dbi_msv = (SV*)GvCV(gv);
 		    }
-		    if (trace_level >= 3) {
+		    if (trace_level >= 1) {
 			PerlIO *logfp = DBILOGFP;
 			PerlIO_printf(logfp,"    <- %s(%s) = %p (%s %p)\n", meth_name, can_meth, (void*)dbi_msv,
 				(imp_msv && isGV(imp_msv)) ? HvNAME(GvSTASH(imp_msv)) : "?", (void*)imp_msv);
@@ -3228,7 +3226,7 @@
             }
         }
 
-	if (trace_level >= 2) {
+        if (trace_level >= (is_nested_call ? 4 : 2)) {
 	    PerlIO *logfp = DBILOGFP;
 	    /* Full pkg method name (or just meth_name for ANON CODE)	*/
 	    const char *imp_meth_name = (imp_msv && isGV(imp_msv)) ? GvNAME(imp_msv) : meth_name;
@@ -3338,11 +3336,11 @@
 
     err_sv = DBIc_ERR(imp_xxh);
 
-    if (trace_level > 1 || (trace_level == 1 && !is_nested_call) ) {
+    if (trace_level >= (is_nested_call ? 3 : 1)) {
 	PerlIO *logfp = DBILOGFP;
 	const int is_fetch  = (*meth_name=='f' && DBIc_TYPE(imp_xxh)==DBIt_ST && strnEQ(meth_name,"fetch",5));
 	const int row_count = (is_fetch) ? DBIc_ROW_COUNT((imp_sth_t*)imp_xxh) : 0;
-	if (is_fetch && row_count>=2 && trace_level<=1 && SvOK(ST(0))) {
+	if (is_fetch && row_count>=2 && trace_level<=4 && SvOK(ST(0))) {
 	    /* skip the 'middle' rows to reduce output */
 	    goto skip_meth_return_trace;
 	}
@@ -4080,7 +4078,7 @@
     SV *outer_ref;
     HV *class_stash = gv_stashsv(class, GV_ADDWARN);
 
-    if (DBIS_TRACE_LEVEL >= 3) {
+    if (DBIS_TRACE_LEVEL >= 5) {
         PerlIO_printf(DBILOGFP, "    New %s (for %s, parent=%s, id=%s)\n",
             neatsvpv(class,0), SvPV_nolen(imp_class), neatsvpv(parent,0), neatsvpv(imp_datasv,0));
         (void)cv; /* avoid unused warning */
@@ -4425,14 +4423,13 @@
     char *meth = SvPV_nolen(SvRV(sv));	/* what should this tie do ?	*/
     char type = *meth++;		/* is this a $ or & style	*/
     imp_xxh_t *imp_xxh = (DBI_LAST_HANDLE_OK) ? DBIh_COM(DBI_LAST_HANDLE) : NULL;
-    int trace = 0;
+    int trace_level = (imp_xxh ? DBIc_TRACE_LEVEL(imp_xxh) : DBIS_TRACE_LEVEL);
     NV profile_t1 = 0.0;
 
     if (imp_xxh && DBIc_has(imp_xxh,DBIcf_Profile))
 	profile_t1 = dbi_time();
 
-    if (DBIS_TRACE_LEVEL >= 2 || (imp_xxh && DBIc_TRACE_LEVEL(imp_xxh) >= 2)) {
-	trace = 2;
+    if (trace_level >= 2) {
 	PerlIO_printf(DBILOGFP,"    -> $DBI::%s (%c) FETCH from lasth=%s\n", meth, type,
 		(imp_xxh) ? neatsvpv(DBI_LAST_HANDLE,0): "none");
     }
@@ -4443,7 +4440,7 @@
 	ST(0) = (imp_xxh) ? sv_2mortal(newRV(DBI_LAST_HANDLE)) : &sv_undef;
     }
     else if ( !imp_xxh ) {
-	if (trace)
+	if (trace_level)
 	    warn("Can't read $DBI::%s, last handle unknown or destroyed", meth);
 	ST(0) = &sv_undef;
     }
@@ -4468,7 +4465,7 @@
 	HE save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575 workaround */
 #endif
 	profile_t1 = 0.0; /* profile this via dispatch only (else we'll double count) */
-	if (DBIS_TRACE_LEVEL >= 2)
+	if (DBIS_TRACE_LEVEL >= 3)
 	    PerlIO_printf(DBILOGFP,"    >> %s::%s\n", HvNAME(imp_stash), meth);
 	ST(0) = sv_2mortal(newRV(DBI_LAST_HANDLE));
 	if ((imp_gv = gv_fetchmethod(imp_stash,meth)) == NULL) {
@@ -4482,7 +4479,7 @@
 	PL_hv_fetch_ent_mh = save_mh;
 #endif
     }
-    if (trace)
+    if (trace_level)
 	PerlIO_printf(DBILOGFP,"    <- $DBI::%s= %s\n", meth, neatsvpv(ST(0),0));
     if (profile_t1) {
         SV *h = sv_2mortal(newRV(DBI_LAST_HANDLE));

Modified: dbi/trunk/t/01basics.t
==============================================================================
--- dbi/trunk/t/01basics.t	(original)
+++ dbi/trunk/t/01basics.t	Mon Jun 16 11:59:57 2008
@@ -133,7 +133,7 @@
 
 ## testing neat
 
-cmp_ok($DBI::neat_maxlen, '==',  400, "... $DBI::neat_maxlen initial state is 400");
+cmp_ok($DBI::neat_maxlen, '==',  1000, "... $DBI::neat_maxlen initial state is 400");
 
 is(neat(1 + 1), "2",	 '... neat : 1 + 1 -> "2"');
 is(neat("2"),   "'2'",   '... neat : 2 -> "\'2\'"');