r18040 - in /branches/upstream/libdbi-perl/current: Changes DBI.pm DBI.xs DBIXS.h META.yml dbiproxy.PL dbixs_rev.h lib/DBD/Gofer/Transport/stream.pm lib/DBI/Profile.pm lib/DBI/ProxyServer.pm t/10examp.t t/40profile.t t/85gofer.t

gregoa-guest at users.alioth.debian.org gregoa-guest at users.alioth.debian.org
Thu Mar 27 16:25:46 UTC 2008


Author: gregoa-guest
Date: Thu Mar 27 16:25:46 2008
New Revision: 18040

URL: http://svn.debian.org/wsvn/?sc=1&rev=18040
Log:
[svn-upgrade] Integrating new upstream version, libdbi-perl (1.604)

Modified:
    branches/upstream/libdbi-perl/current/Changes
    branches/upstream/libdbi-perl/current/DBI.pm
    branches/upstream/libdbi-perl/current/DBI.xs
    branches/upstream/libdbi-perl/current/DBIXS.h
    branches/upstream/libdbi-perl/current/META.yml
    branches/upstream/libdbi-perl/current/dbiproxy.PL
    branches/upstream/libdbi-perl/current/dbixs_rev.h
    branches/upstream/libdbi-perl/current/lib/DBD/Gofer/Transport/stream.pm
    branches/upstream/libdbi-perl/current/lib/DBI/Profile.pm
    branches/upstream/libdbi-perl/current/lib/DBI/ProxyServer.pm
    branches/upstream/libdbi-perl/current/t/10examp.t
    branches/upstream/libdbi-perl/current/t/40profile.t
    branches/upstream/libdbi-perl/current/t/85gofer.t

Modified: branches/upstream/libdbi-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/Changes?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/Changes (original)
+++ branches/upstream/libdbi-perl/current/Changes Thu Mar 27 16:25:46 2008
@@ -2,7 +2,7 @@
 
 DBI::Changes - List of significant changes to the DBI
 
-(As of $Date: 2008-02-08 22:46:09 +0000 (Fri, 08 Feb 2008) $ $Revision: 10706 $)
+(As of $Date: 2008-03-24 14:06:48 +0000 (Mon, 24 Mar 2008) $ $Revision: 10994 $)
 
 =cut
 
@@ -39,6 +39,26 @@
     so not bother FETCHing them (unless pedantic)
 Call method on transport failure so transport can cleanup/reset if it wants
 Gofer: gearman - need to disable coallesing for non-idempotent requests
+
+=head2 Changes in DBI 1.604 (svn rev 10994) 24th March 2008
+
+  Fixed fetchall_arrayref with $max_rows argument broken in 1.603,
+    thanks to Greg Sabino Mullane.
+  Fixed a few harmless compiler warnings on cygwin.
+
+=head2 Changes in DBI 1.603
+
+  Fixed pure-perl fetchall_arrayref with $max_rows argument
+    to not error when fetching after all rows already fetched.
+    (Was fixed for compiled drivers back in DBI 1.31.)
+    Thanks to Mark Overmeer.
+  Fixed C sprintf formats and casts, fixing compiler warnings.
+
+  Changed dbi_profile() to accept a hash of profiles and apply to all.
+  Changed gofer stream transport to improve error reporting.
+  Changed gofer test timeout to avoid spurious failures on slow systems.
+
+  Added options to t/85gofer.t so it's more useful for manual testing.
 
 =head2 Changes in DBI 1.602 (svn rev 10706)  8th February 2008
 

Modified: branches/upstream/libdbi-perl/current/DBI.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/DBI.pm?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/DBI.pm (original)
+++ branches/upstream/libdbi-perl/current/DBI.pm Thu Mar 27 16:25:46 2008
@@ -1,4 +1,4 @@
-# $Id: DBI.pm 10706 2008-02-08 22:46:09Z timbo $
+# $Id: DBI.pm 10994 2008-03-24 14:06:48Z timbo $
 # vim: ts=8:sw=4
 #
 # Copyright (c) 1994-2007  Tim Bunce  Ireland
@@ -9,7 +9,7 @@
 require 5.006_00;
 
 BEGIN {
-$DBI::VERSION = "1.602"; # ==> ALSO update the version in the pod text below!
+$DBI::VERSION = "1.604"; # ==> ALSO update the version in the pod text below!
 }
 
 =head1 NAME
@@ -121,8 +121,8 @@
 
 =head2 NOTES
 
-This is the DBI specification that corresponds to the DBI version 1.602
-($Revision: 10706 $).
+This is the DBI specification that corresponds to the DBI version 1.604
+($Revision: 10994 $).
 
 The DBI is evolving at a steady pace, so it's good to check that
 you have the latest copy.
@@ -1949,7 +1949,12 @@
 
     sub fetchall_arrayref {	# ALSO IN Driver.xst
 	my ($sth, $slice, $max_rows) = @_;
-	$max_rows = -1 unless defined $max_rows;
+
+        # when batch fetching with $max_rows were very likely to try to
+        # fetch the 'next batch' after the previous batch returned
+        # <=$max_rows. So don't treat that as an error.
+        return undef if $max_rows and not $sth->FETCH('Active');
+
 	my $mode = ref($slice) || 'ARRAY';
 	my @rows;
 	my $row;
@@ -1957,17 +1962,16 @@
 	    # we copy the array here because fetch (currently) always
 	    # returns the same array ref. XXX
 	    if ($slice && @$slice) {
-		$max_rows = -1 unless defined $max_rows;
+                $max_rows = -1 unless defined $max_rows;
 		push @rows, [ @{$row}[ @$slice] ]
 		    while($max_rows-- and $row = $sth->fetch);
 	    }
 	    elsif (defined $max_rows) {
-		$max_rows = -1 unless defined $max_rows;
 		push @rows, [ @$row ]
 		    while($max_rows-- and $row = $sth->fetch);
 	    }
 	    else {
-		push @rows, [ @$row ]          while($row = $sth->fetch);
+		push @rows, [ @$row ] while($row = $sth->fetch);
 	    }
 	}
 	elsif ($mode eq 'HASH') {
@@ -1975,6 +1979,8 @@
 	    if (keys %$slice) {
 		my @o_keys = keys %$slice;
 		my @i_keys = map { lc } keys %$slice;
+                # XXX this could be made faster by pre-binding a local hash
+                # using bind_columns and then copying it per row
 		while ($max_rows-- and $row = $sth->fetchrow_hashref('NAME_lc')) {
 		    my %hash;
 		    @hash{@o_keys} = @{$row}{@i_keys};
@@ -5941,7 +5947,9 @@
 fetchall_arrayref() can then be called again to fetch more rows.
 This is especially useful when you need the better performance of
 fetchall_arrayref() but don't have enough memory to fetch and return
-all the rows in one go. Here's an example:
+all the rows in one go.
+
+Here's an example (assumes RaiseError is enabled):
 
   my $rows = []; # cache for batches of rows
   while( my $row = ( shift(@$rows) || # get row from cache, or reload cache:
@@ -5950,7 +5958,7 @@
     ...
   }
 
-That can be the fastest way to fetch and process lots of rows using the DBI,
+That I<might> be the fastest way to fetch and process lots of rows using the DBI,
 but it depends on the relative cost of method calls vs memory allocation.
 
 A standard C<while> loop with column binding is often faster because

Modified: branches/upstream/libdbi-perl/current/DBI.xs
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/DBI.xs?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/DBI.xs (original)
+++ branches/upstream/libdbi-perl/current/DBI.xs Thu Mar 27 16:25:46 2008
@@ -1,6 +1,6 @@
 /* vim: ts=8:sw=4
  *
- * $Id: DBI.xs 10677 2008-01-31 20:38:55Z timbo $
+ * $Id: DBI.xs 10993 2008-03-24 13:44:36Z timbo $
  *
  * Copyright (c) 1994-2003  Tim Bunce  Ireland.
  *
@@ -227,16 +227,16 @@
     static const char msg[] = "you probably need to rebuild the DBD driver (or possibly the DBI)";
     (void)need_dbixs_cv;
     if (dbis_cv != DBISTATE_VERSION || dbis_cs != sizeof(*DBIS))
-	croak("DBI/DBD internal version mismatch (DBI is v%d/s%d, DBD %s expected v%d/s%d) %s.\n",
-	    DBISTATE_VERSION, sizeof(*DBIS), name, dbis_cv, dbis_cs, msg);
+	croak("DBI/DBD internal version mismatch (DBI is v%d/s%lu, DBD %s expected v%d/s%d) %s.\n",
+	    DBISTATE_VERSION, (long unsigned int)sizeof(*DBIS), name, dbis_cv, dbis_cs, msg);
     /* Catch structure size changes - We should probably force a recompile if the DBI	*/
     /* runtime version is different from the build time. That would be harsh but safe.	*/
     if (drc_s != sizeof(dbih_drc_t) || dbc_s != sizeof(dbih_dbc_t) ||
 	stc_s != sizeof(dbih_stc_t) || fdc_s != sizeof(dbih_fdc_t) )
-	    croak("%s (dr:%d/%d, db:%d/%d, st:%d/%d, fd:%d/%d), %s.\n",
+	    croak("%s (dr:%d/%ld, db:%d/%ld, st:%d/%ld, fd:%d/%ld), %s.\n",
 		"DBI/DBD internal structure mismatch",
-		drc_s, sizeof(dbih_drc_t), dbc_s, sizeof(dbih_dbc_t),
-		stc_s, sizeof(dbih_stc_t), fdc_s, sizeof(dbih_fdc_t), msg);
+		drc_s, (long)sizeof(dbih_drc_t), dbc_s, (long)sizeof(dbih_dbc_t),
+		stc_s, (long)sizeof(dbih_stc_t), fdc_s, (long)sizeof(dbih_fdc_t), msg);
 }
 
 static void
@@ -746,7 +746,8 @@
 
 static SV *
 dbih_inner(pTHX_ SV *orv, const char *what)
-{   /* convert outer to inner handle else croak(what) if what is not null */
+{   /* convert outer to inner handle else croak(what) if what is not NULL */
+    /* if what is NULL then return NULL for invalid handles */
     dPERINTERP;
     MAGIC *mg;
     SV *ohv;		/* outer HV after derefing the RV	*/
@@ -766,6 +767,8 @@
 	croak("%s handle %s is not a DBI handle", what, neatsvpv(orv,0));
     }
     if (!SvMAGICAL(ohv)) {
+	if (!what)
+	    return NULL;
 	sv_dump(orv);
 	croak("%s handle %s is not a DBI handle (has no magic)",
 		what, neatsvpv(orv,0));
@@ -906,8 +909,8 @@
     imp_fdh_t *imp_fdh;
     SV *fdsv;
     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 %d invalid",
-		imp_class, col_name, imp_size);
+	croak("panic: dbih_makefdsv %s '%s' imp_size %ld invalid",
+		imp_class, col_name, (long)imp_size);
     if (DBIS_TRACE_LEVEL >= 3)
 	PerlIO_printf(DBILOGFP,"    dbih_make_fdsv(%s, %s, %ld, '%s')\n",
 		neatsvpv(sth,0), imp_class, (long)imp_size, col_name);
@@ -949,14 +952,14 @@
 
     if (DBIS_TRACE_LEVEL >= 3)
 	PerlIO_printf(DBILOGFP,"    dbih_make_com(%s, %p, %s, %ld, %p) thr#%p\n",
-	    neatsvpv(p_h,0), p_imp_xxh, imp_class, (long)imp_size, imp_templ, PERL_GET_THX);
+	    neatsvpv(p_h,0), (void*)p_imp_xxh, imp_class, (long)imp_size, (void*)imp_templ, (void*)PERL_GET_THX);
 
     if (imp_templ && SvOK(imp_templ)) {
 	U32  imp_templ_flags;
 	/* validate the supplied dbi_imp_data looks reasonable,	*/
 	if (SvCUR(imp_templ) != imp_size)
-	    croak("Can't use dbi_imp_data of wrong size (%d not %d)",
-		SvCUR(imp_templ), imp_size);
+	    croak("Can't use dbi_imp_data of wrong size (%ld not %ld)",
+		(long)SvCUR(imp_templ), (long)imp_size);
 
 	/* copy the whole template */
 	dbih_imp_sv = newSVsv(imp_templ);
@@ -1287,7 +1290,7 @@
     if (DBIc_THR_USER(imp_xxh) != my_perl) { /* don't clear handle that belongs to another thread */
 	if (debug >= 3) {
 	    PerlIO_printf(DBILOGFP,"    skipped dbih_clearcom: DBI handle (type=%d, %s) is owned by thread %p not current thread %p\n",
-		  DBIc_TYPE(imp_xxh), HvNAME(DBIc_IMP_STASH(imp_xxh)), DBIc_THR_USER(imp_xxh), my_perl) ;
+		  DBIc_TYPE(imp_xxh), HvNAME(DBIc_IMP_STASH(imp_xxh)), (void*)DBIc_THR_USER(imp_xxh), (void*)my_perl) ;
 	    PerlIO_flush(DBILOGFP);
 	}
 	return;
@@ -2630,7 +2633,8 @@
 /* ----------------------------------------------------------------- */
 /* ---   The DBI dispatcher. The heart of the perl DBI.          --- */
 
-XS(XS_DBI_dispatch)         /* prototype must match XS produced code */
+XS(XS_DBI_dispatch);            /* prototype to pass -Wmissing-prototypes */
+XS(XS_DBI_dispatch)
 {
     dXSARGS;
     dPERINTERP;
@@ -2780,7 +2784,7 @@
 	    if (trace_level >= 2) {
 		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)),
-		      (PerlInterpreter *)DBIc_THR_USER(imp_xxh), my_perl) ;
+		      (void*)DBIc_THR_USER(imp_xxh), (void*)my_perl) ;
 		PerlIO_flush(DBILOGFP);
 	    }
 	    XSRETURN(0); /* don't DESTROY handle, if it is not our's !*/
@@ -2812,8 +2816,8 @@
 		    }
 		    if (trace_level >= 3) {
 			PerlIO *logfp = DBILOGFP;
-			PerlIO_printf(logfp,"    <- %s(%s) = %p (%s %p)\n", meth_name, can_meth, dbi_msv,
-				(imp_msv && isGV(imp_msv)) ? HvNAME(GvSTASH(imp_msv)) : "?", imp_msv);
+			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);
 		    }
 		    ST(0) = (dbi_msv) ? sv_2mortal(newRV(dbi_msv)) : &PL_sv_undef;
 		    XSRETURN(1);
@@ -3092,7 +3096,7 @@
 		    (ima && i==ima->hidearg) ? "****" : neatsvpv(ST(i),0));
 	    }
 #ifdef DBI_USE_THREADS
-	    PerlIO_printf(logfp, ") thr#%p\n", DBIc_THR_USER(imp_xxh));
+	    PerlIO_printf(logfp, ") thr#%p\n", (void*)DBIc_THR_USER(imp_xxh));
 #else
 	    PerlIO_printf(logfp, ")\n");
 #endif
@@ -3204,7 +3208,7 @@
 	    if (is_DESTROY) /* show handle as first arg to DESTROY */
 		/* want to show outer handle so trace makes sense	*/
 		/* but outer handle has been destroyed so we fake it	*/
-		PerlIO_printf(logfp,"(%s=HASH(%p)", HvNAME(SvSTASH(SvRV(orig_h))), DBIc_MY_H(imp_xxh));
+		PerlIO_printf(logfp,"(%s=HASH(%p)", HvNAME(SvSTASH(SvRV(orig_h))), (void*)DBIc_MY_H(imp_xxh));
 	    else
 		PerlIO_printf(logfp,"(%s", neatsvpv(st1,0));
 	    if (items >= 3)
@@ -4173,20 +4177,36 @@
     NV t1
     NV t2
     CODE:
-    D_imp_xxh(h);
-    SV *leaf = dbi_profile(h, imp_xxh, statement,
-	SvROK(method) ? SvRV(method) : method,
-	t1, t2
-    );
-    if (DBIc_TRACE_LEVEL(imp_xxh) >= 9)
-        warn("dbi_profile(%s, %s, %f, %f) =%s, gimme=%ld",
-                neatsvpv(statement,0), neatsvpv(method,0), t1, t2,
-                neatsvpv(leaf,0), (long)GIMME_V);
+    SV *leaf = &sv_undef;
     (void)cv;   /* avoid unused var warnings */
+    if (SvROK(method))
+        method = SvRV(method);
+    if (dbih_inner(aTHX_ h, NULL)) {    /* is a DBI handle */
+        D_imp_xxh(h);
+        leaf = dbi_profile(h, imp_xxh, statement, method, t1, t2);
+    }
+    else if (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV) {
+        /* iterate over values %$h */
+        HV *hv = (HV*)SvRV(h);
+        SV *tmp;
+	char *key;
+	I32 keylen = 0;
+	hv_iterinit(hv);
+	while ( (tmp = hv_iternextsv(hv, &key, &keylen)) != NULL ) {
+            if (SvOK(tmp)) {
+                D_imp_xxh(tmp);
+                leaf = dbi_profile(tmp, imp_xxh, statement, method, t1, t2);
+            }
+	};
+    }
+    else {
+        croak("dbi_profile(%s,...) invalid handle argument", neatsvpv(h,0));
+    }
     if (GIMME_V == G_VOID)
         ST(0) = &sv_undef;  /* skip sv_mortalcopy if not needed */
     else
         ST(0) = sv_mortalcopy(leaf);
+
 
 
 SV *

Modified: branches/upstream/libdbi-perl/current/DBIXS.h
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/DBIXS.h?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/DBIXS.h (original)
+++ branches/upstream/libdbi-perl/current/DBIXS.h Thu Mar 27 16:25:46 2008
@@ -1,4 +1,4 @@
-/* $Id: DBIXS.h 9659 2007-06-18 14:19:45Z timbo $
+/* $Id: DBIXS.h 10899 2008-03-10 12:00:51Z timbo $
  *
  * Copyright (c) 1994-2002  Tim Bunce  Ireland
  *
@@ -467,7 +467,7 @@
 # define DBISTATE_INIT {	/* typically use in BOOT: of XS file	*/    \
     DBISTATE_INIT_DBIS;	\
     if (DBIS == NULL)	\
-	croak("Unable to get DBI state from %s at %p. DBI not loaded.", DBISTATE_PERLNAME, DBISTATE_ADDRSV); \
+	croak("Unable to get DBI state from %s at %p. DBI not loaded.", DBISTATE_PERLNAME, (void*)DBISTATE_ADDRSV); \
     DBIS->check_version(__FILE__, DBISTATE_VERSION, sizeof(*DBIS), NEED_DBIXS_VERSION, \
 		sizeof(dbih_drc_t), sizeof(dbih_dbc_t), sizeof(dbih_stc_t), sizeof(dbih_fdc_t) \
     ); \

Modified: branches/upstream/libdbi-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/META.yml?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/META.yml (original)
+++ branches/upstream/libdbi-perl/current/META.yml Thu Mar 27 16:25:46 2008
@@ -1,14 +1,17 @@
-# http://module-build.sourceforge.net/META-spec.html
-#XXXXXXX This is a prototype!!!  It will change in the future!!! XXXXX#
-name:         DBI
-version:      1.602
-version_from: DBI.pm
-installdirs:  site
-requires:
+--- #YAML:1.0
+name:                DBI
+version:             1.604
+abstract:            Database independent interface for Perl
+license:             ~
+author:              
+    - Tim Bunce (dbi-users at perl.org)
+generated_by:        ExtUtils::MakeMaker version 6.42
+distribution_type:   module
+requires:     
     File::Spec:                    0
     Scalar::Util:                  0
     Storable:                      1
     Test::Simple:                  0.4
-
-distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.30
+meta-spec:
+    url:     http://module-build.sourceforge.net/META-spec-v1.3.html
+    version: 1.3

Modified: branches/upstream/libdbi-perl/current/dbiproxy.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/dbiproxy.PL?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/dbiproxy.PL (original)
+++ branches/upstream/libdbi-perl/current/dbiproxy.PL Thu Mar 27 16:25:46 2008
@@ -7,7 +7,7 @@
 
 use strict;
 
-my $VERSION = sprintf("1.%06d", q$Revision: 9874 $ =~ /(\d+)/o);
+my $VERSION = sprintf("1.%06d", q$Revision: 10720 $ =~ /(\d+)/o);
 
 my $arg_test    = shift(@ARGV)		if $ARGV[0] eq '--test';
 $ENV{DBI_TRACE} = shift(@ARGV) || 2	if $ARGV[0] =~ s/^--dbitrace=?//;
@@ -54,7 +54,7 @@
 =item B<--chroot=dir>
 
 (UNIX only)  After doing a bind(), change root directory to the given
-directory by doing a chroot(). This is usefull for security, but it
+directory by doing a chroot(). This is useful for security, but it
 restricts the environment a lot. For example, you need to load DBI
 drivers in the config file or you have to create hard links to Unix
 sockets, if your drivers are using them. For example, with MySQL, a
@@ -99,7 +99,7 @@
 =item B<--group=gid>
 
 After doing a bind(), change the real and effective GID to the given.
-This is usefull, if you want your server to bind to a privileged port
+This is useful, if you want your server to bind to a privileged port
 (<1024), but don't want the server to execute as root. See also
 the --user option.
 
@@ -140,7 +140,7 @@
 Finally there's a single-connection mode: If the server has accepted a
 connection, he will enter the Run() method. No other connections are
 accepted until the Run() method returns (if the client disconnects).
-This operation mode is usefull if you have neither threads nor fork(),
+This operation mode is useful if you have neither threads nor fork(),
 for example on the Macintosh. For debugging purposes you can force this
 mode with "--mode=single".
 
@@ -152,7 +152,7 @@
 =item B<--user=uid>
 
 After doing a bind(), change the real and effective UID to the given.
-This is usefull, if you want your server to bind to a privileged port
+This is useful, if you want your server to bind to a privileged port
 (<1024), but don't want the server to execute as root. See also
 the --group and the --chroot options.
 

Modified: branches/upstream/libdbi-perl/current/dbixs_rev.h
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/dbixs_rev.h?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/dbixs_rev.h (original)
+++ branches/upstream/libdbi-perl/current/dbixs_rev.h Thu Mar 27 16:25:46 2008
@@ -1,3 +1,4 @@
-/* Fri Jan  4 15:10:17 2008 */
+/* Mon Mar 10 14:00:00 2008 */
+/* Mixed revision working copy (10706M:10899) */
 /* Code modified since last checkin */
-#define DBIXS_REVISION 10429
+#define DBIXS_REVISION 10706

Modified: branches/upstream/libdbi-perl/current/lib/DBD/Gofer/Transport/stream.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/lib/DBD/Gofer/Transport/stream.pm?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/lib/DBD/Gofer/Transport/stream.pm (original)
+++ branches/upstream/libdbi-perl/current/lib/DBD/Gofer/Transport/stream.pm Thu Mar 27 16:25:46 2008
@@ -1,6 +1,6 @@
 package DBD::Gofer::Transport::stream;
 
-#   $Id: stream.pm 10087 2007-10-16 12:42:37Z timbo $
+#   $Id: stream.pm 10905 2008-03-10 22:01:04Z timbo $
 #
 #   Copyright (c) 2007, Tim Bunce, Ireland
 #
@@ -14,7 +14,7 @@
 
 use base qw(DBD::Gofer::Transport::pipeone);
 
-our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
+our $VERSION = sprintf("0.%06d", q$Revision: 10905 $ =~ /(\d+)/o);
 
 __PACKAGE__->mk_accessors(qw(
     go_persist
@@ -154,12 +154,12 @@
     $self->read_response_from_fh( {
         $efh => {
             error => sub { warn "error reading response stderr: $!"; $errno||=$!; 1 },
-            eof   => sub { warn "eof on stderr" if 0; 1 },
+            eof   => sub { warn "eof reading efh" if $trace >= 4; 1 },
             read  => sub { $stderr_msg .= $_; 0 },
         },
         $rfh => {
             error => sub { warn "error reading response: $!"; $errno||=$!; 1 },
-            eof   => sub { warn "eof on stdout" if 0; 1 },
+            eof   => sub { warn "eof reading rfh" if $trace >= 4; 1 },
             read  => sub { $encoded_response .= $_; ($encoded_response=~s/\015\012$//) ? 1 : 0 },
         },
     });
@@ -168,17 +168,16 @@
     # probably exited, possibly with an error to stderr.
     # Turn this situation into a reasonably useful DBI error.
     if (not $encoded_response) {
-        my $msg = "No response received";
-        if (chomp $stderr_msg && $stderr_msg) {
-            $msg .= sprintf ", error reported by \"%s\" (pid %d%s): %s",
+        my @msg;
+        push @msg, "error while reading response: $errno" if $errno;
+        if ($stderr_msg) {
+            chomp $stderr_msg;
+            push @msg, sprintf "error reported by \"%s\" (pid %d%s): %s",
                 $self->cmd_as_string,
                 $pid, ((kill 0, $pid) ? "" : ", exited"),
                 $stderr_msg;
         }
-        else {
-            $msg .= ($errno) ? ", error while reading response: $errno" : "(no error message)";
-        }
-        die "$msg\n";
+        die join(", ", "No response received", @msg)."\n";
     }
 
     $self->trace_msg("Response received: $encoded_response\n",0)

Modified: branches/upstream/libdbi-perl/current/lib/DBI/Profile.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/lib/DBI/Profile.pm?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/lib/DBI/Profile.pm (original)
+++ branches/upstream/libdbi-perl/current/lib/DBI/Profile.pm Thu Mar 27 16:25:46 2008
@@ -612,11 +612,10 @@
 The $h->{Profile}{Path} attribute is processed by dbi_profile() in
 the usual way.
 
-It is recommended that you keep these extra data samples separate
-from the DBI profile data samples by using values for $statement
-and $method that are distinct from any that are likely to appear
-in the profile data normally.
-
+The $h parameter is usually a DBI handle but it can also be a reference to a
+hash, in which case the dbi_profile() acts on each defined value in the hash.
+This is an efficient way to update multiple profiles with a single sample,
+and is used by the L<DashProfiler> module.
 
 =head1 SUBCLASSING
 
@@ -679,7 +678,7 @@
 
 use DBI qw(dbi_time dbi_profile dbi_profile_merge_nodes dbi_profile_merge);
 
-$VERSION = sprintf("2.%06d", q$Revision: 10494 $ =~ /(\d+)/o);
+$VERSION = sprintf("2.%06d", q$Revision: 10916 $ =~ /(\d+)/o);
 
 
 @ISA = qw(Exporter);

Modified: branches/upstream/libdbi-perl/current/lib/DBI/ProxyServer.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/lib/DBI/ProxyServer.pm?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/lib/DBI/ProxyServer.pm (original)
+++ branches/upstream/libdbi-perl/current/lib/DBI/ProxyServer.pm Thu Mar 27 16:25:46 2008
@@ -382,7 +382,7 @@
 DBI::Proxy Server is a module for implementing a proxy for the DBI proxy
 driver, DBD::Proxy. It allows access to databases over the network if the
 DBMS does not offer networked operations. But the proxy server might be
-usefull for you, even if you have a DBMS with integrated network
+useful for you, even if you have a DBMS with integrated network
 functionality: It can be used as a DBI proxy in a firewalled environment.
 
 DBI::ProxyServer runs as a daemon on the machine with the DBMS or on the
@@ -414,7 +414,7 @@
 =item I<chroot> (B<--chroot=dir>)
 
 (UNIX only)  After doing a bind(), change root directory to the given
-directory by doing a chroot(). This is usefull for security, but it
+directory by doing a chroot(). This is useful for security, but it
 restricts the environment a lot. For example, you need to load DBI
 drivers in the config file or you have to create hard links to Unix
 sockets, if your drivers are using them. For example, with MySQL, a
@@ -465,7 +465,7 @@
 =item I<group> (B<--group=gid>)
 
 After doing a bind(), change the real and effective GID to the given.
-This is usefull, if you want your server to bind to a privileged port
+This is useful, if you want your server to bind to a privileged port
 (<1024), but don't want the server to execute as root. See also
 the --user option.
 
@@ -506,7 +506,7 @@
 Finally there's a single-connection mode: If the server has accepted a
 connection, he will enter the Run() method. No other connections are
 accepted until the Run() method returns (if the client disconnects).
-This operation mode is usefull if you have neither threads nor fork(),
+This operation mode is useful if you have neither threads nor fork(),
 for example on the Macintosh. For debugging purposes you can force this
 mode with "--mode=single".
 
@@ -518,7 +518,7 @@
 =item I<user> (B<--user=uid>)
 
 After doing a bind(), change the real and effective UID to the given.
-This is usefull, if you want your server to bind to a privileged port
+This is useful, if you want your server to bind to a privileged port
 (<1024), but don't want the server to execute as root. See also
 the --group and the --chroot options.
 
@@ -538,7 +538,7 @@
 with some additional attributes in the client list.
 
 The config file is a Perl script. At the top of the file you may include
-arbitraty Perl source, for example load drivers at the start (usefull
+arbitraty Perl source, for example load drivers at the start (useful
 to enhance performance), prepare a chroot environment and so on.
 
 The important thing is that you finally return a hash ref of option

Modified: branches/upstream/libdbi-perl/current/t/10examp.t
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/t/10examp.t?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/t/10examp.t (original)
+++ branches/upstream/libdbi-perl/current/t/10examp.t Thu Mar 27 16:25:46 2008
@@ -12,7 +12,7 @@
 my $haveFileSpec = eval { require File::Spec };
 require VMS::Filespec if $^O eq 'VMS';
 
-use Test::More tests => 205;
+use Test::More tests => 208;
 
 # "globals"
 my ($r, $dbh);
@@ -228,12 +228,17 @@
 ok(keys %{$r->[0]} == 3);
 ok("@{$r->[0]}{qw(MODE SIZE NAME)}" eq "@row_a", "'@{$r->[0]}{qw(MODE SIZE NAME)}' ne '@row_a'");
 
-# use Data::Dumper; warn Dumper([\@row_a, $r]);
-
+print "rows()\n"; # assumes previous fetch fetched all rows
 $rows = $csr_b->rows;
 ok($rows > 0, "row count $rows");
 ok($rows == @$r, "$rows vs ".@$r);
 ok($rows == $DBI::rows, "$rows vs $DBI::rows");
+
+print "fetchall_arrayref array slice and max rows\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref([0], 1);
+ok($r);
+is_deeply($r, [[$row_a[0]]]);
 
 # ---
 

Modified: branches/upstream/libdbi-perl/current/t/40profile.t
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/t/40profile.t?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/t/40profile.t (original)
+++ branches/upstream/libdbi-perl/current/t/40profile.t Thu Mar 27 16:25:46 2008
@@ -286,16 +286,22 @@
 $dbh->{Profile}->{Path} = [ '!Time', "!Time~$factor", '!MethodName' ];
 $dbh->{Profile}->{Data} = undef;
 
+# give up a timeslice in the hope that the following few lines
+# run in well under a second even of slow/overloaded systems
 $t1 = int(dbi_time())+1; 1 while int(dbi_time()-0.01) < $t1; # spin till just after second starts
 $t2 = int($t1/$factor)*$factor;
 
 $sth = $dbh->prepare("select name from .");
-
 $tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data});
+
+# if actual "!Time" recorded is 'close enough' then we'll pass
+# the test - it's not worth failing just because a system is slow
+$t1 = (keys %$tmp)[0] if (abs($t1 - (keys %$tmp)[0]) <= 2);
+
 is_deeply $tmp, {
     $t1 => { $t2 => { prepare => [ 1, 0, 0, 0, 0, 0, 0 ] }}
 }, "!Time and !Time~$factor should work"
-  or print Dumper($tmp);
+  or warn Dumper([$t1, $t2, $tmp]);
 
 
 print "testing &norm_std_n3 in Path\n";
@@ -306,7 +312,7 @@
 ];
 $dbh->{Profile}->{Data} = undef;
 $sql = qq{insert into foo20060726 (a,b) values (42,"foo")};
-dbi_profile($dbh, $sql, 'mymethod', 100000000, 100000002);
+dbi_profile( { foo => $dbh, bar => undef }, $sql, 'mymethod', 100000000, 100000002);
 $tmp = $dbh->{Profile}{Data};
 #warn Dumper($tmp);
 is_deeply $tmp, {

Modified: branches/upstream/libdbi-perl/current/t/85gofer.t
URL: http://svn.debian.org/wsvn/branches/upstream/libdbi-perl/current/t/85gofer.t?rev=18040&op=diff
==============================================================================
--- branches/upstream/libdbi-perl/current/t/85gofer.t (original)
+++ branches/upstream/libdbi-perl/current/t/85gofer.t Thu Mar 27 16:25:46 2008
@@ -9,6 +9,7 @@
 use Config;
 use Data::Dumper;
 use Test::More;
+use Getopt::Long;
 
 use DBI qw(dbi_time);
 
@@ -23,24 +24,29 @@
 # next line forces use of Nano rather than default behaviour
 $ENV{DBI_SQL_NANO}=1;
 
-my $perf_count = (@ARGV && $ARGV[0] =~ s/^-c=//) ? shift : (-t STDOUT) ? 100 : 0;
-my %durations;
+GetOptions(
+    'c|count=i' => \(my $opt_count = (-t STDOUT ? 100 : 0)),
+    'dbm=s'     => \my $opt_dbm,
+    'v|verbose!' => \my $opt_verbose,
+    't|transport=s' => \my $opt_transport,
+    'p|policy=s'    => \my $opt_policy,
+) or exit 1;
+
 
 # so users can try others from the command line
-my $dbm = $ARGV[0];
-if (!$dbm) {
+if (!$opt_dbm) {
     # pick first available, starting with SDBM_File
     for (qw( SDBM_File GDBM_File DB_File BerkeleyDB )) {
         if (eval { local $^W; require "$_.pm" }) {
-            $dbm = ($_);
+            $opt_dbm = ($_);
             last;
         }
     }
-    plan skip_all => 'No DBM modules available' if !$dbm;
-}
-my $remote_driver_dsn = "dbm_type=$dbm;lockfile=0";
+    plan skip_all => 'No DBM modules available' if !$opt_dbm;
+}
+my $remote_driver_dsn = "dbm_type=$opt_dbm;lockfile=0";
 my $remote_dsn = "dbi:DBM:$remote_driver_dsn";
-my $timeout = 10;
+my $timeout = 30; # for slow/overloaded systems (incl virtual machines with low priority)
 
 plan 'no_plan';
 
@@ -55,7 +61,7 @@
 # ensure subprocess (for pipeone and stream transport) will use the same modules as us, ie ./blib
 local $ENV{PERL5LIB} = join $Config{path_sep}, @INC;
 
-
+my %durations;
 my $getcwd = getcwd();
 my $username = eval { getpwuid($>) } || ''; # fails on windows
 my $can_ssh = ($username && $username eq 'timbo' && -d '.svn');
@@ -74,7 +80,13 @@
 # too dependant on local config to make a standard test
 delete $trials{http} unless $username eq 'timbo' && -d '.svn';
 
-for my $trial (sort keys %trials) {
+my @transports = ($opt_transport) ? ($opt_transport) : (sort keys %trials);
+print "Transports: @transports\n";
+my @policies = ($opt_policy) ? ($opt_policy) : qw(pedantic classic rush);
+print "Policies: @policies\n";
+print "Count: $opt_count\n";
+
+for my $trial (@transports) {
     (my $transport = $trial) =~ s/_.*//;
     my $trans_attr = $trials{$trial}
         or next;
@@ -86,7 +98,7 @@
         next if $transport eq 'stream' or $transport eq 'pipeone';
     }
 
-    for my $policy_name (qw(pedantic classic rush)) {
+    for my $policy_name (@policies) {
 
         eval { run_tests($transport, $trans_attr, $policy_name) };
         ($@) ? fail("$trial: $@") : pass();
@@ -95,7 +107,7 @@
 }
 
 # to get baseline for comparisons if doing performance testing
-run_tests('no', {}, 'pedantic') if $perf_count;
+run_tests('no', {}, 'pedantic') if $opt_count;
 
 while ( my ($activity, $stats_hash) = each %durations ) {
     print "\n";
@@ -103,9 +115,9 @@
     for my $perf_tag (reverse sort keys %$stats_hash) {
         my $dur = $stats_hash->{$perf_tag} || 0.0000001;
         printf "  %6s %-16s: %.6fsec (%5d/sec)",
-            $activity, $perf_tag, $dur/$perf_count, $perf_count/$dur;
+            $activity, $perf_tag, $dur/$opt_count, $opt_count/$dur;
         my $baseline_dur = $stats_hash->{'~baseline~'};
-        printf " %+5.1fms", (($dur-$baseline_dur)/$perf_count)*1000
+        printf " %+5.1fms", (($dur-$baseline_dur)/$opt_count)*1000
             unless $perf_tag eq '~baseline~';
         print "\n";
     }
@@ -167,17 +179,17 @@
     ok $rowset = $sth->fetchall_hashref('dKey');
     is_deeply($rowset, { '1' => { dKey=>1, dVal=>'apples' }, 2 => { dKey=>2, dVal=>'apples' } });
 
-    if ($perf_count and $transport ne 'pipeone') {
-        print "performance check - $perf_count selects and inserts\n";
+    if ($opt_count and $transport ne 'pipeone') {
+        print "performance check - $opt_count selects and inserts\n";
         my $start = dbi_time();
         $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit")
-            for (1000..1000+$perf_count);
+            for (1000..1000+$opt_count);
         $durations{select}{"$transport+$policy_name"} = dbi_time() - $start;
 
         # some rows in to get a (*very* rough) idea of overheads
         $start = dbi_time();
         $ins_sth->execute($_, 'speed')
-            for (1000..1000+$perf_count);
+            for (1000..1000+$opt_count);
         $durations{insert}{"$transport+$policy_name"} = dbi_time() - $start;
     }
 




More information about the Pkg-perl-cvs-commits mailing list