Author: timbo
Date: Tue Feb 6 04:31:23 2007
New Revision: 8803
Modified:
dbi/trunk/DBI.xs
dbi/trunk/lib/DBD/Gofer/Transport/null.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/t/02dbidrv.t
dbi/trunk/t/03handle.t
dbi/trunk/t/04mods.t
dbi/trunk/t/05thrclone.t
dbi/trunk/t/07kids.t
dbi/trunk/t/11fetch.t
dbi/trunk/t/14utf8.t
dbi/trunk/t/15array.t
dbi/trunk/t/40profile.t
dbi/trunk/t/41prof_dump.t
dbi/trunk/t/42prof_data.t
dbi/trunk/t/43prof_env.t
dbi/trunk/t/50dbm.t
dbi/trunk/t/65transact.t
dbi/trunk/t/72childhandles.t
dbi/trunk/t/85gofer.t
Log:
Fixed some compiler warnings on 64bit systems.
Changes to Gofer transport tracing.
Added $|=1 to tests that didn't have it.
Made t/50dbm.t more robust.
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue Feb 6 04:31:23 2007
@@ -1300,8 +1300,8 @@
if (DBIc_TYPE(imp_xxh) <= DBIt_DB) {
imp_dbh_t *imp_dbh = (imp_dbh_t*)imp_xxh; /* works for DRH also */
if (DBIc_CACHED_KIDS(imp_dbh)) {
- warn("DBI handle 0x%x cleared whilst still holding %d cached
kids",
- (unsigned)DBIc_MY_H(imp_xxh),
(int)HvKEYS(DBIc_CACHED_KIDS(imp_dbh)) );
+ warn("DBI handle 0x%lx cleared whilst still holding %d cached
kids",
+ (unsigned long)DBIc_MY_H(imp_xxh),
(int)HvKEYS(DBIc_CACHED_KIDS(imp_dbh)) );
SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh)); /* may recurse */
DBIc_CACHED_KIDS(imp_dbh) = Nullhv;
}
@@ -1312,20 +1312,20 @@
if (DBIc_TYPE(imp_xxh) >= DBIt_ST
|| (DBIc_ACTIVE_KIDS(imp_xxh) || !DBIc_has(imp_xxh,
DBIcf_AutoCommit))
) {
- warn("DBI handle 0x%x cleared whilst still active",
(unsigned)DBIc_MY_H(imp_xxh));
+ warn("DBI handle 0x%lx cleared whilst still active", (unsigned
long)DBIc_MY_H(imp_xxh));
dump = TRUE;
}
}
/* check that the implementor has done its own housekeeping */
if (DBIc_IMPSET(imp_xxh)) {
- warn("DBI handle 0x%x has uncleared implementors data",
(unsigned)DBIc_MY_H(imp_xxh));
+ warn("DBI handle 0x%lx has uncleared implementors data", (unsigned
long)DBIc_MY_H(imp_xxh));
dump = TRUE;
}
if (DBIc_KIDS(imp_xxh)) {
- warn("DBI handle 0x%x has %d uncleared child handles",
- (unsigned)DBIc_MY_H(imp_xxh), (int)DBIc_KIDS(imp_xxh));
+ warn("DBI handle 0x%lx has %d uncleared child handles",
+ (unsigned long)DBIc_MY_H(imp_xxh), (int)DBIc_KIDS(imp_xxh));
dump = TRUE;
}
}
@@ -2680,6 +2680,12 @@
if (imp_xxh && DBIc_TYPE(imp_xxh) <= DBIt_DB &&
DBIc_CACHED_KIDS((imp_drh_t*)imp_xxh))
clear_cached_kids(mg->mg_obj, imp_xxh, meth_name, trace_level);
if (trace_level >= 3)
+ /* XXX might be better to move this down to after call_depth
has been
+ * incremented and then also SvREFCNT_dec(mg->mg_obj) to force
an immediate
+ * DESTROY of the inner handle if there are no other refs to
it.
+ * That way the inner DESTROY is properly flagged as a nested
call,
+ * and the outer DESTROY gets profiled more accurately, and
callbacks work.
+ */
PerlIO_printf(DBILOGFP,
"%c <> DESTROY(%s) ignored for outer handle (inner %s has
ref cnt %ld)\n",
(dirty?'!':' '), neatsvpv(h,0), neatsvpv(mg->mg_obj,0),
@@ -2784,8 +2790,9 @@
}
XSRETURN(0); /* don't DESTROY handle, if it is not our's !*/
}
- croak("%s %s failed: handle %d is owned by thread %x not current thread
%x (%s)",
- HvNAME(DBIc_IMP_STASH(imp_xxh)), meth_name, DBIc_TYPE(imp_xxh),
(unsigned)h_perl, (unsigned)my_perl,
+ croak("%s %s failed: handle %d is owned by thread %lx not current
thread %lx (%s)",
+ HvNAME(DBIc_IMP_STASH(imp_xxh)), meth_name, DBIc_TYPE(imp_xxh),
+ (unsigned long)h_perl, (unsigned long)my_perl,
"handles can't be shared between threads and your driver may need a
CLONE method added");
}
}
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 Tue Feb 6 04:31:23 2007
@@ -34,13 +34,11 @@
# enabled for the 'client' because it gets very hard to follow.
# So control the Gofer 'server' side independently
# but similar logic as used for DBI_TRACE parsing.
- my $prev_trace_level = DBI->trace(
- ($ENV{DBD_GOFER_NULL_TRACE}) ? (split /=/, $ENV{DBD_GOFER_NULL_TRACE})
: (0)
- );
+ #my $prev_trace_level = DBI->trace( ($ENV{DBD_GOFER_NULL_TRACE}) ? (split
/=/, $ENV{DBD_GOFER_NULL_TRACE}) : (0));
my $response = execute_request( $self->thaw_data($frozen_request,1) );
- DBI->trace($prev_trace_level);
+ #DBI->trace($prev_trace_level);
# put response 'on the shelf' ready for receive_response()
$self->pending_response( $response );
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Tue Feb 6 04:31:23 2007
@@ -86,11 +86,12 @@
)],
);
-our $trace = $ENV{DBI_GOFER_TRACE};
-our $recurse = 0;
+# set trace for server-side gofer
+# Could use DBI_TRACE env var when it's a separate process
+# but using DBI_GOFER_TRACE makes testing easier (e.g., with null transport)
+DBI->trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE};
-# XXX tracing
sub _connect {
my $request = shift;
@@ -113,7 +114,7 @@
RaiseError => 1,
# ensure this connect_cached doesn't have the same args as the client
# because that causes subtle issues if in the same process (ie
transport=null)
- dbi_go_execute_unique => 42+$recurse+rand(),
+ dbi_go_execute_unique => rand(),
});
die "NOT CONNECTED" if $dbh and not $dbh->{Active};
#$dbh->trace(0);
@@ -153,8 +154,7 @@
sub execute_request {
my $request = shift;
- local $recurse = $recurse + 1;
- warn "Gofer request level $recurse\n" if $trace;
+ DBI->trace_msg("-----> execute_request\n");
my @warnings;
local $SIG{__WARN__} = sub { push @warnings, @_ };
# guaranteed not to throw an exception
@@ -169,8 +169,8 @@
err => 1, errstr => $@, state => '',
});
}
- #warn "Gofer response level $recurse: ".$response->rv."\n" if $trace;
$response->warnings([EMAIL PROTECTED]) if @warnings;
+ DBI->trace_msg("<----- execute_request\n");
return $response;
}
Modified: dbi/trunk/t/02dbidrv.t
==============================================================================
--- dbi/trunk/t/02dbidrv.t (original)
+++ dbi/trunk/t/02dbidrv.t Tue Feb 6 04:31:23 2007
@@ -1,5 +1,6 @@
#!perl -w
# vim:sw=4:ts=8
+$|=1;
use strict;
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
Modified: dbi/trunk/t/04mods.t
==============================================================================
--- dbi/trunk/t/04mods.t (original)
+++ dbi/trunk/t/04mods.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
Modified: dbi/trunk/t/05thrclone.t
==============================================================================
--- dbi/trunk/t/05thrclone.t (original)
+++ dbi/trunk/t/05thrclone.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
# --- Test DBI support for threads created after the DBI was loaded
Modified: dbi/trunk/t/07kids.t
==============================================================================
--- dbi/trunk/t/07kids.t (original)
+++ dbi/trunk/t/07kids.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
Modified: dbi/trunk/t/11fetch.t
==============================================================================
--- dbi/trunk/t/11fetch.t (original)
+++ dbi/trunk/t/11fetch.t Tue Feb 6 04:31:23 2007
@@ -1,5 +1,6 @@
#!perl -w
# vim:ts=8:sw=4
+$|=1;
use strict;
Modified: dbi/trunk/t/14utf8.t
==============================================================================
--- dbi/trunk/t/14utf8.t (original)
+++ dbi/trunk/t/14utf8.t Tue Feb 6 04:31:23 2007
@@ -1,5 +1,6 @@
#!perl -w
# vim:ts=8:sw=4
+$|=1;
use Test::More;
use DBI;
Modified: dbi/trunk/t/15array.t
==============================================================================
--- dbi/trunk/t/15array.t (original)
+++ dbi/trunk/t/15array.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
Modified: dbi/trunk/t/40profile.t
==============================================================================
--- dbi/trunk/t/40profile.t (original)
+++ dbi/trunk/t/40profile.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
#
# test script for DBI::Profile
Modified: dbi/trunk/t/41prof_dump.t
==============================================================================
--- dbi/trunk/t/41prof_dump.t (original)
+++ dbi/trunk/t/41prof_dump.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
Modified: dbi/trunk/t/42prof_data.t
==============================================================================
--- dbi/trunk/t/42prof_data.t (original)
+++ dbi/trunk/t/42prof_data.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
Modified: dbi/trunk/t/43prof_env.t
==============================================================================
--- dbi/trunk/t/43prof_env.t (original)
+++ dbi/trunk/t/43prof_env.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
Modified: dbi/trunk/t/50dbm.t
==============================================================================
--- dbi/trunk/t/50dbm.t (original)
+++ dbi/trunk/t/50dbm.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
use File::Path;
@@ -26,9 +27,9 @@
}
if ("@ARGV" eq "all") {
- # test with as many of the 5 major DBM types as are available
- for (qw( SDBM_File GDBM_File NDBM_File ODBM_File DB_File BerkeleyDB )){
- push @dbm_types, $_ if eval { require "$_.pm" };
+ # test with as many of the major DBM types as are available
+ for (qw( SDBM_File GDBM_File DB_File BerkeleyDB NDBM_File ODBM_File )) {
+ push @dbm_types, $_ if eval { local $^W; require "$_.pm" };
}
}
elsif (@ARGV) {
@@ -49,9 +50,9 @@
if (!$num_tests) {
plan skip_all => "No DBM modules available";
}
- else {
- plan tests => $num_tests;
- }
+ else {
+ plan tests => $num_tests;
+ }
}
my $dir = './test_output';
@@ -66,7 +67,8 @@
my @sql = split /\s*;\n/, $sql;
for my $dbm_type ( @dbm_types ) {
print "\n--- Using $dbm_type ($mldbm) ---\n";
- do_test( $dbm_type, [EMAIL PROTECTED], $mldbm );
+ eval { do_test( $dbm_type, [EMAIL PROTECTED], $mldbm ) }
+ or warn $@;
}
}
rmtree $dir;
@@ -75,13 +77,12 @@
my $dtype = shift;
my $stmts = shift;
my $mldbm = shift;
- $|=1;
# The DBI can't test locking here, sadly, because of the risk it'll hang
# on systems with broken NFS locking daemons.
# (This test script doesn't test that locking actually works anyway.)
- my $dsn
="dbi:DBM(RaiseError=1,PrintError=0):dbm_type=$dtype;mldbm=$mldbm;lockfile=0";
+ my $dsn
="dbi:DBM(RaiseError=0,PrintError=1):dbm_type=$dtype;mldbm=$mldbm;lockfile=0";
if ($using_dbd_gofer) {
$dsn .= ";f_dir=$dir";
@@ -116,6 +117,8 @@
#
eval {
local $SIG{__WARN__} = sub { } if $using_dbd_gofer;
+ local $dbh->{RaiseError} = 1;
+ local $dbh->{PrintError} = 0;
$dbh->{dbm_bad_name}=1;
};
ok($@);
@@ -150,6 +153,7 @@
is $DBI::rows, keys %$expected_results;
}
$dbh->disconnect;
+ return 1;
}
1;
__DATA__
Modified: dbi/trunk/t/65transact.t
==============================================================================
--- dbi/trunk/t/65transact.t (original)
+++ dbi/trunk/t/65transact.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
Modified: dbi/trunk/t/72childhandles.t
==============================================================================
--- dbi/trunk/t/72childhandles.t (original)
+++ dbi/trunk/t/72childhandles.t Tue Feb 6 04:31:23 2007
@@ -1,4 +1,5 @@
#!perl -w
+$|=1;
use strict;
Modified: dbi/trunk/t/85gofer.t
==============================================================================
--- dbi/trunk/t/85gofer.t (original)
+++ dbi/trunk/t/85gofer.t Tue Feb 6 04:31:23 2007
@@ -1,5 +1,6 @@
#!perl -w # -*- perl -*-
# vim:sw=4:ts=8
+$|=1;
use strict;
use warnings;
@@ -10,10 +11,13 @@
use lib "/Users/timbo/dbi/trunk/lib";
+# so users can try others from the command line
+my $dbm = $ARGV[0] || "SDBM_File";
+
# use DBD::Gofer directly.
# when combined with DBI_AUTOPROXY this means we have DBD::Gofer => DBD::Gofer
=> DBD::DBM!
#
-my $dsn = "dbi:Gofer:transport=null;dsn=dbi:DBM:dbm_type=SDBM_File;lockfile=0";
+my $dsn = "dbi:Gofer:transport=null;dsn=dbi:DBM:dbm_type=$dbm;lockfile=0";
my $dbh = DBI->connect($dsn);
ok $dbh, 'should connect';
