Author: timbo
Date: Mon Nov 21 09:40:50 2005
New Revision: 2253
Added:
dbi/trunk/t/72childhandles.t
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/Driver.xst
dbi/trunk/MANIFEST
dbi/trunk/Makefile.PL
dbi/trunk/lib/DBD/NullP.pm
dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/03handle.t
dbi/trunk/t/10examp.t
Log:
Fixed prerequisites to include Storable thanks to Michael Schwern.
Change to require perl 5.6.1 (as advertised in 2003) not 5.6.0.
Changed Driver.xst to enable drivers to define an dbd_st_prepare_sv
function where the statement parameter is an SV. That enables
compiled drivers to support SQL strings that are UTF-8.
Changed "use DBI" to only set $DBI::connect_via if not already set.
Changed docs to clarify pre-method clearing of err values.
Added $h->{ChildHandles} (using weakrefs) thanks to Sam Tregar.
Added $h->{Type} docs (returns 'dr', 'db', or 'st')
Adding trace message in DESTROY if InactiveDestroy enabled.
Ported DBI::ProfileDumper::Apache to mod_perl2 RC5+
thanks to Philip M. Golluci
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Nov 21 09:40:50 2005
@@ -14,16 +14,32 @@ DBI::Changes - List of significant chang
Fixed ping in DBD::Proxy thanks to George Campbell.
Fixed dangling ref in $sth after parent $dbh destroyed
with thanks to [EMAIL PROTECTED] for the bug report #13151
+ Fixed prerequisites to include Storable thanks to Michael Schwern.
+XXX TODO: take_imp_data
+XXX TODO: move ChildHandles code into .xs and PurePerl
+
+ Change to require perl 5.6.1 (as advertised in 2003) not 5.6.0.
Changed internals to be more strictly coded thanks to Andy Lester.
Changed warning about multiple copies of Driver.xst found in @INC
to ignore duplicated directories thanks to Ed Avis.
+ Changed Driver.xst to enable drivers to define an dbd_st_prepare_sv
+ function where the statement parameter is an SV. That enables
+ compiled drivers to support SQL strings that are UTF-8.
+ Changed "use DBI" to only set $DBI::connect_via if not already set.
+ Changed docs to clarify pre-method clearing of err values.
Added $sth->{ParamTypes} specification thanks to Dean Arnold.
Added $h->{Callbacks} attribute to enable code hooks to be invoked
when certain methods are called. For example:
$dbh->{Callbacks}->{prepare} = sub { ... };
With thanks to David Wheeler for the kick start.
+ Added $h->{ChildHandles} (using weakrefs) thanks to Sam Tregar.
+ Added $h->{Type} docs (returns 'dr', 'db', or 'st')
+ Adding trace message in DESTROY if InactiveDestroy enabled.
+
+ Ported DBI::ProfileDumper::Apache to mod_perl2 RC5+
+ thanks to Philip M. Golluci
=head2 Changes in DBI 1.48 (svn rev 928), 14th March 2005
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Nov 21 09:40:50 2005
@@ -21,6 +21,7 @@ DBI - Database independent interface for
use DBI;
@driver_names = DBI->available_drivers;
+ %drivers = DBI->installed_drivers;
@data_sources = DBI->data_sources($driver_name, \%attr);
$dbh = DBI->connect($data_source, $username, $auth, \%attr);
@@ -263,7 +264,7 @@ use strict;
DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
-$DBI::connect_via = "connect";
+$DBI::connect_via ||= "connect";
# check if user wants a persistent database connection ( Apache + mod_perl )
if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
@@ -271,7 +272,16 @@ if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PE
DBI->trace_msg("DBI connect via $DBI::connect_via in
$INC{'Apache/DBI.pm'}\n");
}
+# check for weaken support, used by ChildHandles
+my $HAS_WEAKEN = eval {
+ require Scalar::Util;
+ # this will croak() if this Scalar::Util doesn't have a working weaken().
+ Scalar::Util::weaken(my $test = \"foo");
+ 0;
+};
+
%DBI::installed_drh = (); # maps driver names to installed driver handles
+sub installed_drivers { %DBI::installed_drh }
# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
# These are dynamically associated with the last handle used.
@@ -308,6 +318,7 @@ my $dbd_prefix_registry = {
ing_ => { class => 'DBD::Ingres', },
ix_ => { class => 'DBD::Informix', },
jdbc_ => { class => 'DBD::JDBC', },
+ monetdb_ => { class => 'DBD::monetdb', },
msql_ => { class => 'DBD::mSQL', },
mysql_ => { class => 'DBD::mysql', },
mx_ => { class => 'DBD::Multiplex', },
@@ -315,6 +326,7 @@ my $dbd_prefix_registry = {
odbc_ => { class => 'DBD::ODBC', },
ora_ => { class => 'DBD::Oracle', },
pg_ => { class => 'DBD::Pg', },
+ plb_ => { class => 'DBD::Plibdata', },
proxy_ => { class => 'DBD::Proxy', },
rdb_ => { class => 'DBD::RDB', },
sapdb_ => { class => 'DBD::SAP_DB', },
@@ -446,8 +458,15 @@ my $keeperr = { O=>0x0004 };
);
while ( my ($class, $meths) = each %DBI::DBI_methods ) {
+ my $ima_trace = 0+$ENV{DBI_IMA_TRACE}||0;
while ( my ($method, $info) = each %$meths ) {
my $fullmeth = "DBI::${class}::$method";
+ if ($DBI::dbi_debug >= 15) { # quick hack to list DBI methods
+ # and optionally filter by IMA flags
+ my $O = $info->{O}||0;
+ printf "0x%04x %-20s\n", $O, $fullmeth
+ unless $ima_trace && !($O & $ima_trace);
+ }
DBI->_install_method($fullmeth, 'DBI.pm', $info);
}
}
@@ -1162,6 +1181,20 @@ sub _new_handle {
# Now add magic so DBI method dispatch works
DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
+ # add to the parent's ChildHandles
+ if ($HAS_WEAKEN && $parent) {
+ my $handles = $parent->{ChildHandles} ||= [];
+
+ # purge destroyed handles occasionally
+ if (@$handles % 120 == 0 and @$handles) {
+ @$handles = grep { defined } @$handles;
+ Scalar::Util::weaken($_) for @$handles; # re-weaken after grep
+ }
+
+ push @$handles, $h;
+ Scalar::Util::weaken($handles->[-1]);
+ }
+
return $h unless wantarray;
($h, $i);
}
@@ -1324,7 +1357,7 @@ sub _new_sth { # called by DBD::<drivern
unless $method =~ m/^([a-z]+_)\w+$/;
my $prefix = $1;
my $reg_info = $dbd_prefix_registry->{$prefix};
- Carp::croak("method name prefix '$prefix' is not registered") unless
$reg_info;
+ Carp::carp("method name prefix '$prefix' is not associated with a
registered driver") unless $reg_info;
my %attr = %{$attr||{}}; # copy so we can edit
# XXX reformat $attr as needed for _install_method
my ($caller_pkg, $filename, $line) = caller;
@@ -2706,6 +2739,13 @@ through the directories in C<@INC>. By d
some drivers are hidden by others of the same name in earlier
directories. Passing a true value for C<$quiet> will inhibit the warning.
+=item C<installed_drivers>
+
+ %drivers = DBI->installed_drivers();
+
+Returns a list of driver name and driver handle pairs for all
+installed drivers. The driver name does not include the 'DBD::'
+prefix.
=item C<installed_versions>
@@ -2988,16 +3028,19 @@ Returns the I<native> database engine er
method called. The code is typically an integer but you should not
assume that.
-The DBI resets $h->err to undef before most DBI method calls, so the
+The DBI resets $h->err to undef before almost all DBI method calls, so the
value only has a short lifespan. Also, for most drivers, the statement
handles share the same error variable as the parent database handle,
so calling a method on one handle may reset the error on the
related handles.
-If you need to test for individual errors I<and> have your program be
-portable to different database engines, then you'll need to determine
-what the corresponding error codes are for all those engines and test for
-all of them.
+(Methods which don't reset err before being called include err() and errstr(),
+obviously, state(), rows(), func(), trace(), trace_msg(), ping(), and the
+tied hash attribute FETCH() and STORE() methods.)
+
+If you need to test for specific error conditions I<and> have your program be
+portable to different database engines, then you'll need to determine what the
+corresponding error codes are for all those engines and test for all of them.
A driver may return C<0> from err() to indicate a warning condition
after a method call. Similarly, a driver may return an empty string
@@ -3281,6 +3324,35 @@ statement handles created by the L</prep
driver handle, returns a reference to the cache (hash) of
database handles created by the L</connect_cached> method.
+=item C<Type> (scalar)
+
+The C<Type> attribute identifies the type of a DBI handle. Returns
+"dr" for driver handles, "db" for database handles and "st" for
+statement handles.
+
+=item C<ChildHandles> (array ref)
+
+The ChildHandles attribute contains a reference to an array of all the
+handles created by this handle which are still accessible. The
+contents of the array are weak-refs and will become undef when the
+handle goes out of scope. C<ChildHandles> is only available if you
+have the L<Scalar::Util|Scalar::Util> module installed and
+C<Scalar::Util::weaken()> is working.
+
+For example, to enumerate all driver handles, database handles and
+statement handles:
+
+ sub show_child_handles {
+ my ($h, $level) = @_;
+ $level ||= 0;
+ printf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h;
+ show_child_handles($_, $level + 1)
+ for (grep { defined } @{$h->{ChildHandles}});
+ }
+
+ my %drivers = DBI->installed_drivers();
+ show_child_handles($_) for (values %drivers);
+
=item C<CompatMode> (boolean, inherited)
The C<CompatMode> attribute is used by emulation layers (such as
@@ -5158,8 +5230,8 @@ See L</"Placeholders and Bind Values"> f
B<Data Types for Placeholders>
The C<\%attr> parameter can be used to hint at the data type the
-placeholder should have. Typically, the driver is only interested in
-knowing if the placeholder should be bound as a number or a string.
+placeholder should have. This is rarely needed. Typically, the driver is only
+interested in knowing if the placeholder should be bound as a number or a
string.
$sth->bind_param(1, $value, { TYPE => SQL_INTEGER });
@@ -5777,11 +5849,10 @@ See also C<bind_columns> for an example.
The binding is performed at a low level using Perl aliasing.
Whenever a row is fetched from the database $var_to_bind appears
-to be automatically updated simply because it refers to the same
+to be automatically updated simply because it now refers to the same
memory location as the corresponding column value. This makes using
-bound variables very efficient. Multiple variables can be bound
-to a single column, but there's rarely any point. Binding a tied
-variable doesn't work, currently.
+bound variables very efficient.
+Binding a tied variable doesn't work, currently.
The L</bind_param> method
performs a similar, but opposite, function for input variables.
@@ -6574,8 +6645,15 @@ The parameters are the same as passed to
If your subclass supplies a connected method, it should be part of the
MySubDBI::db package.
+One more thing to note: you must let the DBI do the handle creation. If you
+want to override the connect() method in your *::dr class then it must still
+call SUPER::connect to get a $dbh to work with. Similarly, an overridden
+prepare() method in *::db must still call SUPER::prepare to get a $sth.
+If you try to create your own handles using bless() then you'll find the DBI
+will reject them with an "is not a DBI handle (has no magic)" error.
+
Here's a brief example of a DBI subclass. A more thorough example
-can be found in t/subclass.t in the DBI distribution.
+can be found in F<t/subclass.t> in the DBI distribution.
package MySubDBI;
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Nov 21 09:40:50 2005
@@ -1464,6 +1464,9 @@ dbih_set_attr_k(SV *h, SV *keysv, int db
DBIc_set(imp_xxh,DBIcf_HandleSetErr, on);
cacheit = 1; /* child copy setup by dbih_setup_handle() */
}
+ else if (strEQ(key, "ChildHandles")) {
+ cacheit = 1; /* just save it in the hash */
+ }
else if (strEQ(key, "Profile")) {
static const char dbi_class[] = "DBI::Profile";
if (on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) ) {
@@ -1785,6 +1788,15 @@ dbih_get_attr_k(SV *h, SV *keysv, int db
else if (strEQ(key, "CachedKids")) {
valuesv = &sv_undef;
}
+ else if (strEQ(key, "ChildHandles")) {
+ /* get the value from the hash, otherwise return a [] */
+ svp = hv_fetch((HV*)SvRV(h), key, keylen, FALSE);
+ if (svp) {
+ valuesv = newSVsv(*svp);
+ } else {
+ valuesv = newRV_noinc((SV*)newAV());
+ }
+ }
else if (strEQ(key, "CompatMode")) {
valuesv = boolSV(DBIc_COMPAT(imp_xxh));
}
@@ -2969,7 +2981,7 @@ XS(XS_DBI_dispatch) /* prototype
/* could add DBIcf_ShowErrorParams (default to on?) */
svp = hv_fetch((HV*)DBIc_MY_H(imp_xxh),"ParamValues",11,FALSE);
if (svp && SvMAGICAL(*svp))
- mg_get(*svp);
+ mg_get(*svp); /* XXX may recurse, may croak. could use eval */
if (svp && SvRV(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV &&
HvKEYS(SvRV(*svp))>0 ) {
HV *bvhv = (HV*)SvRV(*svp);
SV *sv;
Modified: dbi/trunk/Driver.xst
==============================================================================
--- dbi/trunk/Driver.xst (original)
+++ dbi/trunk/Driver.xst Mon Nov 21 09:40:50 2005
@@ -335,6 +335,8 @@ DESTROY(dbh)
}
if (DBIc_IADESTROY(imp_dbh)) { /* want's ineffective destroy
*/
DBIc_ACTIVE_off(imp_dbh);
+ if (DBIc_DBISTATE(imp_dbh)->debug)
+ PerlIO_printf(DBIc_LOGPIO(imp_dbh), " DESTROY %s
skipped due to InactiveDestroy\n", SvPV_nolen(dbh));
}
if (DBIc_ACTIVE(imp_dbh)) {
/* The application has not explicitly disconnected. That's bad.
*/
@@ -411,13 +413,17 @@ MODULE = DBD::~DRIVER~ PACKAGE = DBD:
void
_prepare(sth, statement, attribs=Nullsv)
SV * sth
- char * statement
+ SV * statement
SV * attribs
CODE:
{
D_imp_sth(sth);
DBD_ATTRIBS_CHECK("_prepare", sth, attribs);
- ST(0) = dbd_st_prepare(sth, imp_sth, statement, attribs) ? &sv_yes :
&sv_no;
+#ifdef dbd_st_prepare_sv
+ ST(0) = dbd_st_prepare_sv(sth, imp_sth, statement, attribs) ? &sv_yes :
&sv_no;
+#else
+ ST(0) = dbd_st_prepare(sth, imp_sth, SVPV_nolen(statement), attribs) ?
&sv_yes : &sv_no;
+#endif
}
@@ -715,6 +721,8 @@ DESTROY(sth)
else {
if (DBIc_IADESTROY(imp_sth)) { /* want's ineffective destroy */
DBIc_ACTIVE_off(imp_sth);
+ if (DBIc_DBISTATE(imp_sth)->debug)
+ PerlIO_printf(DBIc_LOGPIO(imp_sth), " DESTROY %s
skipped due to InactiveDestroy\n", SvPV_nolen(sth));
}
if (DBIc_ACTIVE(imp_sth)) {
D_imp_dbh_from_sth;
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Mon Nov 21 09:40:50 2005
@@ -62,6 +62,7 @@ t/42prof_data.t
t/50dbm.t
t/60preparse.t
t/70callbacks.t
+t/72childhandles.t
t/80proxy.t
t/pod.t
test.pl A very simple test harness using
ExampleP.pm
Modified: dbi/trunk/Makefile.PL
==============================================================================
--- dbi/trunk/Makefile.PL (original)
+++ dbi/trunk/Makefile.PL Mon Nov 21 09:40:50 2005
@@ -11,23 +11,20 @@ BEGIN {
unshift @INC, "lib";
}
-if ($] < 5.006001 && $^O ne 'darwin') {
- # we ignore scaring darwin users because they're stuck on 5.6.0 for now
+if ($] < 5.008000) {
warn qq{\a\a\a
**************************************************************************
-**************************************************************************
- Version $] of perl will NOT BE SUPPORTED by future DBI releases.
- You will have to upgrade your perl or stop upgrading DBI.
- Perl version 5.6.1 will be the lowest version supported.
- Using perl $] you may notice some test warnings and two failures.
+ Perl versions below 5.6.1 are no longer supported by the DBI.
+ Perl versions 5.6.x may fail during installation with a complaint
+ about the use of =head3 in the pod documentation.
Press return to continue...
**************************************************************************
-**************************************************************************
};
sleep 3;
my $pause = <>;
}
+
use ExtUtils::MakeMaker 5.16, qw(WriteMakefile $Verbose);
use Getopt::Long;
use Config;
@@ -128,7 +125,7 @@ my %opts = (
AUTHOR => 'Tim Bunce ([email protected])',
VERSION_FROM => 'DBI.pm',
ABSTRACT_FROM => 'DBI.pm',
- PREREQ_PM => { "Test::Simple" => 0.40 },
+ PREREQ_PM => { "Test::Simple" => 0.40, Storable => 1 },
EXE_FILES => [ "dbiproxy$ext_pl", "dbiprof$ext_pl" ],
DIR => [ ],
dynamic_lib => { OTHERLDFLAGS => "$::opt_g" },
Modified: dbi/trunk/lib/DBD/NullP.pm
==============================================================================
--- dbi/trunk/lib/DBD/NullP.pm (original)
+++ dbi/trunk/lib/DBD/NullP.pm Mon Nov 21 09:40:50 2005
@@ -46,6 +46,7 @@
{ package DBD::NullP::db; # ====== DATABASE ======
$imp_data_size = 0;
use strict;
+ use Carp qw(croak);
sub prepare {
my($dbh, $statement)= @_;
Modified: dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileDumper/Apache.pm (original)
+++ dbi/trunk/lib/DBI/ProfileDumper/Apache.pm Mon Nov 21 09:40:50 2005
@@ -10,6 +10,20 @@ Add this line to your F<httpd.conf>:
PerlSetEnv DBI_PROFILE DBI::ProfileDumper::Apache
+Under mod_perl2 RC5+ you'll need to also add:
+
+ PerlSetEnv DBI_PROFILE_APACHE_LOG_DIR /server_root/logs
+
+OR add
+
+ PerlOptions +GlobalRequest
+
+to the gobal config section you're about test with DBI::ProfileDumper::Apache.
+If you don't do this, you'll see messages in your error_log similar to:
+
+ DBI::ProfileDumper::Apache on_destroy failed: Global $r object is not
available. Set:
+ PerlOptions +GlobalRequest in httpd.conf at
..../DBI/ProfileDumper/Apache.pm line 144
+
Then restart your server. Access the code you wish to test using a
web browser, then shutdown your server. This will create a set of
F<dbi.prof.*> files in your Apache log directory. Get a profiling
@@ -106,12 +120,13 @@ it under the same terms as Perl 5 itself
=cut
use vars qw($VERSION @ISA);
-$VERSION = "1.0";
+$VERSION = "1.1";
@ISA = qw(DBI::ProfileDumper);
use DBI::ProfileDumper;
-use Apache;
use File::Spec;
+use constant MP2 => ($ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION}
== 2) ? 1 : 0;
+
# Override flush_to_disk() to setup File just in time for output.
# Overriding new() would work unless the user creates a DBI handle
# during server startup, in which case all the children would try to
@@ -120,7 +135,21 @@ sub flush_to_disk {
my $self = shift;
# setup File per process
- my $path = Apache->server_root_relative("logs/");
+ my $path;
+ if (MP2) {
+ if ($ENV{DBI_PROFILE_APACHE_LOG_DIR}) {
+ $path = $ENV{DBI_PROFILE_APACHE_LOG_DIR};
+ }
+ else {
+ require Apache2::RequestUtil;
+ require Apache2::ServerUtil;
+ $path =
Apache2::ServerUtil::server_root_relative(Apache2::RequestUtil->request()->pool,
"logs/")
+ }
+ }
+ else {
+ require Apache;
+ $path = Apache->server_root_relative("logs/");
+ }
my $old_file = $self->{File};
$self->{File} = File::Spec->catfile($path, "$old_file.$$");
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Mon Nov 21 09:40:50 2005
@@ -144,6 +144,7 @@ my %is_valid_attribute = map {$_ =>1 } (
BegunWork
CachedKids
Callbacks
+ ChildHandles
CursorName
Database
DebugDispatch
@@ -170,6 +171,7 @@ my %is_valid_attribute = map {$_ =>1 } (
SCALE
Statement
TYPE
+ Type
TraceLevel
Username
Version
@@ -646,6 +648,13 @@ sub FETCH {
return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key
eq'Taint';
return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no,
not undef
return $DBI::dbi_debug if $key eq 'TraceLevel';
+ return [] if $key eq 'ChildHandles';
+ if ($key eq 'Type') {
+ return "dr" if $h->isa('DBI::dr');
+ return "db" if $h->isa('DBI::db');
+ return "st" if $h->isa('DBI::st');
+ Carp::carp( sprintf "Can't get determine Type for %s",$h );
+ }
if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) {
local $^W; # hide undef warnings
Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute
(@{[ %$h ]})",$h,$key )
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Mon Nov 21 09:40:50 2005
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 124;
+use Test::More tests => 128;
## ----------------------------------------------------------------------------
## 03handle.t - tests handles
@@ -16,6 +16,10 @@ BEGIN {
use_ok( 'DBI' );
}
+# installed drivers should start empty
+my %drivers = DBI->installed_drivers();
+is(scalar keys %drivers, 0);
+
## ----------------------------------------------------------------------------
# get the Driver handle
@@ -30,6 +34,13 @@ SKIP: {
cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any
Kids');
}
+# now the driver should be registered
+%drivers = DBI->installed_drivers();
+is(scalar keys %drivers, 1);
+ok(exists $drivers{ExampleP});
+ok($drivers{ExampleP}->isa('DBI::dr'));
+
+
## ----------------------------------------------------------------------------
# do database handle tests inside do BLOCK to capture scope
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Mon Nov 21 09:40:50 2005
@@ -494,7 +494,7 @@ ok($dbh->{AutoCommit});
ok(!$dbh->{BegunWork});
ok($dbh->begin_work);
-ok(!$dbh->{AutoCommit}, $dbh->{AutoCommit});
+ok(!$dbh->{AutoCommit});
ok($dbh->{BegunWork});
$dbh->commit;
Added: dbi/trunk/t/72childhandles.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/72childhandles.t Mon Nov 21 09:40:50 2005
@@ -0,0 +1,95 @@
+#!perl -w
+
+use strict;
+
+#
+# test script for the ChildHandles attribute
+#
+
+use DBI;
+
+use Test;
+BEGIN { plan tests => 22; }
+{
+ # make 10 connections
+ my @dbh;
+ for (1 .. 10) {
+ my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+ push(@dbh, $dbh);
+ }
+
+ # get the driver handle
+ my %drivers = DBI->installed_drivers();
+ my $driver = $drivers{ExampleP};
+ ok($driver);
+
+ # get the kids, should be the 10 connections
+ my $db_handles = $driver->{ChildHandles};
+ ok(scalar @$db_handles, 10);
+
+ # make sure all the handles are there
+ foreach my $h (@dbh) {
+ ok(grep { $h == $_ } @$db_handles);
+ }
+}
+
+# now all the out-of-scope DB handles should be gone
+{
+ my %drivers = DBI->installed_drivers();
+ my $driver = $drivers{ExampleP};
+
+ my $handles = $driver->{ChildHandles};
+ my @db_handles = grep { defined } @$handles;
+ ok(scalar @db_handles, 0);
+}
+
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+
+
+# ChildHandles should start with an empty array-ref
+my $empty = $dbh->{ChildHandles};
+ok(scalar @$empty, 0);
+
+# test child handles for statement handles
+{
+ my @sth;
+ for (1 .. 200) {
+ my $sth = $dbh->prepare('SELECT name FROM t');
+ push(@sth, $sth);
+ }
+ my $handles = $dbh->{ChildHandles};
+ ok(scalar @$handles, 200);
+
+ # test a recursive walk like the one in the docs
+ my @lines;
+ sub show_child_handles {
+ my ($h, $level) = @_;
+ $level ||= 0;
+ push(@lines,
+ sprintf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h);
+ show_child_handles($_, $level + 1)
+ for (grep { defined } @{$h->{ChildHandles}});
+ }
+ show_child_handles($_) for (values %{{DBI->installed_drivers()}});
+
+ ok(scalar @lines, 202);
+ ok($lines[0] =~ /^drh/);
+ ok($lines[1] =~ /^dbh/);
+ ok($lines[2] =~ /^sth/);
+}
+
+# they should be gone now
+my $handles = $dbh->{ChildHandles};
+my @live = grep { defined $_ } @$handles;
+ok(scalar @live, 0);
+
+# test that the childhandle array does not grow uncontrollably
+{
+ for (1 .. 1000) {
+ my $sth = $dbh->prepare('SELECT name FROM t');
+ }
+ my $handles = $dbh->{ChildHandles};
+ ok(scalar @$handles < 1000);
+ my @live = grep { defined } @$handles;
+ ok(scalar @live, 0);
+}
