Author: timbo Date: Sun Mar 21 16:13:06 2004 New Revision: 241 Added: dbi/trunk/t/pod.t Modified: dbi/trunk/DBI.pm dbi/trunk/MANIFEST dbi/trunk/Makefile.PL dbi/trunk/lib/DBD/Multiplex.pm dbi/trunk/lib/DBI/DBD.pm Log: Added t/pod.t from Andy Lester. Rework variant test mechanism to make it more extensible Added DBD::Multiplex test variant (but disabled currently)
Modified: dbi/trunk/DBI.pm ============================================================================== --- dbi/trunk/DBI.pm (original) +++ dbi/trunk/DBI.pm Sun Mar 21 16:13:06 2004 @@ -6585,6 +6585,11 @@ to make that happen is to do it yourself and send me a patch to the source code that shows the changes. +=head2 Browsing the source code repository + +Use http://svn.perl.org/modules/dbi/trunk (basic) +or http://svn.perl.org/viewcvs/modules/ (more useful) + =head2 How to create a patch using Subversion The DBI source code is maintained using Subversion (a replacement Modified: dbi/trunk/MANIFEST ============================================================================== --- dbi/trunk/MANIFEST (original) +++ dbi/trunk/MANIFEST Sun Mar 21 16:13:06 2004 @@ -58,5 +58,6 @@ t/50dbm.t t/60preparse.t t/80proxy.t +t/pod.t test.pl A very simple test harness using ExampleP.pm typemap Modified: dbi/trunk/Makefile.PL ============================================================================== --- dbi/trunk/Makefile.PL (original) +++ dbi/trunk/Makefile.PL Sun Mar 21 16:13:06 2004 @@ -128,7 +128,7 @@ EXE_FILES => [ "dbiproxy$ext_pl", "dbiprof$ext_pl" ], DIR => [ ], dynamic_lib => { OTHERLDFLAGS => "$::opt_g" }, - clean => { FILES=> "\$(DISTVNAME) Perl.xsi t/zz_*.t" + clean => { FILES=> "\$(DISTVNAME) Perl.xsi t/zv*_*.t" ." dbiproxy$ext_pl dbiprof$ext_pl dbitrace.log dbi.prof ndtest.prt" }, dist => { DIST_DEFAULT=> 'clean distcheck disttest tardist', Modified: dbi/trunk/lib/DBD/Multiplex.pm ============================================================================== --- dbi/trunk/lib/DBD/Multiplex.pm (original) +++ dbi/trunk/lib/DBD/Multiplex.pm Sun Mar 21 16:13:06 2004 @@ -22,7 +22,7 @@ # mx needs to manage errors from children RaiseError => 1, PrintError => 1, HandleError => 1, # Kids would give wrong counts - Kids => 1, ActiveKids => 1, CachedKids => 1, + Kids => 1, ActiveKids => 1, CachedKids => 0, Profile => 1, # profile at the mx level Statement => 1, # else first_success + mx_shuffle of prepare() give wrong results ); @@ -208,12 +208,18 @@ $parent_handle->trace_msg(" mx ++ calling $child_handle->$method(".DBI::neat_list($args).")\n"); } +# XXX need to always force RaiseError on the child handles so we can let the DBI +# work out when an error has happened rather than have to duplicate the logic here +# (which is difficult and slow given FETCH and ErrorCount behaviour) + + local $@; # Here, the actual method being multiplexed is being called. push @results, ($wantarray) - ? [ $child_handle->$method(@$args) ] - : [ scalar $child_handle->$method(@$args) ]; + ? [ eval { $child_handle->$method(@$args) } ] + : [ eval { scalar $child_handle->$method(@$args) } ]; - if (my $child_err = $child_handle->err) { + if ($@) { + my $child_err = $child_handle->err; my $child_errstr = $child_handle->errstr; my $error_info = [ $child_err, $child_errstr, $child_handle ]; [EMAIL PROTECTED] - 1] = $error_info; @@ -347,6 +353,7 @@ # delete error handling attribute that we want handled only at top level delete $child_connect_attr{$_} for (qw(RaiseError HandleError)); + $child_connect_attr{RaiseError} = 1; # explicitly silence default $child_connect_attr{PrintError} = 0; # explicitly silence default # delete any multiplex specific attributes from child connect Modified: dbi/trunk/lib/DBI/DBD.pm ============================================================================== --- dbi/trunk/lib/DBI/DBD.pm (original) +++ dbi/trunk/lib/DBI/DBD.pm Sun Mar 21 16:13:06 2004 @@ -3677,26 +3677,45 @@ if ($dbd_attr->{create_pp_tests}) { # XXX need to convert this to work within the generated Makefile # so 'make' creates them and 'make clean' deletes them - die "Can't create DBI::PurePerl tests unless 't' directory exists" - unless -d 't'; - opendir DIR, 't'; + my %test_variants = ( + pp => { name => "DBI::PurePerl", + add => [ '$ENV{DBI_PUREPERL}=2;' ], + }, + mx => { name => "DBD::Multiplex", + add => [ q{$ENV{DBI_AUTOPROXY}='dbi:Multiplex:';} ], + } + # px => { name => "DBD::Proxy", + # need mechanism for starting/stopping the proxy server + # add => [ q{$ENV{DBI_AUTOPROXY}='dbi:Proxy:XXX';} ], + # } + ); + # currently many tests fail - DBD::Multiplex needs more work + # to bring it up to date and improve transparency. + delete $test_variants{mx}; # unless -f "lib/DBD/Multiplex.pm"; + + opendir DIR, 't' or die "Can't create variants of tests in 't' directory: $!"; my @tests = grep { /\.t$/ } readdir DIR; closedir DIR; + + # XXX one day we may try combinations here, ie pp+mx! + foreach my $test (sort @tests) { - next if $test =~ /^zz_.*_pp\.t$/; - $test =~ s/\.t$//; - my $pp_test = "t/zz_${test}_pp.t"; + next if $test !~ /^[0-8]/; my $usethr = ($test =~ /(\d+|\b)thr/ && $] >= 5.008 && $Config{useithreads}); - printf "Creating extra DBI::PurePerl test: $pp_test %s\n", - ($usethr) ? "(use threads)" : ""; - open PPT, ">$pp_test" or warn "Can't create $pp_test: $!"; - print PPT "#!perl -w\n"; - print PPT "use threads;\n" if $usethr; - print PPT "\$ENV{DBI_PUREPERL}=2;\n"; - print PPT "do 't/$test.t' or warn \$!;\n"; - print PPT 'die if $@;'."\n"; - print PPT "exit 0\n"; - close PPT or warn "Error writing $pp_test: $!"; + + while ( my ($v_type, $v_info) = each %test_variants ) { + my $v_test = "t/zv${v_type}_$test"; + printf "Creating %-16s test variant: $v_test %s\n", + $v_info->{name}, ($usethr) ? "(use threads)" : ""; + open PPT, ">$v_test" or warn "Can't create $v_test: $!"; + print PPT "#!perl -w\n"; + print PPT "use threads;\n" if $usethr; + print PPT "$_\n" foreach @{$v_info->{add}}; + print PPT "do 't/$test' or warn \$!;\n"; + print PPT 'die if $@;'."\n"; + print PPT "exit 0\n"; + close PPT or warn "Error writing $v_test: $!"; + } } } return %$mm_attr; Added: dbi/trunk/t/pod.t ============================================================================== --- (empty file) +++ dbi/trunk/t/pod.t Sun Mar 21 16:13:06 2004 @@ -0,0 +1,4 @@ +use Test::More; +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; +all_pod_files_ok();
