Author: timbo
Date: Mon Jan 29 05:04:18 2007
New Revision: 8744
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBD/NullP.pm
dbi/trunk/lib/DBI/DBD.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/03handle.t
dbi/trunk/t/05thrclone.t
dbi/trunk/t/06attrs.t
dbi/trunk/t/08keeperr.t
dbi/trunk/t/09trace.t
dbi/trunk/t/10examp.t
dbi/trunk/t/30subclass.t
dbi/trunk/t/40profile.t
dbi/trunk/t/50dbm.t
dbi/trunk/t/65transact.t
dbi/trunk/test.pl
Log:
Spin-off changes from falling into a rabbit hole with DBD::Gofer (formerly
DBD::Forward)
debugging and having to dig myself out.
A DBD::Forward -> DBD::Gofer rename plus changes will follow.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Jan 29 05:04:18 2007
@@ -2,14 +2,21 @@
DBI::Changes - List of significant changes to the DBI
-(As of $Date:$ $Revision$)
+(As of $Date$ $Revision$)
=cut
-XXX document DBD::Forward
+XXX document DBD::Gofer
=head2 Changes in DBI 1.XX (svn rev XX), XX
+ NOTE: This version has some subtle changes in DBI internals.
+ It's possible, though doubtful, that some may affect your code.
+ I recommend some extra texting before using this release.
+ Or perhaps I'm just being over cautious...
+
+ NOTE: The 'next big thing' is DBD::Gofer. Take a look.
+
Fixed type_info when called for multiple dbh thanks to Cosimo Streppone.
Fixed compile warnings in bleadperl on freebsd-6.1-release
and solaris 10g thanks to Philip M. Gollucci.
@@ -22,13 +29,14 @@
Changed setting trace file to no longer write "Trace file set" to new file.
Changed 'handle cleared whilst still active' warning for dbh
to only be given for dbh that have active sth or are not AutoCommit.
- Changed take_imp_data to call finish on any Active child sth.
+ Changed take_imp_data to call finish on all Active child sth.
+ Changed DBI::PurePerl trace() method to be more consistent.
Updated DBI::DBD docs for driver authors thanks to Ammon Riley
and Dean Arnold.
- Added new DBD::Forward 'stateless proxy' driver and framework,
- and the DBI test suite is now also executed via DBD::Forward,
- and DBD::Forward+DBI::PurePerl, in addition to DBI::PurePerl.
+ Added new DBD::Gofer 'stateless proxy' driver and framework,
+ and the DBI test suite is now also executed via DBD::Gofer,
+ and DBD::Gofer+DBI::PurePerl, in addition to DBI::PurePerl.
Added ability for trace() to support filehandle argument,
including tracing into a string, thanks to Dean Arnold.
Added ability for drivers to implement func() method
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Jan 29 05:04:18 2007
@@ -121,7 +121,7 @@
=head2 NOTES
This is the DBI specification that corresponds to the DBI version 1.54
-($Revision:$).
+($Revision$).
The DBI is evolving at a steady pace, so it's good to check that
you have the latest copy.
@@ -320,7 +320,7 @@
df_ => { class => 'DBD::DF', },
f_ => { class => 'DBD::File', },
file_ => { class => 'DBD::TextFile', },
- fwd_ => { class => 'DBD::Forward', },
+ go_ => { class => 'DBD::Gofer', },
ib_ => { class => 'DBD::InterBase', },
ing_ => { class => 'DBD::Ingres', },
ix_ => { class => 'DBD::Informix', },
@@ -401,7 +401,7 @@
data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
take_imp_data => { U =>[1,1], },
clone => { U =>[1,2,'[\%attr]'] },
- connected => { O=>0x0100 },
+ connected => undef,
begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400 },
commit => { U =>[1,1], O=>0x0480|0x0800 },
rollback => { U =>[1,1], O=>0x0480|0x0800 },
@@ -573,9 +573,10 @@
or Carp::croak("Can't connect to data source $dsn, no database driver
specified "
."and DBI_DSN env var not set");
+ my $proxy;
if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' &&
$driver ne 'Switch') {
my $dbi_autoproxy = $ENV{DBI_AUTOPROXY};
- my $proxy = 'Proxy';
+ $proxy = 'Proxy';
if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) {
$proxy = $1;
$driver_attrib_spec = join ",",
@@ -610,23 +611,16 @@
# attributes in DSN take precedence over \%attr connect parameter
$user = $attr->{Username} if defined $attr->{Username};
$pass = delete $attr->{Password} if defined $attr->{Password};
-
- ($user, $pass) = $drh->default_user($user, $pass, $attr)
- if !(defined $user && defined $pass);
-
- $attr->{Username} = $user; # store username as attribute
+ if ( !(defined $user && defined $pass) ) {
+ ($user, $pass) = $drh->default_user($user, $pass, $attr);
+ }
+ $attr->{Username} = $user; # force the Username to be the actual one used
my $connect_closure = sub {
my ($old_dbh, $override_attr) = @_;
- my $attr = {
- # copy so we can edit them each time we're called
- %attributes,
- # merge in modified attr in %$old_dbh, this should also copy in
- # the dbi_connect_closure attribute so we can reconnect again.
- %{ $override_attr || {} },
- };
- #warn "connect_closure: ".Data::Dumper::Dumper([\%attributes,
$override_attr]);
+ #use Data::Dumper;
+ #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes,
$override_attr]);
my $dbh;
unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) {
@@ -648,45 +642,48 @@
return $dbh; # normally undef, but HandleError could change it
}
- # handle basic RootClass subclassing:
- my $rebless_class = $attr->{RootClass} || ($class ne 'DBI' ? $class :
'');
- if ($rebless_class) {
- no strict 'refs';
- if ($attr->{RootClass}) { # explicit attribute (rather than
static call)
- delete $attr->{RootClass};
- DBI::_load_class($rebless_class, 0);
- }
- unless (@{"$rebless_class\::db::ISA"} &&
@{"$rebless_class\::st::ISA"}) {
- Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are
not setup, RootClass ignored");
- $rebless_class = undef;
- $class = 'DBI';
- }
- else {
- $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via
plain DBI::db
- DBI::_set_isa([$rebless_class], 'DBI'); # sets up both
'::db' and '::st'
- DBI::_rebless($dbh, $rebless_class); # appends '::db'
- }
- }
+ # merge any attribute overrides but don't change $attr itself (for
closure)
+ my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr };
- if (%$attr) {
+ # handle basic RootClass subclassing:
+ my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class :
'');
+ if ($rebless_class) {
+ no strict 'refs';
+ if ($apply->{RootClass}) { # explicit attribute (ie not static
methd call class)
+ delete $apply->{RootClass};
+ DBI::_load_class($rebless_class, 0);
+ }
+ unless (@{"$rebless_class\::db::ISA"} &&
@{"$rebless_class\::st::ISA"}) {
+ Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are
not setup, RootClass ignored");
+ $rebless_class = undef;
+ $class = 'DBI';
+ }
+ else {
+ $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via
plain DBI::db
+ DBI::_set_isa([$rebless_class], 'DBI'); # sets up both
'::db' and '::st'
+ DBI::_rebless($dbh, $rebless_class); # appends '::db'
+ }
+ }
- DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, delete
$attr->{DbTypeSubclass}, $attr)
- if $attr->{DbTypeSubclass};
+ if (%$apply) {
+ if ($apply->{DbTypeSubclass}) {
+ my $DbTypeSubclass = delete $apply->{DbTypeSubclass};
+ DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class,
$DbTypeSubclass);
+ }
my $a;
- foreach $a (qw(RaiseError PrintError AutoCommit)) { # do these first
- next unless exists $attr->{$a};
- $dbh->{$a} = delete $attr->{$a};
+ foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do
these first
+ next unless exists $apply->{$a};
+ $dbh->{$a} = delete $apply->{$a};
}
- foreach $a (keys %$attr) {
- eval { $dbh->{$a} = $attr->{$a} } or $@ && warn $@;
+ while ( my ($a, $v) = each %$apply) {
+ eval { $dbh->{$a} = $v } or $@ && warn $@;
}
}
- # if we've been subclassed then let the subclass know that we're
connected
- # and pass in the original arguments
- $dbh->connected(@orig_args)
- if ref $dbh ne 'DBI::db';
+ # confirm to driver (ie if subclassed) that we've connected sucessfully
+ # and finished the attribute setup. pass in the original arguments
+ $dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy;
DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug;
@@ -842,9 +839,9 @@
sub _rebless_dbtype_subclass {
- my ($dbh, $rootclass, $DbTypeSubclass, $attr) = @_;
+ my ($dbh, $rootclass, $DbTypeSubclass) = @_;
# determine the db type names for class hierarchy
- my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass, $attr);
+ my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass);
# add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc)
$_ = $rootclass.'::'.$_ foreach (@hierarchy);
# load the modules from the 'top down'
@@ -857,7 +854,7 @@
sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC
- my ($dbh, $DbTypeSubclass, $attr) = @_;
+ my ($dbh, $DbTypeSubclass) = @_;
if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne
'CODE') {
# treat $DbTypeSubclass as a comma separated list of names
@@ -1421,6 +1418,7 @@
# XXX debatable as there's no "server side" here
# (and now many uses would trigger warnings on DESTROY)
# $this->STORE(Active => 1);
+ # so drivers should set it in their own connect
$this;
}
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Jan 29 05:04:18 2007
@@ -2445,10 +2445,10 @@
imp_dbh_t *imp_dbh = (DBIc_TYPE(imp_xxh) <= DBIt_DB) ?
(imp_dbh_t*)imp_xxh : (imp_dbh_t*)DBIc_PARENT_COM(imp_xxh);
dbh_outer_hv = DBIc_MY_H(imp_dbh);
if (SvTYPE(dbh_outer_hv) != SVt_PVHV)
- return; /* global destruction - bail */
+ return; /* presumably global destruction - bail
*/
dbh_inner_hv = (HV*)SvRV(dbih_inner((SV*)dbh_outer_hv,
"profile"));
if (SvTYPE(dbh_inner_hv) != SVt_PVHV)
- return; /* global destruction - bail */
+ return; /* presumably global destruction - bail
*/
}
/* fetch from inner first, then outer if key doesn't exist
*/
/* (yes, this is an evil premature optimization) */
@@ -3964,21 +3964,25 @@
CODE:
{
dPERINTERP;
- /* Return old/current value. No change if new value not given. */
- IV level = parse_trace_flags(class, level_sv, (RETVAL = (DBIS) ?
DBIS->debug : 0));
+ IV level;
if (!DBIS) {
ix=ix; /* avoid 'unused variable' warnings */
croak("DBI not initialised");
}
+ /* Return old/current value. No change if new value not given. */
+ RETVAL = (DBIS) ? DBIS->debug : 0;
+ level = parse_trace_flags(class, level_sv, RETVAL);
if (level) /* call before or after altering DBI trace level */
set_trace_file(file);
if (level != RETVAL) {
if ((level & DBIc_TRACE_LEVEL_MASK) > 0) {
- PerlIO_printf(DBILOGFP," DBI %s%s default trace level set to
0x%lx/%ld (pid %d)\n",
+ PerlIO_printf(DBILOGFP," DBI %s%s default trace level set to
0x%lx/%ld (pid %d) at %s\n",
XS_VERSION, dbi_build_opt,
(long)(level & DBIc_TRACE_FLAGS_MASK),
(long)(level & DBIc_TRACE_LEVEL_MASK),
- (int)PerlProc_getpid());
+ (int)PerlProc_getpid(),
+ log_where(Nullsv, 0, "", "", 1, 1, 0)
+ );
if (!PL_dowarn)
PerlIO_printf(DBILOGFP," Note: perl is running without the
recommended perl -w option\n");
PerlIO_flush(DBILOGFP);
@@ -4144,6 +4148,15 @@
MODULE = DBI PACKAGE = DBD::_::db
+void
+connected(...)
+ CODE:
+ /* defined here just to avoid AUTOLOAD */
+ (void)cv;
+ (void)items;
+ ST(0) = &sv_undef;
+
+
SV *
preparse(dbh, statement, ps_accept, ps_return, foo=Nullch)
SV * dbh
Modified: dbi/trunk/lib/DBD/NullP.pm
==============================================================================
--- dbi/trunk/lib/DBD/NullP.pm (original)
+++ dbi/trunk/lib/DBD/NullP.pm Mon Jan 29 05:04:18 2007
@@ -37,7 +37,14 @@
{ package DBD::NullP::dr; # ====== DRIVER ======
$imp_data_size = 0;
use strict;
- # we use default (dummy) connect method
+
+ sub connect { # normally overridden, but a handy default
+ my $dbh = shift->SUPER::connect(@_)
+ or return;
+ $dbh->STORE(Active => 1);
+ $dbh;
+ }
+
sub DESTROY { undef }
}
Modified: dbi/trunk/lib/DBI/DBD.pm
==============================================================================
--- dbi/trunk/lib/DBI/DBD.pm (original)
+++ dbi/trunk/lib/DBI/DBD.pm Mon Jan 29 05:04:18 2007
@@ -3010,14 +3010,14 @@
# XXX need to convert this to work within the generated Makefile
# so 'make' creates them and 'make clean' deletes them
my %test_variants = (
- pp => { name => "DBI::PurePerl",
+ p => { name => "DBI::PurePerl",
add => [ '$ENV{DBI_PUREPERL} = 2' ],
},
- fw => { name => "DBD::Forward",
- add => [ q{$ENV{DBI_AUTOPROXY} =
'dbi:Forward:transport=null'} ],
+ g => { name => "DBD::Gofer",
+ add => [ q{$ENV{DBI_AUTOPROXY} =
'dbi:Gofer:transport=null'} ],
},
- xpf => { name => "PurePerl & Forward",
- add => [ q{$ENV{DBI_PUREPERL} = 2; $ENV{DBI_AUTOPROXY}
= 'dbi:Forward:transport=null'} ],
+ xgp => { name => "PurePerl & Gofer",
+ add => [ q{$ENV{DBI_PUREPERL} = 2; $ENV{DBI_AUTOPROXY}
= 'dbi:Gofer:transport=null'} ],
},
# mx => { name => "DBD::Multiplex",
# add => [ q{local $ENV{DBI_AUTOPROXY} =
'dbi:Multiplex:';} ],
@@ -3047,7 +3047,7 @@
print PPT "#!$v_perl\n";
print PPT "use threads;\n" if $usethr;
print PPT "$_;\n" foreach @{$v_info->{add}};
- print PPT "do 't/$test' or warn \$!;\n";
+ print PPT "require 't/$test'; # or warn \$!;\n";
print PPT 'die if $@;'."\n";
print PPT "exit 0\n";
close PPT or warn "Error writing $v_test: $!";
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Mon Jan 29 05:04:18 2007
@@ -484,26 +484,27 @@
$h_inner->{ErrCount} = 0;
$h_inner->{Active} = 1;
}
+
sub constant {
- warn "constant @_"; return;
+ warn "constant(@_) called unexpectedly"; return undef;
}
+
sub trace {
my ($h, $level, $file) = @_;
$level = $h->parse_trace_flags($level)
if defined $level and !DBI::looks_like_number($level);
my $old_level = $DBI::dbi_debug;
- _set_trace_file($file);
+ _set_trace_file($file) if $level;
if (defined $level) {
$DBI::dbi_debug = $level;
print $DBI::tfh " DBI $DBI::VERSION (PurePerl) "
. "dispatch trace level set to $DBI::dbi_debug\n"
if $DBI::dbi_debug & 0xF;
- if ($level==0 and fileno($DBI::tfh)) {
- _set_trace_file("");
- }
}
+ _set_trace_file($file) if !$level;
return $old_level;
}
+
sub _set_trace_file {
my ($file) = @_;
return unless defined $file;
@@ -816,6 +817,13 @@
}
package
+ DBD::_::db;
+
+sub connected {
+}
+
+
+package
DBD::_::st;
sub fetchrow_arrayref {
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Mon Jan 29 05:04:18 2007
@@ -40,7 +40,7 @@
ok(exists $drivers{ExampleP});
ok($drivers{ExampleP}->isa('DBI::dr'));
-my $using_dbd_forward_null = ($ENV{DBI_AUTOPROXY}||'') =~
/dbi:Forward.*transport=null/i;
+my $using_dbd_gofer_null = ($ENV{DBI_AUTOPROXY}||'') =~
/dbi:Gofer.*transport=null/i;
## ----------------------------------------------------------------------------
# do database handle tests inside do BLOCK to capture scope
@@ -49,7 +49,7 @@
my $dbh = DBI->connect("dbi:$driver:", '', '');
isa_ok($dbh, 'DBI::db');
- my $drh = $dbh->{Driver}; # (re)get drh here so tests can work
using_dbd_forward_null
+ my $drh = $dbh->{Driver}; # (re)get drh here so tests can work
using_dbd_gofer_null
SKIP: {
skip "Kids and ActiveKids attributes not supported under
DBI::PurePerl", 2 if $DBI::PurePerl;
@@ -140,7 +140,7 @@
SKIP: {
skip "swap_inner_handle() not supported under DBI::PurePerl", 23 if
$DBI::PurePerl;
- skip "swap_inner_handle() not testable under DBI_AUTOPROXY", 23 if
$using_dbd_forward_null;
+ skip "swap_inner_handle() not testable under DBI_AUTOPROXY", 23 if
$using_dbd_gofer_null;
my $sth6 = $dbh->prepare($sql);
$sth6->execute(".");
@@ -186,6 +186,7 @@
ok( $dbh->ping, 'ping should be true before disconnect');
$dbh->disconnect;
+ $dbh->{PrintError} = 0; # silence 'not connected' warning
ok( !$dbh->ping, 'ping should be false after disconnect');
SKIP: {
@@ -197,7 +198,7 @@
};
-if ($using_dbd_forward_null) {
+if ($using_dbd_gofer_null) {
$drh->{CachedKids} = {};
}
@@ -248,7 +249,7 @@
SKIP: {
skip "Kids attribute not supported under DBI::PurePerl", 25 if
$DBI::PurePerl;
- skip "drh Kids not testable under DBI_AUTOPROXY", 25 if
$using_dbd_forward_null;
+ skip "drh Kids not testable under DBI_AUTOPROXY", 25 if
$using_dbd_gofer_null;
foreach my $args (
{},
@@ -269,11 +270,11 @@
SKIP: {
skip "take_imp_data test not supported under DBI::PurePerl", 19 if
$DBI::PurePerl;
- skip "take_imp_data test not supported under DBI_AUTOPROXY", 19 if
$using_dbd_forward_null;
+ skip "take_imp_data test not supported under DBI_AUTOPROXY", 19 if
$using_dbd_gofer_null;
my $dbh = DBI->connect("dbi:$driver:", '', '');
isa_ok($dbh, "DBI::db");
- my $drh = $dbh->{Driver}; # (re)get drh here so tests can work
using_dbd_forward_null
+ my $drh = $dbh->{Driver}; # (re)get drh here so tests can work
using_dbd_gofer_null
cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) here');
Modified: dbi/trunk/t/05thrclone.t
==============================================================================
--- dbi/trunk/t/05thrclone.t (original)
+++ dbi/trunk/t/05thrclone.t Mon Jan 29 05:04:18 2007
@@ -20,6 +20,12 @@
plan tests => 3 + 4 * $threads;
+# Something about DBD::Gofer causes a problem. Older versions didn't leak. It
+# started at some point in development but I didn't track it down at the time
+# so the exact change that made it start is now lost in the mists of time.
+warn " You can ignore the $threads 'Scalars leaked' messages (or send me a
patch to fix the underlying problem)\n"
+ if $ENV{DBI_AUTOPROXY};
+
{
package threads_sub;
use base qw(threads);
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Mon Jan 29 05:04:18 2007
@@ -78,7 +78,7 @@
eval {
$dbh->do('select foo from foo')
};
-like($@, qr/^DBD::(ExampleP|Multiplex|Forward)::db do failed: Unknown field
names: foo/ , '... catching exception');
+like($@, qr/^DBD::(ExampleP|Multiplex|Gofer)::db do failed: Unknown field
names: foo/ , '... catching exception');
ok(defined $dbh->err, '... $dbh->err is undefined');
like($dbh->errstr, qr/^Unknown field names: foo\b/, '... checking
$dbh->errstr');
@@ -155,7 +155,7 @@
$sth->execute("foo")
};
# we don't check actual opendir error msg because of locale differences
-like($@, qr/^DBD::(ExampleP|Multiplex|Forward)::st execute failed:
.*opendir\(foo\): /msi, '... checking exception');
+like($@, qr/^DBD::(ExampleP|Multiplex|Gofer)::st execute failed:
.*opendir\(foo\): /msi, '... checking exception');
# Test all of the statement handle attributes.
like($sth->errstr, qr/opendir\(foo\): /, '... checking $sth->errstr');
Modified: dbi/trunk/t/08keeperr.t
==============================================================================
--- dbi/trunk/t/08keeperr.t (original)
+++ dbi/trunk/t/08keeperr.t Mon Jan 29 05:04:18 2007
@@ -62,10 +62,10 @@
}
my $err1 = test_select( My::DBI->connect(@con_info) );
-Test::More::like($err1, qr/^DBD::(ExampleP|Multiplex|Forward)::db
selectrow_arrayref failed: opendir/, '... checking error');
+Test::More::like($err1, qr/^DBD::(ExampleP|Multiplex|Gofer)::db
selectrow_arrayref failed: opendir/, '... checking error');
my $err2 = test_select( DBI->connect(@con_info) );
-Test::More::like($err2, qr/^DBD::(ExampleP|Multiplex|Forward)::db
selectrow_arrayref failed: opendir/, '... checking error');
+Test::More::like($err2, qr/^DBD::(ExampleP|Multiplex|Gofer)::db
selectrow_arrayref failed: opendir/, '... checking error');
package main;
Modified: dbi/trunk/t/09trace.t
==============================================================================
--- dbi/trunk/t/09trace.t (original)
+++ dbi/trunk/t/09trace.t Mon Jan 29 05:04:18 2007
@@ -13,6 +13,7 @@
## ----------------------------------------------------------------------------
BEGIN {
+ $ENV{DBI_TRACE} = 0; # for PurePerl - ensure DBI_TRACE is in the env
use_ok( 'DBI' );
}
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Mon Jan 29 05:04:18 2007
@@ -73,13 +73,14 @@
# This test checks that connect_cached works
# and how it then relates to the CachedKids
# attribute for the driver.
-
- my $dbh_cached_1 = DBI->connect_cached('dbi:ExampleP:', '', '');
- my $dbh_cached_2 = DBI->connect_cached('dbi:ExampleP:', '', '');
- my $dbh_cached_3 = DBI->connect_cached('dbi:ExampleP:', '', '', {
examplep_foo => 1 });
-
+#DBI->trace(4);
+ my $dbh_cached_1 = DBI->connect_cached('dbi:ExampleP:', '', '', {
TraceLevel=>0});
isa_ok($dbh_cached_1, "DBI::db");
+
+ my $dbh_cached_2 = DBI->connect_cached('dbi:ExampleP:', '', '', {
TraceLevel=>0});
isa_ok($dbh_cached_2, "DBI::db");
+
+ my $dbh_cached_3 = DBI->connect_cached('dbi:ExampleP:', '', '', {
examplep_foo => 1 });
isa_ok($dbh_cached_3, "DBI::db");
is($dbh_cached_1, $dbh_cached_2, '... these 2 handles are cached, so
they are the same');
@@ -433,7 +434,7 @@
print "HandleError -> 0 -> RaiseError\n";
$HandleErrorReturn = 0;
ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; });
-ok($@ =~ m/^DBD::(ExampleP|Multiplex|Forward)::db prepare failed:/, $@);
+ok($@ =~ m/^DBD::(ExampleP|Multiplex|Gofer)::db prepare failed:/, $@);
print "HandleError -> 1 -> return (original)undef\n";
$HandleErrorReturn = 1;
Modified: dbi/trunk/t/30subclass.t
==============================================================================
--- dbi/trunk/t/30subclass.t (original)
+++ dbi/trunk/t/30subclass.t Mon Jan 29 05:04:18 2007
@@ -89,6 +89,7 @@
RaiseError => 1,
RootClass => "MyDBI",
CompatMode => 1, # just for clone test
+ dbi_foo => 1, # just to help debugging clone etc
});
isa_ok( $dbh, 'MyDBI::db');
is($dbh->{CompatMode}, 1);
Modified: dbi/trunk/t/40profile.t
==============================================================================
--- dbi/trunk/t/40profile.t (original)
+++ dbi/trunk/t/40profile.t Mon Jan 29 05:04:18 2007
@@ -69,8 +69,9 @@
my $t_file = __FILE__;
$dbh->do("set foo=1"); my $line = __LINE__;
my $expected_caller = "40profile.t line $line";
-$expected_caller .= " via zvfw_40profile.t line 3"
- if $0 =~ /zvfw_/;
+$expected_caller .= " via ${1}40profile.t line 3"
+ if $0 =~ /(zv\w+_)/;
+print Dumper($dbh->{Profile});
is_deeply sanitize_tree($dbh->{Profile}), bless {
'Path' => [ '!MethodName', '!Caller2' ],
'Data' => { 'do' => {
@@ -163,7 +164,7 @@
is_deeply $tmp, bless {
'Path' => [ '!Statement' ],
'Data' => {
- '' => [ 3, 0, 0, 0, 0, 0, 0 ],
+ '' => [ 7, 0, 0, 0, 0, 0, 0 ],
$sql => [ -1, 0, 0, 0, 0, 0, 0 ],
'set foo=1' => [ 1, 0, 0, 0, 0, 0, 0 ],
}
@@ -200,6 +201,13 @@
is_deeply $tmp, bless {
'Path' => [ '{Username}', '!Statement', 'foo', '!MethodName' ],
'Data' => {
+ '' => { # because Profile was enabled by DBI just before Username was
set
+ '' => {
+ 'foo' => {
+ 'STORE' => [ 3, 0, 0, 0, 0, 0, 0 ],
+ }
+ }
+ },
'usrnam' => {
'' => {
'foo' => { },
@@ -217,7 +225,6 @@
},
} => 'DBI::Profile';
-
$dbh->{Profile}->{Path} = [ '!File', '!File2', '!Caller', '!Caller2' ];
$dbh->{Profile}->{Data} = undef;
@@ -275,10 +282,10 @@
}
$tmp = run_test1( { Path => [ 'foo', sub { 'bar' }, 'baz' ] });
-is_deeply $tmp, { 'foo' => { 'bar' => { 'baz' => [ 8, 0,0,0,0,0,0 ] } } };
+is_deeply $tmp, { 'foo' => { 'bar' => { 'baz' => [ 12, 0,0,0,0,0,0 ] } } };
$tmp = run_test1( { Path => [ 'foo', sub { 'ping','pong' } ] });
-is_deeply $tmp, { 'foo' => { 'ping' => { 'pong' => [ 8, 0,0,0,0,0,0 ] } } };
+is_deeply $tmp, { 'foo' => { 'ping' => { 'pong' => [ 12, 0,0,0,0,0,0 ] } } };
$tmp = run_test1( { Path => [ 'foo', sub { \undef } ] });
is_deeply $tmp, { 'foo' => undef }, 'should be vetoed';
@@ -286,7 +293,7 @@
# check what code ref sees in $_
$tmp = run_test1( { Path => [ sub { $_ } ] });
is_deeply $tmp, {
- '' => [ 3, 0, 0, 0, 0, 0, 0 ],
+ '' => [ 7, 0, 0, 0, 0, 0, 0 ],
'select name from .' => [ 5, 0, 0, 0, 0, 0, 0 ]
}, '$_ should contain statement';
@@ -294,6 +301,7 @@
$tmp = run_test1( { Path => [ sub { my ($h,$method) = @_; return \undef if
$method =~ /^[A-Z]+$/; return (ref $h, $method) } ] });
is_deeply $tmp, {
'DBI::db' => {
+ 'connected' => [ 1, 0, 0, 0, 0, 0, 0 ],
'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
},
'DBI::st' => {
Modified: dbi/trunk/t/50dbm.t
==============================================================================
--- dbi/trunk/t/50dbm.t (original)
+++ dbi/trunk/t/50dbm.t Mon Jan 29 05:04:18 2007
@@ -5,7 +5,7 @@
use Test::More;
use Config qw(%Config);
-my $using_dbd_forward_null = ($ENV{DBI_AUTOPROXY}||'') =~
/dbi:Forward.*transport=null/i;
+my $using_dbd_gofer_null = ($ENV{DBI_AUTOPROXY}||'') =~
/dbi:Gofer.*transport=null/i;
use DBI;
use vars qw( @mldbm_types @dbm_types );
@@ -83,7 +83,7 @@
my $dsn
="dbi:DBM(RaiseError=1,PrintError=0):dbm_type=$dtype;mldbm=$mldbm;lockfile=0";
- if ($using_dbd_forward_null) {
+ if ($using_dbd_gofer_null) {
$dsn .= ";f_dir=$dir";
}
@@ -104,8 +104,8 @@
# test if it correctly accepts valid $dbh attributes
SKIP: {
- skip "Can't set attributes after connect using DBD::Forward", 2
- if $using_dbd_forward_null;
+ skip "Can't set attributes after connect using DBD::Gofer", 2
+ if $using_dbd_gofer_null;
eval {$dbh->{f_dir}=$dir};
ok(!$@);
eval {$dbh->{dbm_mldbm}=$mldbm};
@@ -115,7 +115,7 @@
# test if it correctly rejects invalid $dbh attributes
#
eval {
- local $SIG{__WARN__} = sub { } if $using_dbd_forward_null;
+ local $SIG{__WARN__} = sub { } if $using_dbd_gofer_null;
$dbh->{dbm_bad_name}=1;
};
ok($@);
Modified: dbi/trunk/t/65transact.t
==============================================================================
--- dbi/trunk/t/65transact.t (original)
+++ dbi/trunk/t/65transact.t Mon Jan 29 05:04:18 2007
@@ -6,8 +6,8 @@
use Test::More;
-plan skip_all => 'Transactions not supported by DBD::Forward'
- if $ENV{DBI_AUTOPROXY} && $ENV{DBI_AUTOPROXY} =~ /^dbi:Forward/i;
+plan skip_all => 'Transactions not supported by DBD::Gofer'
+ if $ENV{DBI_AUTOPROXY} && $ENV{DBI_AUTOPROXY} =~ /^dbi:Gofer/i;
plan tests => 10;
Modified: dbi/trunk/test.pl
==============================================================================
--- dbi/trunk/test.pl (original)
+++ dbi/trunk/test.pl Mon Jan 29 05:04:18 2007
@@ -58,7 +58,7 @@
print "Available Drivers: ",join(", ",DBI->available_drivers(1)),"\n";
-my $dbh = DBI->connect("dbi:$driver:", '', ''); # old-style connect syntax
+my $dbh = DBI->connect("dbi:$driver:", '', '');
$dbh->debug($::opt_h);
if (0) {
@@ -115,20 +115,11 @@
(split / /, $Config{gccversion}||$Config{ccversion}||'')[0]||'',
$Config{optimize};
- if (0) {
- $null_dbh = DBI->connect('dbi:mysql:VC_log','','',{RaiseError=>1});
- $null_sth = $null_dbh->prepare('select * from big');
- $null_sth->execute();
- $t1 = new Benchmark;
- 1 while ($null_sth->fetchrow_hashref());
- #1 while ($null_sth->fetchrow_arrayref());
- $td = Benchmark::timediff(Benchmark->new, $t1);
- $tds= Benchmark::timestr($td);
- $dur = $td->cpu_a;
- printf "$DBI::rows in $tds\n";
- }
+ $null_dbh->disconnect;
}
+$dbh->disconnect;
+
#DBI->trace(4);
print "$0 done\n";
exit 0;
