Author: timbo
Date: Thu Mar 11 05:30:09 2004
New Revision: 216
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/03handle.t
Log:
Fixed ref($h)->can("foo") to not croak.
Added DBI::common as base class for DBI::db, DBD::st etc.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Thu Mar 11 05:30:09 2004
@@ -13,6 +13,7 @@
Fixed t/41prof_dump.t to work with perl5.9.1.
Fixed DBD_ATTRIB_DELETE macro thanks to Marco Paskamp.
Fixed DBI::PurePerl looks_like_number() and $DBI::rows.
+ Fixed ref($h)->can("foo") to not croak.
Changed attributes (NAME, TYPE etc) of non-executed statement
handle to be undef instead of triggering an error.
@@ -20,6 +21,7 @@
Changed DBI_TRACE env var so just does this at load time:
DBI->trace(split '=', $ENV{DBI_TRACE}, 2);
Improved "invalid number of parameters" error message.
+ Added DBI::common as base class for DBI::db, DBD::st etc.
Major tracing enhancement:
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Thu Mar 11 05:30:09 2004
@@ -461,6 +461,12 @@
}
}
+{
+ package DBI::common;
+ @DBI::dr::ISA = ('DBI::common');
+ @DBI::db::ISA = ('DBI::common');
+ @DBI::st::ISA = ('DBI::common');
+}
# End of init code
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Thu Mar 11 05:30:09 2004
@@ -753,6 +753,10 @@
sv = SvRV(hrv);
else if (hrv == DBI_LAST_HANDLE) /* special for var::FETCH */
sv = DBI_LAST_HANDLE;
+ else if (Perl_sv_derived_from(hrv, "DBI::common")) {
+ /* probably a class name, if ref($h)->foo() */
+ return 0;
+ }
else {
sv_dump(hrv);
croak("Invalid DBI handle %s", neatsvpv(hrv,0));
@@ -2307,10 +2311,6 @@
PerlIO_flush(logfp);
}
- if (!SvROK(h) || SvTYPE(SvRV(h)) != SVt_PVHV) {
- croak("%s: handle %s is not a hash reference",meth_name,neatsvpv(h,0));
- }
-
if ( ( (is_DESTROY=(*meth_name=='D' && strEQ(meth_name,"DESTROY")))) ) {
/* note that croak()'s won't propagate, only append to $@ */
keep_error = TRUE;
@@ -2322,7 +2322,7 @@
data (without having to go through FETCH and STORE methods) and
for tie and non-tie methods to call each other.
*/
- if (SvRMAGICAL(SvRV(h)) && (mg=mg_find(SvRV(h),'P'))!=NULL) {
+ if (SvROK(h) && SvRMAGICAL(SvRV(h)) && (mg=mg_find(SvRV(h),'P'))!=NULL) {
if (SvPVX(mg->mg_obj)==NULL) { /* maybe global destruction */
if (trace_level >= 3)
@@ -2359,12 +2359,24 @@
imp_xxh = dbih_getcom2(h, 0); /* get common Internal Handle Attributes */
if (!imp_xxh) {
- /* XXX perhaps warn() for anything other than DESTROY? */
+ if (strEQ(meth_name, "can")) { /* ref($h)->can("foo") */
+ char *can_meth = SvPV(st1,lna);
+ SV *rv = &PL_sv_undef;
+ GV *gv = gv_fetchmethod_autoload(gv_stashsv(orig_h,FALSE), can_meth,
FALSE);
+ if (gv && isGV(gv))
+ rv = sv_2mortal(newRV((SV*)GvCV(gv)));
+ if (trace_level >= 3) {
+ PerlIO_printf(DBILOGFP," <- %s(%s) = %p\n", meth_name, can_meth,
neatsvpv(rv,0));
+ }
+ ST(0) = rv;
+ XSRETURN(1);
+ }
if (trace_level)
- PerlIO_printf(DBILOGFP, "%c <> %s for %s ignored (dbi_imp_data gone)\n",
+ PerlIO_printf(DBILOGFP, "%c <> %s for %s ignored (no imp_data)\n",
(dirty?'!':' '), meth_name, neatsvpv(h,0));
if (!is_DESTROY)
- warn("Can't call %s method on handle %s after take_imp_data()", meth_name,
neatsvpv(h,0));
+ warn("Can't call %s method on handle %s%s", meth_name, neatsvpv(h,0),
+ SvROK(h) ? " after take_imp_data()" : " (not a reference)");
XSRETURN(0);
}
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Thu Mar 11 05:30:09 2004
@@ -193,6 +193,8 @@
my $bitmask = $param_hash->{'O'} || 0;
my @pre_call_frag;
+ return if $method_name eq 'can';
+
push @pre_call_frag, q{
return if $h_inner; # ignore DESTROY for outer handle
} if $method_name eq 'DESTROY';
@@ -848,7 +850,7 @@
=head1 EXPERIMENTAL STATUS
-DBI::PurePerl is very new so please treat it as experimental pending
+DBI::PurePerl is new so please treat it as experimental pending
more extensive testing. So far it has passed all tests with DBD::CSV,
DBD::AnyData, DBD::XBase, DBD::Sprite, DBD::mysqlPP. Please send
bug reports to Jeff Zucker at <[EMAIL PROTECTED]> with a cc to
@@ -968,7 +970,9 @@
Try re-enabling t/80proxy.t for DBI::PurePerl to see if the problem
that remains will affect you're usage.
-=head2 Undoubtedly Others
+=head2 Others
+
+ can() - doesn't have any special behaviour
Please let us know if you find any other differences between DBI
and DBI::PurePerl.
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Thu Mar 11 05:30:09 2004
@@ -6,7 +6,7 @@
# handle tests
-BEGIN { plan tests => 49 }
+BEGIN { plan tests => 52 }
use DBI;
@@ -134,5 +134,12 @@
is $sth->{NAME_uc_hash}, undef;
is $sth->{NAME_lc_hash}, undef;
+ok ref($dbh)->can("prepare");
+ok !ref($dbh)->can("nonesuch");
+ok ref($sth)->can("execute");
+
+# I don't know why this warning has the "(perhaps ...)" suffix, it shouldn't:
+# Can't locate object method "nonesuch" via package "DBI::db" (perhaps you forgot to
load "DBI::db"?)
+eval { ref($dbh)->nonesuch; };
exit 0;
