Author: timbo
Date: Tue Jan 23 15:42:34 2007
New Revision: 8686
Added:
dbi/trunk/lib/DBD/Forward/
dbi/trunk/lib/DBD/Forward/Transport/
dbi/trunk/lib/DBD/Forward/Transport/Base.pm
dbi/trunk/lib/DBD/Forward/Transport/null.pm
dbi/trunk/t/12quote.t
dbi/trunk/t/13taint.t
Removed:
dbi/trunk/lib/DBI/Forward/Transport/null.pm
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/MANIFEST
dbi/trunk/lib/DBD/ExampleP.pm
dbi/trunk/lib/DBD/Forward.pm
dbi/trunk/lib/DBD/NullP.pm
dbi/trunk/lib/DBI/DBD.pm
dbi/trunk/lib/DBI/Forward/Execute.pm
dbi/trunk/lib/DBI/Forward/Transport/Base.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/03handle.t
dbi/trunk/t/08keeperr.t
dbi/trunk/t/09trace.t
dbi/trunk/t/10examp.t
dbi/trunk/t/40profile.t
dbi/trunk/t/42prof_data.t
dbi/trunk/t/50dbm.t
dbi/trunk/t/72childhandles.t
Log:
Next big chunk of DBD::Forward development.
All tests pass undef DBD::Forward except t/10example.t
Also t/05thrclone reports leaked scalars under threaded perl.
Other changes:
+ Fixed rare error when profiling access to $DBI::err etc tied variables.
+ Changed setting trace file to no longer write "Trace file set" to new file.
+ Changed 'handle cleared whilst still active' warning for dbh
+ to only be given for dbh that have active sth or are not AutoCommit.
+ Changed take_imp_data to call finish on any Active child sth.
+ Added new DBD::Forward 'stateless proxy' driver and framework,
+ and the DBI test suite is now also executed via DBD::Forward.
+ Added ability for drivers to implement func() method
+ so proxy drivers can proxy the func method itself.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue Jan 23 15:42:34 2007
@@ -14,11 +14,23 @@
Fixed to compile for perl built with -DNO_MATHOMS thanks to Jerry D. Hedden.
Fixed to work for bleadperl (r29544) thanks to Nicholas Clark.
Users of Perl >= 5.9.5 will require DBI >= 1.54.
- Changed t/40profile.t to skip tests for perl < 5.8.0.
- Updated DBI::DBD docs for driver authors thanks to Ammon Riley.
+ Fixed rare error when profiling access to $DBI::err etc tied variables.
+ Changed t/40profile.t to skip tests for perl < 5.8.0.
+ Changed setting trace file to no longer write "Trace file set" to new file.
+ Changed 'handle cleared whilst still active' warning for dbh
+ to only be given for dbh that have active sth or are not AutoCommit.
+ Changed take_imp_data to call finish on any Active child sth.
+ Updated DBI::DBD docs for driver authors thanks to Ammon Riley
+ and Dean Arnold.
+
+ Added new DBD::Forward 'stateless proxy' driver and framework,
+ and the DBI test suite is now also executed via DBD::Forward.
+ Added ability for drivers to implement func() method
+ so proxy drivers can proxy the func method itself.
Added SQL_BIGINT type code (resolved to the ODBC/JDBC value (-5))
- Updated trace to support filehandle argument.
+ Added ability for trace() to support filehandle argument,
+ including tracing into a string, thanks to Dean Arnold.
=head2 Changes in DBI 1.53 (svn rev 7995), 31st October 2006
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Tue Jan 23 15:42:34 2007
@@ -577,8 +577,9 @@
my $proxy = 'Proxy';
if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) {
$proxy = $1;
- my $attr_spec = $2 || '';
- $driver_attrib_spec = ($driver_attrib_spec) ?
"$driver_attrib_spec,$attr_spec" : $attr_spec;
+ $driver_attrib_spec = join ",",
+ ($driver_attrib_spec) ? $driver_attrib_spec : (),
+ ($2 ) ? $2 : ();
}
$dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn";
$driver = $proxy;
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue Jan 23 15:42:34 2007
@@ -673,7 +673,6 @@
close_trace_file();
}
DBILOGFP = fp;
- PerlIO_printf(DBILOGFP," Trace file set\n");
/* if this line causes your compiler or linker to choke */
/* then just comment it out, it's not essential. */
PerlIO_setlinebuf(fp); /* force line buffered output */
@@ -1297,9 +1296,14 @@
}
}
- if (DBIc_ACTIVE(imp_xxh)) { /* bad news */
- warn("DBI handle 0x%x cleared whilst still active",
(unsigned)DBIc_MY_H(imp_xxh));
- dump = TRUE;
+ if (DBIc_ACTIVE(imp_xxh)) { /* bad news, potentially */
+ /* warn for sth, warn for dbh only if it has active sth or isn't
AutoCommit */
+ 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));
+ dump = TRUE;
+ }
}
/* check that the implementor has done its own housekeeping */
@@ -1697,8 +1701,19 @@
}
else if (htype==DBIt_ST && strEQ(key, "NUM_OF_FIELDS")) {
D_imp_sth(h);
- if (DBIc_NUM_FIELDS(imp_sth) > 0) /* don't change NUM_FIELDS! */
- croak("NUM_OF_FIELDS already set to %d", DBIc_NUM_FIELDS(imp_sth));
+ if (DBIc_NUM_FIELDS(imp_sth) > 0 /* don't change NUM_FIELDS! */
+ && DBIc_ACTIVE(imp_sth) /* if sth is Active */
+ ) {
+ croak("Can't change NUM_OF_FIELDS (already set to %d)",
DBIc_NUM_FIELDS(imp_sth));
+ }
+ if (DBIc_NUM_FIELDS(imp_sth) > 0
+ && SvIV(valuesv) != DBIc_NUM_FIELDS(imp_sth)
+ && DBIc_TRACE_LEVEL(imp_sth)
+ && DBIc_FIELDS_AV(imp_sth)
+ ) {
+ PerlIO_printf(DBILOGFP,"Warning: changing NUM_OF_FIELDS (from %d
to %d) after row buffer already allocated",
+ SvIV(valuesv), DBIc_NUM_FIELDS(imp_sth));
+ }
DBIc_NUM_FIELDS(imp_sth) = SvIV(valuesv);
cacheit = 1;
}
@@ -2301,7 +2316,6 @@
return;
h_hv = (HV*)SvRV(dbih_inner(h, "dbi_profile"));
- /*h_hv = (SvROK(h)) ? (HV*)SvRV(h) : (HV*)h; */
profile = *hv_fetch(h_hv, "Profile", 7, 1);
if (profile && SvMAGICAL(profile))
@@ -2322,9 +2336,9 @@
statement_pv = SvPV_nolen(statement_sv);
if (DBIc_DBISTATE(imp_xxh)->debug >= 4)
- PerlIO_printf(DBIc_LOGPIO(imp_xxh), "dbi_profile %s %f q{%s}\n",
- neatsvpv((SvTYPE(method)==SVt_PVCV) ? (SV*)CvGV(method) :
method, 0),
- ti, neatsvpv(statement_sv,0));
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh), " dbi_profile %s %fs %s\n",
+ neatsvpv((SvTYPE(method)==SVt_PVCV) ? (SV*)CvGV(method) : method,
0),
+ ti, neatsvpv(statement_sv,0));
dest_node = _profile_next_node(profile, "Data");
@@ -2953,6 +2967,18 @@
imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh),
meth_name, FALSE);
+ /* if method was a 'func' then try falling back to real 'func' method
*/
+ if (!imp_msv && (ima_flags & IMA_FUNC_REDIRECT)) {
+ imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh),
"func", FALSE);
+ if (imp_msv) {
+ /* driver does have func method so undo the earlier 'func'
stack changes */
+ PUSHs(sv_2mortal(newSVpv(meth_name,0)));
+ PUTBACK;
+ ++items;
+ meth_name = "func";
+ }
+ }
+
if (trace_level >= 2) {
PerlIO *logfp = DBILOGFP;
/* Full pkg method name (or just meth_name for ANON CODE) */
@@ -4110,8 +4136,10 @@
}
if (trace)
PerlIO_printf(DBILOGFP," <- $DBI::%s= %s\n", meth,
neatsvpv(ST(0),0));
- if (profile_t1)
- dbi_profile(DBI_LAST_HANDLE, imp_xxh, &sv_undef, (SV*)cv, profile_t1,
dbi_time());
+ if (profile_t1) {
+ SV *h = sv_2mortal(newRV(DBI_LAST_HANDLE));
+ dbi_profile(h, imp_xxh, &sv_undef, (SV*)cv, profile_t1, dbi_time());
+ }
MODULE = DBI PACKAGE = DBD::_::db
@@ -4148,8 +4176,8 @@
*
* If the drivers imp_xxh_t structure contains SV*'s, or other interpreter
* specific items, they should be freed by the drivers own take_imp_data()
- * method. The drivers take_imp_data() method (or Driver.xst code) can
then call
- * SUPER::take_imp_data() to finalize the removal of the imp_xxh_t
structure.
+ * method before it then calls SUPER::take_imp_data() to finalize removal
+ * of the imp_xxh_t structure.
*
* The driver needs to view the take_imp_data method as being nearly the
* same as disconnect+DESTROY only not actually calling the database API to
@@ -4158,9 +4186,8 @@
* in a 'clean' state such that if the drivers own DESTROY method was
* called it would be able to properly handle the contents of the
* structure. This is important in case a new handle created using this
- * imp_data, possibly in a new thread, might end up being DESTROY's before
- * the driver has had a chance to 're-setup' the data. See
- * dbih_setup_handle()
+ * imp_data, possibly in a new thread, might end up being DESTROY'd before
+ * the driver has had a chance to 're-setup' the data. See
dbih_setup_handle()
*
* All the above relates to the 'typical use case' for a compiled driver.
* For a pure-perl driver using a socket pair, for example, the drivers
@@ -4182,7 +4209,7 @@
/* Ideally there should be no child statement handles existing when
* take_imp_data is called because when those statement handles are
* destroyed they may need to interact with the 'zombie' parent dbh.
- * So we do our best to kill neautralize them.
+ * So we do our best to neautralize them (finish & rebless)
*/
if (DBIc_TYPE(imp_xxh) <= DBIt_DB && DBIc_CACHED_KIDS((imp_dbh_t*)imp_xxh))
clear_cached_kids(h, imp_xxh, "take_imp_data", 0);
@@ -4193,6 +4220,12 @@
for (kidslots = AvFILL(av); kidslots >= 0; --kidslots) {
SV **hp = av_fetch(av, kidslots, FALSE);
if (hp && SvROK(*hp) && SvMAGICAL(SvRV(*hp))) {
+ PUSHMARK(sp);
+ XPUSHs(*hp);
+ PUTBACK;
+ perl_call_method("finish", G_SCALAR|G_DISCARD);
+ SPAGAIN;
+ PUTBACK;
sv_unmagic(SvRV(*hp), 'P'); /* untie */
sv_bless(*hp, zombie_stash); /* neutralise */
}
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Tue Jan 23 15:42:34 2007
@@ -10,8 +10,8 @@
Perl.xs Test harness (currently) for Driver.xst
README
Roadmap.pod Planned changes and enhancements for the DBI
-TODO_2005.txt Old (but still mostly relevant) occasional
random notes about what's missing
TASKS.pod Want to help? These things need doing...
+TODO_2005.txt Old (but still mostly relevant) occasional
random notes about what's missing
dbd_xsh.h Prototypes for standard Driver.xst interface
dbi_sql.h Definitions based on SQL CLI / ODBC (#inc'd by
DBIXS.h)
dbipport.h Perl portability macros (from Devel::PPort)
@@ -24,6 +24,9 @@
lib/DBD/DBM.pm A driver for DBM files (uses DBD::File)
lib/DBD/ExampleP.pm A very simple example Driver module
lib/DBD/File.pm A driver base class for simple drivers
+lib/DBD/Forward.pm DBD::Forward 'stateless proxy' driver
+lib/DBD/Forward/Transport/Base.pm Base class for DBD::Forward driver transport
classes
+lib/DBD/Forward/Transport/null.pm DBD::Forward transport that executes locally
(for testing)
lib/DBD/NullP.pm An empty example Driver module
lib/DBD/Proxy.pm Proxy driver
lib/DBD/Sponge.pm A driver for fake cursors (precached data)
@@ -34,6 +37,10 @@
lib/DBI/DBD.pm Some basic help for people writing DBI drivers
lib/DBI/DBD/Metadata.pm Metadata tools for people writing DBI
drivers
lib/DBI/FAQ.pm The DBI FAQ in module form for perldoc
+lib/DBI/Forward/Execute.pm Execution logic for DBD::Forward server
+lib/DBI/Forward/Request.pm Request object from DBD::Forward
+lib/DBI/Forward/Response.pm Response object for DBD::Forward
+lib/DBI/Forward/Transport/Base.pm Base class for DBD::Forward server transport
classes
lib/DBI/Profile.pm Manage DBI usage profile data
lib/DBI/ProfileData.pm
lib/DBI/ProfileDumper.pm
@@ -55,6 +62,8 @@
t/09trace.t
t/10examp.t
t/11fetch.t
+t/12quote.t
+t/13taint.t
t/14utf8.t
t/15array.t
t/19fhtrace.t
@@ -69,6 +78,7 @@
t/70callbacks.t
t/72childhandles.t
t/80proxy.t
+t/85forward.t
t/pod.t
test.pl Assorted informal tests, including tests for
memory leaks
typemap
Modified: dbi/trunk/lib/DBD/ExampleP.pm
==============================================================================
--- dbi/trunk/lib/DBD/ExampleP.pm (original)
+++ dbi/trunk/lib/DBD/ExampleP.pm Tue Jan 23 15:42:34 2007
@@ -60,7 +60,11 @@
my($drh, $dbname, $user, $auth)= @_;
my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dbname });
$dbh->STORE('Active', 1);
- $dbh->{examplep_get_info} = {};
+ $dbh->{examplep_get_info} = {
+ 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR
+ 41 => '.', # SQL_CATALOG_NAME_SEPARATOR
+ 114 => 1, # SQL_CATALOG_LOCATION
+ };
$dbh->{Name} = $dbname;
return $outer;
}
@@ -329,8 +333,6 @@
sub fetch {
my $sth = shift;
- my $dh = $sth->{dbd_datahandle}
- or return $sth->set_err(1, "fetch without successful execute");
my $dir = $sth->{dbd_dir};
my %s;
@@ -346,6 +348,8 @@
$time, $time, $time, 512, 2, "file$num")
}
else { # normal mode
+ my $dh = $sth->{dbd_datahandle}
+ or return $sth->set_err(1, "fetch without successful execute");
my $f = readdir($dh);
unless ($f) {
$sth->finish;
@@ -409,7 +413,7 @@
sub DESTROY {
my $sth = shift;
- $sth->finish if $sth->SUPER::FETCH('Active');
+ #$sth->finish if $sth->SUPER::FETCH('Active');
}
*parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag;
Modified: dbi/trunk/lib/DBD/Forward.pm
==============================================================================
--- dbi/trunk/lib/DBD/Forward.pm (original)
+++ dbi/trunk/lib/DBD/Forward.pm Tue Jan 23 15:42:34 2007
@@ -17,10 +17,13 @@
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the Perl README file.
+# XXX track installed_methods and install proxies on client side after connect?
+
# attributes we'll allow local STORE
our %xxh_local_store_attrib = map { $_=>1 } qw(
Active
CachedKids
+ Callbacks
ErrCount Executed
FetchHashKeyName
HandleError HandleSetErr
@@ -28,11 +31,13 @@
PrintError PrintWarn
Profile
RaiseError
+ RootClass
ShowErrorStatement
Taint TaintIn TaintOut
TraceLevel
Warn
dbi_connect_closure
+ dbi_quote_identifier_cache
);
our $drh = undef; # holds driver handle once initialised
@@ -100,7 +105,7 @@
my $transport_class = $dsn_attr{fwd_transport}
or return $drh->set_err(1, "No transport= argument in
'$orig_dsn'");
- $transport_class = "DBI::Forward::Transport::$dsn_attr{fwd_transport}"
+ $transport_class = "DBD::Forward::Transport::$dsn_attr{fwd_transport}"
unless $transport_class =~ /::/;
eval "require $transport_class"
or return $drh->set_err(1, "Error loading $transport_class: $@");
@@ -122,8 +127,17 @@
fwd_request => $fwd_request,
});
- # store and delete the attributes before marking connection Active
- $dbh->STORE($_ => delete $attr->{$_}) for keys %$attr;
+ $dbh->STORE(Active => 0); # mark as inactive temporarily for STORE
+
+ # Store and delete the attributes before marking connection Active
+ # Leave RaiseError & PrintError in %$attr so DBI's connect can
+ # act on them if the connect fails
+ $dbh->STORE($_ => delete $attr->{$_})
+ for grep { !m/^(RaiseError|PrintError)$/ } keys %$attr;
+
+ # test the connection XXX control via a policy later
+ $dbh->fwd_dbh_method('ping', undef)
+ or return;
$dbh->STORE(Active => 1);
@@ -149,7 +163,11 @@
my $transport = $dbh->{fwd_trans}
or return $dbh->set_err(1, "Not connected (no transport)");
- my $response = $transport->execute($request);
+
+ eval { $transport->transmit_request($request) }
+ or return $dbh->set_err(1, "transmit_request failed: $@");
+
+ my $response = $transport->receive_response;
$dbh->{fwd_response} = $response;
@@ -162,9 +180,11 @@
# Methods that should be forwarded
# XXX get_info? special sub to lazy-cache individual values
for my $method (qw(
- do data_sources
+ data_sources
table_info column_info primary_key_info foreign_key_info
statistics_info
type_info_all get_info
+ parse_trace_flags parse_trace_flag
+ func
)) {
no strict 'refs';
*$method = sub { return shift->fwd_dbh_method($method, undef, @_) }
@@ -181,6 +201,13 @@
# for quote we rely on the default method + type_info_all
# for quote_identifier we rely on the default method + get_info
+ sub do {
+ my $dbh = shift;
+ delete $dbh->{Statement}; # avoid "Modification of non-creatable hash
value attempted"
+ $dbh->{Statement} = $_[0]; # for profiling and ShowErrorStatement
+ return $dbh->fwd_dbh_method('do', undef, @_);
+ }
+
sub ping {
my $dbh = shift;
# XXX local or remote - add policy attribute
@@ -197,8 +224,15 @@
sub FETCH {
my ($dbh, $attrib) = @_;
- # AutoCommit needs special handling
- return 1 if $attrib eq 'AutoCommit';
+ return 1 if $attrib eq 'AutoCommit'; # AutoCommit needs special handling
+
+ # forward driver-private attributes
+ if ($attrib =~ m/^[a-z]/) { # XXX policy? precache on connect?
+ my $value = $dbh->fwd_dbh_method('FETCH', undef, $attrib);
+ $dbh->{$attrib} = $value;
+ return $value;
+ }
+
# else pass up to DBI to handle
return $dbh->SUPER::FETCH($attrib);
}
@@ -206,7 +240,7 @@
sub STORE {
my ($dbh, $attrib, $value) = @_;
if ($attrib eq 'AutoCommit') {
- return 1 if $value;
+ return $dbh->SUPER::STORE($attrib => -901) if $value;
croak "Can't enable transactions when using DBD::Forward";
}
return $dbh->SUPER::STORE($attrib => $value)
@@ -286,7 +320,13 @@
$request->sth_method_calls($sth->{fwd_method_calls});
$request->sth_result_attr({});
- my $response = $sth->{fwd_trans}->execute($request);
+ my $transport = $sth->{fwd_trans}
+ or return $sth->set_err(1, "Not connected (no transport)");
+
+ eval { $transport->transmit_request($request) }
+ or return $sth->set_err(1, "transmit_request failed: $@");
+
+ my $response = $transport->receive_response;
$sth->{fwd_response} = $response;
$sth->{fwd_method_calls} = [];
@@ -296,6 +336,7 @@
$sth->more_results;
}
+ # set error/warn/info (after more_results as that'll clear err)
$sth->set_err($response->err, $response->errstr, $response->state);
return $response->rv;
@@ -324,7 +365,8 @@
if ($NUM_OF_FIELDS > 0) {
$sth->{fwd_current_rowset} = $rowset;
- $sth->{fwd_current_rowset_err} = [ $err, $errstr, $state ] if $err;
+ $sth->{fwd_current_rowset_err} = [ $err, $errstr, $state ]
+ if defined $err;
$sth->STORE(Active => 1) if $rowset;
}
@@ -336,13 +378,19 @@
my ($sth) = @_;
my $resultset = $sth->{fwd_current_rowset}
or return $sth->set_err( @{ $sth->{fwd_current_rowset_err} } );
- return shift @$resultset if @$resultset;
+ return $sth->_set_fbav(shift @$resultset) if @$resultset;
$sth->finish; # no more data so finish
return undef;
}
*fetch = \&fetchrow_arrayref; # alias
- # XXX fetchall_arrayref - for speed
+ sub fetchall_arrayref {
+ my ($sth) = @_;
+ my $resultset = $sth->{fwd_current_rowset}
+ or return $sth->set_err( @{ $sth->{fwd_current_rowset_err} } );
+ $sth->finish; # no more data so finish
+ return $resultset;
+ }
sub rows {
my $sth = shift;
@@ -358,9 +406,9 @@
or $attrib =~ m/^[a-z]/; # driver-private
# ignore values that aren't actually being changed
- my $prev = $sth->FETCH($attrib);
- return 1 if !defined $value && !defined $prev
- or defined $value && defined $prev && $value eq $prev;
+ #my $prev = $sth->FETCH($attrib);
+ #return 1 if !defined $value && !defined $prev
+ # or defined $value && defined $prev && $value eq $prev;
# sth attributes are set at connect-time - see connect()
Carp::carp("Can't alter \$sth->{$attrib}");
Added: dbi/trunk/lib/DBD/Forward/Transport/Base.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Forward/Transport/Base.pm Tue Jan 23 15:42:34 2007
@@ -0,0 +1,39 @@
+package DBD::Forward::Transport::Base;
+
+use strict;
+use warnings;
+
+use Storable qw(freeze thaw);
+
+use base qw(Class::Accessor::Fast);
+
+our $debug = $ENV{DBD_FORWARD_DEBUG} || 0;
+
+
+__PACKAGE__->mk_accessors(qw(
+ fwd_dsn
+));
+
+
+sub freeze_data {
+ my ($self, $data) = @_;
+ $self->_dump(ref($data), $data) if $debug;
+ return freeze($data);
+}
+
+sub thaw_data {
+ my ($self, $frozen_data) = @_;
+ my $data = thaw($frozen_data);
+ $self->_dump(ref($data), $data) if $debug;
+ return $data;
+}
+
+
+sub _dump {
+ my ($self, $label, $data) = @_;
+ require Data::Dumper;
+ warn "$label=".Dumper($data);
+
+}
+
+1;
Added: dbi/trunk/lib/DBD/Forward/Transport/null.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Forward/Transport/null.pm Tue Jan 23 15:42:34 2007
@@ -0,0 +1,48 @@
+package DBD::Forward::Transport::null;
+
+use strict;
+use warnings;
+
+use base qw(DBD::Forward::Transport::Base);
+
+use DBI::Forward::Execute qw(execute_request);
+
+__PACKAGE__->mk_accessors(qw(
+ fwd_pending_response
+));
+
+
+sub transmit_request {
+ my ($self, $request) = @_;
+
+ my $frozen_request = $self->freeze_data($request);
+
+ # ...
+ # the request is magically transported over to ... ourselves
+ # ...
+
+ my $response = execute_request( $self->thaw_data($frozen_request) );
+
+ # put response 'on the shelf' ready for receive_response()
+ $self->fwd_pending_response( $response );
+
+ return 1;
+}
+
+
+sub receive_response {
+ my $self = shift;
+
+ my $response = $self->fwd_pending_response;
+
+ my $frozen_response = $self->freeze_data($response);
+
+ # ...
+ # the response is magically transported back to ... ourselves
+ # ...
+
+ return $self->thaw_data($frozen_response);
+}
+
+
+1;
Modified: dbi/trunk/lib/DBD/NullP.pm
==============================================================================
--- dbi/trunk/lib/DBD/NullP.pm (original)
+++ dbi/trunk/lib/DBD/NullP.pm Tue Jan 23 15:42:34 2007
@@ -79,6 +79,8 @@
return $dbh->SUPER::STORE($attrib, $value);
}
+ sub ping { 1 }
+
sub disconnect {
shift->STORE(Active => 0);
}
Modified: dbi/trunk/lib/DBI/DBD.pm
==============================================================================
--- dbi/trunk/lib/DBI/DBD.pm (original)
+++ dbi/trunk/lib/DBI/DBD.pm Tue Jan 23 15:42:34 2007
@@ -3002,6 +3002,9 @@
pp => { name => "DBI::PurePerl",
add => [ 'local $ENV{DBI_PUREPERL} = 2;' ],
},
+ fw => { name => "DBD::Forward",
+ add => [ q{local $ENV{DBI_AUTOPROXY} =
'dbi:Forward:transport=null';} ],
+ },
mx => { name => "DBD::Multiplex",
add => [ q{local $ENV{DBI_AUTOPROXY} =
'dbi:Multiplex:';} ],
}
Modified: dbi/trunk/lib/DBI/Forward/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Forward/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Forward/Execute.pm Tue Jan 23 15:42:34 2007
@@ -41,15 +41,36 @@
PrintError => 0,
RaiseError => 1,
});
- #$dbh->trace(1);
+ #$dbh->trace(0);
return $dbh;
}
+
sub _reset_dbh {
my ($dbh) = @_;
- $dbh->trace(0, \*STDERR);
+ $dbh->set_err(undef, undef); # clear any error state
+ #$dbh->trace(0, \*STDERR);
+}
+
+
+sub _new_response_with_err {
+ my ($rv) = @_;
+
+ my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state);
+ if ($@ and !$errstr || $@ !~ /^DBD::/) {
+ $err ||= 1;
+ $errstr = ($errstr) ? "$errstr; $@" : $@;
+ }
+ my $response = DBI::Forward::Response->new({
+ rv => $rv,
+ err => $err,
+ errstr => $errstr,
+ state => $state,
+ });
+ return $response;
}
+
sub execute_request {
my $request = shift;
my $response = eval {
@@ -78,18 +99,16 @@
: scalar $dbh->$meth(@$args);
[EMAIL PROTECTED];
};
- my $response = DBI::Forward::Response->new({
- rv => $rv,
- err => $DBI::err,
- errstr => $DBI::errstr,
- state => $DBI::state,
- });
- $response->last_insert_id = $dbh->last_insert_id( @{
$request->dbh_last_insert_id_args })
- if $dbh && $rv && $request->dbh_last_insert_id_args;
- _reset_dbh($dbh);
+ my $response = _new_response_with_err($rv);
+ if ($dbh) {
+ $response->last_insert_id = $dbh->last_insert_id( @{
$request->dbh_last_insert_id_args })
+ if $rv && $request->dbh_last_insert_id_args;
+ _reset_dbh($dbh);
+ }
return $response;
}
+
sub execute_sth_request {
my $request = shift;
my $dbh;
@@ -109,15 +128,10 @@
$sth->execute();
};
- my $response = DBI::Forward::Response->new({
- rv => $rv,
- err => $DBI::err,
- errstr => $DBI::errstr,
- state => $DBI::state,
- });
+ my $response = _new_response_with_err($rv);
# even if the eval failed we still want to gather attribute values
- my $resultset_list = eval {
+ my $resultset_list = $sth && eval {
my $attr_list = $request->sth_result_attr;
$attr_list = [ keys %$attr_list ] if ref $attr_list eq 'HASH';
my $rs_list = [];
@@ -133,11 +147,12 @@
# XXX would be nice to be able to support streaming of results
# which would reduce memory usage and latency for large results
- _reset_dbh($dbh);
+ _reset_dbh($dbh) if $dbh;
return $response;
}
+
sub fetch_result_set {
my ($sth, $extra_attr) = @_;
my %meta;
Modified: dbi/trunk/lib/DBI/Forward/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBI/Forward/Transport/Base.pm (original)
+++ dbi/trunk/lib/DBI/Forward/Transport/Base.pm Tue Jan 23 15:42:34 2007
@@ -1,4 +1,4 @@
-package DBI::Forward::Transport::Base;
+package DBD::Forward::Transport::Base;
use strict;
use warnings;
@@ -7,14 +7,32 @@
use base qw(Class::Accessor::Fast);
+our $debug = $ENV{DBD_FORWARD_DEBUG} || 0;
+
+
__PACKAGE__->mk_accessors(qw(
fwd_dsn
));
-sub execute {
- my ($self, $request) = @_;
- die ref($self)." has not implemented a transport method";
+
+sub freeze_data {
+ my ($self, $data) = @_;
+ $self->_dump(ref($data), $data) if $debug;
+ return freeze($data);
+}
+
+sub thaw_data {
+ my ($self, $frozen_data) = @_;
+ my $data = thaw($frozen_data);
+ $self->_dump(ref($data), $data) if $debug;
+ return $data;
}
+sub _dump {
+ my ($self, $label, $data) = @_;
+ require Data::Dumper;
+ warn "$label=".Dumper($request);
+}
+
1;
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Tue Jan 23 15:42:34 2007
@@ -232,7 +232,6 @@
if IMA_STUB & $bitmask;
push @pre_call_frag, q{
- #$method_name = $imp . '::' . pop @_;
$method_name = pop @_;
} if IMA_FUNC_REDIRECT & $bitmask;
@@ -398,6 +397,9 @@
my @ret;
my $sub = $imp->can($method_name);
+ if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub =
$imp->can('func')) {
+ push @_, $method_name;
+ }
if ($sub) {
(wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_));
}
@@ -405,7 +407,7 @@
# XXX could try explicit fallback to $imp->can('AUTOLOAD') etc
# which would then let Multiplex pass PurePerl tests, but some
# hook into install_method may be better.
- croak "Can't find DBI method $method_name for $h (via $imp)"
+ croak "Can't locate DBI object method \"$method_name\" via package
\"$imp\""
if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[;
}
@@ -475,6 +477,7 @@
$h_inner->{FetchHashKeyName} ||= 'NAME';
$h_inner->{LongReadLen} ||= 80;
$h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN;
+ $h_inner->{Type} ||= 'dr';
}
$h_inner->{"_call_depth"} = 0;
$h_inner->{ErrCount} = 0;
@@ -674,15 +677,15 @@
sub FETCH {
my($h,$key)= @_;
my $v = $h->{$key};
-#warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n");
+ #warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n");
return $v if defined $v;
if ($key =~ /^NAME_.c$/) {
my $cols = $h->FETCH('NAME');
return undef unless $cols;
my @lcols = map { lc $_ } @$cols;
- $h->STORE('NAME_lc', [EMAIL PROTECTED]);
+ $h->{NAME_lc} = [EMAIL PROTECTED];
my @ucols = map { uc $_ } @$cols;
- $h->STORE('NAME_uc',[EMAIL PROTECTED]);
+ $h->{NAME_uc} = [EMAIL PROTECTED];
return $h->FETCH($key);
}
if ($key =~ /^NAME.*_hash$/) {
@@ -704,7 +707,7 @@
return "dr" if $h->isa('DBI::dr');
return "db" if $h->isa('DBI::db');
return "st" if $h->isa('DBI::st');
- Carp::carp( sprintf "Can't get determine Type for %s",$h );
+ Carp::carp( sprintf "Can't determine Type for %s",$h );
}
if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) {
local $^W; # hide undef warnings
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Tue Jan 23 15:42:34 2007
@@ -120,7 +120,7 @@
ok($sth4->execute("."), '... fourth statement handle executed
properly');
ok($sth4->{Active}, '... fourth statement handle is Active');
-
+
my $sth5 = $dbh->prepare_cached($sql, undef, 1);
isa_ok($sth5, 'DBI::st');
Modified: dbi/trunk/t/08keeperr.t
==============================================================================
--- dbi/trunk/t/08keeperr.t (original)
+++ dbi/trunk/t/08keeperr.t Tue Jan 23 15:42:34 2007
@@ -36,7 +36,7 @@
my $sth = shift;
# we localize an attribute here to check that the correpoding STORE
# at scope exit doesn't clear any recorded error
- local $sth->{CompatMode} = 0;
+ local $sth->{dbd_dummy} = 0;
my $rv = $sth->SUPER::execute(@_);
return $rv;
}
@@ -62,15 +62,15 @@
}
my $err1 = test_select( My::DBI->connect(@con_info) );
-Test::More::like($err1, qr/^DBD::(ExampleP|Multiplex)::db selectrow_arrayref
failed: opendir/, '... checking error');
+Test::More::like($err1, qr/^DBD::(ExampleP|Multiplex|Forward)::db
selectrow_arrayref failed: opendir/, '... checking error');
my $err2 = test_select( DBI->connect(@con_info) );
-Test::More::like($err2, qr/^DBD::(ExampleP|Multiplex)::db selectrow_arrayref
failed: opendir/, '... checking error');
+Test::More::like($err2, qr/^DBD::(ExampleP|Multiplex|Forward)::db
selectrow_arrayref failed: opendir/, '... checking error');
package main;
## ----------------------------------------------------------------------------
-# test HandleSetErr
+print "Test HandleSetErr\n";
my $dbh = DBI->connect(@con_info);
isa_ok($dbh, "DBI::db");
@@ -84,7 +84,7 @@
my @handlewarn = (0,0,0);
$SIG{__WARN__} = sub {
my $msg = shift;
- if ($msg =~ /^DBD::ExampleP::\S+\s+(\S+)\s+(\w+)/) {
+ if ($msg =~ /^DBD::\w+::\S+\s+(\S+)\s+(\w+)/) {
++$warn{$2};
$msg =~ s/\n/\\n/g;
print "warn: '$msg'\n";
@@ -261,5 +261,7 @@
is($dbh->errstr, "errstr99", '... $dbh->errstr is as we expected');
is($dbh->state, "OV123", '... $dbh->state is as we expected');
+$dbh->disconnect;
+
1;
# end
Modified: dbi/trunk/t/09trace.t
==============================================================================
--- dbi/trunk/t/09trace.t (original)
+++ dbi/trunk/t/09trace.t Tue Jan 23 15:42:34 2007
@@ -94,7 +94,7 @@
ok $dbh->{TraceLevel};
{
- print "unknown parse_trace_flag\n";
+ print "test unknown parse_trace_flag\n";
my $warn = 0;
local $SIG{__WARN__} = sub {
if ($_[0] =~ /unknown/i) { ++$warn; print "warn: ",@_ }else{ warn @_ }
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Tue Jan 23 15:42:34 2007
@@ -1,4 +1,4 @@
-#!perl -Tw
+#!perl -w
use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB
use DBI qw(:sql_types);
@@ -12,7 +12,7 @@
my $haveFileSpec = eval { require File::Spec };
require VMS::Filespec if $^O eq 'VMS';
-use Test::More tests => 263;
+use Test::More tests => 216;
# "globals"
my ($r, $dbh);
@@ -59,7 +59,7 @@
my $dbh2;
eval {
- $dbh2 = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError => 1,
AutoCommit => 0 });
+ $dbh2 = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError => 1,
AutoCommit => 1 });
};
like($@, qr/install_driver\(NoneSuch\) failed/, '... we should have an
exception here');
ok(!$dbh2, '... $dbh2 should not be defined');
@@ -103,50 +103,10 @@
ok($dbh->{AutoCommit} == 1);
cmp_ok($dbh->{PrintError}, '==', 0, '... PrintError should be 0');
-SKIP: {
- skip "cant test this if we have DBI::PurePerl", 1 if $DBI::PurePerl;
- $dbh->{Taint} = 1;
- ok($dbh->{Taint} == 1);
-}
-
is($dbh->{FetchHashKeyName}, 'NAME', '... FetchHashKey is NAME');
-like($dbh->{example_driver_path}, qr/DBD\/ExampleP\.pm$/, '... checking the
example driver_path');
-
-sub check_quote {
- # checking quote
- is($dbh->quote("quote's"), "'quote''s'", '... quoting strings
with embedded single quotes');
- is($dbh->quote("42", SQL_VARCHAR), "'42'", '... quoting number as
SQL_VARCHAR');
- is($dbh->quote("42", SQL_INTEGER), "42", '... quoting number as
SQL_INTEGER');
- is($dbh->quote(undef), "NULL", '...
quoting undef as NULL');
-}
-
-check_quote();
-
-my $get_info = $dbh->{examplep_get_info} || {};
-
-sub check_quote_identifier {
- # quote_identifier
- $get_info->{29} ='"'; #
SQL_IDENTIFIER_QUOTE_CHAR
- $dbh->{examplep_get_info} = $get_info; # trigger STORE
-
- is($dbh->quote_identifier('foo'), '"foo"', '...
properly quotes foo as "foo"');
- is($dbh->quote_identifier('f"o'), '"f""o"', '...
properly quotes f"o as "f""o"');
- is($dbh->quote_identifier('foo','bar'), '"foo"."bar"', '...
properly quotes foo, bar as "foo"."bar"');
- is($dbh->quote_identifier(undef,undef,'bar'), '"bar"', '...
properly quotes undef, undef, bar as "bar"');
-
- is($dbh->quote_identifier('foo',undef,'bar'), '"foo"."bar"', '...
properly quotes foo, undef, bar as "foo"."bar"');
-
- $get_info->{41} ='@'; # SQL_CATALOG_NAME_SEPARATOR
- $get_info->{114} = 2; # SQL_CATALOG_LOCATION
- $dbh->{examplep_get_info} = $get_info; # trigger STORE
-
- # force cache refresh
- $dbh->{dbi_quote_identifier_cache} = undef;
- is($dbh->quote_identifier('foo',undef,'bar'), '"bar"@"foo"', '... now
quotes it as "bar"@"foo" after flushing cache');
-}
-
-check_quote_identifier();
+# test access to driver-private attributes
+like($dbh->{example_driver_path}, qr/DBD\/ExampleP\.pm$/, '... checking the
example driver_path');
print "others\n";
eval { $dbh->commit('dummy') };
@@ -200,42 +160,12 @@
ok("@{[sort keys %{$csr_b->{NAME_uc_hash}}]}" eq "MODE NAME SIZE");
ok("@{[sort values %{$csr_b->{NAME_uc_hash}}]}" eq "0 1 2");
-SKIP: {
- skip "do not test with DBI::PurePerl", 15 if $DBI::PurePerl;
-
- # Check Taint* attribute switching
-
- #$dbh->{'Taint'} = 1; # set in connect
- ok($dbh->{'Taint'});
- ok($dbh->{'TaintIn'} == 1);
- ok($dbh->{'TaintOut'} == 1);
-
- $dbh->{'TaintOut'} = 0;
- ok($dbh->{'Taint'} == 0);
- ok($dbh->{'TaintIn'} == 1);
- ok($dbh->{'TaintOut'} == 0);
-
- $dbh->{'Taint'} = 0;
- ok($dbh->{'Taint'} == 0);
- ok($dbh->{'TaintIn'} == 0);
- ok($dbh->{'TaintOut'} == 0);
-
- $dbh->{'TaintIn'} = 1;
- ok($dbh->{'Taint'} == 0);
- ok($dbh->{'TaintIn'} == 1);
- ok($dbh->{'TaintOut'} == 0);
-
- $dbh->{'TaintOut'} = 1;
- ok($dbh->{'Taint'} == 1);
- ok($dbh->{'TaintIn'} == 1);
- ok($dbh->{'TaintOut'} == 1);
-}
# get a dir always readable on all platforms
my $dir = getcwd() || cwd();
$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS';
# untaint $dir
-$dir =~ m/(.*)/; $dir = $1 || die;
+#$dir =~ m/(.*)/; $dir = $1 || die;
# ---
@@ -243,7 +173,6 @@
my($col0, $col1, $col2, $col3, $rows);
my(@row_a, @row_b);
-ok($csr_a->{Taint} = 1) unless $DBI::PurePerl && ok(1);
#$csr_a->trace(5);
ok($csr_a->bind_columns(undef, \($col0, $col1, $col2)) );
ok($csr_a->execute( $dir ), $DBI::errstr);
@@ -268,87 +197,6 @@
ok ! eval { $csr_a->bind_col(4, undef) };
like $@, '/bind_col: column 4 is not a valid column \(1..3\)/', 'errstr should
contain error message';
-SKIP: {
-
- # Check Taint attribute works. This requires this test to be run
- # manually with the -T flag: "perl -T -Mblib t/examp.t"
- sub is_tainted {
- my $foo;
- return ! eval { ($foo=join('',@_)), kill 0; 1; };
- }
-
- skip " Taint attribute tests skipped\n", 19 unless(is_tainted($^X) &&
!$DBI::PurePerl);
-
- $dbh->{'Taint'} = 0;
- my $st;
- eval { $st = $dbh->prepare($std_sql); };
- ok(ref $st);
-
- ok($st->{'Taint'} == 0);
-
- ok($st->execute( $dir ));
-
- my @row = $st->fetchrow_array;
- ok(@row);
-
- ok(!is_tainted($row[0]));
- ok(!is_tainted($row[1]));
- ok(!is_tainted($row[2]));
-
- $st->{'TaintIn'} = 1;
-
- @row = $st->fetchrow_array;
- ok(@row);
-
- ok(!is_tainted($row[0]));
- ok(!is_tainted($row[1]));
- ok(!is_tainted($row[2]));
-
- $st->{'TaintOut'} = 1;
-
- @row = $st->fetchrow_array;
- ok(@row);
-
- ok(is_tainted($row[0]));
- ok(is_tainted($row[1]));
- ok(is_tainted($row[2]));
-
- $st->finish;
-
- # check simple method call values
- #ok(1);
- # check simple attribute values
- #ok(1); # is_tainted($dbh->{AutoCommit}) );
- # check nested attribute values (where a ref is returned)
- #ok(is_tainted($csr_a->{NAME}->[0]) );
- # check checking for tainted values
-
- $dbh->{'Taint'} = $csr_a->{'Taint'} = 1;
- eval { $dbh->prepare($^X); 1; };
- ok($@ =~ /Insecure dependency/, $@);
- eval { $csr_a->execute($^X); 1; };
- ok($@ =~ /Insecure dependency/, $@);
- undef $@;
-
- $dbh->{'TaintIn'} = $csr_a->{'TaintIn'} = 0;
-
- eval { $dbh->prepare($^X); 1; };
- ok(!$@);
- eval { $csr_a->execute($^X); 1; };
- ok(!$@);
-
- # Reset taint status to what it was before this block, so that
- # tests later in the file don't get confused
- $dbh->{'Taint'} = $csr_a->{'Taint'} = 1;
-}
-
-
-SKIP: {
- skip "do not test with DBI::PurePerl", 1 if $DBI::PurePerl;
- $csr_a->{Taint} = 0;
- ok($csr_a->{Taint} == 0);
-}
-
ok($csr_b->bind_param(1, $dir));
ok($csr_b->execute());
@row_b = @{ $csr_b->fetchrow_arrayref };
@@ -644,7 +492,7 @@
File::Spec->catfile($dump_dir,
'dumpcsr.tst')
:
"$dump_dir/dumpcsr.tst";
- ($dump_file) = ($dump_file =~ m/^(.*)$/); # untaint
+ #($dump_file) = ($dump_file =~ m/^(.*)$/); # untaint
SKIP: {
skip "# dump_results test skipped: unable to open $dump_file:
$!\n", 2 unless (open(DUMP_RESULTS, ">$dump_file"));
@@ -697,7 +545,6 @@
ok($tables[$_] eq $tables_expected[$_], "$tables[$_] ne $tables_expected[$_]")
foreach (0..$#tables_expected);
-
for (my $i = 0; $i < 300; $i += 100) {
print "Testing the fake directories ($i).\n";
ok($csr_a = $dbh->prepare("SELECT name, mode FROM long_list_$i"));
Added: dbi/trunk/t/12quote.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/12quote.t Tue Jan 23 15:42:34 2007
@@ -0,0 +1,47 @@
+#!perl -w
+
+use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB
+use strict;
+
+use Test::More tests => 10;
+
+use DBI qw(:sql_types);
+use Config;
+use Cwd;
+
+$^W = 1;
+$| = 1;
+
+my $dbh = DBI->connect('dbi:ExampleP:', '', '');
+
+sub check_quote {
+ # checking quote
+ is($dbh->quote("quote's"), "'quote''s'", '... quoting strings
with embedded single quotes');
+ is($dbh->quote("42", SQL_VARCHAR), "'42'", '... quoting number as
SQL_VARCHAR');
+ is($dbh->quote("42", SQL_INTEGER), "42", '... quoting number as
SQL_INTEGER');
+ is($dbh->quote(undef), "NULL", '...
quoting undef as NULL');
+}
+
+check_quote();
+
+sub check_quote_identifier {
+
+ my $qi = $dbh->{dbi_quote_identifier_cache} = [
+ '"', # 29: SQL_IDENTIFIER_QUOTE_CHAR
+ '.', # 41: SQL_CATALOG_NAME_SEPARATOR
+ 1, # 114: SSQL_CATALOG_LOCATION
+ ];
+
+ is($dbh->quote_identifier('foo'), '"foo"', '...
properly quotes foo as "foo"');
+ is($dbh->quote_identifier('f"o'), '"f""o"', '...
properly quotes f"o as "f""o"');
+ is($dbh->quote_identifier('foo','bar'), '"foo"."bar"', '...
properly quotes foo, bar as "foo"."bar"');
+ is($dbh->quote_identifier(undef,undef,'bar'), '"bar"', '...
properly quotes undef, undef, bar as "bar"');
+
+ is($dbh->quote_identifier('foo',undef,'bar'), '"foo"."bar"', '...
properly quotes foo, undef, bar as "foo"."bar"');
+
+ $qi->[1] = '@'; # SQL_CATALOG_NAME_SEPARATOR
+ $qi->[2] = 2; # SQL_CATALOG_LOCATION
+ is($dbh->quote_identifier('foo',undef,'bar'), '"bar"@"foo"', '... now
quotes it as "bar"@"foo" after flushing cache');
+}
+
+check_quote_identifier();
Added: dbi/trunk/t/13taint.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/13taint.t Tue Jan 23 15:42:34 2007
@@ -0,0 +1,134 @@
+#!perl -wT
+
+use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB
+use DBI qw(:sql_types);
+use Config;
+use Cwd;
+use strict;
+
+
+$^W = 1;
+$| = 1;
+
+my $haveFileSpec = eval { require File::Spec };
+require VMS::Filespec if $^O eq 'VMS';
+
+use Test::More;
+
+# Check Taint attribute works. This requires this test to be run
+# manually with the -T flag: "perl -T -Mblib t/examp.t"
+sub is_tainted {
+ my $foo;
+ return ! eval { ($foo=join('',@_)), kill 0; 1; };
+}
+sub mk_tainted {
+ my $string = shift;
+ return substr($string.$^X, 0, length($string));
+}
+
+plan skip_all => "Taint attributes not supported with DBI::PurePerl" if
$DBI::PurePerl;
+plan skip_all => "Taint attribute tests require taint mode (perl -T)" unless
is_tainted($^X);
+plan skip_all => "Taint attribute tests not functional with DBI_AUTOPROXY" if
$ENV{DBI_AUTOPROXY};
+
+plan tests => 36;
+
+# get a dir always readable on all platforms
+my $dir = getcwd() || cwd();
+$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS';
+$dir =~ m/(.*)/; $dir = $1 || die; # untaint $dir
+
+my ($r, $dbh);
+
+$dbh = DBI->connect('dbi:ExampleP:', '', '', { PrintError=>0, RaiseError=>1,
Taint => 1 });
+
+my $std_sql = "select mode,size,name from ?";
+my $csr_a = $dbh->prepare($std_sql);
+ok(ref $csr_a);
+
+ok($dbh->{'Taint'});
+ok($dbh->{'TaintIn'} == 1);
+ok($dbh->{'TaintOut'} == 1);
+
+$dbh->{'TaintOut'} = 0;
+ok($dbh->{'Taint'} == 0);
+ok($dbh->{'TaintIn'} == 1);
+ok($dbh->{'TaintOut'} == 0);
+
+$dbh->{'Taint'} = 0;
+ok($dbh->{'Taint'} == 0);
+ok($dbh->{'TaintIn'} == 0);
+ok($dbh->{'TaintOut'} == 0);
+
+$dbh->{'TaintIn'} = 1;
+ok($dbh->{'Taint'} == 0);
+ok($dbh->{'TaintIn'} == 1);
+ok($dbh->{'TaintOut'} == 0);
+
+$dbh->{'TaintOut'} = 1;
+ok($dbh->{'Taint'} == 1);
+ok($dbh->{'TaintIn'} == 1);
+ok($dbh->{'TaintOut'} == 1);
+
+$dbh->{'Taint'} = 0;
+my $st;
+eval { $st = $dbh->prepare($std_sql); };
+ok(ref $st);
+
+ok($st->{'Taint'} == 0);
+
+ok($st->execute( $dir ), 'should execute ok');
+
+my @row = $st->fetchrow_array;
+ok(@row);
+
+ok(!is_tainted($row[0]));
+ok(!is_tainted($row[1]));
+ok(!is_tainted($row[2]));
+
+print "TaintIn\n";
+$st->{'TaintIn'} = 1;
+
[EMAIL PROTECTED] = $st->fetchrow_array;
+ok(@row);
+
+ok(!is_tainted($row[0]));
+ok(!is_tainted($row[1]));
+ok(!is_tainted($row[2]));
+
+print "TaintOut\n";
+$st->{'TaintOut'} = 1;
+
[EMAIL PROTECTED] = $st->fetchrow_array;
+ok(@row);
+
+ok(is_tainted($row[0]));
+ok(is_tainted($row[1]));
+ok(is_tainted($row[2]));
+
+$st->finish;
+
+my $tainted_sql = mk_tainted($std_sql);
+my $tainted_dot = mk_tainted('.');
+
+$dbh->{'Taint'} = $csr_a->{'Taint'} = 1;
+eval { $dbh->prepare($tainted_sql); 1; };
+ok($@ =~ /Insecure dependency/, $@);
+eval { $csr_a->execute($tainted_dot); 1; };
+ok($@ =~ /Insecure dependency/, $@);
+undef $@;
+
+$dbh->{'TaintIn'} = $csr_a->{'TaintIn'} = 0;
+
+eval { $dbh->prepare($tainted_sql); 1; };
+ok(!$@, $@);
+eval { $csr_a->execute($tainted_dot); 1; };
+ok(!$@, $@);
+
+$csr_a->{Taint} = 0;
+ok($csr_a->{Taint} == 0);
+
+$csr_a->finish;
+
+$dbh->disconnect;
+
+1;
Modified: dbi/trunk/t/40profile.t
==============================================================================
--- dbi/trunk/t/40profile.t (original)
+++ dbi/trunk/t/40profile.t Tue Jan 23 15:42:34 2007
@@ -21,7 +21,7 @@
# tie methods (STORE/FETCH etc) get called different number of times
plan skip_all => "test results assume perl >= 5.8.2"
if $] <= 5.008001;
- plan tests => 45;
+ plan tests => 51;
}
$Data::Dumper::Indent = 1;
@@ -66,11 +66,15 @@
'Path' => [ '!MethodName', '!Caller2' ],
} => 'DBI::Profile';
+my $t_file = __FILE__;
$dbh->do("set foo=1"); my $line = __LINE__;
+my $expected_caller = "40profile.t line $line";
+$expected_caller .= " via zvfw_40profile.t line 3"
+ if $0 =~ /zvfw_/;
is_deeply sanitize_tree($dbh->{Profile}), bless {
'Path' => [ '!MethodName', '!Caller2' ],
'Data' => { 'do' => {
- "40profile.t line $line" => [ 1, 0, 0, 0, 0, 0, 0 ]
+ $expected_caller => [ 1, 0, 0, 0, 0, 0, 0 ]
} }
} => 'DBI::Profile';
#die Dumper $dbh->{Profile};
@@ -78,42 +82,31 @@
# can turn it on at connect
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>6 });
-is_deeply sanitize_tree($dbh->{Profile}), bless {
- 'Path' => [ '!Statement', '!MethodName' ],
- 'Data' => {
- '' => {
- 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ],
- 'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ]
- }
- }
-} => 'DBI::Profile';
+is_deeply $dbh->{Profile}{Path}, [ '!Statement', '!MethodName' ];
+cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 1);
+cmp_ok(keys %{ $dbh->{Profile}{Data}{""} }, '>=', 1); # at least STORE
+ok( ref $dbh->{Profile}{Data}{""}{STORE} );
print "dbi_profile\n";
# Try to avoid rounding problem on double precision systems
# $got->[5] = '1150962858.01596498'
# $expected->[5] = '1150962858.015965'
-# (looks like is_deeply stringifies) by treating as a string:
-my $t1 = DBI::dbi_time() . "";
-dbi_profile($dbh, "Hi, mom", "my_method_name", $t1, $t1 + 1);
-is_deeply sanitize_tree($dbh->{Profile}), bless {
- 'Path' => [ '!Statement', '!MethodName' ],
- 'Data' => {
- '' => {
- 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ], # +0
- 'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ]
- },
- "Hi, mom" => {
- my_method_name => [ 1, 0, 0, 0, 0, 0, 0 ],
- },
- }
-} => 'DBI::Profile';
+# by treating as a string (because is_deeply stringifies)
+my $t1 = DBI::dbi_time() . "";
+my $dummy_statement = "Hi mom";
+my $dummy_methname = "my_method_name";
+dbi_profile($dbh, $dummy_statement, $dummy_methname, $t1, $t1 + 1);
+print Dumper($dbh->{Profile});
+cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 2);
+cmp_ok(keys %{ $dbh->{Profile}{Data}{$dummy_statement} }, '==', 1);
+ok( ref $dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname} );
-my $mine = $dbh->{Profile}{Data}{"Hi, mom"}{my_method_name};
+my $mine = $dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname};
print "@$mine\n";
is_deeply $mine, [ 1, 1, 1, 1, 1, $t1, $t1 ];
my $t2 = DBI::dbi_time() . "";
-dbi_profile($dbh, "Hi, mom", "my_method_name", $t2, $t2 + 2);
+dbi_profile($dbh, $dummy_statement, $dummy_methname, $t2, $t2 + 2);
print "@$mine\n";
is_deeply $mine, [ 2, 3, 1, 1, 2, $t1, $t2 ];
@@ -197,19 +190,19 @@
$sth = $dbh->prepare($sql);
$sth->execute();
$sth->fetchrow_hashref;
+$sth->finish;
undef $sth; # DESTROY
$tmp = sanitize_tree($dbh->{Profile});
+ok $tmp->{Data}{usrnam}{""}{foo}{STORE};
+$tmp->{Data}{usrnam}{""}{foo} = {};
# make test insentitive to number of local files
is_deeply $tmp, bless {
'Path' => [ '{Username}', '!Statement', 'foo', '!MethodName' ],
'Data' => {
'usrnam' => {
'' => {
- 'foo' => {
- 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ],
- 'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ],
- },
+ 'foo' => { },
},
'select name from .' => {
'foo' => {
@@ -217,8 +210,6 @@
'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ],
'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
- # XXX finish shouldn't be profiled as it's not called
explicitly
- # but currently the finish triggered by DESTROY does
get profiled
'finish' => [ 1, 0, 0, 0, 0, 0, 0 ],
},
},
@@ -278,6 +269,7 @@
$sth = $dbh->prepare($sql);
$sth->execute();
$sth->fetchrow_hashref;
+ $sth->finish;
undef $sth; # DESTROY
return sanitize_profile_data_nodes($dbh->{Profile}{Data});
}
@@ -299,18 +291,15 @@
}, '$_ should contain statement';
# check what code ref sees in @_
-$tmp = run_test1( { Path => [ sub { my ($h,$method) = @_; return (ref $h,
$method) } ] });
+$tmp = run_test1( { Path => [ sub { my ($h,$method) = @_; return \undef if
$method =~ /^[A-Z]+$/; return (ref $h, $method) } ] });
is_deeply $tmp, {
'DBI::db' => {
- 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ],
'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
- 'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ],
},
'DBI::st' => {
'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
'finish' => [ 1, 0, 0, 0, 0, 0, 0 ],
- 'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ],
},
}, 'should have @_ as keys';
@@ -344,7 +333,7 @@
is($total_time, 2.93);
DBI->trace(0, "STDOUT"); # close current log to flush it
-ok(-s $LOG_FILE); # check that output went into the log file
+ok(-s $LOG_FILE, 'output should go to log file');
exit 0;
Modified: dbi/trunk/t/42prof_data.t
==============================================================================
--- dbi/trunk/t/42prof_data.t (original)
+++ dbi/trunk/t/42prof_data.t Tue Jan 23 15:42:34 2007
@@ -115,6 +115,7 @@
$sth3->fetchrow_hashref;
$sth3->finish;
}
+$dbh->disconnect;
undef $dbh;
# load dbi.prof
Modified: dbi/trunk/t/50dbm.t
==============================================================================
--- dbi/trunk/t/50dbm.t (original)
+++ dbi/trunk/t/50dbm.t Tue Jan 23 15:42:34 2007
@@ -5,6 +5,8 @@
use Test::More;
use Config qw(%Config);
+my $using_dbd_forward_null = ($ENV{DBI_AUTOPROXY}||'') =~
/dbi:Forward.*transport=null/i;
+
use DBI;
use vars qw( @mldbm_types @dbm_types );
BEGIN {
@@ -42,7 +44,7 @@
print "Using DBM modules: @dbm_types\n";
print "Using MLDBM serializers: @mldbm_types\n" if @mldbm_types;
- my $num_tests = ([EMAIL PROTECTED]) * @dbm_types * 11;
+ my $num_tests = ([EMAIL PROTECTED]) * @dbm_types * 12;
if (!$num_tests) {
plan skip_all => "No DBM modules available";
@@ -80,26 +82,42 @@
# (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";
+
+ if ($using_dbd_forward_null) {
+ $dsn .= ";f_dir=$dir";
+ }
+
my $dbh = DBI->connect( $dsn );
- if ($DBI::VERSION >= 1.37 ) { # needed for install_method
- print $dbh->dbm_versions;
+ my $dbm_versions;
+ if ($DBI::VERSION >= 1.37 # needed for install_method
+ && !$ENV{DBI_AUTOPROXY} # can't transparently proxy driver-private
methods
+ ) {
+ $dbm_versions = $dbh->dbm_versions;
}
else {
- print $dbh->func('dbm_versions');
+ $dbm_versions = $dbh->func('dbm_versions');
}
+ print $dbm_versions;
+ ok($dbm_versions);
isa_ok($dbh, 'DBI::db');
# test if it correctly accepts valid $dbh attributes
- #
- eval {$dbh->{f_dir}=$dir};
- ok(!$@);
- eval {$dbh->{dbm_mldbm}=$mldbm};
- ok(!$@);
+ SKIP: {
+ skip "Can't set attributes after connect using DBD::Forward", 2
+ if $using_dbd_forward_null;
+ eval {$dbh->{f_dir}=$dir};
+ ok(!$@);
+ eval {$dbh->{dbm_mldbm}=$mldbm};
+ ok(!$@);
+ }
# test if it correctly rejects invalid $dbh attributes
#
- eval {$dbh->{dbm_bad_name}=1};
+ eval {
+ local $SIG{__WARN__} = sub { } if $using_dbd_forward_null;
+ $dbh->{dbm_bad_name}=1;
+ };
ok($@);
for my $sql ( @$stmts ) {
Modified: dbi/trunk/t/72childhandles.t
==============================================================================
--- dbi/trunk/t/72childhandles.t (original)
+++ dbi/trunk/t/72childhandles.t Tue Jan 23 15:42:34 2007
@@ -24,6 +24,8 @@
plan tests => 14;
+my $drh;
+
{
# make 10 connections
my @dbh;
@@ -33,12 +35,11 @@
}
# get the driver handle
- my %drivers = DBI->installed_drivers();
- my $driver = $drivers{ExampleP};
- ok $driver;
+ $drh = $dbh[0]->{Driver};
+ ok $drh;
# get the kids, should be the same list of connections
- my $db_handles = $driver->{ChildHandles};
+ my $db_handles = $drh->{ChildHandles};
is ref $db_handles, 'ARRAY';
is scalar @$db_handles, scalar @dbh;
@@ -52,10 +53,7 @@
# now all the out-of-scope DB handles should be gone
{
- my %drivers = DBI->installed_drivers();
- my $driver = $drivers{ExampleP};
-
- my $handles = $driver->{ChildHandles};
+ my $handles = $drh->{ChildHandles};
my @db_handles = grep { defined } @$handles;
is scalar @db_handles, 0, "All handles should be undef now";
}
@@ -68,9 +66,10 @@
# test child handles for statement handles
{
my @sth;
- for (1 .. 200) {
+ my $sth_count = 200;
+ for (1 .. $sth_count) {
my $sth = $dbh->prepare('SELECT name FROM t');
- push(@sth, $sth);
+ push @sth, $sth;
}
my $handles = $dbh->{ChildHandles};
is scalar @$handles, scalar @sth;
@@ -85,10 +84,11 @@
show_child_handles($_, $level + 1)
for (grep { defined } @{$h->{ChildHandles}});
}
- show_child_handles($_) for (values %{{DBI->installed_drivers()}});
+ my $drh = $dbh->{Driver};
+ show_child_handles($drh, 0);
print @lines[0..4];
- is scalar @lines, 202;
+ is scalar @lines, $sth_count + 2;
like $lines[0], qr/^drh/;
like $lines[1], qr/^dbh/;
like $lines[2], qr/^sth/;
