Author: timbo
Date: Mon Jul 10 05:15:49 2006
New Revision: 6629
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.xs
dbi/trunk/lib/DBI/Profile.pm
dbi/trunk/t/40profile.t
Log:
Added ability for DBI::Profile Path to contain code refs - cool.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Jul 10 05:15:49 2006
@@ -7,12 +7,14 @@
=head2 Changes in DBI 1.52 (svn rev XXX), XXX
XXX update DBD::File (as sub-module?) to match latest.
-XXX update docs for Profile !Foo magic vars
+XXX update docs for Profile !Foo magic vars and code refs.
Fixed memory leak (16 bytes per sth) thanks to Doru Theodor Petrescu.
Fixed small memory leak (per interpreter/thread) thanks to Ephraim Dan.
Fixed execute_for_fetch/execute_array to RaiseError thanks to Martin J.
Evans.
- Added $dbh->statistics_info thanks to Brandon Black.
+
+ Added ability for DBI::Profile Path to contain code refs - cool.
+ Added $dbh->statistics_info specification thanks to Brandon Black.
=head2 Changes in DBI 1.51 (svn rev 6475), 6th June 2006
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Jul 10 05:15:49 2006
@@ -2235,7 +2235,8 @@
if (SvTYPE(node) != SVt_PVHV) {
HV *hv = newHV();
if (SvOK(node))
- warn("Profile data element %s replaced with new hash ref",
neatsvpv(orig_node,0));
+ warn("Profile data element %s replaced with new hash ref (for %s)",
+ neatsvpv(orig_node,0), name);
sv_setsv(node, newRV_noinc((SV*)hv));
node = (SV*)hv;
}
@@ -2245,7 +2246,7 @@
static void
-dbi_profile(SV *h, imp_xxh_t *imp_xxh, const char *statement, SV *method,
double t1, double t2)
+dbi_profile(SV *h, imp_xxh_t *imp_xxh, SV *statement_sv, SV *method, double
t1, double t2)
{
#define DBIprof_MAX_PATH_ELEM 100
#define DBIprof_COUNT 0
@@ -2261,6 +2262,7 @@
int src_idx = 0;
HV *dbh_outer_hv = NULL;
HV *dbh_inner_hv = NULL;
+ char *statement_pv;
SV *profile;
SV *tmp;
SV *dest_node;
@@ -2289,14 +2291,18 @@
return;
}
- if (!statement) {
+ /* statement_sv: undef = use $h->{Statement}, "" (&sv_no) = use empty
string */
+
+ if (!SvOK(statement_sv)) {
SV **psv = hv_fetch(h_hv, "Statement", 9, 0);
- statement = (psv && SvOK(*psv)) ? SvPV_nolen(*psv) : "";
+ statement_sv = (psv && SvOK(*psv)) ? *psv : &sv_no;
}
+ statement_pv = SvPV_nolen(statement_sv);
+
if (DBIc_DBISTATE(imp_xxh)->debug >= 4)
PerlIO_printf(DBIc_LOGPIO(imp_xxh), "dbi_profile %s %f q{%s}\n",
neatsvpv((SvTYPE(method)==SVt_PVCV) ? (SV*)CvGV(method) :
method, 0),
- ti, statement);
+ ti, neatsvpv(statement_sv,0));
dest_node = _profile_next_node(profile, "Data");
@@ -2309,18 +2315,49 @@
while ( src_idx <= len ) {
SV *pathsv = AvARRAY(av)[src_idx++];
- if (SvROK(tmp) && SvTYPE(SvRV(tmp))==SVt_PVCV) {
+ if (SvROK(pathsv) && SvTYPE(SvRV(pathsv))==SVt_PVCV) {
/* call sub, use returned list of values as path */
- /* if no values returned then don't save data */
- warn("code ref in Path");
- dest_node = _profile_next_node(dest_node, "CODE");
+ /* returning a ref to undef vetos this profile data */
+ dSP;
+ I32 ax;
+ SV *code_sv = SvRV(pathsv);
+ I32 items;
+ I32 item_idx;
+ char *method_pv = (SvTYPE(method)==SVt_PVCV)
+ ? GvNAME(CvGV(method))
+ : (isGV(method) ? GvNAME(method) : SvPV_nolen(method));
+ EXTEND(SP, 4);
+ PUSHMARK(SP);
+ PUSHs(h); /* push inner handle, then others params */
+ PUSHs( sv_2mortal(newSVpv(method_pv,0)));
+ PUTBACK;
+ SAVE_DEFSV; /* local($_) = $statement */
+ DEFSV = statement_sv;
+ items = call_sv(code_sv, G_ARRAY);
+ SPAGAIN;
+ SP -= items ;
+ ax = (SP - PL_stack_base) + 1 ;
+ for (item_idx=0; item_idx < items; ++item_idx) {
+ SV *item_sv = ST(item_idx);
+ if (SvROK(item_sv)) {
+ if (!SvOK(SvRV(item_sv)))
+ items = -2; /* flag that we're rejecting this
profile data */
+ else /* other refs reserved */
+ warn("Ignored ref returned by code ref in Profile
Path");
+ break;
+ }
+ dest_node = _profile_next_node(dest_node,
SvPV_nolen(item_sv));
+ }
+ PUTBACK;
+ if (items == -2) /* this profile data was vetoed */
+ return;
}
else if (SvOK(pathsv)) {
STRLEN len;
const char *p = SvPV(pathsv,len);
if (p[0] == '!') { /* special cases */
if (p[1] == 'S' && strEQ(p, "!Statement")) {
- dest_node = _profile_next_node(dest_node, statement);
+ dest_node = _profile_next_node(dest_node,
statement_pv);
}
else if (p[1] == 'M' && strEQ(p, "!MethodName")) {
p = (SvTYPE(method)==SVt_PVCV)
@@ -2393,7 +2430,7 @@
}
}
else { /* a bad Path value is treated as a Path of just Statement */
- dest_node = _profile_next_node(dest_node, statement);
+ dest_node = _profile_next_node(dest_node, statement_pv);
}
@@ -3246,8 +3283,8 @@
}
if (profile_t1) { /* see also dbi_profile() call a few lines below */
- char *Statement = (ima_flags & IMA_UNRELATED_TO_STMT) ? "" : Nullch;
- dbi_profile(h, imp_xxh, Statement, imp_msv ? imp_msv : (SV*)cv,
+ SV *statement_sv = (ima_flags & IMA_UNRELATED_TO_STMT) ? &sv_no :
&sv_undef;
+ dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv,
profile_t1, dbi_time());
}
if (is_warning) {
@@ -3262,8 +3299,8 @@
}
}
else if (profile_t1) { /* see also dbi_profile() call a few lines above */
- char *Statement = (ima_flags & IMA_UNRELATED_TO_STMT) ? "" : Nullch;
- dbi_profile(h, imp_xxh, Statement, imp_msv ? imp_msv : (SV*)cv,
+ SV *statement_sv = (ima_flags & IMA_UNRELATED_TO_STMT) ? &sv_no :
&sv_undef;
+ dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv,
profile_t1, dbi_time());
}
@@ -3923,9 +3960,8 @@
D_imp_xxh(h);
STRLEN lna = 0;
(void)cv;
- dbi_profile(h, imp_xxh,
- SvOK(statement) ? SvPV(statement,lna) : Nullch,
- SvROK(method) ? SvRV(method) : method,
+ dbi_profile(h, imp_xxh, statement,
+ SvROK(method) ? SvRV(method) : method,
t1, t2
);
RETVAL = &sv_undef;
@@ -4028,7 +4064,7 @@
if (trace)
PerlIO_printf(DBILOGFP," <- $DBI::%s= %s\n", meth,
neatsvpv(ST(0),0));
if (profile_t1)
- dbi_profile(DBI_LAST_HANDLE, imp_xxh, Nullch, (SV*)cv, profile_t1,
dbi_time());
+ dbi_profile(DBI_LAST_HANDLE, imp_xxh, &sv_undef, (SV*)cv, profile_t1,
dbi_time());
MODULE = DBI PACKAGE = DBD::_::db
Modified: dbi/trunk/lib/DBI/Profile.pm
==============================================================================
--- dbi/trunk/lib/DBI/Profile.pm (original)
+++ dbi/trunk/lib/DBI/Profile.pm Mon Jul 10 05:15:49 2006
@@ -638,7 +638,7 @@
(my $progname = $0) =~ s:.*/::;
if ($count) {
$prologue .= sprintf "%fs ", $time_in_dbi;
- my $perl_time = ($DBI::PERL_ENDING) ? time_in_dbi() - $^T : $t2-$t1;
+ my $perl_time = ($DBI::PERL_ENDING) ? time() - $^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",
@@ -694,6 +694,7 @@
sub format_profile_thingy {
my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
+ return "undef" if not defined $thingy;
return $self->format_profile_leaf( $thingy, $depth, $pad, $path, $leaves)
if UNIVERSAL::isa($thingy,'ARRAY');
return $self->format_profile_branch($thingy, $depth, $pad, $path, $leaves)
Modified: dbi/trunk/t/40profile.t
==============================================================================
--- dbi/trunk/t/40profile.t (original)
+++ dbi/trunk/t/40profile.t Mon Jul 10 05:15:49 2006
@@ -20,7 +20,7 @@
}
}
-use Test::More tests => 37;
+use Test::More tests => 43;
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
@@ -177,6 +177,7 @@
ok($output =~ /\((\d+) calls\)/);
ok($1 >= $count);
+#
-----------------------------------------------------------------------------------
# try statement and method name path
$dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
@@ -186,12 +187,11 @@
$sql = "select name from .";
$sth = $dbh->prepare($sql);
$sth->execute();
-while ( my $hash = $sth->fetchrow_hashref ) {}
+$sth->fetchrow_hashref;
undef $sth; # DESTROY
$tmp = sanitize_tree($dbh->{Profile});
# make test insentitive to number of local files
-$tmp->{Data}{usrnam}{'select name from .'}{foo}{fetchrow_hashref}[0] = -1;
is_deeply $tmp, bless {
'Path' => [ '{Username}', DBIprofile_Statement, 'foo',
DBIprofile_MethodName ],
'Data' => {
@@ -205,15 +205,78 @@
'select name from .' => {
'foo' => {
'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
- 'fetchrow_hashref' => [ -1, 0, 0, 0, 0, 0, 0 ],
+ 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ],
- 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ]
+ 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ # XXX finish shouldn't be profiled as it's not called
explicitly
+ # but currently the finish triggered by DESTROY does
get profiled
+ 'finish' => [ 1, 0, 0, 0, 0, 0, 0 ],
},
},
},
},
} => 'DBI::Profile';
+
+#
-----------------------------------------------------------------------------------
+
+print "testing code ref in Path\n";
+
+sub run_test1 {
+ my ($profile) = @_;
+ $dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
+ RaiseError => 1,
+ Profile => $profile,
+ });
+ $sql = "select name from .";
+ $sth = $dbh->prepare($sql);
+ $sth->execute();
+ $sth->fetchrow_hashref;
+ undef $sth; # DESTROY
+ return sanitize_profile_data_nodes($dbh->{Profile}{Data});
+}
+
+$tmp = run_test1( { Path => [ 'foo', sub { 'bar' }, 'baz' ] });
+is_deeply $tmp, { 'foo' => { 'bar' => { 'baz' => [ 8, 0,0,0,0,0,0 ] } } };
+
+$tmp = run_test1( { Path => [ 'foo', sub { 'ping','pong' } ] });
+is_deeply $tmp, { 'foo' => { 'ping' => { 'pong' => [ 8, 0,0,0,0,0,0 ] } } };
+
+$tmp = run_test1( { Path => [ 'foo', sub { \undef } ] });
+is_deeply $tmp, { 'foo' => undef }, 'should be vetoed';
+
+# check what code ref sees in $_
+$tmp = run_test1( { Path => [ sub { $_ } ] });
+is_deeply $tmp, {
+ '' => [ 3, 0, 0, 0, 0, 0, 0 ],
+ 'select name from .' => [ 5, 0, 0, 0, 0, 0, 0 ]
+}, '$_ should contain statement';
+
+# check what code ref sees in @_
+$tmp = run_test1( { Path => [ sub { my ($h,$method) = @_; return (ref $h,
$method) } ] });
+is_deeply $tmp, {
+ 'DBI::db' => {
+ 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ],
+ },
+ 'DBI::st' => {
+ 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'finish' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ },
+}, 'should have @_ as keys';
+
+# check we can filter by method
+$tmp = run_test1( { Path => [ sub { return \undef unless $_[1] =~ /^fetch/;
return $_[1] } ] });
+#warn Dumper($tmp);
+is_deeply $tmp, {
+ 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
+}, 'should be able to filter by method';
+
+#
-----------------------------------------------------------------------------------
+
print "dbi_profile_merge\n";
my $total_time = dbi_profile_merge(
my $totals=[],
@@ -244,18 +307,20 @@
my $data = shift;
return $data unless ref $data;
$data = dclone($data);
- _sanitize_node($data->{Data}) if $data->{Data};
+ sanitize_profile_data_nodes($data->{Data}) if $data->{Data};
return $data;
}
-sub _sanitize_node {
+sub sanitize_profile_data_nodes {
my $node = shift;
if (ref $node eq 'HASH') {
- _sanitize_node($_) for values %$node;
+ sanitize_profile_data_nodes($_) for values %$node;
}
elsif (ref $node eq 'ARRAY') {
- # sanitize the profile data node so tests
- $_ = 0 for @[EMAIL PROTECTED]; # not 0
+ if (@$node == 7 and DBI::looks_like_number($node->[0])) {
+ # sanitize the profile data node to simplify tests
+ $_ = 0 for @[EMAIL PROTECTED]; # not 0
+ }
}
- return;
+ return $node;
}
