Author: timbo
Date: Sun Jul 23 14:39:31 2006
New Revision: 6693
Added:
dbi/trunk/t/43prof_env.t
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.xs
dbi/trunk/MANIFEST
dbi/trunk/dumpmethods.pl
dbi/trunk/lib/DBI/Profile.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/40profile.t
dbi/trunk/t/41prof_dump.t
dbi/trunk/t/72childhandles.t
dbi/trunk/test.pl
Log:
Fixed memory leak (per handle) thanks to Nicholas Clark.
*** A small leak remains, probably since DBI 1.49.
Changed parsing of non-numeric DBI_PROFILE env var values.
Changed DBI::Profile docs extensively - still a work-in-progress
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Sun Jul 23 14:39:31 2006
@@ -10,9 +10,13 @@
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 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.
+ Changed parsing of non-numeric DBI_PROFILE env var values.
+ Changed DBI::Profile docs extensively.
+
Added ability for DBI::Profile Path to contain code refs - cool!
Added $dbh->statistics_info specification thanks to Brandon Black.
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Sun Jul 23 14:39:31 2006
@@ -1068,6 +1068,7 @@
DBIc_ATTR(imp, Errstr) = COPY_PARENT("Errstr",1,0); /* scalar ref
*/
DBIc_ATTR(imp, TraceLevel)=COPY_PARENT("TraceLevel",0,0);/* scalar
(int)*/
DBIc_ATTR(imp, FetchHashKeyName) = COPY_PARENT("FetchHashKeyName",0,0);
/* scalar ref */
+
if (parent) {
dbih_setup_attrib(h,imp,"HandleSetErr",parent,0,1);
dbih_setup_attrib(h,imp,"HandleError",parent,0,1);
@@ -1080,10 +1081,13 @@
AV *av;
/* 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_setsv(*tmp_svp, (SV*)newRV_noinc((SV*)newAV()));
+ if (!SvROK(*tmp_svp)) {
+ SV *ChildHandles_rvav = newRV((SV*)newAV());
+ sv_setsv(*tmp_svp, ChildHandles_rvav);
+ sv_free(ChildHandles_rvav);
+ }
av = (AV*)SvRV(*tmp_svp);
- av_push(av, (SV*)sv_rvweaken(newRV((SV*)SvRV(orv))));
+ av_push(av, (SV*)sv_rvweaken(newRV((SV*)SvRV(orv))));
if (av_len(av) % 120 == 0) {
/* time to do some housekeeping to remove dead handles */
I32 i = av_len(av); /* 0 = 1 element */
@@ -1564,7 +1568,7 @@
cacheit = 1; /* just save it in the hash */
}
else if (strEQ(key, "Profile")) {
- static const char dbi_class[] = "DBI::Profile";
+ static const char profile_class[] = "DBI::Profile";
if (on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) ) {
/* not a hash ref so use DBI::Profile to work out what to do */
dTHR;
@@ -1574,17 +1578,17 @@
perl_require_pv("DBI/Profile.pm");
if (SvTRUE(ERRSV)) {
STRLEN lna;
- warn("Can't load %s: %s", dbi_class, SvPV(ERRSV,lna));
+ warn("Can't load %s: %s", profile_class, SvPV(ERRSV,lna));
valuesv = &sv_undef;
}
else {
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(dbi_class,0)));
+ XPUSHs(sv_2mortal(newSVpv(profile_class,0)));
XPUSHs(valuesv);
PUTBACK;
returns = perl_call_method("_auto_new", G_SCALAR);
if (returns != 1)
- croak("%s _auto_new", dbi_class);
+ croak("%s _auto_new", profile_class);
SPAGAIN;
valuesv = POPs;
PUTBACK;
@@ -1594,8 +1598,8 @@
if (on && !sv_isobject(valuesv)) {
/* not blessed already - so default to DBI::Profile */
HV *stash;
- perl_require_pv(dbi_class);
- stash = gv_stashpv(dbi_class, GV_ADDWARN);
+ perl_require_pv(profile_class);
+ stash = gv_stashpv(profile_class, GV_ADDWARN);
sv_bless(valuesv, stash);
}
DBIc_set(imp_xxh,DBIcf_Profile, on);
@@ -2562,6 +2566,7 @@
I32 trace_level = (trace_flags & DBIc_TRACE_LEVEL_MASK);
int is_DESTROY;
int is_FETCH;
+ int is_unrelated_to_Statement = 0;
int keep_error = FALSE;
UV ErrCount = UV_MAX;
int i, outitems;
@@ -2802,6 +2807,10 @@
}
}
+ is_unrelated_to_Statement = ( (DBIc_TYPE(imp_xxh) == DBIt_ST) ? 0
+ : (DBIc_TYPE(imp_xxh) == DBIt_DR) ? 1
+ : (ima_flags & IMA_UNRELATED_TO_STMT) );
+
if (tainting && items > 1 /* method call has args */
&& DBIc_is(imp_xxh, DBIcf_TaintIn) /* taint checks requested */
&& !(ima_flags & IMA_NO_TAINT_IN)
@@ -3200,8 +3209,8 @@
neatsvpv(DBIc_ERR(imp_xxh),0), neatsvpv(DBIc_STATE(imp_xxh),0)
);
if ( DBIc_has(imp_xxh, DBIcf_ShowErrorStatement)
+ && !is_unrelated_to_Statement
&& (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)
) {
@@ -3283,7 +3292,7 @@
}
if (profile_t1) { /* see also dbi_profile() call a few lines below */
- SV *statement_sv = (ima_flags & IMA_UNRELATED_TO_STMT) ? &sv_no :
&sv_undef;
+ SV *statement_sv = (is_unrelated_to_Statement) ? &sv_no : &sv_undef;
dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv,
profile_t1, dbi_time());
}
@@ -3299,7 +3308,7 @@
}
}
else if (profile_t1) { /* see also dbi_profile() call a few lines above */
- SV *statement_sv = (ima_flags & IMA_UNRELATED_TO_STMT) ? &sv_no :
&sv_undef;
+ SV *statement_sv = (is_unrelated_to_Statement) ? &sv_no : &sv_undef;
dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv,
profile_t1, dbi_time());
}
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Sun Jul 23 14:39:31 2006
@@ -59,7 +59,7 @@
t/40profile.t
t/41prof_dump.t
t/42prof_data.t
-t/43profenv.t
+t/43prof_env.t
t/50dbm.t
t/60preparse.t
t/70callbacks.t
Modified: dbi/trunk/dumpmethods.pl
==============================================================================
--- dbi/trunk/dumpmethods.pl (original)
+++ dbi/trunk/dumpmethods.pl Sun Jul 23 14:39:31 2006
@@ -1,5 +1,9 @@
package DBI;
+use warnings;
+
+use Data::Dumper;
+
BEGIN { $ENV{DBI_PUREPERL} = 2 }
use DBI;
@@ -7,6 +11,7 @@
my @ima_n = grep { /^IMA_.*/ } keys %{"DBI::"};
warn "@ima_n";
my %ima_n2v = map { /^(IMA_.*)/ ? ($1=>&$_) : () } @ima_n;
+warn Dumper \%ima_n2v;
my %ima_v2n = reverse %ima_n2v;
my @ima_a = map { $ima_v2a{1<<$_} || "b".($_+1) } 0..31;
@@ -15,8 +20,7 @@
my %bit2hex; @bit2hex{ @bit2hex_bitkeys } = @bit2hex_bitvals;
my @bit2hex_values = ("0x00000000", @bit2hex_bitvals);
-use Data::Dumper;
-warn Dumper \%DBI::DBI_methods;
+#warn Dumper \%DBI::DBI_methods;
while ( my ($class, $meths) = each %DBI::DBI_methods ) {
Modified: dbi/trunk/lib/DBI/Profile.pm
==============================================================================
--- dbi/trunk/lib/DBI/Profile.pm (original)
+++ dbi/trunk/lib/DBI/Profile.pm Sun Jul 23 14:39:31 2006
@@ -12,16 +12,16 @@
DBI_PROFILE=2 prog.pl
This will profile your program and then output a textual summary
-grouped by query. You can also enable profiling by setting the
-Profile attribute of any DBI handle:
+grouped by query when the program exits. You can also enable profiling by
+setting the Profile attribute of any DBI handle:
$dbh->{Profile} = 2;
-Other values are possible - see L<"ENABLING A PROFILE"> below.
+Then the summary will be printed when the handle is destroyed.
-=head1 DESCRIPTION
+Many other values apart from are possible - see L<"ENABLING A PROFILE"> below.
-DBI::Profile is fairly new and subject to change.
+=head1 DESCRIPTION
The DBI::Profile module provides a simple interface to collect and
report performance and benchmarking data from the DBI.
@@ -52,14 +52,13 @@
another high-resolution timestamp and calls a function to record
the information. That function is passed the two timestamps
plus the DBI handle and the name of the method that was called.
-That information about a single DBI method call is called the
-I<profile sample> data.
+That data about a single DBI method call is called a I<profile sample>.
=item Data Filtering
-If the method call was invoked by the DBI or by a driver then the
-call is currently ignored for profiling because the time spent will
-be accounted for by the original 'outermost' call.
+If the method call was invoked by the DBI or by a driver then the call is
+ignored for profiling because the time spent will be accounted for by the
+original 'outermost' call for your code.
For example, the calls that the selectrow_arrayref() method makes
to prepare() and execute() etc. are not counted individually
@@ -68,14 +67,14 @@
done then it would be very easy to double count time spent inside
the DBI.
-In future releases it may be possible to alter this behaviour.
-
=item Data Storage Tree
-The profile data is stored as 'leaves on a tree'. The 'path' through
-the branches of the tree to the particular leaf that will store the
-profile sample data for a profiled call is determined dynamically.
-This is a powerful feature.
+The profile data is accumulated as 'leaves on a tree'. The 'path' through the
+branches of the tree to a particular leaf is determined dynamically for each
sample.
+This is a key feature of DBI profiliing.
+
+For each profiled method call the DBI walks along the Path and uses each value
+in the Path to step into and grow the Data tree.
For example, if the Path is
@@ -85,54 +84,43 @@
$h->{Profile}->{Data}->{foo}->{bar}->{baz}
-It wouldn't be very useful to merge all the call data into one leaf
-node (except to get an overall 'time spent inside the DBI' total).
-It's more common to want the Path to include the current statement
-text and/or the name of the method called to show what the time
-spent inside the DBI was for.
-
-The Path can contain some 'magic cookie' values that are automatically
-replaced by corresponding dynamic values when they're used.
-For example DBIprofile_Statement (exported by DBI::profile) is
-automatically replaced by value of the C<Statement> attribute of
-the handle. For example, is the Path was:
-
- [ 'foo', DBIprofile_Statement, 'bar' ]
+But it's not very useful to merge all the call data into one leaf node (except
+to get an overall 'time spent inside the DBI' total). It's more common to want
+the Path to include dynamic values such as the current statement text and/or
+the name of the method called to show what the time spent inside the DBI was
for.
-and the value of $h->{Statement} was:
+The Path can contain some 'magic cookie' values that are automatically replaced
+by corresponding dynamic values when they're used. These magic cookies always
+start with a punctuation character.
- SELECT * FROM tablename
+For example a value of 'C<!MethodName>' in the Path causes the corresponding
+entry in the Data to be the name of the method that was called.
+For example, if the Path was:
-then the profile data will be merged into the tree at:
+ [ 'foo', '!MethodName', 'selectall_arrayref' ]
- $h->{Profile}->{Data}->{foo}->{SELECT * FROM tablename}->{bar}
+and the selectall_arrayref() method was called, then the profile sample data
+for that call will be merged into the tree at:
-The default Path is just C<[ DBIprofile_Statement ]> and so by
-default the profile data is aggregated per distinct Statement string.
-
-For statement handles this is always simply the string that was
-given to prepare() when the handle was created. For database handles
-this is the statement that was last prepared or executed on that
-database handle. That can lead to a little 'fuzzyness' because, for
-example, calls to the quote() method to build a new statement will
-typically be associated with the previous statement. In practice
-this isn't a significant issue and the dynamic Path mechanism can
-be used to setup your own rules.
+ $h->{Profile}->{Data}->{foo}->{selectall_arrayref}->{bar}
=item Profile Data
Profile data is stored at the 'leaves' of the tree as references
to an array of numeric values. For example:
- [
- 106, # count
- 0.0312958955764771, # total duration
- 0.000490069389343262, # first duration
- 0.000176072120666504, # shortest duration
- 0.00140702724456787, # longest duration
- 1023115819.83019, # time of first event
- 1023115819.86576, # time of last event
- ]
+ [
+ 106, # 0: count of samples at this node
+ 0.0312958955764771, # 1: total duration
+ 0.000490069389343262, # 2: first duration
+ 0.000176072120666504, # 3: shortest duration
+ 0.00140702724456787, # 4: longest duration
+ 1023115819.83019, # 5: time of first sample
+ 1023115819.86576, # 6: time of last sample
+ ]
+
+After the first sample, later samples always update elements 0, 1, and 6, and
+may update 3 or 4 depending on the duration of the sampled call.
=back
@@ -145,55 +133,61 @@
The Profile attribute holds a blessed reference to a hash object
that contains the profile data and attributes relating to it.
+
The class the Profile object is blessed into is expected to
provide at least a DESTROY method which will dump the profile data
to the DBI trace file handle (STDERR by default).
-All these examples have the same effect as the first:
+All these examples have the same effect as each other:
+ $h->{Profile} = 0;
+ $h->{Profile} = "/DBI::Profile";
+ $h->{Profile} = DBI::Profile->new();
$h->{Profile} = {};
- $h->{Profile} = "DBI::Profile";
- $h->{Profile} = "2/DBI::Profile";
- $h->{Profile} = 2;
+ $h->{Profile} = { Path => [] };
+
+Similarly, these examples have the same effect as each other:
+
+ $h->{Profile} = 6;
+ $h->{Profile} = "6/DBI::Profile";
+ $h->{Profile} = "!Statement:!MethodName/DBI::Profile";
+ $h->{Profile} = { Path => [ '!Statement', '!MethodName' ] };
If a non-blessed hash reference is given then the DBI::Profile
module is automatically C<require>'d and the reference is blessed
into that class.
-If a string is given then it is split on 'C</>' characters and the
-first value is used to select the Path to be used (see below).
+If a string is given then it is processed like this:
+
+ ($path, $module, $args) = split /\//, $string, 3
+
+ @path = split /:/, $path
+ @args = split /:/, $args
+
+ eval "require $module" if $module
+ $module ||= "DBI::Profile"
+
+ $module->new( Path => [EMAIL PROTECTED], @args )
+
+So the first value is used to select the Path to be used (see below).
The second value, if present, is used as the name of a module which
will be loaded and it's C<new> method called. If not present it
defaults to DBI::Profile. Any other values are passed as arguments
-to the C<new> method. For example: "C<2/DBIx::OtherProfile/Foo/42>".
+to the C<new> method. For example: "C<2/DBIx::OtherProfile/Foo:42>".
+
+Numbers can be used as a shorthand way to enable common Path values.
+The simplest way to explain how the values are interpreted is to show the code:
-Various common sequences for Path can be selected by simply assigning
-an integer value to Profile. The simplest way to explain how the
-values are interpreted is to show the code:
-
- push @Path, "DBI" if $path & 0x01;
- 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.
-
-Using "C<2>" causes profile sample data to be merged grouped by
-the corresponding Statement text. This is the most frequently used.
-
-Using "C<4>" causes profile sample data to be merged grouped by
-the method name ('FETCH', 'prepare' etc.). Using "C<8>" is similar
-but gives the fully qualified 'glob name' of the method called. For
-example: '*DBD::Driver::db::prepare', '*DBD::_::st::fetchrow_hashref'.
-
-The values can be added together to create deeper paths. The most
-useful being 6 (statement then method name) or 10 (statement then
-method name with class). Using a negative number will reverse the
-path. Thus -6 will group by method name then statement.
+ push @Path, "DBI" if $path_elem & 0x01;
+ 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;
+
+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
+negative number will reverse the path. Thus "-6" will group by method name then
+statement.
The spliting and parsing of string values assigned to the Profile
attribute may seem a little odd, but there's a good reason for it.
@@ -201,7 +195,8 @@
string which can be passed in to a script as a parameter. For
example:
- dbi:DriverName(RaiseError=>1,Profile=>2):dbname
+ dbi:DriverName(Profile=>2):dbname
+ dbi:DriverName(Profile=>{Username}:!Statement/MyProfiler/Foo:42):dbname
And also, if the C<DBI_PROFILE> environment variable is set then
The DBI arranges for every driver handle to share the same profile
@@ -231,18 +226,27 @@
=item Special Constant
-B<DBIprofile_Statement>
+B<!Statement>
Use the current Statement text. Typically that's the value of the Statement
attribute for the handle the method was called with. Some methods, like
commit() and rollback(), are unrelated to a particular statement. For those
-methods DBIprofile_Statement records an empty string.
+methods !Statement records an empty string.
+
+For statement handles this is always simply the string that was
+given to prepare() when the handle was created. For database handles
+this is the statement that was last prepared or executed on that
+database handle. That can lead to a little 'fuzzyness' because, for
+example, calls to the quote() method to build a new statement will
+typically be associated with the previous statement. In practice
+this isn't a significant issue and the dynamic Path mechanism can
+be used to setup your own rules.
-B<DBIprofile_MethodName>
+B<!MethodName>
Use the name of the DBI method that the profile sample relates to.
-B<DBIprofile_MethodClass>
+B<!MethodClass>
Use the fully qualified name of the DBI method, including
the package, that the profile sample relates to. This shows you
@@ -261,7 +265,7 @@
DBD::mysql::db::selectrow_arrayref. Currently the first
call Pern't record the true location. That may change.
-B<DBIprofile_Caller>
+B<!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.
@@ -294,7 +298,7 @@
If the value of Path is anything other than an array reference,
it is treated as if it was:
- [ DBI::Profile::DBIprofile_Statement ]
+ [ DBI::Profile::!Statement ]
=head1 REPORTING
@@ -467,9 +471,9 @@
The $h parameter is the handle the extra profile sample should be
associated with. The $statement parameter is the string to use where
-the Path specifies DBIprofile_Statement. If $statement is undef
+the Path specifies !Statement. If $statement is undef
then $h->{Statement} will be used. Similarly $method is the string
-to use if the Path specifies DBIprofile_MethodName. There is no
+to use if the Path specifies !MethodName. There is no
default value for $method.
The $h->{Profile}{Path} attribute is processed by dbi_profile() in
@@ -491,7 +495,7 @@
Applications which generate many different statement strings
(typically because they don't use placeholders) and profile with
-DBIprofile_Statement in the Path (the default) will consume memory
+!Statement in the Path (the default) will consume memory
in the Profile Data structure for each statement.
If a method throws an exception itself (not via RaiseError) then
@@ -577,47 +581,42 @@
# This sub is called by DBI internals when a non-hash-ref is
# assigned to the Profile attribute. For example
- # dbi:mysql(RaiseError=>1,Profile=>4/DBIx::MyProfile):dbname
+ #
dbi:mysql(RaiseError=>1,Profile=>!Statement:!MethodName/DBIx::MyProfile/arg1:arg2):dbname
# This sub works out what to do and returns a suitable hash ref.
- my ($path, $module, @args);
-
- # parse args
- if ($arg =~ m!/!) {
- # it's a path/module/arg/arg/arg list
- ($path, $module, @args) = split /\s*\/\s*/, $arg, -1;
- } elsif ($arg =~ /^\d+$/) {
- # it's a numeric path selector
- $path = $arg;
- } else {
- # it's a module name
- $module = $arg;
- }
+ $arg =~ s/^DBI::/2\/DBI::/
+ and carp "Automatically changed old-style DBI::Profile specification
to $arg";
+ # it's a path/module/arg/arg/arg list
+ my ($path, $package, $args) = split /\//, $arg, 3;
+ my @args = (defined $args) ? split(/:/, $args, -1) : ();
my @Path;
- if ($path) {
- my $reverse = ($path < 0) ? ($path=-$path, 1) : 0;
- push @Path, "DBI" if $path & 0x01;
- 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
- push @Path, DBIprofile_Statement;
- }
- if ($module) {
- if (eval "require $module") {
- $class = $module;
- }
- else {
- carp "Can't use $module for DBI profile: $@";
- }
+ for my $element (split /:/, $path) {
+ if (DBI::looks_like_number($element)) {
+ my $reverse = ($element < 0) ? ($element=-$element, 1) : 0;
+ my @p;
+ 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 @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;
+ }
+ else {
+ push @Path, $element;
+ }
}
- return $class->new(Path => [EMAIL PROTECTED], @args);
+ eval "require $package" if $package; # sliently ignores errors
+ $package ||= $class;
+
+ return $package->new(Path => [EMAIL PROTECTED], @args);
}
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Sun Jul 23 14:39:31 2006
@@ -119,11 +119,11 @@
use constant IMA_KEEP_ERR_SUB => 0x0008; #/* '' if in nested call */
use constant IMA_NO_TAINT_IN => 0x0010; #/* don't check for tainted
args*/
use constant IMA_NO_TAINT_OUT => 0x0020; #/* don't taint results */
-use constant IMA_COPY_STMT => 0x0040; #/* copy sth Statement to dbh */
+use constant IMA_COPY_UP_STMT => 0x0040; #/* copy sth Statement to dbh */
use constant IMA_END_WORK => 0x0080; #/* set on commit & rollback */
use constant IMA_STUB => 0x0100; #/* donothing eg $dbh->connected */
use constant IMA_CLEAR_STMT => 0x0200; #/* clear Statement before call */
-use constant IMA_PROF_EMPTY_STMT=> 0x0400; #/* profile as empty Statement */
+use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement
*/
use constant IMA_NOT_FOUND_OKAY => 0x0800; #/* not error if not found */
use constant IMA_EXECUTE => 0x1000; #/* do/execute: DBIcf_Executed */
use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/
@@ -237,12 +237,12 @@
push @pre_call_frag, q{
my $parent_dbh = $h->{Database};
- } if (IMA_COPY_STMT|IMA_EXECUTE) & $bitmask;
+ } if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask;
push @pre_call_frag, q{
warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg
proxy problems
$parent_dbh->{Statement} = $h->{Statement} if $parent_dbh;
- } if IMA_COPY_STMT & $bitmask;
+ } if IMA_COPY_UP_STMT & $bitmask;
push @pre_call_frag, q{
$h->{Executed} = 1;
Modified: dbi/trunk/t/40profile.t
==============================================================================
--- dbi/trunk/t/40profile.t (original)
+++ dbi/trunk/t/40profile.t Sun Jul 23 14:39:31 2006
@@ -52,9 +52,9 @@
# using a package name
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
-$dbh->{Profile} = "DBI::Profile";
+$dbh->{Profile} = "/DBI::Profile";
is_deeply sanitize_tree($dbh->{Profile}), bless {
- 'Path' => [ DBIprofile_Statement ],
+ 'Path' => [ ],
} => 'DBI::Profile';
# using a combined path and name
Modified: dbi/trunk/t/41prof_dump.t
==============================================================================
--- dbi/trunk/t/41prof_dump.t (original)
+++ dbi/trunk/t/41prof_dump.t Sun Jul 23 14:39:31 2006
@@ -25,7 +25,7 @@
}
my $dbh = DBI->connect("dbi:ExampleP:", '', '',
- { RaiseError=>1, Profile=>"DBI::ProfileDumper" });
+ { RaiseError=>1, Profile=>"2/DBI::ProfileDumper" });
isa_ok( $dbh, 'DBI::db' );
isa_ok( $dbh->{Profile}, "DBI::ProfileDumper" );
isa_ok( $dbh->{Profile}{Data}, 'HASH' );
Added: dbi/trunk/t/43prof_env.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/43prof_env.t Sun Jul 23 14:39:31 2006
@@ -0,0 +1,52 @@
+#!perl -w
+
+use strict;
+
+#
+# test script for using DBI_PROFILE env var to enable DBI::Profile
+# and testing non-ref assignments to $h->{Profile}
+#
+
+BEGIN { $ENV{DBI_PROFILE} = 6 } # prior to use DBI
+
+use DBI;
+use DBI::Profile;
+use File::Spec;
+use Config;
+use Data::Dumper;
+
+BEGIN {
+ if ($DBI::PurePerl) {
+ print "1..0 # Skipped: profiling not supported for DBI::PurePerl\n";
+ exit 0;
+ }
+}
+
+use Test::More tests => 11;
+
+DBI->trace(0, "STDOUT");
+
+my $dbh1 = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+is(ref $dbh1->{Profile}, "DBI::Profile");
+is(ref $dbh1->{Profile}{Data}, 'HASH');
+is(ref $dbh1->{Profile}{Path}, 'ARRAY');
+
+my $dbh2 = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+is(ref $dbh2->{Profile}, "DBI::Profile");
+is(ref $dbh2->{Profile}{Data}, 'HASH');
+is(ref $dbh2->{Profile}{Path}, 'ARRAY');
+
+is $dbh1->{Profile}, $dbh2->{Profile}, '$h->{Profile} should be shared';
+
+$dbh1->do("set dummy=1");
+$dbh1->do("set dummy=2");
+
+my $profile = $dbh1->{Profile};
+
+my $p_data = $profile->{Data};
+is keys %$p_data, 3; # '', $sql1, $sql2
+ok $p_data->{''};
+ok $p_data->{"set dummy=1"};
+ok $p_data->{"set dummy=2"};
+
+__END__
Modified: dbi/trunk/t/72childhandles.t
==============================================================================
--- dbi/trunk/t/72childhandles.t (original)
+++ dbi/trunk/t/72childhandles.t Sun Jul 23 14:39:31 2006
@@ -22,7 +22,7 @@
exit 0;
}
-plan tests => 15;
+plan tests => 14;
{
# make 10 connections
@@ -62,10 +62,8 @@
my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
-
my $empty = $dbh->{ChildHandles};
-is ref $empty, 'ARRAY', "ChildHandles should be an array-ref if wekref is
available";
-is scalar @$empty, 0, "ChildHandles should start with an empty array-ref";
+is_deeply $empty, [], "ChildHandles should be an array-ref if wekref is
available";
# test child handles for statement handles
{
Modified: dbi/trunk/test.pl
==============================================================================
--- dbi/trunk/test.pl (original)
+++ dbi/trunk/test.pl Sun Jul 23 14:39:31 2006
@@ -37,7 +37,7 @@
$::opt_t = 0; # thread test
$::opt_n = 0; # counter for other options
-GetOptions(qw(d=i h=i l=s m t=i n=i))
+GetOptions(qw(d=i h=i l=s m=i t=i n=i))
or die "Usage: $0 [-d n] [-h n] [-m] [-t n] [-n n] [drivername]\n";
my $count = 0;
@@ -73,23 +73,22 @@
if ($::opt_m) {
#$dbh->trace(9);
- my $level = 4;
+ my $level = $::opt_m;
my $cnt = 10000;
print "Using $driver, same dbh...\n";
- #for (my $i=0; $i<$cnt; ++$i) { mem_test($dbh, undef, $level, undef,
undef, undef) }
+ for (my $i=0; $i<$cnt; ++$i) { mem_test($dbh, undef, $level, undef, undef,
undef) }
print "Using NullP, reconnecting each time...\n";
- #for (my $i=0; $i<$cnt; ++$i) { mem_test(undef, ['dbi:NullP:'], $level,
undef, undef, undef) }
+ for (my $i=0; $i<$cnt; ++$i) { mem_test(undef, ['dbi:NullP:'], $level,
undef, undef, undef) }
print "Using ExampleP, reconnecting each time...\n";
my $r_develleak = 0;
- mem_test(undef, ['dbi:ExampleP:'], $level, undef, undef, \$r_develleak)
- while 1;
+ mem_test(undef, ['dbi:NullP:'], $level, undef, undef, \$r_develleak) while
1;
#mem_test(undef, ['dbi:mysql:VC'], $level, "select * from campaigns where
length(?)>0", 0, undef) while 1;
}
elsif ($::opt_t) {
thread_test();
}
else {
-
+
# new experimental connect_test_perf method
DBI->connect_test_perf("dbi:$driver:", '', '', {
dbi_loops=>5, dbi_par=>20, dbi_verb=>1
@@ -142,9 +141,14 @@
system("echo $count; $ps$$") if (($count++ % 500) == 0);
my $dbh = $orig_dbh || DBI->connect(@$connect);
+ $dbh->{RaiseError} = 1;
my $cursor_a;
- my $dl_count = ($$r_develleak++) ? Devel::Leak::NoteSV(my $dl_handle) : 0;
+ my ($dl_count, $dl_handle);
+ if ($$r_develleak++) {
+ $dbh->trace(2);
+ $dl_count = Devel::Leak::NoteSV($dl_handle);
+ }
$cursor_a = $dbh->prepare($select) if $level >= 2;
$cursor_a->execute(@$params) if $level >= 3;
@@ -153,7 +157,10 @@
$cursor_a->finish if $cursor_a && $cursor_a->{Active};
undef $cursor_a;
- die Devel::Leak::CheckSV($dl_handle) if $dl_handle;
+ @{$dbh->{ChildHandles}} = ();
+
+ die Devel::Leak::CheckSV($dl_handle)-$dl_count
+ if $dl_handle;
$dbh->disconnect unless $orig_dbh;
undef $dbh;
