Author: timbo Date: Mon Jan 29 14:49:42 2007 New Revision: 8748 Added: dbi/trunk/lib/DBD/Gofer/Transport/pipe.pm (contents, props changed) dbi/trunk/lib/DBI/Gofer/Transport/pipe.pm (contents, props changed) Modified: dbi/trunk/Changes dbi/trunk/META.yml dbi/trunk/Makefile.PL dbi/trunk/lib/DBD/Gofer.pm (contents, props changed) dbi/trunk/lib/DBD/Gofer/Transport/Base.pm (contents, props changed) dbi/trunk/lib/DBD/Gofer/Transport/null.pm (contents, props changed) dbi/trunk/lib/DBI/Gofer/Execute.pm (contents, props changed) dbi/trunk/lib/DBI/Gofer/Request.pm (contents, props changed) dbi/trunk/lib/DBI/Gofer/Response.pm (contents, props changed) dbi/trunk/lib/DBI/Gofer/Transport/Base.pm (contents, props changed) dbi/trunk/t/03handle.t dbi/trunk/t/05thrclone.t dbi/trunk/t/50dbm.t dbi/trunk/t/65transact.t dbi/trunk/t/72childhandles.t
Log: More work-in-progress, including adding a 'pipe' transport. Modified: dbi/trunk/Changes ============================================================================== --- dbi/trunk/Changes (original) +++ dbi/trunk/Changes Mon Jan 29 14:49:42 2007 @@ -8,14 +8,15 @@ XXX document DBD::Gofer -=head2 Changes in DBI 1.XX (svn rev XX), XX +=head2 Changes in DBI 1.54 (svn rev 8745), 29th January 2007 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. + NOTE: This release includes the 'next big thing' for DBI: 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 Modified: dbi/trunk/META.yml ============================================================================== --- dbi/trunk/META.yml (original) +++ dbi/trunk/META.yml Mon Jan 29 14:49:42 2007 @@ -1,7 +1,7 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: DBI -version: 1.53 +version: 1.54 version_from: DBI.pm installdirs: site requires: Modified: dbi/trunk/Makefile.PL ============================================================================== --- dbi/trunk/Makefile.PL (original) +++ dbi/trunk/Makefile.PL Mon Jan 29 14:49:42 2007 @@ -289,6 +289,7 @@ inst_libdbi = ' . File::Spec->catdir($self->{INST_LIB}, 'DBI') . ' changes_pm = ' . File::Spec->catfile($self->{INST_LIB}, 'DBI', 'Changes.pm') . ' roadmap_pm = ' . File::Spec->catfile($self->{INST_LIB}, 'DBI', 'Roadmap.pm') . ' +'.q{ config :: $(changes_pm) $(roadmap_pm) $(NOECHO) $(NOOP) @@ -302,7 +303,10 @@ $(MKPATH) $(inst_libdbi) $(RM_F) $(roadmap_pm) $(CP) Roadmap.pod $(roadmap_pm) -'; + +checkkeywords: + find lib -type f -name .svn -prune -o -name \*.pm -exec bash -c '[ -z "$$(svn pg svn:keywords {})" ] && echo svn propset svn:keywords \"Id Revision\" {}' \; +}; return $xst; } Modified: dbi/trunk/lib/DBD/Gofer.pm ============================================================================== --- dbi/trunk/lib/DBD/Gofer.pm (original) +++ dbi/trunk/lib/DBD/Gofer.pm Mon Jan 29 14:49:42 2007 @@ -8,9 +8,9 @@ require DBI::Gofer::Response; require Carp; - our $VERSION = sprintf("0.%06d", q$Revision: 8705 $ =~ /(\d+)/o); + our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o); -# $Id: Gofer.pm 8705 2007-01-26 01:08:25Z timbo $ +# $Id$ # # Copyright (c) 2007, Tim Bunce, Ireland # @@ -95,6 +95,11 @@ my $go_dsn = ($dsn =~ s/\bdsn=(.*)$// && $1) or return $drh->set_err(1, "No dsn= argument in '$orig_dsn'"); + if ($attr->{go_bypass}) { # don't use DBD::Gofer for this connection + # useful for testing with DBI_AUTOPROXY, e.g., t/03handle.t + return DBI->connect($go_dsn, $user, $auth, $attr); + } + my %dsn_attr = (%dsn_attr_defaults, go_dsn => $go_dsn); # extract any go_ attributes from the connect() attr arg for my $k (grep { /^go_/ } keys %$attr) { @@ -114,7 +119,7 @@ or return $drh->set_err(1, "No transport= argument in '$orig_dsn'"); $transport_class = "DBD::Gofer::Transport::$dsn_attr{go_transport}" unless $transport_class =~ /::/; - eval "require $transport_class" + eval "require $transport_class" # XXX fix unsafe string eval or return $drh->set_err(1, "Error loading $transport_class: $@"); my $go_trans = eval { $transport_class->new(\%dsn_attr) } or return $drh->set_err(1, "Error instanciating $transport_class: $@"); Modified: dbi/trunk/lib/DBD/Gofer/Transport/Base.pm ============================================================================== --- dbi/trunk/lib/DBD/Gofer/Transport/Base.pm (original) +++ dbi/trunk/lib/DBD/Gofer/Transport/Base.pm Mon Jan 29 14:49:42 2007 @@ -1,6 +1,6 @@ package DBD::Gofer::Transport::Base; -# $Id: Base.pm 8696 2007-01-24 23:12:38Z timbo $ +# $Id$ # # Copyright (c) 2007, Tim Bunce, Ireland # @@ -10,43 +10,10 @@ use strict; use warnings; -use Carp qw(cluck); -use Storable qw(freeze thaw); +use base qw(DBI::Gofer::Transport::Base); -use base qw(Class::Accessor::Fast); +our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o); -our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o); - -our $debug = $ENV{DBD_GOFER_TRACE} || 0; - - -__PACKAGE__->mk_accessors(qw( - go_dsn -)); - - -sub freeze_data { - my ($self, $data, $skip_debug) = @_; - $self->_dump("DBD_GOFER_TRACE freezing ".ref($data), $data) - if $debug && not $skip_debug; - local $Storable::forgive_me = 1; # for CODE refs etc - return freeze($data); -} - -sub thaw_data { - my ($self, $frozen_data, $skip_debug) = @_; - my $data = thaw($frozen_data); - $self->_dump("DBD_GOFER_TRACE thawing ".ref($data), $data) - if $debug && not $skip_debug; - return $data; -} - - -sub _dump { - my ($self, $label, $data) = @_; - require Data::Dumper; - # XXX dd settings - warn "$label=".Data::Dumper::Dumper($data); -} +sub _init_debug { $ENV{DBD_GOFER_TRACE} || 0 } 1; Modified: dbi/trunk/lib/DBD/Gofer/Transport/null.pm ============================================================================== --- dbi/trunk/lib/DBD/Gofer/Transport/null.pm (original) +++ dbi/trunk/lib/DBD/Gofer/Transport/null.pm Mon Jan 29 14:49:42 2007 @@ -1,6 +1,6 @@ package DBD::Gofer::Transport::null; -# $Id: null.pm 8696 2007-01-24 23:12:38Z timbo $ +# $Id$ # # Copyright (c) 2007, Tim Bunce, Ireland # @@ -14,7 +14,7 @@ use DBI::Gofer::Execute qw(execute_request); -our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o); +our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o); __PACKAGE__->mk_accessors(qw( pending_response Added: dbi/trunk/lib/DBD/Gofer/Transport/pipe.pm ============================================================================== --- (empty file) +++ dbi/trunk/lib/DBD/Gofer/Transport/pipe.pm Mon Jan 29 14:49:42 2007 @@ -0,0 +1,103 @@ +package DBD::Gofer::Transport::pipe; + +# $Id$ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +use base qw(DBD::Gofer::Transport::Base); + +our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o); + +__PACKAGE__->mk_accessors(qw( + response_info +)); + + +sub transmit_request { + my ($self, $request) = @_; + + my $info = eval { + my $frozen_request = $self->freeze_data($request); + + local $ENV{DBI_TRACE}; + local $ENV{DBI_AUTOPROXY}; + local $ENV{DBI_PROFILE}; + local $ENV{PERL5LIB} = join ":", @INC; + my $cmd = "perl -MDBI::Gofer::Transport::pipe -e run_one_stdio"; + + my ($wfh, $rfh, $efh) = (gensym, gensym, gensym); + my $pid = open3($wfh, $rfh, $efh, $cmd) + or die "error starting subprocess: $!\n"; + + # send frozen request + print $wfh $frozen_request; + # indicate that there's no more + close $wfh + or die "error writing to subprocess: $!\n"; + + # so far so good. return the state info + { pid=>$pid, rfh=>$rfh, efh=>$efh }; + }; + if ($@) { + warn $@; + $info = {}; + $info->{response} = DBI::Gofer::Response->new({ + err => 1, + errstr => $@, + }); + } + + # record what we need to get a response, ready for receive_response() + $self->response_info( $info ); + + return 1; +} + + +sub receive_response { + my $self = shift; + + my $info = $self->response_info || die; + my ($response, $pid, $rfh, $efh) = @{$info}{qw(response pid rfh efh)}; + + return $response if $response; # failed while starting + + waitpid $info->{pid}, 0 + or warn "waitpid: $!"; # XXX do something more useful? + + my $frozen_response = do { local $/; <$rfh> }; + my $stderr_msg = do { local $/; <$efh> }; + + if (not $frozen_response) { # no output on stdout at all + return DBI::Gofer::Response->new({ + err => 1, + errstr => "pipe command failed: $stderr_msg", + }); + } + warn "STDERR message: $stderr_msg" if $stderr_msg; # XXX do something more useful + #warn DBI::neat($frozen_response); + + # XXX may be corrupt + $response = $self->thaw_data($frozen_response); + + return $response; +} + + +1; + +__END__ + +Spectacularly inefficient. + +Intended as a test of the truely stateless nature of the Gofer servers, +and an example implementation of a transport that talks to another process. Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm ============================================================================== --- dbi/trunk/lib/DBI/Gofer/Execute.pm (original) +++ dbi/trunk/lib/DBI/Gofer/Execute.pm Mon Jan 29 14:49:42 2007 @@ -1,6 +1,6 @@ package DBI::Gofer::Execute; -# $Id: Execute.pm 8696 2007-01-24 23:12:38Z timbo $ +# $Id$ # # Copyright (c) 2007, Tim Bunce, Ireland # @@ -16,7 +16,7 @@ use base qw(Exporter); -our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o); +our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o); our @EXPORT_OK = qw( execute_request @@ -24,7 +24,7 @@ execute_sth_request ); -our @sth_std_attr = qw( +my @sth_std_attr = qw( NUM_OF_PARAMS NUM_OF_FIELDS NAME @@ -32,7 +32,58 @@ NULLABLE PRECISION SCALE - CursorName +); + +my %extra_attr = ( + # what driver-specific attributes should be returned for the driver being used? + # keyed by $dbh->{Driver}{Name} + # XXX for dbh attr only need to be returned on first access by client + # the client should then cache them. So need a way to indicate that. + # XXX for sth should split into attr specific to resultsets (where NUM_OF_FIELDS > 0) and others + # which would reduce processing/traffic for non-select statements + mysql => { + dbh => [qw( + )], + sth => [qw( + mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment + mysql_length mysql_max_length mysql_table mysql_type mysql_type_name + )], + }, + Pg => { + dbh => [qw( + pg_protocol pg_lib_version pg_server_version + pg_db pg_host pg_port pg_default_port + pg_options pg_pid + )], + sth => [qw( + pg_size pg_type pg_oid_status pg_cmd_status + )], + }, + Sybase => { + dbh => [qw( + syb_dynamic_supported syb_oc_version syb_server_version syb_server_version_string + )], + sth => [qw( + syb_types syb_result_type syb_proc_status + )], + }, +); + +my %extra_sth_attr = ( + # what driver-specific attributes should be returned for the driver being used? + # keyed by $dbh->{Driver}{Name} + # XXX could split into attr specific to resultsets (where NUM_OF_FIELDS > 0) and others + # which would reduce processing/traffic for non-select statements + mysql => [qw( + mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment + mysql_length mysql_max_length mysql_table mysql_type mysql_type_name + )], + Pg => [qw( + pg_size pg_type pg_oid_status pg_cmd_status + )], + Sybase => [qw( + syb_types syb_result_type syb_proc_status + )], ); our $trace = $ENV{DBI_GOFER_TRACE}; @@ -43,13 +94,16 @@ sub _connect { my $request = shift; - local $ENV{DBI_AUTOPROXY}; + + local $ENV{DBI_AUTOPROXY}; # limit the insanity + my $connect_args = $request->connect_args; my ($dsn, $u, $p, $attr) = @$connect_args; # delete attributes we don't want to affect the server-side delete @{$attr}{qw(Profile InactiveDestroy Warn HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)}; my $connect_method = 'connect_cached'; -#$connect_method = 'connect'; + #$connect_method = 'connect'; + # XXX need way to limit/purge connect cache over time my $dbh = DBI->$connect_method($dsn, $u, $p, { %$attr, @@ -70,7 +124,6 @@ sub _reset_dbh { my ($dbh) = @_; $dbh->set_err(undef, undef); # clear any error state - #$dbh->trace(0, \*STDERR); } @@ -78,16 +131,22 @@ my ($rv) = @_; my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state); + + # if we caught an exception and there's either no DBI error, or the + # exception itself doesn't look like a DBI exception, then append the + # exception to errstr if ($@ and !$errstr || $@ !~ /^DBD::/) { $err ||= 1; $errstr = ($errstr) ? "$errstr; $@" : $@; } + my $response = DBI::Gofer::Response->new({ rv => $rv, err => $err, errstr => $errstr, state => $state, }); + return $response; } @@ -109,10 +168,11 @@ err => 1, errstr => $@, state => '', }); } - warn "Gofer response level $recurse: ".$response->rv."\n" if $trace; + #warn "Gofer response level $recurse: ".$response->rv."\n" if $trace; return $response; } + sub execute_dbh_request { my $request = shift; my $dbh; @@ -138,11 +198,6 @@ $response->sth_resultsets( _gather_sth_resultsets($rv, $request) ); $response->rv("(sth)"); } - if (0) { - # if not using connect_cached then we want to gracefu - local $SIG{__WARN__} = sub {}; - undef $dbh; - } return $response; } @@ -184,13 +239,24 @@ sub _gather_sth_resultsets { my ($sth, $request) = @_; return eval { - my $attr_list = $request->sth_result_attr; - $attr_list = [ keys %$attr_list ] if ref $attr_list eq 'HASH'; + my $driver_name = $sth->{Database}{Driver}{Name}; + my $extra_sth_attr = $extra_sth_attr{$driver_name} || []; + + my $sth_attr = {}; + $sth_attr->{$_} = 1 for (@sth_std_attr, @$extra_sth_attr); + + # let the client add/remove sth atributes + if (my $sth_result_attr = $request->sth_result_attr) { + $sth_attr->{$_} = $sth_result_attr->{$_} + for keys %$sth_result_attr; + } + my $rs_list = []; do { - my $rs = fetch_result_set($sth, $attr_list); + my $rs = fetch_result_set($sth, $sth_attr); push @$rs_list, $rs; - } while $sth->more_results; + } while $sth->more_results + || $sth->{syb_more_results}; $rs_list; }; @@ -198,12 +264,17 @@ sub fetch_result_set { - my ($sth, $extra_attr) = @_; + my ($sth, $extra_sth_attr) = @_; my %meta; - for my $attr (@sth_std_attr, @$extra_attr) { - $meta{ $attr } = $sth->{$attr}; + while ( my ($attr,$use) = each %$extra_sth_attr ) { + next unless $use; + my $v = eval { $sth->FETCH($attr) }; + warn $@ if $@; + $meta{ $attr } = $v if defined $v; } - if ($sth->FETCH('NUM_OF_FIELDS')) { # if a select + my $NUM_OF_FIELDS = $meta{NUM_OF_FIELDS}; + $NUM_OF_FIELDS = $sth->FETCH('NUM_OF_FIELDS') unless defined $NUM_OF_FIELDS; + if ($NUM_OF_FIELDS) { # is a select $meta{rowset} = eval { $sth->fetchall_arrayref() }; $meta{err} = $DBI::err; $meta{errstr} = $DBI::errstr; Modified: dbi/trunk/lib/DBI/Gofer/Request.pm ============================================================================== --- dbi/trunk/lib/DBI/Gofer/Request.pm (original) +++ dbi/trunk/lib/DBI/Gofer/Request.pm Mon Jan 29 14:49:42 2007 @@ -1,6 +1,6 @@ package DBI::Gofer::Request; -# $Id: Request.pm 8696 2007-01-24 23:12:38Z timbo $ +# $Id$ # # Copyright (c) 2007, Tim Bunce, Ireland # @@ -9,7 +9,7 @@ use base qw(Class::Accessor::Fast); -our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o); +our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o); __PACKAGE__->mk_accessors(qw( Modified: dbi/trunk/lib/DBI/Gofer/Response.pm ============================================================================== --- dbi/trunk/lib/DBI/Gofer/Response.pm (original) +++ dbi/trunk/lib/DBI/Gofer/Response.pm Mon Jan 29 14:49:42 2007 @@ -1,6 +1,6 @@ package DBI::Gofer::Response; -# $Id: Response.pm 8696 2007-01-24 23:12:38Z timbo $ +# $Id$ # # Copyright (c) 2007, Tim Bunce, Ireland # @@ -9,7 +9,7 @@ use base qw(Class::Accessor::Fast); -our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o); +our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o); __PACKAGE__->mk_accessors(qw( rv Modified: dbi/trunk/lib/DBI/Gofer/Transport/Base.pm ============================================================================== --- dbi/trunk/lib/DBI/Gofer/Transport/Base.pm (original) +++ dbi/trunk/lib/DBI/Gofer/Transport/Base.pm Mon Jan 29 14:49:42 2007 @@ -1,6 +1,6 @@ -package DBD::Gofer::Transport::Base; +package DBI::Gofer::Transport::Base; -# $Id: Base.pm 8696 2007-01-24 23:12:38Z timbo $ +# $Id$ # # Copyright (c) 2007, Tim Bunce, Ireland # @@ -14,35 +14,47 @@ use base qw(Class::Accessor::Fast); -our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o); +our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o); -our $debug = $ENV{DBI_GOFER_TRACE} || 0; +sub _init_trace { $ENV{DBI_GOFER_TRACE} || 0 } __PACKAGE__->mk_accessors(qw( + trace go_dsn )); +sub new { + my ($class, $args) = @_; + $args->{trace} ||= $class->_init_trace; + return $class->SUPER::new($args); +} + + sub freeze_data { - my ($self, $data) = @_; - $self->_dump("DBI_GOFER_TRACE ".ref($data), $data) if $debug; + my ($self, $data, $skip_trace) = @_; + $self->_dump("freezing ".ref($data), $data) + if !$skip_trace and $self->trace; local $Storable::forgive_me = 1; # for CODE refs etc return freeze($data); } sub thaw_data { - my ($self, $frozen_data) = @_; + my ($self, $frozen_data, $skip_trace) = @_; my $data = thaw($frozen_data); - $self->_dump("DBI_GOFER_TRACE ".ref($data), $data) if $debug; + $self->_dump("thawing ".ref($data), $data) + if !$skip_trace and $self->trace; return $data; } + sub _dump { my ($self, $label, $data) = @_; require Data::Dumper; - warn "$label=".Dumper($request); + # XXX config dumper format + warn "$label=".Dumper($data); } 1; Added: dbi/trunk/lib/DBI/Gofer/Transport/pipe.pm ============================================================================== --- (empty file) +++ dbi/trunk/lib/DBI/Gofer/Transport/pipe.pm Mon Jan 29 14:49:42 2007 @@ -0,0 +1,36 @@ +package DBI::Gofer::Transport::pipe; + +# $Id$ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use DBI::Gofer::Execute qw(execute_request); + +use base qw(DBI::Gofer::Transport::Base Exporter); + +our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o); + +our @EXPORT = qw(run_one_stdio); + + +sub run_one_stdio { + + my $self = DBI::Gofer::Transport::pipe->new(); + + my $frozen_request = do { local $/; <STDIN> }; + + my $response = execute_request( $self->thaw_data($frozen_request) ); + + my $frozen_response = $self->freeze_data($response); + + print $frozen_response; +} + + +1; Modified: dbi/trunk/t/03handle.t ============================================================================== --- dbi/trunk/t/03handle.t (original) +++ dbi/trunk/t/03handle.t Mon Jan 29 14:49:42 2007 @@ -40,7 +40,7 @@ ok(exists $drivers{ExampleP}); ok($drivers{ExampleP}->isa('DBI::dr')); -my $using_dbd_gofer_null = ($ENV{DBI_AUTOPROXY}||'') =~ /dbi:Gofer.*transport=null/i; +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/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_gofer_null + my $drh = $dbh->{Driver}; # (re)get drh here so tests can work using_dbd_gofer SKIP: { skip "Kids and ActiveKids attributes not supported under DBI::PurePerl", 2 if $DBI::PurePerl; @@ -140,10 +140,10 @@ 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_gofer_null; my $sth6 = $dbh->prepare($sql); $sth6->execute("."); + my $sth1_driver_name = $sth1->{Database}{Driver}{Name}; ok( $sth6->{Active}, '... sixth statement handle is active'); ok(!$sth1->{Active}, '... first statement handle is not active'); @@ -170,14 +170,14 @@ $sth6->finish; - ok(my $dbh_nullp = DBI->connect("dbi:NullP:")); + ok(my $dbh_nullp = DBI->connect("dbi:NullP:", undef, undef, { go_bypass => 1 })); 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" ); + cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', $sth1_driver_name ); ok( $sth1->swap_inner_handle($sth7,1), "... can swap to different parent if forced"); cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', "NullP" ); @@ -198,7 +198,7 @@ }; -if ($using_dbd_gofer_null) { +if ($using_dbd_gofer) { $drh->{CachedKids} = {}; } @@ -249,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_gofer_null; + skip "drh Kids not testable under DBD::Gofer", 25 if $using_dbd_gofer; foreach my $args ( {}, @@ -270,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_gofer_null; + skip "take_imp_data test not supported under DBD::Gofer", 19 if $using_dbd_gofer; 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_null + 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'); Modified: dbi/trunk/t/05thrclone.t ============================================================================== --- dbi/trunk/t/05thrclone.t (original) +++ dbi/trunk/t/05thrclone.t Mon Jan 29 14:49:42 2007 @@ -23,8 +23,8 @@ # 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}; +warn " You can ignore the $threads 'Scalars leaked' messages you may see here (or send me a patch to fix the underlying problem)\n" + if $ENV{DBI_AUTOPROXY} && not $ENV{DBI_PUREPERL}; { package threads_sub; Modified: dbi/trunk/t/50dbm.t ============================================================================== --- dbi/trunk/t/50dbm.t (original) +++ dbi/trunk/t/50dbm.t Mon Jan 29 14:49:42 2007 @@ -5,7 +5,7 @@ use Test::More; use Config qw(%Config); -my $using_dbd_gofer_null = ($ENV{DBI_AUTOPROXY}||'') =~ /dbi:Gofer.*transport=null/i; +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/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_gofer_null) { + if ($using_dbd_gofer) { $dsn .= ";f_dir=$dir"; } @@ -105,7 +105,7 @@ # test if it correctly accepts valid $dbh attributes SKIP: { skip "Can't set attributes after connect using DBD::Gofer", 2 - if $using_dbd_gofer_null; + if $using_dbd_gofer; 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_gofer_null; + local $SIG{__WARN__} = sub { } if $using_dbd_gofer; $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 14:49:42 2007 @@ -31,4 +31,4 @@ ok($dbh->{AutoCommit}); ok(!$dbh->{BegunWork}); -exit 0; +1; Modified: dbi/trunk/t/72childhandles.t ============================================================================== --- dbi/trunk/t/72childhandles.t (original) +++ dbi/trunk/t/72childhandles.t Mon Jan 29 14:49:42 2007 @@ -24,6 +24,8 @@ plan tests => 14; +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i; + my $drh; { @@ -66,7 +68,7 @@ # test child handles for statement handles { my @sth; - my $sth_count = 200; + my $sth_count = 20; for (1 .. $sth_count) { my $sth = $dbh->prepare('SELECT name FROM t'); push @sth, $sth; @@ -99,7 +101,9 @@ is scalar @live, 0, "handles should be gone now"; # test that the childhandle array does not grow uncontrollably -{ +SKIP: { + skip "slow tests avoided when using DBD::Gofer", 2 if $using_dbd_gofer; + for (1 .. 1000) { my $sth = $dbh->prepare('SELECT name FROM t'); } @@ -108,3 +112,5 @@ my @live = grep { defined } @$handles; is scalar @live, 0; } + +1;
