Author: timbo
Date: Sun Jul 30 15:42:07 2006
New Revision: 6734
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.xs
dbi/trunk/MANIFEST
dbi/trunk/lib/DBD/ExampleP.pm
dbi/trunk/lib/DBD/File.pm
dbi/trunk/lib/DBI/Profile.pm
dbi/trunk/lib/DBI/ProfileData.pm
dbi/trunk/lib/DBI/ProfileDumper.pm
dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
dbi/trunk/t/40profile.t
dbi/trunk/test.pl
Log:
Fixed memory leak (per handle) thanks to Nicholas Clark and Ephraim Dan.
Refactored dbi_caller and related code for log_where for profiling.
Added '!File', '!File2', '!Caller', '!Caller2' for Profile Path.
Added '&subname' support to Profile Path (_auto_new) - undocumented currently.
Updated ProfileDumper docs for new DBI_PROFILE syntax.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Sun Jul 30 15:42:07 2006
@@ -4,22 +4,26 @@
=cut
-=head2 Changes in DBI 1.52 (svn rev XXX), XXX
+XXX update docs for Profile &subname magic Path elements
-XXX update DBD::File (as sub-module?) to match latest.
-XXX update docs for Profile !Foo magic vars and code refs.
+=head2 Changes in DBI 1.52 (svn rev 6734), 30h July 2006
+ Fixed memory leak (per handle) thanks to Nicholas Clark and Ephraim Dan.
Fixed memory leak (16 bytes per sth) thanks to Doru Theodor Petrescu.
- Fixed memory leak (per handle) thanks to Nicholas Clark.
- A small leak remains, probably since DBI 1.49.
Fixed execute_for_fetch/execute_array to RaiseError thanks to Martin J.
Evans.
+ Fixed for perl 5.9.4. Users of Perl >= 5.9.4 will require DBI >= 1.52.
- Changed parsing of non-numeric DBI_PROFILE env var values.
- Changed DBI::Profile docs extensively.
+ Updated DBD::File to 0.35 to match the latest release on CPAN.
- Added ability for DBI::Profile Path to contain code refs - cool!
Added $dbh->statistics_info specification thanks to Brandon Black.
+ Many changes and additions to profiling:
+ Profile Path can now uses sane strings instead of obscure numbers,
+ can refer to attributes, assorted magical values, and even code refs!
+ Parsing of non-numeric DBI_PROFILE env var values has changed.
+ Changed DBI::Profile docs extensively - many new features.
+ See DBI::Profile docs for more information.
+
=head2 Changes in DBI 1.51 (svn rev 6475), 6th June 2006
Fixed $dbh->clone method 'signature' thanks to Jeffrey Klein.
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Sun Jul 30 15:42:07 2006
@@ -1082,7 +1082,7 @@
/* add weakref to new (outer) handle into parents ChildHandles
array */
tmp_svp = hv_fetch((HV*)SvRV(parent), "ChildHandles", 12, 1);
if (!SvROK(*tmp_svp)) {
- SV *ChildHandles_rvav = newRV((SV*)newAV());
+ SV *ChildHandles_rvav = newRV_noinc((SV*)newAV());
sv_setsv(*tmp_svp, ChildHandles_rvav);
sv_free(ChildHandles_rvav);
}
@@ -2102,8 +2102,8 @@
}
-static char *
-dbi_caller(long *line)
+static COP *
+dbi_caller_cop()
{
dTHX;
register I32 cxix;
@@ -2112,7 +2112,6 @@
PERL_SI *top_si = PL_curstackinfo;
char *stashname;
- *line = -1;
for ( cxix = dbi_dopoptosub_at(ccstack, cxstack_ix) ;; cxix =
dbi_dopoptosub_at(ccstack, cxix - 1)) {
/* we may be in a higher stacklevel, so dig down deeper */
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
@@ -2129,50 +2128,56 @@
stashname = CopSTASHPV(cx->blk_oldcop);
if (!stashname)
continue;
- if (!(stashname[0] == 'D'
- && stashname[1] == 'B'
- && strchr("DI", stashname[2])
- && (!stashname[3] || (stashname[3] == ':' && stashname[4] ==
':'))))
+ if (!(stashname[0] == 'D' && stashname[1] == 'B'
+ && strchr("DI", stashname[2])
+ && (!stashname[3] || (stashname[3] == ':' && stashname[4]
== ':'))))
{
- STRLEN len;
- *line = (I32)CopLINE(cx->blk_oldcop);
- return SvPV(GvSV(CopFILEGV(cx->blk_oldcop)), len);
+ return cx->blk_oldcop;
}
cxix = dbi_dopoptosub_at(ccstack, cxix - 1);
}
return NULL;
}
+static void
+dbi_caller_string(SV *buf, COP *cop, char *prefix, char *suffix, int
show_line, int show_caller, int show_path)
+{
+ dTHX;
+ STRLEN len;
+ long line = CopLINE(cop);
+ char *file = SvPV(GvSV(CopFILEGV(cop)), len);
+ if (!show_path) {
+ char *sep;
+ if ( (sep=strrchr(file,'/')) || (sep=strrchr(file,'\\')))
+ file = sep+1;
+ }
+ if (show_line) {
+ sv_catpvf(buf, "%s%s line %ld", (prefix) ? prefix : "", file, line);
+ }
+ else {
+ sv_catpvf(buf, "%s%s", (prefix) ? prefix : "", file);
+ }
+}
static char *
-log_where(SV *buf, int append, char *prefix, char *suffix, int show_caller,
int show_path)
+log_where(SV *buf, int append, char *prefix, char *suffix, int show_line, int
show_caller, int show_path)
{
dTHX;
dTHR;
- if (!buf) {
- buf = sv_2mortal(newSV(80));
- sv_setpv(buf,"");
- }
- else
- if (!append)
+ if (!buf)
+ buf = sv_2mortal(newSVpv("",0));
+ else if (!append)
sv_setpv(buf,"");
if (CopLINE(curcop)) {
- STRLEN len;
- long near_line = CopLINE(curcop);
- char *near_file = SvPV(GvSV(CopFILEGV(curcop)), len);
- char *file = near_file;
- if (!show_path) {
- char *sep;
- if ( (sep=strrchr(file,'/')) || (sep=strrchr(file,'\\')))
- file = sep+1;
- }
- sv_catpvf(buf, "%s%s line %ld", (prefix) ? prefix : "", file,
near_line);
-
- if (show_caller) {
- long far_line;
- char *far_file = dbi_caller(&far_line);
- if (far_file && !(far_line==near_line && strEQ(far_file,near_file))
)
- sv_catpvf(buf, " via %s line %ld", far_file, far_line);
+ COP *cop;
+ char *buf_start = SvEND(buf);
+ dbi_caller_string(buf, curcop, prefix, suffix, show_line, show_caller,
show_path);
+ if (show_caller && (cop = dbi_caller_cop())) {
+ SV *via = sv_2mortal(newSVpv("",0));
+ dbi_caller_string(via, cop, prefix, suffix, show_line,
show_caller, show_path);
+ if (strNE(SvPV_nolen(via), buf_start)) {
+ sv_catpvf(buf, " via %s", SvPV_nolen(via));
+ }
}
}
if (dirty)
@@ -2386,8 +2391,17 @@
}
dest_node = _profile_next_node(dest_node, p);
}
+ else if (p[1] == 'F' && strEQ(p, "!File")) {
+ dest_node = _profile_next_node(dest_node, log_where(0,
0, "", "", 0, 0, 0));
+ }
+ else if (p[1] == 'F' && strEQ(p, "!File2")) {
+ dest_node = _profile_next_node(dest_node, log_where(0,
0, "", "", 0, 1, 0));
+ }
else if (p[1] == 'C' && strEQ(p, "!Caller")) {
- dest_node = _profile_next_node(dest_node, log_where(0,
0, "", "", 1, 0));
+ dest_node = _profile_next_node(dest_node, log_where(0,
0, "", "", 1, 0, 0));
+ }
+ else if (p[1] == 'C' && strEQ(p, "!Caller2")) {
+ dest_node = _profile_next_node(dest_node, log_where(0,
0, "", "", 1, 1, 0));
}
else {
warn("Unknown ! element in DBI::Profile Path: %s", p);
@@ -2587,7 +2601,7 @@
(dirty?'!':' '), meth_name, neatsvpv(h,0),
(long)SvREFCNT(h), (SvROK(h) ? (long)SvREFCNT(SvRV(h)) : (long)-1),
(long)items, (int)gimme, (long)ima_flags, (long)PerlProc_getpid());
- PerlIO_puts(logfp, log_where(0, 0, " at ","\n", (trace_level >= 3),
(trace_level >= 4)));
+ PerlIO_puts(logfp, log_where(0, 0, " at ","\n", 1, (trace_level >= 3),
(trace_level >= 4)));
PerlIO_flush(logfp);
}
@@ -3106,7 +3120,7 @@
PerlIO_printf(logfp," (not implemented)");
/* XXX add flag to show pid here? */
/* add file and line number information */
- PerlIO_puts(logfp, log_where(0, 0, " at ", "\n", (trace_level >= 3),
(trace_level >= 4)));
+ PerlIO_puts(logfp, log_where(0, 0, " at ", "\n", 1, (trace_level >= 3),
(trace_level >= 4)));
skip_meth_return_trace:
PerlIO_flush(logfp);
}
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Sun Jul 30 15:42:07 2006
@@ -36,6 +36,7 @@
lib/DBI/ProfileData.pm
lib/DBI/ProfileDumper.pm
lib/DBI/ProfileDumper/Apache.pm
+lib/DBI/ProfileSubs.pm
lib/DBI/ProxyServer.pm The proxy drivers server
lib/DBI/PurePerl.pm A DBI.xs emulation in Perl
lib/DBI/SQL/Nano.pm A 'smaller than micro' SQL parser
Modified: dbi/trunk/lib/DBD/ExampleP.pm
==============================================================================
--- dbi/trunk/lib/DBD/ExampleP.pm (original)
+++ dbi/trunk/lib/DBD/ExampleP.pm Sun Jul 30 15:42:07 2006
@@ -317,9 +317,10 @@
}
else {
$sth->{dbd_dir} = $dir;
- $sth->{dbd_datahandle} = Symbol::gensym(); #
"DBD::ExampleP::".++$DBD::ExampleP::gensym;
- opendir($sth->{dbd_datahandle}, $dir)
- or return $sth->set_err(2, "opendir($dir): $!");
+ my $sym = Symbol::gensym(); #
"DBD::ExampleP::".++$DBD::ExampleP::gensym;
+ opendir($sym, $dir)
+ or return $sth->set_err(2, "opendir($dir): $!");
+ $sth->{dbd_datahandle} = $sym;
}
$sth->STORE(Active => 1);
return 1;
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Sun Jul 30 15:42:07 2006
@@ -29,7 +29,7 @@
use vars qw(@ISA $VERSION $drh $valid_attrs);
-$VERSION = '0.33';
+$VERSION = '0.35';
$drh = undef; # holds driver handle(s) once initialised
Modified: dbi/trunk/lib/DBI/Profile.pm
==============================================================================
--- dbi/trunk/lib/DBI/Profile.pm (original)
+++ dbi/trunk/lib/DBI/Profile.pm Sun Jul 30 15:42:07 2006
@@ -182,7 +182,7 @@
push @Path, "!Statement" if $path_elem & 0x02;
push @Path, "!MethodName" if $path_elem & 0x04;
push @Path, "!MethodClass" if $path_elem & 0x08;
- push @Path, "!Caller" if $path_elem & 0x10;
+ push @Path, "!Caller2" if $path_elem & 0x10;
So "2" is the same as "!Statement" and "6" (2+4) is the same as
"!Statement:!Method". Those are the two most commonly used values. Using a
@@ -267,9 +267,21 @@
B<!Caller>
+Use a string showing the filename and line number of the code calling the
method.
+
+B<!Caller2>
+
Use a string showing the filename and line number of the code calling the
-method, and the filename and line number of the code that called that.
-The content and format of the string may change.
+method, as for !Caller, but also include filename and line number of the code
+that called that. Calls from DBI:: and DBD:: packages are skipped.
+
+B<!File>
+
+Same as !Caller above except that only the filename is included, not the line
number.
+
+B<!File2>
+
+Same as !Caller2 above except that only the filenames are included, not the
line number.
=item Code Reference
@@ -496,7 +508,8 @@
Applications which generate many different statement strings
(typically because they don't use placeholders) and profile with
!Statement in the Path (the default) will consume memory
-in the Profile Data structure for each statement.
+in the Profile Data structure for each statement. Use a code ref
+in the Path to return an edited (simplified) form of the statement.
If a method throws an exception itself (not via RaiseError) then
it won't be counted in the profile.
@@ -552,7 +565,6 @@
DBIprofile_Statement
DBIprofile_MethodName
DBIprofile_MethodClass
- DBIprofile_Caller
dbi_profile
dbi_profile_merge
dbi_time
@@ -564,7 +576,6 @@
use constant DBIprofile_Statement => '!Statement';
use constant DBIprofile_MethodName => '!MethodName';
use constant DBIprofile_MethodClass => '!MethodClass';
-use constant DBIprofile_Caller => '!Caller';
$ON_DESTROY_DUMP = sub { DBI->trace_msg(shift, 0) };
@@ -596,17 +607,25 @@
if (DBI::looks_like_number($element)) {
my $reverse = ($element < 0) ? ($element=-$element, 1) : 0;
my @p;
+ # a single "DBI" is special-cased in format()
push @p, "DBI" if $element & 0x01;
push @p, DBIprofile_Statement if $element & 0x02;
push @p, DBIprofile_MethodName if $element & 0x04;
push @p, DBIprofile_MethodClass if $element & 0x08;
- push @p, DBIprofile_Caller if $element & 0x10;
+ push @p, '!Caller2' if $element & 0x10;
push @Path, ($reverse ? reverse @p : @p);
}
- elsif ($element =~ /^&(\w.*)/) {
- # XXX need to work out what package to map names into
- warn "$element style elements not yet supported in Path";
- push @Path, $element;
+ elsif ($element =~ m/^&(\w.*)/) {
+ my $name = "DBI::ProfileSubs::$1"; # capture $1 early
+ require DBI::ProfileSubs;
+ my $code = do { no strict; *{$name}{CODE} };
+ if (defined $code) {
+ push @Path, $code;
+ }
+ else {
+ warn "$name: subroutine not found\n";
+ push @Path, $element;
+ }
}
else {
push @Path, $element;
@@ -645,7 +664,7 @@
$prologue .= sprintf "(%d calls) $progname \@ $ts\n", $count;
}
if (@$leaves == 1 && ref($self->{Data}) eq 'HASH' &&
$self->{Data}->{DBI}) {
- $detail = ""; # hide it
+ $detail = ""; # hide the "DBI" from DBI_PROFILE=1
}
}
return ($prologue, $detail) if wantarray;
Modified: dbi/trunk/lib/DBI/ProfileData.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileData.pm (original)
+++ dbi/trunk/lib/DBI/ProfileData.pm Sun Jul 30 15:42:07 2006
@@ -130,6 +130,10 @@
s!(([NS],){100,})!sprintf("$2,{repeated %d times}",length($1)/2)!eg;
}
+It's often better to perform this kinds of normalization in the DBI while the
+data is being collected, to avoid too much memory being used by storing profile
+data for many different SQL statement. See L<DBI::Profile>.
+
=cut
sub new {
@@ -294,9 +298,9 @@
data format. For example:
$header = {
- Path => '[ DBIprofile_Statement, DBIprofile_MethodName ]',
- Program => 't/42profile_data.t',
- };
+ Path => [ '!Statement', '!MethodName' ],
+ Program => 't/42profile_data.t',
+ };
Note that modifying this hash will modify the header data stored
inside the profile object.
Modified: dbi/trunk/lib/DBI/ProfileDumper.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileDumper.pm (original)
+++ dbi/trunk/lib/DBI/ProfileDumper.pm Sun Jul 30 15:42:07 2006
@@ -11,7 +11,7 @@
DBI_PROFILE environment variable and run your program as usual. For
example, using bash:
- DBI_PROFILE=DBI::ProfileDumper program.pl
+ DBI_PROFILE=2/DBI::ProfileDumper program.pl
Then analyze the generated file (F<dbi.prof>) with L<dbiprof|dbiprof>:
@@ -22,15 +22,15 @@
use DBI;
# profile with default path (2) and output file (dbi.prof)
- $dbh->{Profile} = "DBI::ProfileDumper";
+ $dbh->{Profile} = "2/DBI::ProfileDumper";
# same thing, spelled out
- $dbh->{Profile} = "2/DBI::ProfileDumper/File/dbi.prof";
+ $dbh->{Profile} = "2/DBI::ProfileDumper/File:dbi.prof";
# another way to say it
- use DBI::Profile qw(DBIprofile_Statement);
+ use DBI::Profile;
$dbh->{Profile} = DBI::ProfileDumper->new(
- Path => [ DBIprofile_Statement ]
+ Path => [ '!Statement' ]
File => 'dbi.prof' );
# using a custom path
@@ -53,15 +53,15 @@
One way to use this module is just to enable it in your C<$dbh>:
- $dbh->{Profile} = "DBI::ProfileDumper";
+ $dbh->{Profile} = "1/DBI::ProfileDumper";
This will write out profile data by statement into a file called
F<dbi.prof>. If you want to modify either of these properties, you
can construct the DBI::ProfileDumper object yourself:
- use DBI::Profile qw(DBIprofile_Statement);
+ use DBI::Profile;
$dbh->{Profile} = DBI::ProfileDumper->new(
- Path => [ DBIprofile_Statement ]
+ Path => [ '!Statement' ]
File => 'dbi.prof' );
The C<Path> option takes the same values as in
@@ -72,7 +72,7 @@
You can also activate this module by setting the DBI_PROFILE
environment variable:
- $ENV{DBI_PROFILE} = "DBI::ProfileDumper";
+ $ENV{DBI_PROFILE} = "!Statement/DBI::ProfileDumper";
This will cause all DBI handles to share the same profiling object.
@@ -105,7 +105,7 @@
newlines, the profile data forms the body of the file. For example:
DBI::ProfileDumper 1.0
- Path = [ DBIprofile_Statement, DBIprofile_MethodName ]
+ Path = [ '!Statement', '!MethodName' ]
Program = t/42profile_data.t
+ 1 SELECT name FROM users WHERE id = ?
@@ -212,15 +212,7 @@
my @path_words;
if ($self->{Path}) {
foreach (@{$self->{Path}}) {
- if ($_ eq DBI::Profile::DBIprofile_Statement) {
- push @path_words, "DBIprofile_Statement";
- } elsif ($_ eq DBI::Profile::DBIprofile_MethodName) {
- push @path_words, "DBIprofile_MethodName";
- } elsif ($_ eq DBI::Profile::DBIprofile_MethodClass) {
- push @path_words, "DBIprofile_MethodClass";
- } else {
- push @path_words, $_;
- }
+ push @path_words, $_;
}
}
print $fh "Path = [ ", join(', ', @path_words), " ]\n";
Modified: dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileDumper/Apache.pm (original)
+++ dbi/trunk/lib/DBI/ProfileDumper/Apache.pm Sun Jul 30 15:42:07 2006
@@ -8,7 +8,7 @@
Add this line to your F<httpd.conf>:
- PerlSetEnv DBI_PROFILE DBI::ProfileDumper::Apache
+ PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache
Under mod_perl2 RC5+ you'll need to also add:
@@ -53,7 +53,7 @@
The easiest way to use this module is just to set the DBI_PROFILE
environment variable in your F<httpd.conf>:
- PerlSetEnv DBI_PROFILE DBI::ProfileDumper::Apache
+ PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache
If you want to use one of DBI::Profile's other Path settings, you can
use a string like:
@@ -63,7 +63,7 @@
It's also possible to use this module by setting the Profile attribute
of any DBI handle:
- $dbh->{Profile} = "DBI::ProfileDumper::Apache";
+ $dbh->{Profile} = "2/DBI::ProfileDumper::Apache";
See L<DBI::ProfileDumper> for more possibilities.
Modified: dbi/trunk/t/40profile.t
==============================================================================
--- dbi/trunk/t/40profile.t (original)
+++ dbi/trunk/t/40profile.t Sun Jul 30 15:42:07 2006
@@ -20,7 +20,7 @@
}
}
-use Test::More tests => 43;
+use Test::More tests => 46;
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
@@ -47,7 +47,7 @@
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "4";
is_deeply sanitize_tree($dbh->{Profile}), bless {
- 'Path' => [ DBIprofile_MethodName ],
+ 'Path' => [ '!MethodName' ],
} => 'DBI::Profile';
# using a package name
@@ -61,12 +61,12 @@
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "20/DBI::Profile";
is_deeply sanitize_tree($dbh->{Profile}), bless {
- 'Path' => [ DBIprofile_MethodName, DBIprofile_Caller ],
+ 'Path' => [ '!MethodName', '!Caller2' ],
} => 'DBI::Profile';
$dbh->do("set foo=1"); my $line = __LINE__;
is_deeply sanitize_tree($dbh->{Profile}), bless {
- 'Path' => [ DBIprofile_MethodName, DBIprofile_Caller ],
+ 'Path' => [ '!MethodName', '!Caller2' ],
'Data' => { 'do' => {
"40profile.t line $line" => [ 1, 0, 0, 0, 0, 0, 0 ]
} }
@@ -77,7 +77,7 @@
# can turn it on at connect
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>6 });
is_deeply sanitize_tree($dbh->{Profile}), bless {
- 'Path' => [ DBIprofile_Statement, DBIprofile_MethodName ],
+ 'Path' => [ '!Statement', '!MethodName' ],
'Data' => {
'' => {
'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ],
@@ -90,7 +90,7 @@
my $t1 = DBI::dbi_time;
dbi_profile($dbh, "Hi, mom", "my_method_name", $t1, $t1 + 1);
is_deeply sanitize_tree($dbh->{Profile}), bless {
- 'Path' => [ DBIprofile_Statement, DBIprofile_MethodName ],
+ 'Path' => [ '!Statement', '!MethodName' ],
'Data' => {
'' => {
'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ], # +0
@@ -159,7 +159,7 @@
my $tmp = sanitize_tree($dbh->{Profile});
$tmp->{Data}{$sql}[0] = -1; # make test insensitive to local file count
is_deeply $tmp, bless {
- 'Path' => [ DBIprofile_Statement ],
+ 'Path' => [ '!Statement' ],
'Data' => {
'' => [ 3, 0, 0, 0, 0, 0, 0 ],
$sql => [ -1, 0, 0, 0, 0, 0, 0 ],
@@ -182,7 +182,7 @@
# try statement and method name path
$dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
RaiseError => 1,
- Profile => { Path => [ '{Username}', DBIprofile_Statement, 'foo',
DBIprofile_MethodName ] }
+ Profile => { Path => [ '{Username}', '!Statement', 'foo', '!MethodName' ] }
});
$sql = "select name from .";
$sth = $dbh->prepare($sql);
@@ -193,7 +193,7 @@
$tmp = sanitize_tree($dbh->{Profile});
# make test insentitive to number of local files
is_deeply $tmp, bless {
- 'Path' => [ '{Username}', DBIprofile_Statement, 'foo',
DBIprofile_MethodName ],
+ 'Path' => [ '{Username}', '!Statement', 'foo', '!MethodName' ],
'Data' => {
'usrnam' => {
'' => {
@@ -218,6 +218,43 @@
} => 'DBI::Profile';
+$dbh->{Profile}->{Path} = [ '!File', '!File2', '!Caller', '!Caller2' ];
+$dbh->{Profile}->{Data} = undef;
+
+my ($file, $line1, $line2) = (__FILE__, undef, undef);
+$file =~ s:.*/::;
+sub a_sub {
+ $sth = $dbh->prepare("select name from ."); $line2 = __LINE__;
+}
+a_sub(); $line1 = __LINE__;
+
+$tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data});
+#warn Dumper($tmp);
+is_deeply $tmp, {
+ "$file" => {
+ "$file" => {
+ "$file line $line2" => {
+ "$file line $line2 via $file line $line1" => [ 1, 0, 0, 0, 0, 0, 0 ]
+ }
+ }
+ }
+};
+
+
+$dbh->{Profile} = '&norm_std_n3'; # assign as string to get magic
+is_deeply $dbh->{Profile}{Path}, [
+ \&DBI::ProfileSubs::norm_std_n3
+];
+$dbh->{Profile}->{Data} = undef;
+$sql = qq{insert into foo20060726 (a,b) values (42,"foo")};
+dbi_profile($dbh, $sql, 'mymethod', 100000000, 100000002);
+$tmp = $dbh->{Profile}{Data};
+#warn Dumper($tmp);
+is_deeply $tmp, {
+ 'insert into foo<N> (a,b) values (<N>,"<S>")' => [ 1, '2', '2', '2', '2',
'100000000', '100000000' ]
+};
+
+
#
-----------------------------------------------------------------------------------
print "testing code ref in Path\n";
Modified: dbi/trunk/test.pl
==============================================================================
--- dbi/trunk/test.pl (original)
+++ dbi/trunk/test.pl Sun Jul 30 15:42:07 2006
@@ -28,7 +28,10 @@
use Getopt::Long;
use strict;
-our $has_devel_leak = eval { require Devel::Leak };
+our $has_devel_leak = eval {
+ local $^W = 0; # silence "Use of uninitialized value $DynaLoader::args[0]
in subroutine entry";
+ require Devel::Leak;
+};
$::opt_d = 0;
$::opt_l = '';
