Author: timbo
Date: Fri Oct 1 16:37:25 2004
New Revision: 475
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/ToDo
dbi/trunk/lib/DBD/NullP.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/02dbidrv.t
dbi/trunk/t/03handle.t
dbi/trunk/t/15array.t
Log:
Added $h1->swap_inner_handle($h2) - sponsored by BizRate.com
Added common DESTROY method to avoid AUTOLOAD lookup.
Assorted test and other tidyups.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Fri Oct 1 16:37:25 2004
@@ -27,6 +27,9 @@
a warning and is no longer fatal. Thanks to Vadim.
Corrected fetchall_arrayref() docs example thanks to Drew Broadley.
+ Added $h1->swap_inner_handle($h2) sponsored by BizRate.com
+
+
=head2 Changes in DBI 1.43 (svn rev 377), 2nd July 2004
Fixed connect() and connect_cached() RaiseError/PrintError
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Fri Oct 1 16:37:25 2004
@@ -365,6 +365,7 @@
set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'],
O=>0x0010 },
trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 },
trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ],
O=>0x0004, T=>8 },
+ swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
},
dr => { # Database Driver Interface
'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3 },
@@ -1279,7 +1280,6 @@
return;
}
- sub DESTROY { return } # avoid AUTOLOAD
}
@@ -1300,6 +1300,7 @@
my ($this) = DBI::_new_dbh($drh, {
'Name' => $dsn,
});
+ # $this->STORE(Active => 1); debatable as there's no "server side" here
$this;
}
@@ -2837,6 +2838,24 @@
check if $trace_flag_name is a driver specific trace flags and, if
not, then call the DBIs default parse_trace_flag().
+=item C<swap_inner_handle>
+
+ $rc = $h1->swap_inner_handle( $h2 );
+ $rc = $h1->swap_inner_handle( $h2, $allow_reparent );
+
+Brain transplants for handles. You don't need to know about this
+unless you want to become a handle surgeon.
+
+A DBI handle is a reference to a tied hash. A tied hash has an
+I<inner> hash that actually holds the contents. The swap_inner_handle()
+method swaps the inner hashes between two handles. The $h1 and $h2
+handles still point to the same tied hashes, but what those hashes
+are tied to has been swapped. In effect $h1 I<becomes> $h2 and
+vice-versa. This is powerful stuff. Use with care.
+
+As a small safety measure, the two handles, $h1 and $h2, have to
+share the same parent unless $allow_reparent is true.
+
=back
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Fri Oct 1 16:37:25 2004
@@ -1587,10 +1587,6 @@
case 'D':
if (keylen==8 && strEQ(key, "Database")) {
- /* this is here but is, sadly, not called because
- * not-preloading them into the handle attrib cache caused
- * wierdness in t/proxy.t that I never got to the bottom
- * of. One day maybe. */
D_imp_from_child(imp_dbh, imp_dbh_t, imp_xxh);
valuesv = newRV((SV*)DBIc_MY_H(imp_dbh));
cacheit = FALSE; /* else creates ref loop */
@@ -3990,6 +3986,15 @@
void
+DESTROY(h)
+ SV * h
+ CODE:
+ /* DESTROY defined here just to avoid AUTOLOAD */
+ h = h;
+ ST(0) = &sv_undef;
+
+
+void
STORE(h, keysv, valuesv)
SV * h
SV * keysv
@@ -4135,6 +4140,46 @@
ST(0) = sv_2mortal(newSViv(-1));
+void
+swap_inner_handle(rh1, rh2, allow_reparent=0)
+ SV * rh1
+ SV * rh2
+ IV allow_reparent
+ CODE:
+ {
+ D_impdata(imp_xxh1, imp_xxh_t, rh1);
+ D_impdata(imp_xxh2, imp_xxh_t, rh2);
+ SV *h1i = dbih_inner(rh1, "swap_inner_handle");
+ SV *h2i = dbih_inner(rh2, "swap_inner_handle");
+ SV *h1 = (rh1 == h1i) ? (SV*)DBIc_MY_H(imp_xxh1) : SvRV(rh1);
+ SV *h2 = (rh2 == h2i) ? (SV*)DBIc_MY_H(imp_xxh2) : SvRV(rh2);
+ if (DBIc_TYPE(imp_xxh1) != DBIc_TYPE(imp_xxh2)) {
+ char buf[99];
+ sprintf(buf, "Can't swap_inner_handle between %sh and %sh",
+ dbih_htype_name(DBIc_TYPE(imp_xxh1)),
dbih_htype_name(DBIc_TYPE(imp_xxh2)));
+ DBIh_SET_ERR_CHAR(rh1, imp_xxh1, "1", 1, buf, Nullch, Nullch);
+ XSRETURN_NO;
+ }
+ if (!allow_reparent && DBIc_PARENT_COM(imp_xxh1) != DBIc_PARENT_COM(imp_xxh2)) {
+ DBIh_SET_ERR_CHAR(rh1, imp_xxh1, "1", 1,
+ "Can't swap_inner_handle with handle from different parent",
+ Nullch, Nullch);
+ XSRETURN_NO;
+ }
+ SvREFCNT_inc(h1i);
+ SvREFCNT_inc(h2i);
+ sv_unmagic(h1, 'P'); /* untie(%$h1) */
+ sv_unmagic(h2, 'P'); /* untie(%$h2) */
+ sv_magic(h1, h2i, 'P', Nullch, 0); /* tie %$h1, $h2i */
+ DBIc_MY_H(imp_xxh2) = (HV*)h1;
+ sv_magic(h2, h1i, 'P', Nullch, 0); /* tie %$h2, $h1i */
+ DBIc_MY_H(imp_xxh1) = (HV*)h2;
+ SvREFCNT_dec(h1i);
+ SvREFCNT_dec(h2i);
+ ST(0) = &sv_yes;
+ }
+
+
MODULE = DBI PACKAGE = DBD::_mem::common
void
Modified: dbi/trunk/ToDo
==============================================================================
--- dbi/trunk/ToDo (original)
+++ dbi/trunk/ToDo Fri Oct 1 16:37:25 2004
@@ -435,8 +435,6 @@
Add hook to DBI::DBD to write a myconfig.txt file into the
source directory containing key driver and config info.
-Add $h->swap_internal_handle($other_h)
-
dbish - state AutoCommit status clearly at connect time.
(And try to set AutoCommit off in eval?)
test shell "/connect user pass" etc
Modified: dbi/trunk/lib/DBD/NullP.pm
==============================================================================
--- dbi/trunk/lib/DBD/NullP.pm (original)
+++ dbi/trunk/lib/DBD/NullP.pm Fri Oct 1 16:37:25 2004
@@ -64,7 +64,7 @@
# or fetch and cache attribute values too expensive to prefetch.
return 1 if $attrib eq 'AutoCommit';
# else pass up to DBI to handle
- return $dbh->DBD::_::db::FETCH($attrib);
+ return $dbh->SUPER::FETCH($attrib);
}
sub STORE {
@@ -75,10 +75,13 @@
return 1 if $value; # is already set
croak("Can't disable AutoCommit");
}
- return $dbh->DBD::_::db::STORE($attrib, $value);
+ return $dbh->SUPER::STORE($attrib, $value);
+ }
+
+ sub disconnect {
+ shift->STORE(Active => 0);
}
- sub DESTROY { undef }
}
@@ -112,17 +115,16 @@
my ($sth, $attrib) = @_;
# would normally validate and only fetch known attributes
# else pass up to DBI to handle
- return $sth->DBD::_::st::FETCH($attrib);
+ return $sth->SUPER::FETCH($attrib);
}
sub STORE {
my ($sth, $attrib, $value) = @_;
# would normally validate and only store known attributes
# else pass up to DBI to handle
- return $sth->DBD::_::st::STORE($attrib, $value);
+ return $sth->SUPER::STORE($attrib, $value);
}
- sub DESTROY { undef }
}
1;
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Fri Oct 1 16:37:25 2004
@@ -576,6 +576,13 @@
package
DBD::_::common;
+sub swap_inner_handle {
+ my ($h1, $h2) = @_;
+ # can't make this work till we can get the outer handle from the inner one
+ # probably via a WeakRef
+ return $h1->set_err(1, "swap_inner_handle not currently supported by
DBI::PurePerl");
+}
+
sub trace { # XXX should set per-handle level, not global
my ($h, $level, $file) = @_;
$level = $h->parse_trace_flags($level)
Modified: dbi/trunk/t/02dbidrv.t
==============================================================================
--- dbi/trunk/t/02dbidrv.t (original)
+++ dbi/trunk/t/02dbidrv.t Fri Oct 1 16:37:25 2004
@@ -1,4 +1,5 @@
#!perl -w
+# vim:sw=4:ts=8
use strict;
@@ -24,10 +25,10 @@
## main Test Driver Package
{
- package DBD::Test;
+ package DBD::Test;
use strict;
- use warnings;
+ use warnings;
my $drh = undef;
@@ -86,8 +87,6 @@
Test::More::cmp_ok($DBD::Test::db::imp_data_size, '==', 0, '... check
DBD::Test::db::imp_data_size to avoid typo');
- sub DESTROY { 1 }
-
sub do {
my $h = shift;
@@ -128,6 +127,10 @@
push @ds, "dbi:Test:baz";
return @ds;
}
+
+ sub disconnect {
+ shift->STORE(Active => 0);
+ }
}
## ----------------------------------------------------------------------------
@@ -181,6 +184,8 @@
ok($dbh->do('dummy'), '... this will trigger more driver internal tests above
in DBD::Test::db');
+ $dbh->disconnect;
+
$drh->set_err("41", "foo 41 drh");
cmp_ok($drh->err, '==', 41, '... checking Driver handle err set with set_err
method');
$dbh->set_err("42", "foo 42 dbh");
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Fri Oct 1 16:37:25 2004
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 101;
+use Test::More tests => 124;
## ----------------------------------------------------------------------------
## 03handle.t - tests handles
@@ -62,68 +62,115 @@
ok($sth1->{Active}, '... our first statment is Active');
- # use this to check that we are warned
- my $warn = 0;
- local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /still active/ };
-
- my $sth2 = $dbh->prepare_cached($sql);
- isa_ok($sth2, 'DBI::st');
-
- is($sth1, $sth2, '... prepare_cached returned the same statement handle');
- cmp_ok($warn,'==', 1, '... we got warned about our first statement handle being
still active');
-
- ok(!$sth1->{Active}, '... our first statment is no longer Active since we
re-prepared it');
+ {
+ my $warn = 0; # use this to check that we are warned
+ local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /still active/i };
+
+ my $sth2 = $dbh->prepare_cached($sql);
+ isa_ok($sth2, 'DBI::st');
+
+ is($sth1, $sth2, '... prepare_cached returned the same statement handle');
+ cmp_ok($warn,'==', 1, '... we got warned about our first statement handle
being still active');
+
+ ok(!$sth1->{Active}, '... our first statment is no longer Active since we
re-prepared it');
+
+ my $sth3 = $dbh->prepare_cached($sql, { foo => 1 });
+ isa_ok($sth3, 'DBI::st');
+
+ isnt($sth1, $sth3, '... prepare_cached returned a different statement handle
now');
+ cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
+ ok(eq_set(
+ [ values %{$ck} ],
+ [ $sth1, $sth3 ]
+ ),
+ '... both statment handles should be in the CachedKids');
+
+ ok($sth1->execute("."), '... executing first statement handle again');
+ ok($sth1->{Active}, '... first statement handle is now active again');
+
+ my $sth4 = $dbh->prepare_cached($sql, undef, 3);
+ isa_ok($sth4, 'DBI::st');
+
+ isnt($sth1, $sth4, '... our fourth statement handle is not the same as our
first');
+ ok($sth1->{Active}, '... first statement handle is still active');
+
+ cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
+ ok(eq_set(
+ [ values %{$ck} ],
+ [ $sth2, $sth4 ]
+ ),
+ '... second and fourth statment handles should be in the CachedKids');
+
+ $sth1->finish;
+ ok(!$sth1->{Active}, '... first statement handle is no longer active');
+
+ ok($sth4->execute("."), '... fourth statement handle executed properly');
+ ok($sth4->{Active}, '... fourth statement handle is Active');
+
+ my $sth5 = $dbh->prepare_cached($sql, undef, 1);
+ isa_ok($sth5, 'DBI::st');
+
+ cmp_ok($warn, '==', 1, '... we still only got one warning');
+
+ is($sth4, $sth5, '... fourth statement handle and fifth one match');
+ ok(!$sth4->{Active}, '... fourth statement handle is not Active');
+ ok(!$sth5->{Active}, '... fifth statement handle is not Active (shouldnt be
its the same as fifth)');
+
+ cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
+ ok(eq_set(
+ [ values %{$ck} ],
+ [ $sth2, $sth5 ]
+ ),
+ '... second and fourth/fifth statment handles should be in the CachedKids');
+ }
- my $sth3 = $dbh->prepare_cached($sql, { foo => 1 });
- isa_ok($sth3, 'DBI::st');
+ SKIP: {
+ skip "become() not supported under DBI::PurePerl", 23 if $DBI::PurePerl;
- isnt($sth1, $sth3, '... prepare_cached returned a different statement handle
now');
- cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
- ok(eq_set(
- [ values %{$ck} ],
- [ $sth1, $sth3 ]
- ),
- '... both statment handles should be in the CachedKids');
+ my $sth6 = $dbh->prepare($sql);
+ $sth6->execute(".");
- ok($sth1->execute("."), '... executing first statement handle again');
- ok($sth1->{Active}, '... first statement handle is now active again');
-
- my $sth4 = $dbh->prepare_cached($sql, undef, 3);
- isa_ok($sth4, 'DBI::st');
-
- isnt($sth1, $sth4, '... our fourth statement handle is not the same as our
first');
- ok($sth1->{Active}, '... first statement handle is still active');
-
- cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
- ok(eq_set(
- [ values %{$ck} ],
- [ $sth2, $sth4 ]
- ),
- '... second and fourth statment handles should be in the CachedKids');
-
- $sth1->finish;
- ok(!$sth1->{Active}, '... first statement handle is no longer active');
+ ok( $sth6->{Active}, '... sixth statement handle is active');
+ ok(!$sth1->{Active}, '... first statement handle is not active');
- ok($sth4->execute("."), '... fourth statement handle executed properly');
- ok($sth4->{Active}, '... fourth statement handle is Active');
-
- my $sth5 = $dbh->prepare_cached($sql, undef, 1);
- isa_ok($sth5, 'DBI::st');
-
- is($sth4, $sth5, '... fourth statement handle and fifth one match');
- ok(!$sth4->{Active}, '... fourth statement handle is not Active');
- ok(!$sth5->{Active}, '... fifth statement handle is not Active (shouldnt be its
the same as fifth)');
-
- cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
- ok(eq_set(
- [ values %{$ck} ],
- [ $sth2, $sth5 ]
- ),
- '... second and fourth/fifth statment handles should be in the CachedKids');
+ ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the
sixth');
+ ok(!$sth6->{Active}, '... sixth statement handle is now not active');
+ ok( $sth1->{Active}, '... first statement handle is now active again');
+
+ ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the
sixth');
+ ok( $sth6->{Active}, '... sixth statement handle is active');
+ ok(!$sth1->{Active}, '... first statement handle is not active');
+
+ ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the
sixth');
+ ok(!$sth6->{Active}, '... sixth statement handle is now not active');
+ ok( $sth1->{Active}, '... first statement handle is now active again');
+
+ $sth1->{PrintError} = 0;
+ ok(!$sth1->swap_inner_handle($dbh), '... can not swap a sth with a dbh');
+ cmp_ok( $sth1->errstr, 'eq', "Can't swap_inner_handle between sth and dbh");
+
+ ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the
sixth');
+ ok( $sth6->{Active}, '... sixth statement handle is active');
+ ok(!$sth1->{Active}, '... first statement handle is not active');
+
+ $sth6->finish;
+
+ ok(my $dbh_nullp = DBI->connect("dbi:NullP:"));
+ ok(my $sth7 = $dbh_nullp->prepare(""));
+
+ $sth1->{PrintError} = 0;
+ ok(!$sth1->swap_inner_handle($sth7), "... can't swap_inner_handle with handle
from different parent");
+ cmp_ok( $sth1->errstr, 'eq', "Can't swap_inner_handle with handle from
different parent");
+
+ cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', "ExampleP" );
+ ok( $sth1->swap_inner_handle($sth7,1), "... can swap to different parent if
forced");
+ cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', "NullP" );
+
+ $dbh_nullp->disconnect;
+ }
- cmp_ok($warn, '==', 1, '... we still only got one warning');
$dbh->disconnect;
-
+
SKIP: {
skip "Kids and ActiveKids attributes not supported under DBI::PurePerl", 2 if
$DBI::PurePerl;
@@ -302,6 +349,8 @@
# I don't know why this warning has the "(perhaps ...)" suffix, it shouldn't:
# Can't locate object method "nonesuch" via package "DBI::db" (perhaps you forgot
to load "DBI::db"?)
eval { ref($dbh)->nonesuch; };
+
+ $dbh->disconnect;
};
SKIP: {
Modified: dbi/trunk/t/15array.t
==============================================================================
--- dbi/trunk/t/15array.t (original)
+++ dbi/trunk/t/15array.t Fri Oct 1 16:37:25 2004
@@ -224,6 +224,8 @@
is( $sth->errstr, 'Value for parameter 2 must be a scalar or an arrayref, not a
HASH', '... errstr is as expected');
ok(!defined $sth->bind_param_array(":foo", [ qw(a b c) ]), '... bind_param_array
should return undef');
-is( $sth->errstr, "Can't use named placeholders for non-driver supported
bind_param_array", '... errstr is as expected');
+is( $sth->errstr, "Can't use named placeholder ':foo' for non-driver supported
bind_param_array", '... errstr is as expected');
+
+$dbh->disconnect;
1;
