Author: timbo
Date: Mon Mar 27 13:17:49 2006
New Revision: 3722
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.xs
dbi/trunk/lib/DBI/Profile.pm
dbi/trunk/t/40profile.t
Log:
Changed DBI::Profile format to always include a percentage,
if not exiting then is time between the first and last DBI call.
Added DBIprofile_Caller as Profile Path item to specify that a
string like "Bar.pm line 23 via foo.pl line 543" be used.
Don't profile FETCH of $h->{Profile}.
Use inner hash so dbi_profile doesn't trigger magic and dispatch.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Mar 27 13:17:49 2006
@@ -21,6 +21,8 @@
Improved performance for thread-enabled perls thanks to Gisle Aas.
Drivers can now use PERL_NO_GET_CONTEXT thanks to Gisle Aas.
Driver authors please read the notes in the DBI::DBD docs.
+ Changed DBI::Profile format to always include a percentage,
+ if not exiting then is time between the first and last DBI call.
Changed DBI::ProfileData to be more forgiving of systems with
unstable clocks (where time may go backwards occasionally).
Clarified the 'Subclassing the DBI' docs.
@@ -29,7 +31,8 @@
Added 'fetch array of hash refs' example to selectall_arrayref
docs thanks to Tom Schindl.
Added reference to $DBI::neat_maxlen in TRACING section of docs.
- Added ability for DBI::Profile Path to specify attribute names.
+ Added ability for DBI::Profile Path to include attributes
+ and a summary of where the code was called from.
=head2 Changes in DBI 1.50 (svn rev 2307), 13 December 2005
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Mar 27 13:17:49 2006
@@ -2108,8 +2108,9 @@
return NULL;
}
+
static char *
-log_where(int trace_level, SV *buf, int append, char *suffix)
+log_where(SV *buf, int append, char *prefix, char *suffix, int show_caller,
int show_path)
{
dTHX;
dTHR;
@@ -2125,14 +2126,14 @@
long near_line = CopLINE(curcop);
char *near_file = SvPV(GvSV(CopFILEGV(curcop)), len);
char *file = near_file;
- if (trace_level <= 4) {
+ if (!show_path) {
char *sep;
if ( (sep=strrchr(file,'/')) || (sep=strrchr(file,'\\')))
file = sep+1;
}
- sv_catpvf(buf, " at %s line %ld", file, near_line);
+ sv_catpvf(buf, "%s%s line %ld", (prefix) ? prefix : "", file,
near_line);
- if (trace_level >= 3) {
+ 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))
)
@@ -2223,8 +2224,8 @@
if (!DBIc_has(imp_xxh, DBIcf_Profile))
return;
- /* XXX need to switch to inner handle */
- h_hv = (SvROK(h)) ? (HV*)SvRV(h) : (HV*)h;
+ 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))
@@ -2291,6 +2292,9 @@
p = SvPV_nolen(method);
}
break;
+ case -2100000004: /* DBIprofile_Caller */
+ p = log_where(0, 0, "", "", 1, 0);
+ break;
default:
p = SvPV_nolen(pathsv);
break;
@@ -2339,19 +2343,19 @@
}
path[idx++] = Nullch;
+ /* this walk-down-the-tree code should be merged into the loop above */
tmp = profile;
for (idx=0; path[idx]; ++idx) {
+ SV *orig_tmp = tmp;
if (SvROK(tmp))
tmp = SvRV(tmp);
- else if (SvTYPE(tmp) != SVt_PVHV) {
+ if (SvTYPE(tmp) != SVt_PVHV) {
HV *hv = newHV();
if (SvOK(tmp))
- warn("Profile data element %s replaced with new hash ref",
neatsvpv(tmp,0));
+ warn("Profile data element %s replaced with new hash ref",
neatsvpv(orig_tmp,0));
sv_setsv(tmp, newRV_noinc((SV*)hv));
tmp = (SV*)hv;
}
- if (SvTYPE(tmp) != SVt_PVHV)
- break;
tmp = *hv_fetch((HV*)tmp, path[idx], strlen(path[idx]), 1);
/* warn("%d hv_fetch %s = %s", idx, path[idx], neatsvpv(tmp,0)); */
}
@@ -2365,22 +2369,23 @@
av_store(av, DBIprof_MAX_TIME, newSVnv(ti));
av_store(av, DBIprof_FIRST_CALLED, newSVnv(t1));
av_store(av, DBIprof_LAST_CALLED, newSVnv(t1));
- return;
}
- if (SvROK(tmp))
- tmp = SvRV(tmp);
- if (SvTYPE(tmp) != SVt_PVAV)
- croak("Invalid Profile data leaf element at depth %d: %s (type %d)",
- idx, neatsvpv(tmp,0), SvTYPE(tmp));
- av = (AV*)tmp;
- sv_inc( *av_fetch(av, DBIprof_COUNT, 1));
- tmp = *av_fetch(av, DBIprof_TOTAL_TIME, 1);
- sv_setnv(tmp, SvNV(tmp) + ti);
- tmp = *av_fetch(av, DBIprof_MIN_TIME, 1);
- if (ti < SvNV(tmp)) sv_setnv(tmp, ti);
- tmp = *av_fetch(av, DBIprof_MAX_TIME, 1);
- if (ti > SvNV(tmp)) sv_setnv(tmp, ti);
- sv_setnv( *av_fetch(av, DBIprof_LAST_CALLED, 1), t1);
+ else {
+ if (SvROK(tmp))
+ tmp = SvRV(tmp);
+ if (SvTYPE(tmp) != SVt_PVAV)
+ croak("Invalid Profile data leaf element at depth %d: %s (type %d)",
+ idx, neatsvpv(tmp,0), SvTYPE(tmp));
+ av = (AV*)tmp;
+ sv_inc( *av_fetch(av, DBIprof_COUNT, 1));
+ tmp = *av_fetch(av, DBIprof_TOTAL_TIME, 1);
+ sv_setnv(tmp, SvNV(tmp) + ti);
+ tmp = *av_fetch(av, DBIprof_MIN_TIME, 1);
+ if (ti < SvNV(tmp)) sv_setnv(tmp, ti);
+ tmp = *av_fetch(av, DBIprof_MAX_TIME, 1);
+ if (ti > SvNV(tmp)) sv_setnv(tmp, ti);
+ sv_setnv( *av_fetch(av, DBIprof_LAST_CALLED, 1), t1);
+ }
return;
}
@@ -2500,7 +2505,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(trace_level, 0, 0, "\n"));
+ PerlIO_puts(logfp, log_where(0, 0, " at ","\n", (trace_level >= 3),
(trace_level >= 4)));
PerlIO_flush(logfp);
}
@@ -2802,6 +2807,9 @@
) {
qsv = Nullsv;
}
+ /* disable profiling of FETCH of Profile data */
+ if (*key == 'P' && strEQ(key, "Profile"))
+ profile_t1 = 0.0;
}
}
@@ -3011,7 +3019,8 @@
else if (!imp_msv)
PerlIO_printf(logfp," (not implemented)");
/* XXX add flag to show pid here? */
- PerlIO_puts(logfp, log_where(trace_level, 0, 0, "\n")); /* add file and
line number information */
+ /* add file and line number information */
+ PerlIO_puts(logfp, log_where(0, 0, " at ", "\n", (trace_level >= 3),
(trace_level >= 4)));
skip_meth_return_trace:
PerlIO_flush(logfp);
}
Modified: dbi/trunk/lib/DBI/Profile.pm
==============================================================================
--- dbi/trunk/lib/DBI/Profile.pm (original)
+++ dbi/trunk/lib/DBI/Profile.pm Mon Mar 27 13:17:49 2006
@@ -175,6 +175,9 @@
push @Path, DBIprofile_Statement if $path & 0x02;
push @Path, DBIprofile_MethodName if $path & 0x04;
push @Path, DBIprofile_MethodClass if $path & 0x08;
+ push @Path, DBIprofile_Caller if $path & 0x10;
+
+(The order here is subject to change and shouldn't be relied upon.)
So using the value "C<1>" causes all profile data to be merged into
a single leaf of the tree. That's useful when you just want a total.
@@ -258,6 +261,12 @@
DBD::mysql::db::selectrow_arrayref. Currently the first
call Pern't record the true location. That may change.
+B<DBIprofile_Caller>
+
+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.
+
=item Code Reference
Not yet implemented.
@@ -304,7 +313,7 @@
The default results format looks like this:
- DBI::Profile: 0.001015s (5 calls) programname @ YYYY-MM-DD HH:MM:SS
+ DBI::Profile: 0.001015s 42.7% (5 calls) programname @ YYYY-MM-DD HH:MM:SS
'' =>
0.000024s / 2 = 0.000012s avg (first 0.000015s, min 0.000009s, max
0.000015s)
'SELECT mode,size,name FROM table' =>
@@ -317,7 +326,8 @@
If the results are being formated when the perl process is exiting
(which is usually the case when the DBI_PROFILE environment variable
is used) then the percentage of time the process spent inside the
-DBI is also shown.
+DBI is also shown. If the process is not exiting then the percentage is
+calculated using the time between the first and last call to the DBI.
In the example above the paths in the tree are only one level deep and
use the Statement text as the value (that's the default behaviour).
@@ -499,6 +509,9 @@
Time spent fetching tied variables, $DBI::errstr, is counted.
+Time spent in FETCH for $h->{Profile} is not counted, so getting the profile
+data doesn't alter it.
+
DBI::PurePerl does not support profiling (though it could in theory).
A few platforms don't support the gettimeofday() high resolution
@@ -535,6 +548,7 @@
DBIprofile_Statement
DBIprofile_MethodName
DBIprofile_MethodClass
+ DBIprofile_Caller
dbi_profile
dbi_profile_merge
dbi_time
@@ -546,6 +560,7 @@
use constant DBIprofile_Statement => -2100000001;
use constant DBIprofile_MethodName => -2100000002;
use constant DBIprofile_MethodClass => -2100000003;
+use constant DBIprofile_Caller => -2100000004;
$ON_DESTROY_DUMP = sub { DBI->trace_msg(shift, 0) };
@@ -586,6 +601,7 @@
push @Path, DBIprofile_Statement if $path & 0x02;
push @Path, DBIprofile_MethodName if $path & 0x04;
push @Path, DBIprofile_MethodClass if $path & 0x08;
+ push @Path, DBIprofile_Caller if $path & 0x10;
@Path = reverse @Path if $reverse;
} else {
# default Path
@@ -618,13 +634,12 @@
if (@$leaves) {
dbi_profile_merge(my $totals=[], @$leaves);
- my ($count, $dbi_time) = @$totals;
+ my ($count, $time_in_dbi, undef, undef, undef, $t1, $t2) = @$totals;
(my $progname = $0) =~ s:.*/::;
if ($count) {
- $prologue .= sprintf "%fs ", $dbi_time;
- my $perl_time = dbi_time() - $^T;
- $prologue .= sprintf "%.2f%% ", $dbi_time/$perl_time*100
- if $DBI::PERL_ENDING && $perl_time;
+ $prologue .= sprintf "%fs ", $time_in_dbi;
+ my $perl_time = ($DBI::PERL_ENDING) ? time_in_dbi() - $^T : $t2-$t1;
+ $prologue .= sprintf "%.2f%% ", $time_in_dbi/$perl_time*100 if
$perl_time;
my @lt = localtime(time);
my $ts = sprintf "%d-%02d-%02d %02d:%02d:%02d",
1900+$lt[5], $lt[4]+1, @lt[3,2,1,0];
Modified: dbi/trunk/t/40profile.t
==============================================================================
--- dbi/trunk/t/40profile.t (original)
+++ dbi/trunk/t/40profile.t Mon Mar 27 13:17:49 2006
@@ -44,7 +44,6 @@
$dbh->{Profile} = "4";
is_deeply sanitize_tree($dbh->{Profile}), bless {
'Path' => [ DBIprofile_MethodName ],
- 'Data' => { FETCH => [ 1, 0, 0, 0, 0, 0, 0 ] }
} => 'DBI::Profile';
# using a package name
@@ -52,16 +51,19 @@
$dbh->{Profile} = "DBI::Profile";
is_deeply sanitize_tree($dbh->{Profile}), bless {
'Path' => [ DBIprofile_Statement ],
- 'Data' => { '' => [ 1, 0, 0, 0, 0, 0, 0 ] }
} => 'DBI::Profile';
# using a combined path and name
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
-$dbh->{Profile} = "2/DBI::Profile";
+$dbh->{Profile} = "20/DBI::Profile";
+$dbh->do("set foo=1"); my $line = __LINE__;
is_deeply sanitize_tree($dbh->{Profile}), bless {
- 'Path' => [ DBIprofile_Statement ],
- 'Data' => { '' => [ 1, 0, 0, 0, 0, 0, 0 ] }
+ 'Path' => [ DBIprofile_MethodName, DBIprofile_Caller ],
+ 'Data' => { 'do' => {
+ "40profile.t line $line" => [ 1, 0, 0, 0, 0, 0, 0 ]
+ } }
} => 'DBI::Profile';
+#die Dumper $dbh->{Profile};
# can turn it on at connect
@@ -70,7 +72,7 @@
'Path' => [ DBIprofile_Statement, DBIprofile_MethodName ],
'Data' => {
'' => {
- 'FETCH' => [ 3, 0, 0, 0, 0, 0, 0 ],
+ 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ],
'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ]
}
}
@@ -83,7 +85,7 @@
'Path' => [ DBIprofile_Statement, DBIprofile_MethodName ],
'Data' => {
'' => {
- 'FETCH' => [ 5, 0, 0, 0, 0, 0, 0 ], # +2!
+ 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ], # +0
'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ]
},
"Hi, mom" => {
@@ -151,7 +153,7 @@
is_deeply $tmp, bless {
'Path' => [ DBIprofile_Statement ],
'Data' => {
- '' => [ 7, 0, 0, 0, 0, 0, 0 ],
+ '' => [ 3, 0, 0, 0, 0, 0, 0 ],
$sql => [ -1, 0, 0, 0, 0, 0, 0 ],
'set foo=1' => [ 1, 0, 0, 0, 0, 0, 0 ],
}
@@ -185,17 +187,10 @@
is_deeply $tmp, bless {
'Path' => [ '{Username}', DBIprofile_Statement, 'foo',
DBIprofile_MethodName ],
'Data' => {
- '' => {
- '' => {
- 'foo' => {
- 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ],
- },
- },
- },
'usrnam' => {
'' => {
'foo' => {
- 'FETCH' => [ 2, 0, 0, 0, 0, 0, 0 ],
+ 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ],
'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ],
},
},
