[svn:dbi] r10252 - in dbi/trunk: lib/DBI t

[timbo]

Author: timbo
Date: Wed Nov 14 15:32:55 2007
New Revision: 10252

Modified:
   dbi/trunk/lib/DBI/ProxyServer.pm
   dbi/trunk/t/80proxy.t

Log:
Avoid undef warnings in proxy server (though they may indicate deeper problems 
as I've only seen them on cpan testers reports where the proxy test has failed).
Add more info to t/80proxy.t output if it fails.


Modified: dbi/trunk/lib/DBI/ProxyServer.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProxyServer.pm    (original)
+++ dbi/trunk/lib/DBI/ProxyServer.pm    Wed Nov 14 15:32:55 2007
@@ -215,7 +215,7 @@
     # $dbh. However, we'd have a reference loop in that case and
     # I would be concerned about garbage collection. :-(
     $dbh->{'private_server'} = $server;
-    $server->Debug("CallMethod: => " . join(",", @_));
+    $server->Debug("CallMethod: => " . do { local $^W; join(",", @_)});
     my @result = eval { $server->SUPER::CallMethod(@_) };
     my $msg = $@;
     undef $dbh->{'private_server'};
@@ -223,7 +223,7 @@
        $server->Debug("CallMethod died with: $@");
        die $msg;
     } else {
-       $server->Debug("CallMethod: <= " . join(",", @result));
+       $server->Debug("CallMethod: <= " . do { local $^W; join(",", @result) 
});
     }
     @result;
 }

Modified: dbi/trunk/t/80proxy.t
==============================================================================
--- dbi/trunk/t/80proxy.t       (original)
+++ dbi/trunk/t/80proxy.t       Wed Nov 14 15:32:55 2007
@@ -11,6 +11,7 @@
 require Cwd;
 
 my $haveFileSpec = eval { require File::Spec };
+my $failed_tests = 0;
 
 $| = 1;
 $^W = 1;
@@ -24,8 +25,10 @@
 
 eval {
     local $SIG{__WARN__} = sub { $@ = shift };
+    require Storable;
     require DBD::Proxy;
     require DBI::ProxyServer;
+    require RPC::PlServer;
     require Net::Daemon::Test;
 };
 if ($@) {
@@ -56,6 +59,7 @@
        ++$numTest;
        ($ok) ? print "ok $numTest at line $line\n" : print "not ok $numTest\n";
        warn "# failed test $numTest at line ".(caller)[2]."$msg\n" unless $ok;
+        ++$failed_tests unless $ok;
        return $ok;
     }
 }
@@ -70,16 +74,19 @@
  close(FILE))
     or die "Failed to create config file $config_file: $!";
 
-my($handle, $port);
-my $numTests = 131;
+my $debug = ($ENV{DBI_TRACE}||=0) ? 1 : 0;
+my $dbitracelog = "dbiproxy.dbilog";
+
+my ($handle, $port, @child_args);
+
+my $numTests = 139;
 
 if (@ARGV) {
     $port = $ARGV[0];
 }
 else {
 
-    # set DBI_TRACE to 0 to just get dbiproxy.log DBI trace for server
-    # set DBI_TRACE > 0 to also get DBD::Proxy trace
+    unlink $dbitracelog;
     unlink "dbiproxy.log";
     unlink "dbiproxy.truss";
 
@@ -92,22 +99,22 @@
     # pass our @INC to children (e.g., so -Mblib passes through)
     $ENV{PERL5LIB} = join($Config{path_sep}, @INC);
 
-    my $dbi_trace_level = DBI->trace(0);
-    my @child_args = (
+    # server DBI trace level always at least 1
+    my $dbitracelevel = DBI->trace(0) || 1;
+    @child_args = (
        #'truss', '-o', 'dbiproxy.truss',
        $^X, 'dbiproxy', '--test', # --test must be first command line arg
-       ($dbi_trace_level ? ('--dbitrace=dbiproxy.log') : ()),
+       "--dbitrace=$dbitracelevel=$dbitracelog", # must be second arg
        '--configfile', $config_file,
-       (($dbi_trace_level) ? ('--logfile=1') : ()),
+       ($dbitracelevel >= 2 ? ('--debug') : ()),
        '--mode=single',
-       '--debug',
+       '--logfile=STDERR',
        '--timeout=60'
     );
-    warn " starting test dbiproxy process: @child_args\n" if $dbi_trace_level;
+    warn " starting test dbiproxy process: @child_args\n" if DBI->trace(0);
     ($handle, $port) = Net::Daemon::Test->Child($numTests, @child_args);
 }
 
-my $debug = ($ENV{DBI_TRACE}) ? 1 : 0;
 my $dsn = 
"DBI:Proxy:hostname=127.0.0.1;port=$port;debug=$debug;dsn=DBI:ExampleP:";
 
 print "Making a first connection and closing it immediately.\n";
@@ -383,11 +390,12 @@
 
 
 # Test large recordsets
-for (my $i = 0;  $i < 300;  $i += 100) {
+for (my $i = 0;  $i <= 300;  $i += 100) {
     print "Testing the fake directories ($i).\n";
     Test($csr_a = $dbh->prepare("SELECT name, mode FROM long_list_$i"));
     Test($csr_a->execute(), $DBI::errstr);
     my $ary = $csr_a->fetchall_arrayref;
+    Test(!$DBI::errstr, $DBI::errstr);
     Test(@$ary == $i, "expected $i got "[EMAIL PROTECTED]);
     if ($i) {
         my @n1 = map { $_->[0] } @$ary;
@@ -441,16 +449,27 @@
 #  }
 #  Test(%tables == 0);
 
+if ($failed_tests) {
+    warn "Proxy: @child_args\n";
+    for my $class (qw(Net::Daemon RPC::PlServer Storable)) {
+        (my $pm = $class) =~ s/::/\//g; $pm .= ".pm";
+        my $version = eval { $class->VERSION } || '?';
+        warn sprintf "Using %-13s %-6s  %s\n", $class, $version, $INC{$pm};
+    }
+    warn join(", ", map { "$_=$ENV{$_}" } grep { /^LC_|LANG/ } keys %ENV)."\n";
+    warn "More info can be found in $dbitracelog\n";
+}
 
 
 END {
-    my $status = $?;
+    local $?;
     $handle->Terminate() if $handle;
     undef $handle;
-    my $f = $config_file;
-    undef $config_file;
-    unlink $f if $f;
-    $? = $status;
+    unlink $config_file if $config_file;
+    if (!$failed_tests) {
+        unlink 'dbiproxy.log';
+        unlink $dbitracelog if $dbitracelog;
+    }
 };
 
 1;