Author: timbo
Date: Mon Apr 16 11:37:58 2007
New Revision: 9418
Added:
dbi/trunk/dbilogstrip.PL (contents, props changed)
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/MANIFEST
dbi/trunk/Makefile.PL
dbi/trunk/dbiprof.PL
dbi/trunk/dbiproxy.PL
dbi/trunk/dumpmethods.pl
dbi/trunk/goferperf.pl (props changed)
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/01basics.t
dbi/trunk/t/02dbidrv.t
dbi/trunk/test.pl
Log:
Moved _new_handle and TIEHASH to C.
Now 20% faster (for $null_dbh->prepare('') while $i--;)
Added dbilogstrip utility (gets installed) to filter DBI logs.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Apr 16 11:37:58 2007
@@ -53,9 +53,12 @@
Changed DBD::NullP to be slightly more useful for testing.
Changed File::Spec prerequisite to not require a minimum version.
Changed tests to work with other DBMs thanks to ZMAN.
+ Changed some handle creation code from perl to C code,
+ so handle creation cost reduced by ~20%.
Many assorted Gofer related bug fixes, enhancements and docs.
Added goferperf.pl utility (doesn't get installed).
+ Added dbilogstrip utility (gets installed)
Added support for DBI Profile Path to contain refs to scalars
which will be de-ref'd for each profile sample.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Apr 16 11:37:58 2007
@@ -778,6 +778,7 @@
$drh = eval { $driver_class->driver($attr || {}) };
unless ($drh && ref $drh && !$@) {
my $advice = "";
+ $@ ||= "$driver_class->driver didn't return a handle";
# catch people on case in-sensitive systems using the wrong case
$advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right."
if $@ =~ /locate object method/;
@@ -1136,13 +1137,14 @@
my $loops ||= $attr->{dbi_loops} || 5;
my $par ||= $attr->{dbi_par} || 1; # parallelism
my $verb ||= $attr->{dbi_verb} || 1;
+ my $meth ||= $attr->{dbi_meth} || 'connect';
print "$dsn: testing $loops sets of $par connections:\n";
- require Benchmark;
require "FileHandle.pm"; # don't let toke.c create empty FileHandle
package
- $| = 1;
- my $t0 = new Benchmark; # not currently used
+ local $| = 1;
my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn
driver\n");
- my $t1 = new Benchmark;
+ # test the connection and warm up caches etc
+ $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed:
$DBI::errstr");
+ my $t1 = dbi_time();
my $loop;
for $loop (1..$loops) {
my @cons;
@@ -1150,58 +1152,30 @@
for (1..$par) {
print "$_ ";
push @cons, ($drh->connect($dsn,$dbuser,$dbpass)
- or Carp::croak("Can't connect # $_: $DBI::errstr\n"));
+ or Carp::croak("connect failed: $DBI::errstr\n"));
}
print "\nDisconnecting...\n" if $verb;
for (@cons) {
- $_->disconnect or warn "bad disconnect $DBI::errstr"
+ $_->disconnect or warn "disconnect failed: $DBI::errstr"
}
}
- my $t2 = new Benchmark;
- my $td = Benchmark::timediff($t2, $t1);
- printf "Made %2d connections in %s\n", $loops*$par,
Benchmark::timestr($td);
- print "\n";
+ my $t2 = dbi_time();
+ my $td = $t2 - $t1;
+ printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n",
+ $par, $loops, $td, $loops*$par, $td/($loops*$par);
return $td;
}
# Help people doing DBI->errstr, might even document it one day
-# XXX probably best moved to cheaper XS code
+# XXX probably best moved to cheaper XS code if this gets documented
sub err { $DBI::err }
sub errstr { $DBI::errstr }
# --- Private Internal Function for Creating New DBI Handles
-sub _new_handle {
- my ($class, $parent, $attr, $imp_data, $imp_class) = @_;
-
- Carp::croak('Usage: DBI::_new_handle'
- .'($class_name, parent_handle, \%attr, $imp_data)'."\n"
- .'got: ('.join(", ",$class, $parent, $attr, $imp_data).")\n")
- unless (@_ == 5 and (!$parent or ref $parent)
- and ref $attr eq 'HASH'
- and $imp_class);
-
- $attr->{ImplementorClass} = $imp_class
- or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not
given");
-
- DBI->trace_msg(" New $class (for $imp_class, parent=$parent,
id=".($imp_data||'').")\n")
- if $DBI::dbi_debug >= 3;
-
- # This is how we create a DBI style Object:
- my (%hash, $i, $h);
- $i = tie %hash, $class, $attr; # ref to inner hash (for driver)
- $h = bless \%hash, $class; # ref to outer hash (for application)
- # The above tie and bless may migrate down into _setup_handle()...
- # Now add magic so DBI method dispatch works
- DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
-
- return $h unless wantarray;
- ($h, $i);
-}
-# XXX minimum constructors for the tie's (alias to XS version)
-sub DBI::st::TIEHASH { bless $_[1] => $_[0] };
+# XXX move to PurePerl?
*DBI::dr::TIEHASH = \&DBI::st::TIEHASH;
*DBI::db::TIEHASH = \&DBI::st::TIEHASH;
@@ -7228,16 +7202,21 @@
=head2 Tracing Tips
-You can add tracing to your own application code using the
-L</trace_msg> method.
+You can add tracing to your own application code using the L</trace_msg>
method.
+
+It can sometimes be handy to compare trace files from two different runs of the
+same script. However using a tool like C<diff> on the original log output
+doesn't work well because the trace file is full of object addresses that may
+differ on each run.
-It can sometimes be handy to compare trace files from two different
-runs of the same script. However using a tool like C<diff> doesn't work
-well because the trace file is full of object addresses that may
-differ each run. Here's a handy little command to strip those out:
+The DBI includes a handy utility called dbilogstrip that can be used to
+'normalize' the log content. It can be used as a filter like this:
- perl -pe 's/\b0x[\da-f]{6,}/0xNNNN/gi; s/\b[\da-f]{6,}/<long number>/gi'
+ DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip >
dbitrace1.log
+ DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip >
dbitrace2.log
+ diff -u dbitrace1.log dbitrace2.log
+See L<dbilogstrip> for more information.
=head1 DBI ENVIRONMENT VARIABLES
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Apr 16 11:37:58 2007
@@ -1150,7 +1150,7 @@
/* Use DBI magic on inner handle to carry handle attributes */
sv_magic(SvRV(h), dbih_imp_sv, DBI_MAGIC, Nullch, 0);
SvREFCNT_dec(dbih_imp_sv); /* since sv_magic() incremented it */
- SvRMAGICAL_on(SvRV(h)); /* so magic gets sv_clear'd ok */
+ SvRMAGICAL_on(SvRV(h)); /* so DBI magic gets sv_clear'd ok */
DBI_SET_LAST_HANDLE(h);
@@ -1179,6 +1179,10 @@
dbih_dumphandle(SV *h, const char *msg, int level)
{
D_imp_xxh(h);
+ if (level >= 9) {
+ dTHX;
+ sv_dump(h);
+ }
dbih_dumpcom(imp_xxh, msg, level);
}
@@ -3872,6 +3876,58 @@
void
+_new_handle(class, parent, attr_ref, imp_datasv, imp_class)
+ SV * class
+ SV * parent
+ SV * attr_ref
+ SV * imp_datasv
+ SV * imp_class
+ PPCODE:
+ dTHX;
+ dPERINTERP;
+ HV *outer;
+ SV *outer_ref;
+ GV *class_stash = gv_stashsv(class, GV_ADDWARN);
+ (void)cv;
+
+ if (DBIS_TRACE_LEVEL >= 3) {
+ 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));
+ }
+
+ hv_store(SvRV(attr_ref), "ImplementorClass", 16, SvREFCNT_inc(imp_class),
0);
+
+ /* make attr into inner handle by blessing it into class */
+ sv_bless(attr_ref, class_stash);
+ /* tie new outer hash to inner handle */
+ outer = newHV(); /* create new hash to be outer handle */
+ outer_ref = newRV_noinc((SV*)outer);
+ /* make outer hash into a handle by blessing it into class */
+ sv_bless(outer_ref, class_stash);
+ /* tie outer handle to inner handle */
+ sv_magic((SV*)outer, attr_ref, PERL_MAGIC_tied, Nullch, 0);
+ /*SvREFCNT_dec(attr_ref); /* because sv_magic() incremented it */
+
+ /*
+ my (%outer, $i, $h);
+ $i = tie %outer, $class, $attr; # ref to inner hash (for driver)
+ $h = bless \%outer, $class; # ref to outer hash (for
application)
+ DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
+ return $h unless wantarray;
+ return ($h, $i);
+ */
+ dbih_setup_handle(outer_ref, SvPV_nolen(imp_class), parent,
SvOK(imp_datasv) ? imp_datasv : Nullsv);
+
+ /* return outer handle, plus inner handle if not in scalar context */
+ sv_2mortal(outer_ref);
+ EXTEND(SP, 2);
+ PUSHs(outer_ref);
+ if (GIMME != G_SCALAR) {
+ PUSHs(attr_ref);
+ }
+
+
+void
_setup_handle(sv, imp_class, parent, imp_datasv)
SV * sv
char * imp_class
@@ -4592,6 +4648,17 @@
}
+MODULE = DBI PACKAGE = DBI::st
+
+void
+TIEHASH(class, inner_ref)
+ SV * class
+ SV * inner_ref
+ CODE:
+ HV *stash = gv_stashsv(class, GV_ADDWARN); /* a new hash is supplied to
us, we just need to bless and apply tie magic */
+ sv_bless(inner_ref, stash);
+ ST(0) = inner_ref;
+
MODULE = DBI PACKAGE = DBD::_::common
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Mon Apr 16 11:37:58 2007
@@ -15,6 +15,7 @@
dbd_xsh.h Prototypes for standard Driver.xst interface
dbi_sql.h Definitions based on SQL CLI / ODBC (#inc'd by
DBIXS.h)
dbipport.h Perl portability macros (from Devel::PPort)
+dbilogstrip.PL Utility to normalise DBI logs so they can be
compared with diff
dbiprof.PL
dbiproxy.PL Frontend for DBI::ProxyServer
dbivport.h DBI version portability macros (for drivers to
copy)
Modified: dbi/trunk/Makefile.PL
==============================================================================
--- dbi/trunk/Makefile.PL (original)
+++ dbi/trunk/Makefile.PL Mon Apr 16 11:37:58 2007
@@ -126,11 +126,11 @@
"File::Spec" => 0,
"Scalar::Util" => 0,
},
- EXE_FILES => [ "dbiproxy$ext_pl", "dbiprof$ext_pl" ],
+ EXE_FILES => [ "dbiproxy$ext_pl", "dbiprof$ext_pl", "dbilogstrip$ext_pl" ],
DIR => [ ],
dynamic_lib => { OTHERLDFLAGS => "$::opt_g" },
clean => { FILES=> "\$(DISTVNAME) Perl.xsi t/zv*_*.t"
- ." dbiproxy$ext_pl dbiprof$ext_pl dbitrace.log dbi.prof
ndtest.prt" },
+ ." dbiproxy$ext_pl dbiprof$ext_pl dbilogstrip$ext_pl
dbitrace.log dbi.prof ndtest.prt" },
dist => {
DIST_DEFAULT=> 'clean distcheck disttest tardist',
PREOP => '$(MAKE) -f Makefile.old distdir',
@@ -310,7 +310,7 @@
$(CP) Roadmap.pod $(roadmap_pm)
checkkeywords:
- $(RM_F) blib
+ $(RM_RF) blib
find . -type f \( -name .svn -prune -o -name \*.pm -o -name \*.PL -o
-name \*.pl \) \
-exec bash -c '[ -z "$$(svn pg svn:keywords {})" ] && echo svn
propset svn:keywords \"Id Revision\" {}' \;
};
Added: dbi/trunk/dbilogstrip.PL
==============================================================================
--- (empty file)
+++ dbi/trunk/dbilogstrip.PL Mon Apr 16 11:37:58 2007
@@ -0,0 +1,34 @@
+# -*- perl -*-
+my $file = $ARGV[0] || 'dbilogstrip';
+
+my $script = <<'SCRIPT';
+~startperl~
+
+use strict;
+
+while (<>) {
+ # normalize hex addresses: 0xDEADHEAD => 0x
+ s/ \b 0x [0-9a-f]+ /0x/gx;
+ # normalize process id number
+ s/ \b pid \W? \d+ /pidN/gx;
+
+} continue {
+ print or die "-p destination: $!\n";
+}
+
+
+SCRIPT
+
+require Config;
+my $config = {};
+$config->{'startperl'} = $Config::Config{'startperl'};
+
+$script =~ s/\~(\w+)\~/$config->{$1}/eg;
+if (!(open(FILE, ">$file")) ||
+ !(print FILE $script) ||
+ !(close(FILE))) {
+ die "Error while writing $file: $!\n";
+}
+chmod 0755, $file;
+print "Extracted $file from ",__FILE__," with variable substitutions.\n";
+
Modified: dbi/trunk/dbiprof.PL
==============================================================================
--- dbi/trunk/dbiprof.PL (original)
+++ dbi/trunk/dbiprof.PL Mon Apr 16 11:37:58 2007
@@ -1,6 +1,6 @@
# -*- perl -*-
-my $file = 'dbiprof';
+my $file = $ARGV[0] || 'dbiprof';
my $script = <<'SCRIPT';
~startperl~
@@ -246,4 +246,5 @@
!(close(FILE))) {
die "Error while writing $file: $!\n";
}
+chmod 0755, $file;
print "Extracted $file from ",__FILE__," with variable substitutions.\n";
Modified: dbi/trunk/dbiproxy.PL
==============================================================================
--- dbi/trunk/dbiproxy.PL (original)
+++ dbi/trunk/dbiproxy.PL Mon Apr 16 11:37:58 2007
@@ -1,6 +1,6 @@
# -*- perl -*-
-my $file = 'dbiproxy';
+my $file = $ARGV[0] || 'dbiproxy';
my $script = <<'SCRIPT';
~startperl~
@@ -187,6 +187,7 @@
L<DBI::ProxyServer(3)>, L<DBD::Proxy(3)>, L<DBI(3)>
+=cut
SCRIPT
@@ -200,4 +201,5 @@
!(close(FILE))) {
die "Error while writing $file: $!\n";
}
+chmod 0755, $file;
print "Extracted $file from ",__FILE__," with variable substitutions.\n";
Modified: dbi/trunk/dumpmethods.pl
==============================================================================
--- dbi/trunk/dumpmethods.pl (original)
+++ dbi/trunk/dumpmethods.pl Mon Apr 16 11:37:58 2007
@@ -41,7 +41,7 @@
my $O = $info->{O}||0;
my @ima_flags = map { ($O & $_) ? $bit2hex{$_} : () } @bit2hex_bitkeys;
- printf "\$h->$fullmeth($proto) @ima_flags # 0x%04x\n", $O;
+ printf "\$h->%s(%s) %s # 0x%04x\n", $fullmeth, $proto, "@ima_flags",
$O;
}
}
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Mon Apr 16 11:37:58 2007
@@ -436,6 +436,28 @@
}
}
+
+sub _new_handle {
+ my ($class, $parent, $attr, $imp_data, $imp_class) = @_;
+
+ DBI->trace_msg(" New $class (for $imp_class, parent=$parent,
id=".($imp_data||'').")\n")
+ if $DBI::dbi_debug >= 3;
+
+ $attr->{ImplementorClass} = $imp_class
+ or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not
given");
+
+ # This is how we create a DBI style Object:
+ # %outer gets tied to %$attr (which becomes the 'inner' handle)
+ my (%outer, $i, $h);
+ $i = tie %outer, $class, $attr; # ref to inner hash (for driver)
+ $h = bless \%outer, $class; # ref to outer hash (for application)
+ # The above tie and bless may migrate down into _setup_handle()...
+ # Now add magic so DBI method dispatch works
+ DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
+ return $h unless wantarray;
+ return ($h, $i);
+}
+
sub _setup_handle {
my($h, $imp_class, $parent, $imp_data) = @_;
my $h_inner = tied(%$h) || $h;
@@ -635,6 +657,8 @@
return time();
}
+sub DBI::st::TIEHASH { bless $_[1] => $_[0] };
+
package
DBI::var;
Modified: dbi/trunk/t/01basics.t
==============================================================================
--- dbi/trunk/t/01basics.t (original)
+++ dbi/trunk/t/01basics.t Mon Apr 16 11:37:58 2007
@@ -148,20 +148,6 @@
## ----------------------------------------------------------------------------
## testing DBI functions
-## testing dbi_debug
-
-cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug's initial state is 0");
-
-SKIP: {
- my $null = File::Spec->devnull();
- skip "cannot find : $null", 2 unless ($^O eq "MSWin32" || -e $null);
-
- DBI->trace(15,$null);
- cmp_ok($DBI::dbi_debug, '==', 15, "... DBI::dbi_debug is 15");
- DBI->trace(0, undef);
- cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug is 0");
-}
-
## test DBI->internal
my $switch = DBI->internal;
@@ -317,4 +303,18 @@
like("@installed_drivers", qr/Sponge/, '... make sure at least one of
them is DBI::Spounge');
}
+## testing dbi_debug
+
+cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug's initial state is 0");
+
+SKIP: {
+ my $null = File::Spec->devnull();
+ skip "cannot find : $null", 2 unless ($^O eq "MSWin32" || -e $null);
+
+ DBI->trace(15,$null);
+ cmp_ok($DBI::dbi_debug, '==', 15, "... DBI::dbi_debug is 15");
+ DBI->trace(0, undef);
+ cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug is 0");
+}
+
1;
Modified: dbi/trunk/t/02dbidrv.t
==============================================================================
--- dbi/trunk/t/02dbidrv.t (original)
+++ dbi/trunk/t/02dbidrv.t Mon Apr 16 11:37:58 2007
@@ -198,7 +198,8 @@
SKIP: {
skip "Kids attribute not supported under DBI::PurePerl", 1 if
$DBI::PurePerl;
- cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any
Kids');
+ cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids')
+ or $drh->dump_handle("bad Kids",3);
}
# copied up to drh from dbh when dbh was DESTROYd
Modified: dbi/trunk/test.pl
==============================================================================
--- dbi/trunk/test.pl (original)
+++ dbi/trunk/test.pl Mon Apr 16 11:37:58 2007
@@ -94,14 +94,14 @@
# new experimental connect_test_perf method
DBI->connect_test_perf("dbi:$driver:", '', '', {
- dbi_loops=>5, dbi_par=>20, dbi_verb=>1
+ dbi_loops=>3, dbi_par=>20, dbi_verb=>1
});
require Benchmark;
print "Testing handle creation speed...\n";
my $null_dbh = DBI->connect('dbi:NullP:','','');
my $null_sth = $null_dbh->prepare(''); # create one to warm up
- $count = 10_000;
+ $count = 20_000;
my $i = $count;
my $t1 = new Benchmark;
$null_dbh->prepare('') while $i--;
