Author: timbo
Date: Fri Jun 5 15:13:00 2009
New Revision: 12810
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/t/72childhandles.t
Log:
Added DBI->visit_handles($coderef) method.
Added $h->visit_child_handles($coderef) method.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Fri Jun 5 15:13:00 2009
@@ -59,10 +59,11 @@
Fixes to DBD::File (H.Merijn Brand)
added f_schema attribute
table names case sensitive when quoted, insensitive when unquoted
- workaround a bug in SQL::Statement (temporary fix)
- "You passed x parameters where y required" now only warns if it
- finds a mismatch on the first execute of the handle
+ workaround a bug in SQL::Statement (temporary fix) related
+ to the "You passed x parameters where y required" error
+ Added DBI->visit_handles($coderef) method.
+ Added $h->visit_child_handles($coderef) method.
Added docs form column_info()'s COLUMN_DEF value.
Clarified docs on stickyness of data type via bind_param().
Clarified docs on stickyness of data type via bind_col().
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Fri Jun 5 15:13:00 2009
@@ -399,6 +399,7 @@
trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ],
O=>0x0004, T=>8 },
swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
private_attribute_info => { },
+ visit_child_handles => { U => [2,3,'$coderef [, $info ]'], O=>0x0404,
T=>4 },
},
dr => { # Database Driver Interface
'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'],
H=>3, O=>0x8000 },
@@ -534,6 +535,18 @@
return ($scheme, $driver, $attr, $attr_hash, $dsn);
}
+sub visit_handles {
+ my ($class, $code, $outer_info) = @_;
+ $outer_info = {} if not defined $outer_info;
+ my %drh = DBI->installed_drivers;
+ for my $h (values %drh) {
+ my $child_info = $code->($h, $outer_info)
+ or next;
+ $h->visit_child_handles($code, $child_info);
+ }
+ return $outer_info;
+}
+
# --- The DBI->connect Front Door methods
@@ -1399,6 +1412,17 @@
return undef;
}
+ sub visit_child_handles {
+ my ($h, $code, $info) = @_;
+ $info = {} if not defined $info;
+ for my $ch (@{ $h->{ChildHandles} || []}) {
+ next unless $ch;
+ my $child_info = $code->($ch, $info)
+ or next;
+ $ch->visit_child_handles($code, $child_info);
+ }
+ return $info;
+ }
}
@@ -2860,6 +2884,31 @@
tracing facilities.
+=head3 C<visit_handles>
+
+ DBI->visit_handles( $coderef );
+ DBI->visit_handles( $coderef, $info );
+
+Where $coderef is a reference to a subroutine and $info is an arbitrary value
+which, if undefined, defaults to a reference to an empty hash. Returns $info.
+
+For each installed driver handle, if any, $coderef is invoked as:
+
+ $coderef->($driver_handle, $info);
+
+If the execution of $coderef returns a true value then L</visit_child_handles>
+is called on that child handle and passed the returned value as $info.
+
+For example:
+
+ my $info = $dbh->{Driver}->visit_child_handles(sub {
+ my ($h, $info) = @_;
+ ++$info->{ $h->{Type} }; # count types of handles (dr/db/st)
+ return $info; # visit kids
+ });
+
+See also L</visit_child_handles>.
+
=head2 DBI Utility Functions
@@ -3327,6 +3376,32 @@
dbh1o -> dbh2i
sthAo -> sthBi(dbh2i)
+=head3 C<visit_child_handles>
+
+ $h->visit_child_handles( $coderef );
+ $h->visit_child_handles( $coderef, $info );
+
+Where $coderef is a reference to a subroutine and $info is an arbitrary value
+which, if undefined, defaults to a reference to an empty hash. Returns $info.
+
+For each child handle of $h, if any, $coderef is invoked as:
+
+ $coderef->($child_handle, $info);
+
+If the execution of $coderef returns a true value then C<visit_child_handles>
+is called on that child handle and passed the returned value as $info.
+
+For example:
+
+ # count database connections with names (DSN) matching a pattern
+ my $connections = 0;
+ $dbh->{Driver}->visit_child_handles(sub {
+ my ($h, $info) = @_;
+ ++$connections if $h->{Name} =~ /foo/;
+ return 0; # don't visit kids
+ })
+
+See also L</visit_handles>.
=head1 ATTRIBUTES COMMON TO ALL HANDLES
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Fri Jun 5 15:13:00 2009
@@ -111,7 +111,7 @@
#define IMA_NO_TAINT_IN 0x0010 /* don't check for tainted args */
#define IMA_NO_TAINT_OUT 0x0020 /* don't taint results */
#define IMA_COPY_UP_STMT 0x0040 /* copy sth Statement to dbh */
-#define IMA_END_WORK 0x0080 /* set on commit & rollback */
+#define IMA_END_WORK 0x0080 /* method is commit or rollback */
#define IMA_STUB 0x0100 /* donothing eg $dbh->connected */
#define IMA_CLEAR_STMT 0x0200 /* clear Statement before call */
#define IMA_UNRELATED_TO_STMT 0x0400 /* profile as empty Statement */
Modified: dbi/trunk/t/72childhandles.t
==============================================================================
--- dbi/trunk/t/72childhandles.t (original)
+++ dbi/trunk/t/72childhandles.t Fri Jun 5 15:13:00 2009
@@ -23,7 +23,7 @@
exit 0;
}
-plan tests => 14;
+plan tests => 16;
my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i;
@@ -101,6 +101,38 @@
my @live = grep { defined $_ } @$handles;
is scalar @live, 0, "handles should be gone now";
+# test visit_child_handles
+{
+ my $info;
+ my $visitor = sub {
+ my ($h, $info) = @_;
+ my $type = $h->{Type};
+ ++$info->{ $type }{ ($type eq 'st') ? $h->{Statement} : $h->{Name} };
+ return $info;
+ };
+ DBI->visit_handles($visitor, $info = {});
+ is_deeply $info, {
+ 'dr' => {
+ 'ExampleP' => 1,
+ ($using_dbd_gofer) ? (Gofer => 1) : ()
+ },
+ 'db' => { '' => 1 },
+ };
+
+ my $sth1 = $dbh->prepare('SELECT name FROM t');
+ my $sth2 = $dbh->prepare('SELECT name FROM t');
+ DBI->visit_handles($visitor, $info = {});
+ is_deeply $info, {
+ 'dr' => {
+ 'ExampleP' => 1,
+ ($using_dbd_gofer) ? (Gofer => 1) : ()
+ },
+ 'db' => { '' => 1 },
+ 'st' => { 'SELECT name FROM t' => 2 }
+ };
+
+}
+
# test that the childhandle array does not grow uncontrollably
SKIP: {
skip "slow tests avoided when using DBD::Gofer", 2 if $using_dbd_gofer;
