Author: timbo
Date: Fri Feb 27 14:35:48 2004
New Revision: 167
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/Driver.xst
dbi/trunk/ToDo
dbi/trunk/lib/DBD/ExampleP.pm
dbi/trunk/lib/DBI/DBD.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/01basics.t
dbi/trunk/t/09trace.t
dbi/trunk/t/10examp.t
dbi/trunk/t/50dbm.t
Log:
Fixed DBI::PurePerl looks_like_number() and $DBI::rows.
Changed DBI_TRACE env var so just does this at load time:
DBI->trace(split '=', $ENV{DBI_TRACE}, 2);
Added $h->parse_trace_flags("foo|SQL|7") to map a group of
trace flags into the corresponding trace flag bits.
Added automatic calling of parse_trace_flags() if
setting the trace level to a non-numeric value:
$h->{TraceLevel}="foo|SQL|7"; $h->trace("foo|SQL|7");
DBI->connect("dbi:Driver(TraceLevel=SQL|foo):...", ...);
Added to and reworked the trace documentation.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Fri Feb 27 14:35:48 2004
@@ -6,31 +6,40 @@
=head1 CHANGES in DBI 1.42 (svn rev XX), XXnd February 2004
-Document $t->trace_flags etc
+Document $t->parse_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.
Fixed DBD_ATTRIB_DELETE macro thanks to Marco Paskamp.
+ Fixed DBI::PurePerl looks_like_number() and $DBI::rows.
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.
+ 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.
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");
+ Major tracing enhancement:
- Major additions that Jeff Zucker and I have been working on:
+ Added $h->parse_trace_flags("foo|SQL|7") to map a group of
+ trace flags into the corresponding trace flag bits.
+ Added automatic calling of parse_trace_flags() if
+ setting the trace level to a non-numeric value:
+ $h->{TraceLevel}="foo|SQL|7"; $h->trace("foo|SQL|7");
+ DBI->connect("dbi:Driver(TraceLevel=SQL|foo):...", ...);
+ Added to and reworked the trace documentation.
+
+ Major driver additions that Jeff Zucker and I have been working on:
Added DBI::SQL::Nano a 'smaller than micro' SQL parser
with an SQL::Statement compatible API. If SQL::Statement
is installed then DBI::SQL::Nano becomes an empty subclass
of SQL::Statement, unless the DBI_SQL_NANO env var is true.
Added DBD::File, modified to use DBI::SQL::Nano.
- Added DBD::DBM that provides an SQL interface to DBM files.
+ Added DBD::DBM, an SQL interface to DBM files using DBD::File.
=head1 CHANGES in DBI 1.41 (svn rev 130), 22nd February 2004
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Fri Feb 27 14:35:48 2004
@@ -230,7 +230,7 @@
) ], # notionally "in" DBI::Profile and normally imported from there
);
-$DBI::dbi_debug = $ENV{DBI_TRACE} || $ENV{PERL_DBI_DEBUG} || 0;
+$DBI::dbi_debug = 0;
$DBI::neat_maxlen = 400;
# If you get an error here like "Can't find loadable object ..."
@@ -251,11 +251,16 @@
}
-*trace_msg = \&DBD::_::common::trace_msg;
-*set_err = \&DBD::_::common::set_err;
+# Alias some handle methods to also be DBI class methods
+for (qw(trace_msg set_err parse_trace_flags parse_trace_flag)) {
+ no strict;
+ *$_ = \&{"DBD::_::common::$_"};
+}
use strict;
+DBI->trace(split '=', $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
+
$DBI::connect_via = "connect";
# check if user wants a persistent database connection ( Apache + mod_perl )
@@ -264,24 +269,8 @@
DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n");
}
-
-if ($DBI::dbi_debug) {
- @DBI::dbi_debug = ($DBI::dbi_debug);
-
- unless (DBI::looks_like_number($DBI::dbi_debug)) {
- # dbi_debug is a file name to write trace log to.
- # Default level is 2 but if file starts with "digits=" then the
- # digits (and equals) are stripped off and used as the level
- unshift @DBI::dbi_debug, 2;
- @DBI::dbi_debug = ($1,$2) if $DBI::dbi_debug =~ m/^(\d+)=(.*)/;
- $DBI::dbi_debug = $DBI::dbi_debug[0];
- }
- DBI->trace(@DBI::dbi_debug);
-}
-
%DBI::installed_drh = (); # maps driver names to installed driver handles
-
# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
# These are dynamically associated with the last handle used.
tie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list
@@ -367,8 +356,8 @@
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 },
+ parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 },
+ parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 },
);
%DBI::DBI_methods = ( # Define the DBI interface methods per class:
@@ -1235,30 +1224,33 @@
DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line",
\%attr);
}
- sub trace_flags {
+ sub parse_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) {
+ for my $word (split /\s*[|&]\s*/, $spec) {
+ if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) {
$level = $word;
- } elsif (my $flag = $h->trace_flag($word)) {
+ } elsif ($word eq 'ALL') {
+ $flags = 0x7FFFFFFF; # XXX last bit causes negative headaches
+ last;
+ } elsif (my $flag = $h->parse_trace_flag($word)) {
$flags |= $flag;
}
else {
push @unknown, $word;
}
}
- if (@unknown && $h->FETCH('Warn')) {
- warn "Unknown trace flags ignored: ".
- join(", ", map { DBI::neat($_) } @unknown);
+ if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) {
+ Carp::carp("$h->parse_trace_flags($spec): Unknown trace flags ignored: ".
+ join(" ", map { DBI::neat($_) } @unknown));
}
$flags |= $level;
return $flags;
}
- sub trace_flag {
+ sub parse_trace_flag {
my ($h, $name) = @_;
# 0xddDDDDrL (driver, DBI, reserved, Level)
return 0x00000100 if $name eq 'SQL';
@@ -2480,47 +2472,19 @@
=item C<trace>
- DBI->trace($trace_level)
- DBI->trace($trace_level, $trace_filename)
- $trace_level = DBI->trace;
-
-DBI trace information can be enabled for all handles using the C<trace>
-DBI class method. It sets the I<global default minimum> trace level.
-To enable trace information for a specific handle, use the similar
-C<$h-E<gt>trace> method described elsewhere.
+ DBI->trace($trace_setting)
+ DBI->trace($trace_setting, $trace_filename)
+ $trace_setting = DBI->trace;
+
+The C<DBI-E<gt>trace> method sets the I<global default> trace
+settings and returns the I<previous> trace settings. It can also
+be used to change where the trace output is sent.
-Trace levels are as follows:
-
- 0 - Trace disabled.
- 1 - Trace DBI method calls returning with results or errors.
- 2 - Trace method entry with parameters and returning with results.
- 3 - As above, adding some high-level information from the driver
- and some internal information from the DBI.
- 4 - As above, adding more detailed information from the driver.
- 5 and above - As above but with more and more obscure information.
-
-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
-specific problem, when you need to see "inside" the driver and DBI.
-
-The trace output is detailed and typically very useful. Much of the
-trace output is formatted using the L</neat> function, so strings
-in the trace output may be edited and truncated.
-
-Initially trace output is written to C<STDERR>. If C<$trace_filename> is
-specified and can be opened in append mode then all trace
-output (including that from other handles) is redirected to that file.
-A warning is generated is the file can't be opened.
-Further calls to C<trace> without a C<$trace_filename> do not alter where
-the trace output is sent. If C<$trace_filename> is undefined, then
-trace output is sent to C<STDERR> and the previous trace file is closed.
-The C<trace> method returns the I<previous> tracelevel.
-
-See also the C<$h-E<gt>trace> and C<$h-E<gt>trace_msg> methods and the
-L</DEBUGGING> section
-for information about the C<DBI_TRACE> environment variable.
+There's a similar method, C<$h-E<gt>trace>, which sets the trace
+settings for the specific handle it's called on.
+See the L</TRACING> section for full details about the DBI's powerful
+tracing facilities.
=back
@@ -2759,37 +2723,19 @@
=item C<trace>
- $h->trace($trace_level);
- $h->trace($trace_level, $trace_filename);
-
-DBI trace information can be enabled for a specific handle (and any
-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 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.
-
-The trace output is detailed and typically very useful. Much of the
-trace output is formatted using the L</neat> function, so strings
-in the trace output may be edited and truncated.
-
-Initially, trace output is written to C<STDERR>. If C<$trace_filename> is
-specified, then the file is opened in append mode and I<all> trace
-output (including that from other handles) is redirected to that file.
-Further calls to trace without a C<$trace_filename> do not alter where
-the trace output is sent. If C<$trace_filename> is undefined, then
-trace output is sent to C<STDERR> and the previous trace file is closed.
+ $h->trace($trace_settings);
+ $h->trace($trace_settings, $trace_filename);
+ $trace_settings = $h->trace;
+
+The trace() method is used to alter the trace settings for a handle
+(and any future children of that handle). It can also be used to
+change where the trace output is sent.
-See also the C<DBI-E<gt>trace> method, the C<$h-E<gt>{TraceLevel}> attribute,
-and L</DEBUGGING> for information about the C<DBI_TRACE> environment variable.
+There's a similar method, C<DBI-E<gt>trace>, which sets the global
+default trace settings.
+See the L</TRACING> section for full details about the DBI's powerful
+tracing facilities.
=item C<trace_msg>
@@ -3155,8 +3101,9 @@
=item C<TraceLevel> (integer, inherited)
-The C<TraceLevel> attribute can be used as an alternative to the L</trace> method
-to set the DBI trace level for a specific handle.
+The C<TraceLevel> attribute can be used as an alternative to the
+L</trace> method to set the DBI trace level and trace flags for a
+specific handle.
=item C<FetchHashKeyName> (string, inherited)
@@ -6177,34 +6124,88 @@
COMMON TO ALL HANDLES> for info and important caveats.
-=head1 DEBUGGING
+=head1 TRACING
+
+The DBI has a powerful tracing mechanism built in. It enables you
+to see what's going on 'behind the scenes', both within the DBI and
+the drivers you're using.
+
+=head2 Trace Settings
+
+Which details are written to the trace output is controlled by a
+combination of a I<trace level>, an integer from 0 to 15, and a set
+of I<trace flags> that are either on or off. Together these are known
+as the I<trace settings> and are stored together in a single integer.
+For normal use you only need to set the trace level, and generally
+only to a value between 1 and 4.
+
+Each handle has it's own trace settings, and so does the DBI.
+When you call a method the DBI merges the handles settings into its
+own for the duration of the call. The highest trace level of the
+two is used and the trace flags are OR'd together.
+
+=head1 Enabling Trace
+
+The C<$h-E<gt>trace> method sets the trace settings for a handle
+and C<DBI-E<gt>trace> does the same for the DBI.
In addition to the L</trace> method, you can enable the same trace
-information by setting the C<DBI_TRACE> environment variable before
-starting Perl.
+information, and direct the output to a file, by setting the
+C<DBI_TRACE> environment variable before starting Perl.
+See L</DBI_TRACE> for more information.
-On Unix-like systems using a Bourne-like shell, you can do this easily
-on the command line:
+Finally, you can set, or get, the trace settings for a handle using
+the C<TraceLevel> attribute.
- DBI_TRACE=2 perl your_test_script.pl
+=head2 Trace Levels
-If C<DBI_TRACE> is set to a non-numeric value, then it is assumed to
-be a file name and the trace level will be set to 2 with all trace
-output appended to that file. If the name begins with a number
-followed by an equal sign (C<=>), then the number and the equal sign are
-stripped off from the name, and the number is used to set the trace
-level. For example:
+Trace levels are as follows:
- DBI_TRACE=1=dbitrace.log perl your_test_script.pl
+ 0 - Trace disabled.
+ 1 - Trace DBI method calls returning with results or errors.
+ 2 - Trace method entry with parameters and returning with results.
+ 3 - As above, adding some high-level information from the driver
+ and some internal information from the DBI.
+ 4 - As above, adding more detailed information from the driver.
+ 5 and above - As above but with more and more obscure information.
+
+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 are best reserved for investigating a specific
+problem, when you need to see "inside" the driver and DBI.
+
+The trace output is detailed and typically very useful. Much of the
+trace output is formatted using the L</neat> function, so strings
+in the trace output may be edited and truncated.
+
+=head2 Trace Output
-See also the L</trace> method.
+Initially trace output is written to C<STDERR>. Both the
+C<$h-E<gt>trace> and C<DBI-E<gt>trace> methods take an optional
+$trace_filename parameter. If specified and can be opened in
+append mode then all trace output (including that from other handles)
+is redirected to that file. A warning is generated if the file
+can't be opened.
+
+Further calls to trace() without a $trace_filename do not alter where
+the trace output is sent. If $trace_filename is undefined, then
+trace output is sent to C<STDERR> and the previous trace file is closed.
+
+Currently $trace_filename can't be a filehandle. But meanwhile you
+can use the special strings C<"STDERR"> and C<"STDOUT"> to select
+those filehandles.
+
+=head2 Tracing Tips
+
+You can add tracing to your own application code using the
+C<$h-E<gt>trace_msg> method.
It can sometimes be handy to compare trace files from two different
runs of the same script. However using a tool like C<diff> doesn't work
well because the trace file is full of object addresses that may
differ each run. Here's a handy little command to strip those out:
- perl -pe 's/\b0x[\da-f]{6,}/0xNNNN/gi; s/\b[\da-f]{6,}/<long number>/gi'
+ perl -pe 's/\b0x[\da-f]{6,}/0xNNNN/gi; s/\b[\da-f]{6,}/<long number>/gi'
=head1 DBI ENVIRONMENT VARIABLES
@@ -6257,9 +6258,28 @@
=head2 DBI_TRACE
-The DBI_TRACE environment variable takes an integer value that
-specifies the trace level for DBI at startup. Can also be used to
-direct trace output to a file. See L</DEBUGGING> for more information.
+The DBI_TRACE environment variable specifies the global default
+trace settings for the DBI at startup. Can also be used to direct
+trace output to a file. When the DBI is loaded it does:
+
+ DBI->trace(split '=', $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
+
+So if C<DBI_TRACE> contains an "C<=>" character then what follows
+it is used as the name of the file to append the trace to.
+
+output appended to that file. If the name begins with a number
+followed by an equal sign (C<=>), then the number and the equal sign are
+stripped off from the name, and the number is used to set the trace
+level. For example:
+
+ DBI_TRACE=1=dbitrace.log perl your_test_script.pl
+
+On Unix-like systems using a Bourne-like shell, you can do this easily
+on the command line:
+
+ DBI_TRACE=2 perl your_test_script.pl
+
+See L</TRACING> for more information.
=head2 PERL_DBI_DEBUG (obsolete)
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Fri Feb 27 14:35:48 2004
@@ -219,7 +219,7 @@
DBIS->logmsg = dbih_logmsg;
DBIS->logfp = PerlIO_stderr();
DBIS->debug = (parent_dbis) ? parent_dbis->debug
- : atoi((p=getenv("DBI_TRACE")) ? p : "0");
+ : SvIV(perl_get_sv("DBI::dbi_debug",0x5));
DBIS->neatsvpvlen = (parent_dbis) ? parent_dbis->neatsvpvlen
: perl_get_sv("DBI::neat_maxlen", GV_ADDMULTI);
#ifdef DBI_USE_THREADS
@@ -618,24 +618,52 @@
}
+static IV
+parse_trace_flags(SV *h, SV *level_sv, IV old_level)
+{
+ IV level;
+ if (SvTRUE(level_sv)) {
+ if (looks_like_number(level_sv) && SvIV(level_sv)>=0)
+ level = SvIV(level_sv); /* number: number */
+ else { /* string: parse it */
+ dSP;
+ PUSHMARK(sp);
+ XPUSHs(h);
+ XPUSHs(level_sv);
+ PUTBACK;
+ if (perl_call_method("parse_trace_flags", G_SCALAR) != 1)
+ croak("panic: parse_trace_flags");/* should never happen */
+ SPAGAIN;
+ level = POPi;
+ PUTBACK;
+ }
+ }
+ else if (SvOK(level_sv))
+ level = 0; /* defined but false: 0 */
+ else
+ level = old_level; /* undef: no change */
+ return level;
+}
+
+
static int
-set_trace(SV *h, I32 level, SV *file)
+set_trace(SV *h, SV *level_sv, SV *file)
{
dPERINTERP;
D_imp_xxh(h);
- /* Return trace level in effect now. No change if new value not given */
- int RETVAL = DBIS->debug;
+ int RETVAL = DBIS->debug; /* Return trace level in effect now */
+ IV level = parse_trace_flags(h, level_sv, RETVAL);
set_trace_file(file);
- if (level != RETVAL) { /* set value */
- if (level > 0) {
+ if (level != RETVAL) { /* set value */
+ if ((level & DBIc_TRACE_LEVEL_MASK) > 0) {
PerlIO_printf(DBIc_LOGPIO(imp_xxh),
- " %s trace level set to %ld/%ld (DBI @ %ld/%ld) in DBI %s%s (pid
%d)\n",
+ " %s trace level set to 0x%lx/%ld (DBI @ Ox%lx/%ld) in DBI %s%s
(pid %d)\n",
neatsvpv(h,0),
(long)(level & DBIc_TRACE_LEVEL_MASK),
(long)(level & ~DBIc_TRACE_LEVEL_MASK),
DBIc_TRACE_LEVEL(imp_xxh), DBIc_TRACE_FLAGS(imp_xxh),
XS_VERSION, dbi_build_opt, (int)PerlProc_getpid());
- if (!PL_dowarn && level>0)
+ if (!PL_dowarn)
PerlIO_printf(DBIc_LOGPIO(imp_xxh)," Note: perl is running without
the recommended perl -w option\n");
PerlIO_flush(DBIc_LOGPIO(imp_xxh));
}
@@ -1476,7 +1504,7 @@
DBIc_set(imp_xxh,DBIcf_BegunWork, on);
}
else if (keylen==10 && strEQ(key, "TraceLevel")) {
- set_trace(h, (int)SvIV(valuesv), Nullsv);
+ set_trace(h, valuesv, Nullsv);
}
else if (keylen==9 && strEQ(key, "TraceFile")) { /* XXX undocumented and
readonly */
set_trace_file(valuesv);
@@ -2462,12 +2490,11 @@
/* record this inner handle for use by DBI::var::FETCH */
if (is_DESTROY) {
- SV *lhp = DBIc_PARENT_H(imp_xxh);
if (DBIc_TYPE(imp_xxh) <= DBIt_DB ) { /* is dbh or drh */
imp_xxh_t *parent_imp;
- if (SvTRUE(DBIc_ERR(imp_xxh)) && (parent_imp = DBIc_PARENT_COM(imp_xxh)) )
{
+ if (SvOK(DBIc_ERR(imp_xxh)) && (parent_imp = DBIc_PARENT_COM(imp_xxh)) ) {
/* copy err/errstr/state values to $DBI::err etc still work */
sv_setsv(DBIc_ERR(parent_imp), DBIc_ERR(imp_xxh));
sv_setsv(DBIc_ERRSTR(parent_imp), DBIc_ERRSTR(imp_xxh));
@@ -2479,6 +2506,7 @@
}
if (DBI_IS_LAST_HANDLE(h)) { /* if destroying _this_ handle */
+ SV *lhp = DBIc_PARENT_H(imp_xxh);
if (lhp && SvROK(lhp)) {
DBI_SET_LAST_HANDLE(lhp);
}
@@ -2680,9 +2708,10 @@
SvTRUE(err_sv) ? "ERROR:" : strlen(SvPV_nolen(err_sv)) ? "warn:" :
"info:",
neatsvpv(err_sv,0), neatsvpv(DBIc_ERRSTR(imp_xxh),0));
}
- PerlIO_printf(logfp,"%c%c <- %s",
+ PerlIO_printf(logfp,"%c%c <%c %s",
(call_depth > 1) ? '0'+call_depth-1 : (dirty?'!':' '),
(DBIc_is(imp_xxh, DBIcf_TaintIn|DBIcf_TaintOut)) ? 'T' : ' ',
+ (qsv) ? '>' : '-',
meth_name);
if (trace_level==1 && items>=2) { /* make level 1 more useful */
/* we only have the first two parameters available here */
@@ -3491,8 +3520,8 @@
int
-trace(sv, level_sv=Nullsv, file=Nullsv)
- SV * sv
+trace(class, level_sv=&sv_undef, file=Nullsv)
+ SV * class
SV * level_sv
SV * file
ALIAS:
@@ -3500,18 +3529,20 @@
CODE:
{
dPERINTERP;
+ /* Return old/current value. No change if new value not given. */
+ IV level = parse_trace_flags(class, level_sv, (RETVAL = (DBIS) ? DBIS->debug :
0));
if (!DBIS) {
- sv=sv; ix=ix; /* avoid 'unused variable' warnings */
+ ix=ix; /* avoid 'unused variable' warnings */
croak("DBI not initialised");
}
- /* Return old/current value. No change if new value not given. */
- RETVAL = DBIS->debug;
set_trace_file(file); /* always call this regardless of level */
- if (level_sv && SvOK(level_sv) && SvIV(level_sv) != RETVAL) {
- int level = SvIV(level_sv);
- if (level > 0) {
- PerlIO_printf(DBILOGFP," DBI %s%s dispatch trace level set to %d (in
pid %d)\n",
- XS_VERSION, dbi_build_opt, level, (int)PerlProc_getpid());
+ if (level != RETVAL) {
+ if ((level & DBIc_TRACE_LEVEL_MASK) > 0) {
+ PerlIO_printf(DBILOGFP," DBI %s%s default trace level set to Ox%lx/%ld
(in pid %d)\n",
+ XS_VERSION, dbi_build_opt,
+ (long)(level & DBIc_TRACE_LEVEL_MASK),
+ (long)(level & ~DBIc_TRACE_LEVEL_MASK),
+ (int)PerlProc_getpid());
if (!PL_dowarn)
PerlIO_printf(DBILOGFP," Note: perl is running without the
recommended perl -w option\n");
PerlIO_flush(DBILOGFP);
@@ -4033,7 +4064,7 @@
int
trace(h, level=0, file=Nullsv)
SV *h
- I32 level
+ SV *level
SV *file
ALIAS:
debug = 1
Modified: dbi/trunk/Driver.xst
==============================================================================
--- dbi/trunk/Driver.xst (original)
+++ dbi/trunk/Driver.xst Fri Feb 27 14:35:48 2004
@@ -323,9 +323,9 @@
if (!DBIc_IMPSET(imp_dbh)) { /* was never fully set up */
STRLEN lna;
if (DBIc_WARN(imp_dbh) && !dirty && DBIc_DBISTATE(imp_dbh)->debug >= 2)
- PerlIO_printf(DBILOGFP,
+ PerlIO_printf(DBIc_LOGPIO(imp_dbh),
" DESTROY for %s ignored - handle not initialised\n",
- SvPV(dbh,lna));
+ SvPV(dbh,lna));
}
else {
/* pre-disconnect checks and tidy-ups */
@@ -703,7 +703,7 @@
STRLEN lna;
if (DBIc_WARN(imp_sth) && !dirty && DBIc_DBISTATE(imp_sth)->debug >= 2)
PerlIO_printf(DBIc_LOGPIO(imp_sth),
- "Statement handle %s DESTROY ignored - never set up\n",
+ " DESTROY for %s ignored - handle not initialised\n",
SvPV(sth,lna));
}
else {
Modified: dbi/trunk/ToDo
==============================================================================
--- dbi/trunk/ToDo (original)
+++ dbi/trunk/ToDo Fri Feb 27 14:35:48 2004
@@ -168,6 +168,8 @@
Remove dummy 'Switch' driver.
+Add %time to per-node DBI::Profile dump
+
Sponge behave_like - generalize into new_child()
copy RaiseError, PrintError, HandleError etc from the specified handle
but which attributes? LongReadLen, LongTruncOk etc? Presumably all
Modified: dbi/trunk/lib/DBD/ExampleP.pm
==============================================================================
--- dbi/trunk/lib/DBD/ExampleP.pm (original)
+++ dbi/trunk/lib/DBD/ExampleP.pm Fri Feb 27 14:35:48 2004
@@ -249,14 +249,14 @@
grep { $_ =~ /$re/ } $dbh->tables();
}
- sub trace_flag {
+ sub parse_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);
+ return $h->SUPER::parse_trace_flag($name);
}
}
@@ -395,7 +395,7 @@
sub DESTROY { undef }
- *trace_flag = \&DBD::ExampleP::db::trace_flag;
+ *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag;
}
1;
Modified: dbi/trunk/lib/DBI/DBD.pm
==============================================================================
--- dbi/trunk/lib/DBI/DBD.pm (original)
+++ dbi/trunk/lib/DBI/DBD.pm Fri Feb 27 14:35:48 2004
@@ -1263,16 +1263,16 @@
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).
+parse_trace_flag() method (note that's parse_trace_flag not parse_trace_flags).
- sub trace_flag {
+ sub parse_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);
+ return $h->SUPER::parse_trace_flag($name);
}
All private flag names must be lowercase, and all private flags
@@ -1471,10 +1471,10 @@
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
+If you've defined a parse_trace_flag() method in ::db you'll also want
it in ::st, so just alias it in:
- *trace_flag = \&DBD::foo:db::trace_flag;
+ *parse_trace_flag = \&DBD::foo:db::parse_trace_flag;
And perhaps some other methods that are not part of the DBI
specification, in particular to make metadata available.
@@ -2179,7 +2179,7 @@
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
+DBIc_TRACE_FLAGS(imp), that is: 0xFF000000. See the parse_trace_flag() method
elsewhere in this document.
=cut
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Fri Feb 27 14:35:48 2004
@@ -174,8 +174,8 @@
untie $DBI::err;
untie $DBI::errstr;
untie $DBI::state;
+ untie $DBI::rows;
#tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean
- #tie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg
}
sub _install_method {
@@ -439,12 +439,15 @@
}
sub trace {
my ($h, $level, $file) = @_;
+ $level = $h->parse_trace_flags($level)
+ if defined $level and !DBI::looks_like_number($level);
my $old_level = $DBI::dbi_debug;
_set_trace_file($file);
if (defined $level) {
$DBI::dbi_debug = $level;
print $DBI::tfh " DBI $DBI::VERSION (PurePerl) "
- . "dispatch trace level set to $DBI::dbi_debug\n" if $DBI::dbi_debug;
+ . "dispatch trace level set to $DBI::dbi_debug\n"
+ if $DBI::dbi_debug & 0xF;
if ($level==0 and fileno($DBI::tfh)) {
_set_trace_file("");
}
@@ -534,19 +537,16 @@
if (!defined $thing or $thing eq '') {
push @new, undef;
}
- elsif ( ($thing & ~ $thing) eq "0") { # magic from Randal
- push @new, 1;
- }
else {
- push @new, 0;
- }
+ push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/)
? 1 : 0;
+ }
}
return (@_ >1) ? @new : $new[0];
}
sub neat {
my $v = shift;
return "undef" unless defined $v;
- return $v if looks_like_number($v);
+ return $v if (($v & ~ $v) eq "0"); # is SvNIOK
my $maxlen = shift || $DBI::neat_maxlen;
if ($maxlen && $maxlen < length($v) + 2) {
$v = substr($v,0,$maxlen-5);
@@ -562,7 +562,7 @@
my($key)=shift;
return $DBI::err if $$key eq '*err';
return $DBI::errstr if $$key eq '&errstr';
- Carp::croak("FETCH $key not supported when using DBI::PurePerl");
+ Carp::confess("FETCH $key not supported when using DBI::PurePerl");
}
package
@@ -570,6 +570,8 @@
sub trace { # XXX should set per-handle level, not global
my ($h, $level, $file) = @_;
+ $level = $h->parse_trace_flags($level)
+ if defined $level and !DBI::looks_like_number($level);
my $old_level = $DBI::dbi_debug;
DBI::_set_trace_file($file) if defined $file;
if (defined $level) {
@@ -754,7 +756,7 @@
sub dbih_setup_fbav {
my $h = shift;
return $h->{'_fbav'} || do {
- $DBI::PurePerl::var->{rows} = $h->{'_rows'} = 0;
+ $DBI::rows = $h->{'_rows'} = 0;
my $fields = $h->{'NUM_OF_FIELDS'}
or DBI::croak("NUM_OF_FIELDS not set");
my @row = (undef) x $fields;
@@ -764,14 +766,14 @@
sub _get_fbav {
my $h = shift;
my $av = $h->{'_fbav'} ||= dbih_setup_fbav($h);
- ++$h->{'_rows'};
+ $DBI::rows = ++$h->{'_rows'};
return $av;
}
sub _set_fbav {
my $h = shift;
my $fbav = $h->{'_fbav'};
if ($fbav) {
- ++$h->{'_rows'};
+ $DBI::rows = ++$h->{'_rows'};
}
else {
$fbav = $h->_get_fbav;
@@ -805,7 +807,7 @@
}
sub rows {
my $h = shift;
- my $rows = $h->{'_rows'} || $DBI::PurePerl::var->{rows};
+ my $rows = $h->{'_rows'};
return -1 unless defined $rows;
return $rows;
}
Modified: dbi/trunk/t/01basics.t
==============================================================================
--- dbi/trunk/t/01basics.t (original)
+++ dbi/trunk/t/01basics.t Fri Feb 27 14:35:48 2004
@@ -81,18 +81,21 @@
ok(0, SQL_VARCHAR == 12);
ok(0, SQL_ALL_TYPES == 0);
-ok(0, neat(1+1) eq "2");
-ok(0, neat("2") eq "'2'");
-ok(0, neat(undef) eq "undef");
-ok(0, neat_list([1+1, "2", undef, "foobarbaz"], 8, "|") eq "2|'2'|undef|'foo...'");
-my @is_num = looks_like_number(undef, "", "foo", 1, ".");
+my @is_num = looks_like_number(undef, "", "foo", 1, ".", 2, "2");
ok(0, !defined $is_num[0]); # undef -> undef
ok(0, !defined $is_num[1]); # "" -> undef (eg "don't know")
ok(0, defined $is_num[2]); # "foo" -> defined false
ok(0, !$is_num[2]); # "foo" -> defined false
ok(0, $is_num[3]); # 1 -> true
ok(0, !$is_num[4]); # "." -> false
+ok(0, $is_num[5]); # 1 -> true
+ok(0, $is_num[6]); # 1 -> true
+
+ok(0, neat(1+1) eq "2");
+ok(0, neat("2") eq "'2'");
+ok(0, neat(undef) eq "undef");
+ok(0, neat_list([1+1, "2", undef, "foobarbaz"], 8, "|") eq "2|'2'|undef|'foo...'");
ok(0, DBI::hash("foo1" ) == -1077531989, DBI::hash("foo1"));
ok(0, DBI::hash("foo1",0) == -1077531989, DBI::hash("foo1",0));
@@ -117,5 +120,5 @@
ok(0, @installed_drivers >= 1);
ok(0, grep { $_ eq 'Sponge' } @installed_drivers);
-BEGIN { $tests = 43 }
+BEGIN { $tests = 45 }
exit 0;
Modified: dbi/trunk/t/09trace.t
==============================================================================
--- dbi/trunk/t/09trace.t (original)
+++ dbi/trunk/t/09trace.t Fri Feb 27 14:35:48 2004
@@ -5,7 +5,7 @@
use Test::More;
use DBI;
-BEGIN { plan tests => 32 }
+BEGIN { plan tests => 53 }
$|=1;
@@ -25,46 +25,71 @@
is( $dbh->{TraceLevel}, $DBI::dbi_debug & 0xF);
+my $trace_file = "dbitrace.log";
+print "trace to file $trace_file\n";
+1 while unlink $trace_file;
+$dbh->trace(0, $trace_file);
+ok( -f $trace_file );
+
my @names = qw(
SQL
foo bar baz boo bop
);
my %flag;
+my $all_flags = 0;
foreach my $name (@names) {
- print "trace_flag $name\n";
- ok( my $flag1 = $dbh->trace_flag($name) );
- ok( my $flag2 = $dbh->trace_flags($name) );
+ print "parse_trace_flag $name\n";
+ ok( my $flag1 = $dbh->parse_trace_flag($name) );
+ ok( my $flag2 = $dbh->parse_trace_flags($name) );
is( $flag1, $flag2 );
+
+ $dbh->{TraceLevel} = $flag1;
+ is( $dbh->{TraceLevel}, $flag1 );
+ $dbh->{TraceLevel} = 0;
+ is( $dbh->{TraceLevel}, 0 );
+ $dbh->{TraceLevel} = $name; # set by name
+ $dbh->{TraceLevel} = undef; # check no change on undef
+ is( $dbh->{TraceLevel}, $flag1 );
+
$flag{$name} = $flag1;
+ $all_flags |= $flag1
+ if defined $flag1; # reduce noise if there's a bug
}
+print "parse_trace_flag @names\n";
is keys %flag, @names;
+$dbh->{TraceLevel} = 0;
+$dbh->{TraceLevel} = join "|", @names;
+is $dbh->{TraceLevel}, $all_flags;
+
+{
+print "inherit\n";
+ok( my $sth = $dbh->prepare("select ctime, name from foo") );
+is( $sth->{TraceLevel}, $all_flags );
+}
+
+$dbh->{TraceLevel} = 0;
+ok !$dbh->{TraceLevel};
+$dbh->{TraceLevel} = 'ALL';
+ok $dbh->{TraceLevel};
{
-print "unknown trace_flag\n";
+print "unknown parse_trace_flag\n";
my $warn = 0;
-local $SIG{__WARN__} = sub { ($_[0] =~ /unknown/i) ? ++$warn : warn @_ };
-is $dbh->trace_flag("nonesuch"), undef;
+local $SIG{__WARN__} = sub {
+ if ($_[0] =~ /unknown/i) { ++$warn; print "warn: ",@_ }else{ warn @_ }
+};
+is $dbh->parse_trace_flag("nonesuch"), undef;
is $warn, 0;
-is $dbh->trace_flags("nonesuch"), 0;
+is $dbh->parse_trace_flags("nonesuch"), 0;
is $warn, 1;
+is $dbh->parse_trace_flags("nonesuch|SQL|nonesuch2"), $dbh->parse_trace_flag("SQL");
+is $warn, 2;
}
-print "trace file & TraceLevel changes\n";
-ok( my $sth = $dbh->prepare("select ctime, name from foo") );
-
-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
+$dbh->trace(0);
+ok !$dbh->{TraceLevel};
+$dbh->trace(undef, "STDERR"); # close $trace_file
ok( -s $trace_file );
1;
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Fri Feb 27 14:35:48 2004
@@ -375,6 +375,7 @@
$rows = $csr_b->rows;
ok(0, $rows > 0, "row count $rows");
ok(0, $rows == @$r, "$rows vs "[EMAIL PROTECTED]);
+ok(0, $rows == $DBI::rows, "$rows vs $DBI::rows");
#$csr_b->trace(0);
# ---
@@ -671,4 +672,4 @@
exit 0;
-BEGIN { $tests = 245; }
+BEGIN { $tests = 246; }
Modified: dbi/trunk/t/50dbm.t
==============================================================================
--- dbi/trunk/t/50dbm.t (original)
+++ dbi/trunk/t/50dbm.t Fri Feb 27 14:35:48 2004
@@ -57,6 +57,7 @@
is $DBI::rows, keys %$expected_results;
}
+1;
__DATA__
DROP TABLE fruit;
CREATE TABLE fruit (dKey INT, dVal VARCHAR(10));
