Author: timbo
Date: Tue Feb 24 04:39:10 2004
New Revision: 139
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/MANIFEST
dbi/trunk/ToDo
dbi/trunk/lib/DBD/ExampleP.pm
dbi/trunk/lib/DBI/DBD.pm
dbi/trunk/t/02dbidrv.t
dbi/trunk/t/06attrs.t
dbi/trunk/t/10examp.t
dbi/trunk/t/80proxy.t
Log:
Changed ShowErrorStatement to apply to more $dbh methods.
Improved "invalid number of parameters" error message.
Corrected typos in docs thanks to Steffen Goeldner.
Added $h->trace_flags("foo,SQL,7") to map a set of
trace flags into the corresponding trace flag bits:
$h->{TraceLevel} = $h->trace_flags("foo,SQL,7");
(eventually $h->{TraceLevel} = "foo,SQL,7"; will work, but
print $h->{TraceLevel} will probably still print an integer)
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue Feb 24 04:39:10 2004
@@ -6,14 +6,22 @@
=head1 CHANGES in DBI 1.42 (svn rev XX), XXnd February 2004
+Document $t->trace_flags etc
+
Fixed $sth->{NUM_OF_FIELDS} of non-executed statement handle
to be undef as per the docs (it was 0).
Fixed t/41prof_dump.t to work with perl5.9.1.
Changed attributes (NAME, TYPE etc) of non-executed statement
handle to be undef instead of triggering an error.
+ Changed ShowErrorStatement to apply to more $dbh methods.
+ Improved "invalid number of parameters" error message.
Corrected typos in docs thanks to Steffen Goeldner.
+ Added $h->trace_flags("foo,SQL,7") to map a set of
+ trace flags into the corresponding trace flag bits:
+ $h->{TraceLevel} = $h->trace_flags("foo,SQL,7");
+
=head1 CHANGES in DBI 1.41 (svn rev 130), 22nd February 2004
Fixed execute_for_array() so tuple_status parameter is optional
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Tue Feb 24 04:39:10 2004
@@ -363,10 +363,12 @@
private_data => { U =>[1,1], O=>0x0004 },
err => $keeperr,
errstr => $keeperr,
- state => { U =>[1,1], O=>0x0004 },
- set_err => { O=>0x0010 },
+ state => $keeperr,
+ set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'],
O=>0x0010 },
_not_impl => undef,
can => { O=>0x0100 }, # special case, see dispatch
+ trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 },
+ trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 },
);
%DBI::DBI_methods = ( # Define the DBI interface methods per class:
@@ -390,32 +392,32 @@
begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400 },
commit => { U =>[1,1], O=>0x0480|0x0800 },
rollback => { U =>[1,1], O=>0x0480|0x0800 },
- 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'],
O=>0x1200 },
- last_insert_id => { U =>[3,4,'$table_name, $field_name [, \%attr ]'],
O=>0x0100 },
+ 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'],
O=>0x3200 },
+ last_insert_id => { U =>[3,4,'$table_name, $field_name [, \%attr ]'],
O=>0x2100 },
preparse => { }, # XXX
- prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0x0200 },
- prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'] },
- selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'] },
- selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'] },
- selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'] },
- selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'] },
- selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params
] ]'] },
- selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'] },
+ prepare => { U =>[2,3,'$statement [, \%attr]'],
O=>0x2200 },
+ prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'],
O=>0x2200 },
+ selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'],
O=>0x2000 },
+ selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'],
O=>0x2000 },
+ selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'],
O=>0x2000 },
+ selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'],
O=>0x2000 },
+ selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params
] ]'], O=>0x2000 },
+ selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'],
O=>0x2000 },
ping => { U =>[1,1], O=>0x0404 },
disconnect => { U =>[1,1], O=>0x0400|0x0800 },
quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430 },
quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430 },
rows => $keeperr,
- tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]'
], O=>0x0200 },
- table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]'
], O=>0x0200|0x0800 },
- column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr
]'],O=>0x0200|0x0800 },
- primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],
O=>0x0200|0x0800 },
- primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],
O=>0x0200 },
- foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table,
$fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x0200|0x0800 },
- type_info_all => { U =>[1,1], O=>0x0200|0x0800 },
- type_info => { U =>[1,2,'$data_type'], O=>0x0200 },
- get_info => { U =>[2,2,'$info_type'], O=>0x0200|0x0800 },
+ tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]'
], O=>0x2200 },
+ table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]'
], O=>0x2200|0x0800 },
+ column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr
]'],O=>0x2200|0x0800 },
+ primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],
O=>0x2200|0x0800 },
+ primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],
O=>0x2200 },
+ foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table,
$fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x0800 },
+ type_info_all => { U =>[1,1], O=>0x2200|0x0800 },
+ type_info => { U =>[1,2,'$data_type'], O=>0x2200 },
+ get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 },
},
st => { # Statement Class Interface
@Common_IF,
@@ -1233,6 +1235,35 @@
DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line",
\%attr);
}
+ sub trace_flags {
+ my ($h, $spec) = @_;
+ my $level = 0;
+ my $flags = 0;
+ my @unknown;
+ for my $word (split /[|&]/, $spec) {
+ if (DBI::looks_like_number($word) && $word <= 0xF) {
+ $level = $word;
+ } elsif (my $flag = $h->trace_flag($word)) {
+ $flags |= $flag;
+ }
+ else {
+ push @unknown, $word;
+ }
+ }
+ if (@unknown && $h->FETCH('Warn')) {
+ warn "Unknown trace flags ignored: ".
+ join(", ", map { DBI::neat($_) } @unknown);
+ }
+ $flags |= $level;
+ return $flags;
+ }
+
+ sub trace_flag {
+ my ($h, $name) = @_;
+ # 0xddDDDDrL (driver, DBI, reserved, Level)
+ return 0x00000100 if $name eq 'SQL';
+ return;
+ }
}
@@ -2735,9 +2766,13 @@
future children of that handle) by setting the trace level using the
C<trace> method.
+The $trace_level is an integer where the lowest 4 bits are used to
+set the general 'trace level' and the higher bits are 'trace flags'
+used to enable tracing of particular 'topics'.
+
Trace level 1 is best for a simple overview of what's happening.
Trace level 2 is a good choice for general purpose tracing. Levels 3
-and above (up to 9) are best reserved for investigating a
+and above (up to 15) are best reserved for investigating a
specific problem, when you need to see "inside" the driver and DBI.
Set C<$trace_level> to 0 to disable the trace.
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue Feb 24 04:39:10 2004
@@ -90,12 +90,12 @@
/* Internal Method Attributes (attached to dispatch methods when installed) */
typedef struct dbi_ima_st {
- short minargs;
- short maxargs;
- short hidearg;
+ U8 minargs;
+ U8 maxargs;
+ U8 hidearg;
+ U8 trace_level;
char *usage_msg;
- U16 flags;
- U16 trace_level;
+ U32 flags;
} dbi_ima_t;
/* These values are embedded in the data passed to install_method */
@@ -105,13 +105,14 @@
#define IMA_KEEP_ERR_SUB 0x0008 /* '' if in a nested call */
#define IMA_NO_TAINT_IN 0x0010 /* don't check for tainted args */
#define IMA_NO_TAINT_OUT 0x0020 /* don't taint results */
-#define IMA_COPY_STMT 0x0040 /* copy sth Statement to dbh */
+#define IMA_COPY_UP_STMT 0x0040 /* copy sth Statement to dbh */
#define IMA_END_WORK 0x0080 /* set on commit & rollback */
#define IMA_STUB 0x0100 /* donothing eg $dbh->connected */
#define IMA_CLEAR_STMT 0x0200 /* clear Statement before call */
-#define IMA_PROF_EMPTY_STMT 0x0400 /* profile as empty Statement */
+#define IMA_UNRELATED_TO_STMT 0x0400 /* profile as empty Statement */
#define IMA_NOT_FOUND_OKAY 0x0800 /* no error if not found */
#define IMA_EXECUTE 0x1000 /* do/execute: DBIcf_Executed */
+#define IMA_SHOW_ERR_STMT 0x2000 /* dbh meth relates to Statement*/
#define DBIc_STATE_adjust(imp_xxh, state) \
(SvOK(state) /* SQLSTATE is implemented by driver */ \
@@ -2422,10 +2423,9 @@
if (ima->minargs && (items < ima->minargs
|| (ima->maxargs>0 && items > ima->maxargs))) {
- /* the error reporting is a little tacky here */
sprintf(msg,
- "DBI %s: invalid number of parameters: handle + %ld\n",
- meth_name, (long)items-1);
+ "DBI %s: invalid number of arguments: got handle + %ld, expected
handle + between %d and %d\n",
+ meth_name, (long)items-1, (int)ima->minargs-1,
(int)ima->maxargs-1);
err = msg;
}
/* arg type checking could be added here later */
@@ -2499,7 +2499,7 @@
call_depth = ++DBIc_CALL_DEPTH(imp_xxh);
if (ima) {
- if (ima->flags & IMA_COPY_STMT) { /* execute() */
+ if (ima->flags & IMA_COPY_UP_STMT) { /* execute() */
SV *parent = DBIc_PARENT_H(imp_xxh);
SV *tmp_sv = *hv_fetch((HV*)SvRV(h), "Statement", 9, 1);
/* XXX sv_copy() if Profiling? */
@@ -2829,11 +2829,8 @@
sv_catsv(msg, DBIc_ERRSTR(imp_xxh));
if ( DBIc_has(imp_xxh, DBIcf_ShowErrorStatement)
- && (DBIc_TYPE(imp_xxh) == DBIt_ST
- || strEQ(err_meth_name,"prepare") /* XXX use IMA flag for this */
- || strEQ(err_meth_name,"do")
- || strnEQ(err_meth_name,"select",6)
- )
+ && (DBIc_TYPE(imp_xxh) == DBIt_ST || ima->flags & IMA_SHOW_ERR_STMT)
+ && !(ima->flags & IMA_UNRELATED_TO_STMT) /* error unrelated to
Statement */
&& (statement_svp = hv_fetch((HV*)SvRV(h), "Statement", 9, 0))
&& statement_svp && SvOK(*statement_svp)
) {
@@ -2913,7 +2910,7 @@
}
if (profile_t1) { /* see also dbi_profile() call a few lines below */
- char *Statement = (ima && ima->flags & IMA_PROF_EMPTY_STMT) ? "" : Nullch;
+ char *Statement = (ima && ima->flags & IMA_UNRELATED_TO_STMT) ? "" :
Nullch;
dbi_profile(h, imp_xxh, Statement, imp_msv ? imp_msv : (SV*)cv,
profile_t1, dbi_time());
}
@@ -2929,7 +2926,7 @@
}
}
else if (profile_t1) { /* see also dbi_profile() call a few lines above */
- char *Statement = (ima && ima->flags & IMA_PROF_EMPTY_STMT) ? "" : Nullch;
+ char *Statement = (ima && ima->flags & IMA_UNRELATED_TO_STMT) ? "" : Nullch;
dbi_profile(h, imp_xxh, Statement, imp_msv ? imp_msv : (SV*)cv,
profile_t1, dbi_time());
}
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Tue Feb 24 04:39:10 2004
@@ -44,6 +44,7 @@
t/06attrs.t
t/07kids.t
t/08keeperr.t
+t/09trace.t
t/10examp.t
t/15array.t
t/20meta.t
Modified: dbi/trunk/ToDo
==============================================================================
--- dbi/trunk/ToDo (original)
+++ dbi/trunk/ToDo Tue Feb 24 04:39:10 2004
@@ -135,6 +135,7 @@
Review drivers for handling of multiple result sets
to define common api for all.
$sth->more_results, maybe via $sth->become($sth2) later (or transplant/swap)
+Also standard way to 'reset/reconfigure' a statement handle.
#define a large negative number to mean 'error' from st_execute and
change *.xst to treat either that or -2 as an error. (The -2 is
@@ -142,6 +143,12 @@
--- Other changes
+Add data structure describing attributes
+Use the data structure to replace similar data in Proxy and PurePerl code
+
+Remove _not_impl. Alias debug to trace in DBI::(dr/db/st) ad remove
+debug() method from internals.
+
Mechanism to 'unset' the keep_error flag for the current call, which
could then be used by FETCH when appropriate. Or, better:
New ima flags: CLEAR_ERR (on entry), CHECK_ERR (on exit), CHECK_NEW_ERR
Modified: dbi/trunk/lib/DBD/ExampleP.pm
==============================================================================
--- dbi/trunk/lib/DBD/ExampleP.pm (original)
+++ dbi/trunk/lib/DBD/ExampleP.pm Tue Feb 24 04:39:10 2004
@@ -248,6 +248,17 @@
my $dbh = shift; my $re = shift;
grep { $_ =~ /$re/ } $dbh->tables();
}
+
+ sub trace_flag {
+ my ($h, $name) = @_;
+ return 0x01000000 if $name eq 'foo';
+ return 0x02000000 if $name eq 'bar';
+ return 0x04000000 if $name eq 'baz';
+ return 0x08000000 if $name eq 'boo';
+ return 0x10000000 if $name eq 'bop';
+ return $h->SUPER::trace_flag($name);
+ }
+
}
@@ -383,6 +394,9 @@
}
sub DESTROY { undef }
+
+ *trace_flag = \&DBD::ExampleP::db::trace_flag;
}
1;
+# vim: sw=4:ts=8
Modified: dbi/trunk/lib/DBI/DBD.pm
==============================================================================
--- dbi/trunk/lib/DBI/DBD.pm (original)
+++ dbi/trunk/lib/DBI/DBD.pm Tue Feb 24 04:39:10 2004
@@ -1258,6 +1258,26 @@
method and possibly a I<quote> method if DBI's default isn't correct for
you.
+Where reasonable use $h->SUPER::foo() to call the DBI's method in
+some or all cases and just wrap your custom behavior around that.
+
+If you want to use private trace flags you'll probably want to be
+able to set them by name. To do that you'll need to define a
+trace_flag() method (note that's trace_flag not trace_flags).
+
+ sub trace_flag {
+ my ($h, $name) = @_;
+ return 0x01000000 if $name eq 'foo';
+ return 0x02000000 if $name eq 'bar';
+ return 0x04000000 if $name eq 'baz';
+ return 0x08000000 if $name eq 'boo';
+ return 0x10000000 if $name eq 'bop';
+ return $h->SUPER::trace_flag($name);
+ }
+
+All private flag names must be lowercase, and all private flags
+must be in the top 8 of the 32 bits.
+
=cut
#=head3 The DBD::Driver::st package
@@ -1451,10 +1471,16 @@
A C<type_info_all> method to return details of supported types.
+If you've defined a trace_flag() method in ::db you'll also want
+it in ::st, so just alias it in:
+
+ *trace_flag = \&DBD::foo:db::trace_flag;
+
And perhaps some other methods that are not part of the DBI
specification, in particular to make metadata available.
-Considering Tim's recent postings, do yourself a favour and follow the
-ODBC driver.
+Remember that they must have names that begin with your drivers
+registered prefix so they can be installed using install_method().
+
=cut
@@ -2141,20 +2167,20 @@
The name DBILOGFP, which was also used in previous versions of this document, should
be
replaced by DBIc_LOGPIO(imp_xxh).
-Your code should not call the C C<E<lt>stdio.hE<gt>> I/O functions; you should either
use
-C<PerlIO_printf>() as shown, or standard Perl functions such as C<warn>():
-
- if (DBIc_DBISTATE(imp_xxh)->debug >= 2)
- PerlIO_printf(DBIc_LOGPIO(imp_xxh), "%s error %d recorded: %s\n",
- what, rc, SvPV(errstr,na));
-
-Or:
-
- if (DBIc_DBISTATE(imp_xxh)->debug >= 2)
- warn("%s error %d recorded: %s\n", what, rc, SvPV(errstr,na));
+Your code should not call the C C<E<lt>stdio.hE<gt>> I/O functions; you should use
+C<PerlIO_printf>() as shown:
-That's the first time we see how debug/trace logging works within a DBI
-driver. Make use of this as often as you can!
+ if (DBIc_TRACE_LEVEL(imp_xxh) >= 2)
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh), "foobar %s: %s\n",
+ foo, neatsvpv(errstr,0));
+
+That's the first time we see how tracing works within a DBI
+driver. Make use of this as often as you can! But don't output anything
+at a trace level less than 3. Levels 1 and 2 are reserved for the DBI.
+
+You can define up to 8 private trace flags using the top 8 bits of
+DBIc_TRACE_FLAGS(imp), that is: 0xFF000000. See the trace_flag() method
+elsewhere in this document.
=cut
Modified: dbi/trunk/t/02dbidrv.t
==============================================================================
--- dbi/trunk/t/02dbidrv.t (original)
+++ dbi/trunk/t/02dbidrv.t Tue Feb 24 04:39:10 2004
@@ -63,8 +63,6 @@
main::ok($h);
main::ok(!tied $h);
- #$h->trace(9);
-
print "Driver for inner handles needs to be the Drivers inner handle\n";
my $drh_i = $h->{Driver};
main::ok($drh_i);
@@ -76,8 +74,6 @@
main::ok($drh_o);
main::ok(ref $drh_o);
main::ok(tied %$drh_o) unless $DBI::PurePerl && main::ok(1);
-
- #$h->trace(0);
}
sub data_sources { # just used to run tests 'inside' a driver
@@ -149,7 +145,6 @@
ok($name);
ok($name eq "Test");
print "FETCH'd $name\n";
-DBI->trace(0);
ok($drh->can('disconnect_all') ? 1 : 0, 0); # not implemented
}
else { ok(1) for (1..5) }
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Tue Feb 24 04:39:10 2004
@@ -4,7 +4,7 @@
use Test::More;
use DBI;
-BEGIN { plan tests => 149 }
+BEGIN { plan tests => 143 }
$|=1;
@@ -96,7 +96,7 @@
else { ok(1); ok(1); }
ok( ! defined $drh->{CachedKids} );
ok( ! defined $drh->{HandleError} );
-is( $drh->{TraceLevel}, 0 );
+is( $drh->{TraceLevel}, $DBI::dbi_debug & 0xF );
is( $drh->{FetchHashKeyName}, 'NAME', );
ok( ! defined $drh->{Profile} );
is( $drh->{LongReadLen}, 80 );
@@ -203,19 +203,7 @@
is( $sth->{Statement}, "select ctime, name from foo" );
ok( ! defined $sth->{RowsInCache} );
-my $trace_file = "dbitrace.log";
-1 while unlink $trace_file;
-$sth->trace(2, $trace_file);
-ok( -f $trace_file );
-is( $sth->{TraceLevel}, 2 );
-$sth->{TraceLevel} = 0;
-is( $sth->{TraceLevel}, 0 );
-$sth->{TraceLevel} = 3;
-is( $sth->{TraceLevel}, 3 );
-$sth->trace(0); # set to 0 before return to STDERR
-is( $sth->{TraceLevel}, 0 );
-$sth->trace(0, "STDERR"); # close $trace_file
-ok( -s $trace_file );
+# $h->{TraceLevel} tests are in t/09trace.t
1;
# end
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Tue Feb 24 04:39:10 2004
@@ -109,7 +109,7 @@
print "others\n";
eval { $dbh->commit('dummy') };
-ok(0, $@ =~ m/DBI commit: invalid number of parameters: handle \+ 1/)
+ok(0, $@ =~ m/DBI commit: invalid number of arguments:/, $@)
unless $DBI::PurePerl && ok(0,1);
ok(0, $dbh->ping);
Modified: dbi/trunk/t/80proxy.t
==============================================================================
--- dbi/trunk/t/80proxy.t (original)
+++ dbi/trunk/t/80proxy.t Tue Feb 24 04:39:10 2004
@@ -144,7 +144,7 @@
print "Trying commit with invalid number of parameters.\n";
eval { $dbh->commit('dummy') };
-Test($@ =~ m/^DBI commit: invalid number of parameters: handle \+ 1/)
+Test($@ =~ m/^DBI commit: invalid number of arguments:/)
unless $DBI::PurePerl && Test(1);
print "Trying select with unknown field name.\n";
