Author: timbo
Date: Mon Apr 30 06:12:10 2007
New Revision: 9476
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/03handle.t
dbi/trunk/t/86gofer_fail.t
Log:
Add take_imp_data to DBI::PurePerl
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Apr 30 06:12:10 2007
@@ -69,6 +69,7 @@
which will be de-ref'd for each profile sample.
Added dbilogstrip utility to edit DBI logs for diff'ing (gets installed)
Added details for SQLite 3.3 to NULL handling docs thanks to Alex Teslik.
+ Added take_imp_data() to DBI::PurePerl.
Gofer related changes:
Fixed gofer pipeone & stream transports to avoid risk of hanging.
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Mon Apr 30 06:12:10 2007
@@ -159,6 +159,8 @@
Database
DebugDispatch
Driver
+ Err
+ Errstr
ErrCount
FetchHashKeyName
HandleError
@@ -179,6 +181,7 @@
RowCacheSize
RowsInCache
SCALE
+ State
Statement
TYPE
Type
@@ -260,7 +263,7 @@
}
else {
my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask)
- ? q{= $h->{_parent}->{_call_depth} }
+ ? q{= $h->{dbi_pp_parent}->{dbi_pp_call_depth} }
: "";
push @pre_call_frag, qq{
my \$keep_error $ke_init;
@@ -296,7 +299,7 @@
} if exists $ENV{DBI_TRACE}; # note use of 'exists'
push @pre_call_frag, q{
- $h->{'_last_method'} = $method_name;
+ $h->{'dbi_pp_last_method'} = $method_name;
} unless exists $DBI::last_method_except{$method_name};
# --- post method call code fragments ---
@@ -341,7 +344,7 @@
if ( !$keep_error
&& defined(my $err = $h->{err})
- && ($call_depth <= 1 && !$h->{_parent}{_call_depth})
+ && ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth})
) {
my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError
HandleError)};
@@ -351,7 +354,7 @@
or (!$err && length($err) && $pw) # warning
) {
my $last = ($DBI::last_method_except{$method_name})
- ? ($h->{'_last_method'}||$method_name) : $method_name;
+ ? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name;
my $errstr = $h->{errstr} || $DBI::errstr || $err || '';
my $msg = sprintf "%s %s %s: %s", $imp, $last,
($err eq "0") ? "warning" : "failed", $errstr;
@@ -394,20 +397,24 @@
$h = $h_inner if $h_inner;
my $imp;
- if ($method_name eq 'DESTROY') { # XXX move this into pre_call_frag
+ if ($method_name eq 'DESTROY') {
# during global destruction, $h->{...} can trigger "Can't call
FETCH on an undef value"
# implying that tied() above lied to us, so we need to use eval
local $@; # protect $@
$imp = eval { $h->{"ImplementorClass"} } or return; # probably
global destruction
}
else {
- $imp = $h->{"ImplementorClass"} or return; # probably global
destruction
+ $imp = $h->{"ImplementorClass"} or do {
+ warn "Can't call $method_name method on handle $h after
take_imp_data()\n"
+ if not exists $h->{Active};
+ return; # or, more likely, global destruction
+ };
}
] . join("\n", '', @pre_call_frag, '') . q[
- my $call_depth = $h->{'_call_depth'} + 1;
- local ($h->{'_call_depth'}) = $call_depth;
+ my $call_depth = $h->{'dbi_pp_call_depth'} + 1;
+ local ($h->{'dbi_pp_call_depth'}) = $call_depth;
my @ret;
my $sub = $imp->can($method_name);
@@ -490,7 +497,7 @@
elsif (ref($parent) =~ /::dr$/){
$h_inner->{Driver} = $parent;
}
- $h_inner->{_parent} = $parent;
+ $h_inner->{dbi_pp_parent} = $parent;
# add to the parent's ChildHandles
if ($HAS_WEAKEN) {
@@ -515,7 +522,7 @@
$h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN;
$h_inner->{Type} ||= 'dr';
}
- $h_inner->{"_call_depth"} = 0;
+ $h_inner->{"dbi_pp_call_depth"} = 0;
$h_inner->{ErrCount} = 0;
$h_inner->{Active} = 1;
}
@@ -830,7 +837,7 @@
$p->{state} = $DBI::state;
}
- $h->{'_last_method'} = $method;
+ $h->{'dbi_pp_last_method'} = $method;
return $rv; # usually undef
}
sub trace_msg {
@@ -844,7 +851,28 @@
warn "private_data @_";
}
sub take_imp_data {
- undef;
+ my $dbh = shift;
+ # A reasonable default implementation based on the one in DBI.xs.
+ # Typically a pure-perl driver would have their own take_imp_data method
+ # that would delete all but the essential items in the hash before einding
with:
+ # return $dbh->SUPER::take_imp_data();
+ # Of course it's useless if the driver doesn't also implement support for
+ # the dbi_imp_data attribute to the connect() method.
+ require Storable;
+ croak("Can't take_imp_data from handle that's not Active")
+ unless $dbh->{Active};
+ for my $sth (@{ $dbh->{ChildHandles} || [] }) {
+ next unless $sth;
+ $sth->finish if $sth->{Active};
+ bless $sth, 'DBI::zombie';
+ }
+ delete $dbh->{$_} for (keys %is_valid_attribute);
+ delete $dbh->{$_} for grep { m/^dbi_/ } keys %$dbh;
+ # warn "@{[ %$dbh ]}";
+ local $Storable::forgive_me = 1; # in case there are some CODE refs
+ my $imp_data = Storable::freeze($dbh);
+ # XXX um, should probably untie here - need to check dispatch behaviour
+ return $imp_data;
}
sub rows {
return -1; # always returns -1 here, see DBD::_::st::rows below
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Mon Apr 30 06:12:10 2007
@@ -270,21 +270,26 @@
# handle take_imp_data test
SKIP: {
- skip "take_imp_data test not supported under DBI::PurePerl", 19 if
$DBI::PurePerl;
skip "take_imp_data test not supported under DBD::Gofer", 19 if
$using_dbd_gofer;
+ # XXX because we use Kids, ActiveKids and ChildHandles in the tests
+ # if PurePerl supported those then we'd be able to run these tests
+# skip "take_imp_data test not supported under DBI::PurePerl", 19 if
$DBI::PurePerl;
+
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_gofer
- cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) here');
+ cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) here')
+ unless $DBI::PurePerl && pass();
$dbh->prepare("select name from ?"); # destroyed at once
my $sth2 = $dbh->prepare("select name from ?"); # inactive
my $sth3 = $dbh->prepare("select name from ?"); # active:
$sth3->execute(".");
is $sth3->{Active}, 1;
- is $dbh->{ActiveKids}, 1;
+ is $dbh->{ActiveKids}, 1
+ unless $DBI::PurePerl && pass();
my $ChildHandles = $dbh->{ChildHandles};
ok $ChildHandles, 'we need weakrefs for take_imp_data to work safely with
child handles';
@@ -306,8 +311,8 @@
like $@, qr/Can't locate object method/;
{
- my $warn;
- local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /after take_imp_data/
};
+ my @warn;
+ local $SIG{__WARN__} = sub { push @warn, $_[0] if $_[0] =~ /after
take_imp_data/; print "warn: @_\n"; };
my $drh = $dbh->{Driver};
ok(!defined $drh, '... our Driver should be undefined');
@@ -319,14 +324,15 @@
ok(!defined $dbh->quote(42), '... quote should return undefined');
- cmp_ok($warn, '==', 4, '... we should have gotten 4 warnings');
+ cmp_ok(scalar @warn, '==', 4, '... we should have gotten 4 warnings');
}
my $dbh2 = DBI->connect("dbi:$driver:", '', '', { dbi_imp_data =>
$imp_data });
isa_ok($dbh2, "DBI::db");
# need a way to test dbi_imp_data has been used
- cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) again');
+ cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) again')
+ unless $DBI::PurePerl && pass();
}
Modified: dbi/trunk/t/86gofer_fail.t
==============================================================================
--- dbi/trunk/t/86gofer_fail.t (original)
+++ dbi/trunk/t/86gofer_fail.t Mon Apr 30 06:12:10 2007
@@ -12,8 +12,10 @@
# here we test the DBI_GOFER_RANDOM_FAIL mechanism
# and how gofer deals with failures
+plan skip_all => "DBI_GOFER_RANDOM_FAIL not supported with PurePerl" if
$DBI::PurePerl;
+
if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity
- plan skip_all => "non-gofer DBI_AUTOPROXY" if $ap !~ /^dbi:Gofer/i;
+ plan skip_all => "Gofer DBI_AUTOPROXY" if $ap =~ /^dbi:Gofer/i;
# this means we have DBD::Gofer => DBD::Gofer => DBD::whatever
# rather than disable it we let it run because we're twisted
