File Coverage

blib/lib/DBI/Profile.pm
Criterion Covered Total %
statement 144 159 90.5
branch 54 86 62.7
condition 19 31 61.2
subroutine 21 23 91.3
pod 3 11 27.2
total 241 310 77.7


line stmt bran cond sub pod time code
1             package DBI::Profile;
2              
3             =head1 NAME
4              
5             DBI::Profile - Performance profiling and benchmarking for the DBI
6              
7             =head1 SYNOPSIS
8              
9             The easiest way to enable DBI profiling is to set the DBI_PROFILE
10             environment variable to 2 and then run your code as usual:
11              
12             DBI_PROFILE=2 prog.pl
13              
14             This will profile your program and then output a textual summary
15             grouped by query when the program exits. You can also enable profiling by
16             setting the Profile attribute of any DBI handle:
17              
18             $dbh->{Profile} = 2;
19              
20             Then the summary will be printed when the handle is destroyed.
21              
22             Many other values apart from are possible - see L<"ENABLING A PROFILE"> below.
23              
24             =head1 DESCRIPTION
25              
26             The DBI::Profile module provides a simple interface to collect and
27             report performance and benchmarking data from the DBI.
28              
29             For a more elaborate interface, suitable for larger programs, see
30             L and L.
31             For Apache/mod_perl applications see
32             L.
33              
34             =head1 OVERVIEW
35              
36             Performance data collection for the DBI is built around several
37             concepts which are important to understand clearly.
38              
39             =over 4
40              
41             =item Method Dispatch
42              
43             Every method call on a DBI handle passes through a single 'dispatch'
44             function which manages all the common aspects of DBI method calls,
45             such as handling the RaiseError attribute.
46              
47             =item Data Collection
48              
49             If profiling is enabled for a handle then the dispatch code takes
50             a high-resolution timestamp soon after it is entered. Then, after
51             calling the appropriate method and just before returning, it takes
52             another high-resolution timestamp and calls a function to record
53             the information. That function is passed the two timestamps
54             plus the DBI handle and the name of the method that was called.
55             That data about a single DBI method call is called a I.
56              
57             =item Data Filtering
58              
59             If the method call was invoked by the DBI or by a driver then the call is
60             ignored for profiling because the time spent will be accounted for by the
61             original 'outermost' call for your code.
62              
63             For example, the calls that the selectrow_arrayref() method makes
64             to prepare() and execute() etc. are not counted individually
65             because the time spent in those methods is going to be allocated
66             to the selectrow_arrayref() method when it returns. If this was not
67             done then it would be very easy to double count time spent inside
68             the DBI.
69              
70             =item Data Storage Tree
71              
72             The profile data is accumulated as 'leaves on a tree'. The 'path' through the
73             branches of the tree to a particular leaf is determined dynamically for each sample.
74             This is a key feature of DBI profiling.
75              
76             For each profiled method call the DBI walks along the Path and uses each value
77             in the Path to step into and grow the Data tree.
78              
79             For example, if the Path is
80              
81             [ 'foo', 'bar', 'baz' ]
82              
83             then the new profile sample data will be I into the tree at
84              
85             $h->{Profile}->{Data}->{foo}->{bar}->{baz}
86              
87             But it's not very useful to merge all the call data into one leaf node (except
88             to get an overall 'time spent inside the DBI' total). It's more common to want
89             the Path to include dynamic values such as the current statement text and/or
90             the name of the method called to show what the time spent inside the DBI was for.
91              
92             The Path can contain some 'magic cookie' values that are automatically replaced
93             by corresponding dynamic values when they're used. These magic cookies always
94             start with a punctuation character.
95              
96             For example a value of 'C' in the Path causes the corresponding
97             entry in the Data to be the name of the method that was called.
98             For example, if the Path was:
99              
100             [ 'foo', '!MethodName', 'bar' ]
101              
102             and the selectall_arrayref() method was called, then the profile sample data
103             for that call will be merged into the tree at:
104              
105             $h->{Profile}->{Data}->{foo}->{selectall_arrayref}->{bar}
106              
107             =item Profile Data
108              
109             Profile data is stored at the 'leaves' of the tree as references
110             to an array of numeric values. For example:
111              
112             [
113             106, # 0: count of samples at this node
114             0.0312958955764771, # 1: total duration
115             0.000490069389343262, # 2: first duration
116             0.000176072120666504, # 3: shortest duration
117             0.00140702724456787, # 4: longest duration
118             1023115819.83019, # 5: time of first sample
119             1023115819.86576, # 6: time of last sample
120             ]
121              
122             After the first sample, later samples always update elements 0, 1, and 6, and
123             may update 3 or 4 depending on the duration of the sampled call.
124              
125             =back
126              
127             =head1 ENABLING A PROFILE
128              
129             Profiling is enabled for a handle by assigning to the Profile
130             attribute. For example:
131              
132             $h->{Profile} = DBI::Profile->new();
133              
134             The Profile attribute holds a blessed reference to a hash object
135             that contains the profile data and attributes relating to it.
136              
137             The class the Profile object is blessed into is expected to
138             provide at least a DESTROY method which will dump the profile data
139             to the DBI trace file handle (STDERR by default).
140              
141             All these examples have the same effect as each other:
142              
143             $h->{Profile} = 0;
144             $h->{Profile} = "/DBI::Profile";
145             $h->{Profile} = DBI::Profile->new();
146             $h->{Profile} = {};
147             $h->{Profile} = { Path => [] };
148              
149             Similarly, these examples have the same effect as each other:
150              
151             $h->{Profile} = 6;
152             $h->{Profile} = "6/DBI::Profile";
153             $h->{Profile} = "!Statement:!MethodName/DBI::Profile";
154             $h->{Profile} = { Path => [ '!Statement', '!MethodName' ] };
155              
156             If a non-blessed hash reference is given then the DBI::Profile
157             module is automatically C'd and the reference is blessed
158             into that class.
159              
160             If a string is given then it is processed like this:
161              
162             ($path, $module, $args) = split /\//, $string, 3
163              
164             @path = split /:/, $path
165             @args = split /:/, $args
166              
167             eval "require $module" if $module
168             $module ||= "DBI::Profile"
169              
170             $module->new( Path => \@Path, @args )
171              
172             So the first value is used to select the Path to be used (see below).
173             The second value, if present, is used as the name of a module which
174             will be loaded and it's C method called. If not present it
175             defaults to DBI::Profile. Any other values are passed as arguments
176             to the C method. For example: "C<2/DBIx::OtherProfile/Foo:42>".
177              
178             Numbers can be used as a shorthand way to enable common Path values.
179             The simplest way to explain how the values are interpreted is to show the code:
180              
181             push @Path, "DBI" if $path_elem & 0x01;
182             push @Path, "!Statement" if $path_elem & 0x02;
183             push @Path, "!MethodName" if $path_elem & 0x04;
184             push @Path, "!MethodClass" if $path_elem & 0x08;
185             push @Path, "!Caller2" if $path_elem & 0x10;
186              
187             So "2" is the same as "!Statement" and "6" (2+4) is the same as
188             "!Statement:!Method". Those are the two most commonly used values. Using a
189             negative number will reverse the path. Thus "-6" will group by method name then
190             statement.
191              
192             The splitting and parsing of string values assigned to the Profile
193             attribute may seem a little odd, but there's a good reason for it.
194             Remember that attributes can be embedded in the Data Source Name
195             string which can be passed in to a script as a parameter. For
196             example:
197              
198             dbi:DriverName(Profile=>2):dbname
199             dbi:DriverName(Profile=>{Username}:!Statement/MyProfiler/Foo:42):dbname
200              
201             And also, if the C environment variable is set then
202             The DBI arranges for every driver handle to share the same profile
203             object. When perl exits a single profile summary will be generated
204             that reflects (as nearly as practical) the total use of the DBI by
205             the application.
206              
207              
208             =head1 THE PROFILE OBJECT
209              
210             The DBI core expects the Profile attribute value to be a hash
211             reference and if the following values don't exist it will create
212             them as needed:
213              
214             =head2 Data
215              
216             A reference to a hash containing the collected profile data.
217              
218             =head2 Path
219              
220             The Path value is a reference to an array. Each element controls the
221             value to use at the corresponding level of the profile Data tree.
222              
223             If the value of Path is anything other than an array reference,
224             it is treated as if it was:
225              
226             [ '!Statement' ]
227              
228             The elements of Path array can be one of the following types:
229              
230             =head3 Special Constant
231              
232             B
233              
234             Use the current Statement text. Typically that's the value of the Statement
235             attribute for the handle the method was called with. Some methods, like
236             commit() and rollback(), are unrelated to a particular statement. For those
237             methods !Statement records an empty string.
238              
239             For statement handles this is always simply the string that was
240             given to prepare() when the handle was created. For database handles
241             this is the statement that was last prepared or executed on that
242             database handle. That can lead to a little 'fuzzyness' because, for
243             example, calls to the quote() method to build a new statement will
244             typically be associated with the previous statement. In practice
245             this isn't a significant issue and the dynamic Path mechanism can
246             be used to setup your own rules.
247              
248             B
249              
250             Use the name of the DBI method that the profile sample relates to.
251              
252             B
253              
254             Use the fully qualified name of the DBI method, including
255             the package, that the profile sample relates to. This shows you
256             where the method was implemented. For example:
257              
258             'DBD::_::db::selectrow_arrayref' =>
259             0.022902s
260             'DBD::mysql::db::selectrow_arrayref' =>
261             2.244521s / 99 = 0.022445s avg (first 0.022813s, min 0.022051s, max 0.028932s)
262              
263             The "DBD::_::db::selectrow_arrayref" shows that the driver has
264             inherited the selectrow_arrayref method provided by the DBI.
265              
266             But you'll note that there is only one call to
267             DBD::_::db::selectrow_arrayref but another 99 to
268             DBD::mysql::db::selectrow_arrayref. Currently the first
269             call doesn't record the true location. That may change.
270              
271             B
272              
273             Use a string showing the filename and line number of the code calling the method.
274              
275             B
276              
277             Use a string showing the filename and line number of the code calling the
278             method, as for !Caller, but also include filename and line number of the code
279             that called that. Calls from DBI:: and DBD:: packages are skipped.
280              
281             B
282              
283             Same as !Caller above except that only the filename is included, not the line number.
284              
285             B
286              
287             Same as !Caller2 above except that only the filenames are included, not the line number.
288              
289             B
290              
291             Use the current value of time(). Rarely used. See the more useful C below.
292              
293             B
294              
295             Where C is an integer. Use the current value of time() but with reduced precision.
296             The value used is determined in this way:
297              
298             int( time() / N ) * N
299              
300             This is a useful way to segregate a profile into time slots. For example:
301              
302             [ '!Time~60', '!Statement' ]
303              
304             =head3 Code Reference
305              
306             The subroutine is passed the handle it was called on and the DBI method name.
307             The current Statement is in $_. The statement string should not be modified,
308             so most subs start with C.
309              
310             The list of values it returns is used at that point in the Profile Path.
311             Any undefined values are treated as the string "C".
312              
313             The sub can 'veto' (reject) a profile sample by including a reference to undef
314             (C<\undef>) in the returned list. That can be useful when you want to only profile
315             statements that match a certain pattern, or only profile certain methods.
316              
317             =head3 Subroutine Specifier
318              
319             A Path element that begins with 'C<&>' is treated as the name of a subroutine
320             in the DBI::ProfileSubs namespace and replaced with the corresponding code reference.
321              
322             Currently this only works when the Path is specified by the C
323             environment variable.
324              
325             Also, currently, the only subroutine in the DBI::ProfileSubs namespace is
326             C<'&norm_std_n3'>. That's a very handy subroutine when profiling code that
327             doesn't use placeholders. See L for more information.
328              
329             =head3 Attribute Specifier
330              
331             A string enclosed in braces, such as 'C<{Username}>', specifies that the current
332             value of the corresponding database handle attribute should be used at that
333             point in the Path.
334              
335             =head3 Reference to a Scalar
336              
337             Specifies that the current value of the referenced scalar be used at that point
338             in the Path. This provides an efficient way to get 'contextual' values into
339             your profile.
340              
341             =head3 Other Values
342              
343             Any other values are stringified and used literally.
344              
345             (References, and values that begin with punctuation characters are reserved.)
346              
347              
348             =head1 REPORTING
349              
350             =head2 Report Format
351              
352             The current accumulated profile data can be formatted and output using
353              
354             print $h->{Profile}->format;
355              
356             To discard the profile data and start collecting fresh data
357             you can do:
358              
359             $h->{Profile}->{Data} = undef;
360              
361              
362             The default results format looks like this:
363              
364             DBI::Profile: 0.001015s 42.7% (5 calls) programname @ YYYY-MM-DD HH:MM:SS
365             '' =>
366             0.000024s / 2 = 0.000012s avg (first 0.000015s, min 0.000009s, max 0.000015s)
367             'SELECT mode,size,name FROM table' =>
368             0.000991s / 3 = 0.000330s avg (first 0.000678s, min 0.000009s, max 0.000678s)
369              
370             Which shows the total time spent inside the DBI, with a count of
371             the total number of method calls and the name of the script being
372             run, then a formatted version of the profile data tree.
373              
374             If the results are being formatted when the perl process is exiting
375             (which is usually the case when the DBI_PROFILE environment variable
376             is used) then the percentage of time the process spent inside the
377             DBI is also shown. If the process is not exiting then the percentage is
378             calculated using the time between the first and last call to the DBI.
379              
380             In the example above the paths in the tree are only one level deep and
381             use the Statement text as the value (that's the default behaviour).
382              
383             The merged profile data at the 'leaves' of the tree are presented
384             as total time spent, count, average time spent (which is simply total
385             time divided by the count), then the time spent on the first call,
386             the time spent on the fastest call, and finally the time spent on
387             the slowest call.
388              
389             The 'avg', 'first', 'min' and 'max' times are not particularly
390             useful when the profile data path only contains the statement text.
391             Here's an extract of a more detailed example using both statement
392             text and method name in the path:
393              
394             'SELECT mode,size,name FROM table' =>
395             'FETCH' =>
396             0.000076s
397             'fetchrow_hashref' =>
398             0.036203s / 108 = 0.000335s avg (first 0.000490s, min 0.000152s, max 0.002786s)
399              
400             Here you can see the 'avg', 'first', 'min' and 'max' for the
401             108 calls to fetchrow_hashref() become rather more interesting.
402             Also the data for FETCH just shows a time value because it was only
403             called once.
404              
405             Currently the profile data is output sorted by branch names. That
406             may change in a later version so the leaf nodes are sorted by total
407             time per leaf node.
408              
409              
410             =head2 Report Destination
411              
412             The default method of reporting is for the DESTROY method of the
413             Profile object to format the results and write them using:
414              
415             DBI->trace_msg($results, 0); # see $ON_DESTROY_DUMP below
416              
417             to write them to the DBI trace() filehandle (which defaults to
418             STDERR). To direct the DBI trace filehandle to write to a file
419             without enabling tracing the trace() method can be called with a
420             trace level of 0. For example:
421              
422             DBI->trace(0, $filename);
423              
424             The same effect can be achieved without changing the code by
425             setting the C environment variable to C<0=filename>.
426              
427             The $DBI::Profile::ON_DESTROY_DUMP variable holds a code ref
428             that's called to perform the output of the formatted results.
429             The default value is:
430              
431             $ON_DESTROY_DUMP = sub { DBI->trace_msg($results, 0) };
432              
433             Apart from making it easy to send the dump elsewhere, it can also
434             be useful as a simple way to disable dumping results.
435              
436             =head1 CHILD HANDLES
437              
438             Child handles inherit a reference to the Profile attribute value
439             of their parent. So if profiling is enabled for a database handle
440             then by default the statement handles created from it all contribute
441             to the same merged profile data tree.
442              
443              
444             =head1 PROFILE OBJECT METHODS
445              
446             =head2 format
447              
448             See L.
449              
450             =head2 as_node_path_list
451              
452             @ary = $dbh->{Profile}->as_node_path_list();
453             @ary = $dbh->{Profile}->as_node_path_list($node, $path);
454              
455             Returns the collected data ($dbh->{Profile}{Data}) restructured into a list of
456             array refs, one for each leaf node in the Data tree. This 'flat' structure is
457             often much simpler for applications to work with.
458              
459             The first element of each array ref is a reference to the leaf node.
460             The remaining elements are the 'path' through the data tree to that node.
461              
462             For example, given a data tree like this:
463              
464             {key1a}{key2a}[node1]
465             {key1a}{key2b}[node2]
466             {key1b}{key2a}{key3a}[node3]
467              
468             The as_node_path_list() method will return this list:
469              
470             [ [node1], 'key1a', 'key2a' ]
471             [ [node2], 'key1a', 'key2b' ]
472             [ [node3], 'key1b', 'key2a', 'key3a' ]
473              
474             The nodes are ordered by key, depth-first.
475              
476             The $node argument can be used to focus on a sub-tree.
477             If not specified it defaults to $dbh->{Profile}{Data}.
478              
479             The $path argument can be used to specify a list of path elements that will be
480             added to each element of the returned list. If not specified it defaults to a
481             ref to an empty array.
482              
483             =head2 as_text
484              
485             @txt = $dbh->{Profile}->as_text();
486             $txt = $dbh->{Profile}->as_text({
487             node => undef,
488             path => [],
489             separator => " > ",
490             format => '%1$s: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'."\n";
491             sortsub => sub { ... },
492             );
493              
494             Returns the collected data ($dbh->{Profile}{Data}) reformatted into a list of formatted strings.
495             In scalar context the list is returned as a single concatenated string.
496              
497             A hashref can be used to pass in arguments, the default values are shown in the example above.
498              
499             The C and arguments are passed to as_node_path_list().
500              
501             The C argument is used to join the elements of the path for each leaf node.
502              
503             The C argument is used to pass in a ref to a sub that will order the list.
504             The subroutine will be passed a reference to the array returned by
505             as_node_path_list() and should sort the contents of the array in place.
506             The return value from the sub is ignored. For example, to sort the nodes by the
507             second level key you could use:
508              
509             sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary }
510              
511             The C argument is a C format string that specifies the format
512             to use for each leaf node. It uses the explicit format parameter index
513             mechanism to specify which of the arguments should appear where in the string.
514             The arguments to sprintf are:
515              
516             1: path to node, joined with the separator
517             2: average duration (total duration/count)
518             (3 thru 9 are currently unused)
519             10: count
520             11: total duration
521             12: first duration
522             13: smallest duration
523             14: largest duration
524             15: time of first call
525             16: time of first call
526              
527             =head1 CUSTOM DATA MANIPULATION
528              
529             Recall that C<< $h->{Profile}->{Data} >> is a reference to the collected data.
530             Either to a 'leaf' array (when the Path is empty, i.e., DBI_PROFILE env var is 1),
531             or a reference to hash containing values that are either further hash
532             references or leaf array references.
533              
534             Sometimes it's useful to be able to summarise some or all of the collected data.
535             The dbi_profile_merge_nodes() function can be used to merge leaf node values.
536              
537             =head2 dbi_profile_merge_nodes
538              
539             use DBI qw(dbi_profile_merge_nodes);
540              
541             $time_in_dbi = dbi_profile_merge_nodes(my $totals=[], @$leaves);
542              
543             Merges profile data node. Given a reference to a destination array, and zero or
544             more references to profile data, merges the profile data into the destination array.
545             For example:
546              
547             $time_in_dbi = dbi_profile_merge_nodes(
548             my $totals=[],
549             [ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
550             [ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
551             );
552              
553             $totals will then contain
554              
555             [ 25, 0.93, 0.11, 0.01, 0.23, 1023110000, 1023110010 ]
556              
557             and $time_in_dbi will be 0.93;
558              
559             The second argument need not be just leaf nodes. If given a reference to a hash
560             then the hash is recursively searched for leaf nodes and all those found
561             are merged.
562              
563             For example, to get the time spent 'inside' the DBI during an http request,
564             your logging code run at the end of the request (i.e. mod_perl LogHandler)
565             could use:
566              
567             my $time_in_dbi = 0;
568             if (my $Profile = $dbh->{Profile}) { # if DBI profiling is enabled
569             $time_in_dbi = dbi_profile_merge_nodes(my $total=[], $Profile->{Data});
570             $Profile->{Data} = {}; # reset the profile data
571             }
572              
573             If profiling has been enabled then $time_in_dbi will hold the time spent inside
574             the DBI for that handle (and any other handles that share the same profile data)
575             since the last request.
576              
577             Prior to DBI 1.56 the dbi_profile_merge_nodes() function was called dbi_profile_merge().
578             That name still exists as an alias.
579              
580             =head1 CUSTOM DATA COLLECTION
581              
582             =head2 Using The Path Attribute
583              
584             XXX example to be added later using a selectall_arrayref call
585             XXX nested inside a fetch loop where the first column of the
586             XXX outer loop is bound to the profile Path using
587             XXX bind_column(1, \${ $dbh->{Profile}->{Path}->[0] })
588             XXX so you end up with separate profiles for each loop
589             XXX (patches welcome to add this to the docs :)
590              
591             =head2 Adding Your Own Samples
592              
593             The dbi_profile() function can be used to add extra sample data
594             into the profile data tree. For example:
595              
596             use DBI;
597             use DBI::Profile (dbi_profile dbi_time);
598              
599             my $t1 = dbi_time(); # floating point high-resolution time
600              
601             ... execute code you want to profile here ...
602              
603             my $t2 = dbi_time();
604             dbi_profile($h, $statement, $method, $t1, $t2);
605              
606             The $h parameter is the handle the extra profile sample should be
607             associated with. The $statement parameter is the string to use where
608             the Path specifies !Statement. If $statement is undef
609             then $h->{Statement} will be used. Similarly $method is the string
610             to use if the Path specifies !MethodName. There is no
611             default value for $method.
612              
613             The $h->{Profile}{Path} attribute is processed by dbi_profile() in
614             the usual way.
615              
616             The $h parameter is usually a DBI handle but it can also be a reference to a
617             hash, in which case the dbi_profile() acts on each defined value in the hash.
618             This is an efficient way to update multiple profiles with a single sample,
619             and is used by the L module.
620              
621             =head1 SUBCLASSING
622              
623             Alternate profile modules must subclass DBI::Profile to help ensure
624             they work with future versions of the DBI.
625              
626              
627             =head1 CAVEATS
628              
629             Applications which generate many different statement strings
630             (typically because they don't use placeholders) and profile with
631             !Statement in the Path (the default) will consume memory
632             in the Profile Data structure for each statement. Use a code ref
633             in the Path to return an edited (simplified) form of the statement.
634              
635             If a method throws an exception itself (not via RaiseError) then
636             it won't be counted in the profile.
637              
638             If a HandleError subroutine throws an exception (rather than returning
639             0 and letting RaiseError do it) then the method call won't be counted
640             in the profile.
641              
642             Time spent in DESTROY is added to the profile of the parent handle.
643              
644             Time spent in DBI->*() methods is not counted. The time spent in
645             the driver connect method, $drh->connect(), when it's called by
646             DBI->connect is counted if the DBI_PROFILE environment variable is set.
647              
648             Time spent fetching tied variables, $DBI::errstr, is counted.
649              
650             Time spent in FETCH for $h->{Profile} is not counted, so getting the profile
651             data doesn't alter it.
652              
653             DBI::PurePerl does not support profiling (though it could in theory).
654              
655             For asynchronous queries, time spent while the query is running on the
656             backend is not counted.
657              
658             A few platforms don't support the gettimeofday() high resolution
659             time function used by the DBI (and available via the dbi_time() function).
660             In which case you'll get integer resolution time which is mostly useless.
661              
662             On Windows platforms the dbi_time() function is limited to millisecond
663             resolution. Which isn't sufficiently fine for our needs, but still
664             much better than integer resolution. This limited resolution means
665             that fast method calls will often register as taking 0 time. And
666             timings in general will have much more 'jitter' depending on where
667             within the 'current millisecond' the start and end timing was taken.
668              
669             This documentation could be more clear. Probably needs to be reordered
670             to start with several examples and build from there. Trying to
671             explain the concepts first seems painful and to lead to just as
672             many forward references. (Patches welcome!)
673              
674             =cut
675              
676              
677 12     12   6451 use strict;
  12         37  
  12         452  
678 12     12   72 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  12         27  
  12         860  
679 12     12   80 use Exporter ();
  12         26  
  12         188  
680 12     12   242751 use UNIVERSAL ();
  12         173  
  12         319  
681 12     12   77 use Carp;
  12         30  
  12         982  
682              
683 12     12   5702 use DBI qw(dbi_time dbi_profile dbi_profile_merge_nodes dbi_profile_merge);
  12         38  
  12         2404  
684              
685             $VERSION = "2.015065";
686              
687             @ISA = qw(Exporter);
688             @EXPORT = qw(
689             DBIprofile_Statement
690             DBIprofile_MethodName
691             DBIprofile_MethodClass
692             dbi_profile
693             dbi_profile_merge_nodes
694             dbi_profile_merge
695             dbi_time
696             );
697             @EXPORT_OK = qw(
698             format_profile_thingy
699             );
700              
701 12     12   101 use constant DBIprofile_Statement => '!Statement';
  12         29  
  12         1083  
702 12     12   82 use constant DBIprofile_MethodName => '!MethodName';
  12         28  
  12         636  
703 12     12   72 use constant DBIprofile_MethodClass => '!MethodClass';
  12         136  
  12         5559  
704              
705             our $ON_DESTROY_DUMP = sub { DBI->trace_msg(shift, 0) };
706             our $ON_FLUSH_DUMP = sub { DBI->trace_msg(shift, 0) };
707              
708             sub new {
709 20     20 0 42 my $class = shift;
710 20         63 my $profile = { @_ };
711 20         165 return bless $profile => $class;
712             }
713              
714              
715             sub _auto_new {
716 20     20   61 my $class = shift;
717 20         54 my ($arg) = @_;
718              
719             # This sub is called by DBI internals when a non-hash-ref is
720             # assigned to the Profile attribute. For example
721             # dbi:mysql(RaiseError=>1,Profile=>!Statement:!MethodName/DBIx::MyProfile/arg1:arg2):dbname
722             # This sub works out what to do and returns a suitable hash ref.
723              
724 20 50       71 $arg =~ s/^DBI::/2\/DBI::/
725             and carp "Automatically changed old-style DBI::Profile specification to $arg";
726              
727             # it's a path/module/k1:v1:k2:v2:... list
728 20         85 my ($path, $package, $args) = split /\//, $arg, 3;
729 20 100       85 my @args = (defined $args) ? split(/:/, $args, -1) : ();
730 20         36 my @Path;
731              
732 20         65 for my $element (split /:/, $path) {
733 18 100       102 if (DBI::looks_like_number($element)) {
    50          
734 16 50       62 my $reverse = ($element < 0) ? ($element=-$element, 1) : 0;
735 16         26 my @p;
736             # a single "DBI" is special-cased in format()
737 16 50       47 push @p, "DBI" if $element & 0x01;
738 16 100       52 push @p, DBIprofile_Statement if $element & 0x02;
739 16 100       49 push @p, DBIprofile_MethodName if $element & 0x04;
740 16 50       46 push @p, DBIprofile_MethodClass if $element & 0x08;
741 16 100       39 push @p, '!Caller2' if $element & 0x10;
742 16 50       66 push @Path, ($reverse ? reverse @p : @p);
743             }
744             elsif ($element =~ m/^&(\w.*)/) {
745 2         12 my $name = "DBI::ProfileSubs::$1"; # capture $1 early
746 2         1316 require DBI::ProfileSubs;
747 12     12   91 my $code = do { no strict; *{$name}{CODE} };
  12         27  
  12         19490  
  2         5  
  2         3  
  2         11  
748 2 50       8 if (defined $code) {
749 2         8 push @Path, $code;
750             }
751             else {
752 0         0 warn "$name: subroutine not found\n";
753 0         0 push @Path, $element;
754             }
755             }
756             else {
757 0         0 push @Path, $element;
758             }
759             }
760              
761 20 100       477 eval "require $package" if $package; # silently ignores errors
762 20   66     79 $package ||= $class;
763              
764 20         105 return $package->new(Path => \@Path, @args);
765             }
766              
767              
768             sub empty { # empty out profile data
769 48     48 0 127 my $self = shift;
770 48 50       166 DBI->trace_msg("profile data discarded\n",0) if $self->{Trace};
771 48         167 $self->{Data} = undef;
772             }
773              
774             sub filename { # baseclass method, see DBI::ProfileDumper
775 0     0 0 0 return undef;
776             }
777              
778             sub flush_to_disk { # baseclass method, see DBI::ProfileDumper & DashProfiler::Core
779 0     0 0 0 my $self = shift;
780 0 0       0 return unless $ON_FLUSH_DUMP;
781 0 0       0 return unless $self->{Data};
782 0         0 my $detail = $self->format();
783 0 0       0 $ON_FLUSH_DUMP->($detail) if $detail;
784             }
785              
786              
787             sub as_node_path_list {
788 84     84 1 119 my ($self, $node, $path) = @_;
789             # convert the tree into an array of arrays
790             # from
791             # {key1a}{key2a}[node1]
792             # {key1a}{key2b}[node2]
793             # {key1b}{key2a}{key3a}[node3]
794             # to
795             # [ [node1], 'key1a', 'key2a' ]
796             # [ [node2], 'key1a', 'key2b' ]
797             # [ [node3], 'key1b', 'key2a', 'key3a' ]
798              
799 84 50 66     158 $node ||= $self->{Data} or return;
800 84   100     125 $path ||= [];
801 84 100       130 if (ref $node eq 'HASH') { # recurse
802 48         70 $path = [ @$path, undef ];
803             return map {
804 48         101 $path->[-1] = $_;
  76         89  
805 76 50       147 ($node->{$_}) ? $self->as_node_path_list($node->{$_}, $path) : ()
806             } sort keys %$node;
807             }
808 36         130 return [ $node, @$path ];
809             }
810              
811              
812             sub as_text {
813 6     6 1 1144 my ($self, $args_ref) = @_;
814 6   100     25 my $separator = $args_ref->{separator} || " > ";
815             my $format_path_element = $args_ref->{format_path_element}
816 6   50     24 || "%s"; # or e.g., " key%2$d='%s'"
817             my $format = $args_ref->{format}
818 6   100     19 || '%1$s: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'."\n";
819              
820 6         19 my @node_path_list = $self->as_node_path_list(undef, $args_ref->{path});
821              
822 6 100       24 $args_ref->{sortsub}->(\@node_path_list) if $args_ref->{sortsub};
823              
824 6         39 my $eval = "qr/".quotemeta($separator)."/";
825 6   33     368 my $separator_re = eval($eval) || quotemeta($separator);
826             #warn "[$eval] = [$separator_re]";
827 6         18 my @text;
828 6         17 my @spare_slots = (undef) x 7;
829 6         13 for my $node_path (@node_path_list) {
830 20         42 my ($node, @path) = @$node_path;
831 20         24 my $idx = 0;
832 20         30 for (@path) {
833 56         69 s/[\r\n]+/ /g;
834 56         110 s/$separator_re/ /g;
835 56         59 ++$idx;
836 56 50       72 if ($format_path_element eq "%s") {
837 56         90 $_ = sprintf $format_path_element, $_;
838             } else {
839 0         0 $_ = sprintf $format_path_element, $_, $idx;
840             }
841             }
842 20 50       152 push @text, sprintf $format,
843             join($separator, @path), # 1=path
844             ($node->[0] ? $node->[1]/$node->[0] : 0), # 2=avg
845             @spare_slots,
846             @$node; # 10=count, 11=dur, 12=first_dur, 13=min, 14=max, 15=first_called, 16=last_called
847             }
848 6 50       17 return @text if wantarray;
849 6         41 return join "", @text;
850             }
851              
852              
853             sub format {
854 40     40 1 78 my $self = shift;
855 40   33     106 my $class = ref($self) || $self;
856              
857 40         75 my $prologue = "$class: ";
858             my $detail = $self->format_profile_thingy(
859 40         124 $self->{Data}, 0, " ",
860             my $path = [],
861             my $leaves = [],
862             )."\n";
863              
864 40 100       102 if (@$leaves) {
865 38         277 dbi_profile_merge_nodes(my $totals=[], @$leaves);
866 38         94 my ($count, $time_in_dbi, undef, undef, undef, $t1, $t2) = @$totals;
867 38         242 (my $progname = $0) =~ s:.*/::;
868 38 50       100 if ($count) {
869 38         124 $prologue .= sprintf "%fs ", $time_in_dbi;
870 38 50       96 my $perl_time = ($DBI::PERL_ENDING) ? time() - $^T : $t2-$t1;
871 38 100       146 $prologue .= sprintf "%.2f%% ", $time_in_dbi/$perl_time*100 if $perl_time;
872 38         960 my @lt = localtime(time);
873 38         232 my $ts = sprintf "%d-%02d-%02d %02d:%02d:%02d",
874             1900+$lt[5], $lt[4]+1, @lt[3,2,1,0];
875 38         161 $prologue .= sprintf "(%d calls) $progname \@ $ts\n", $count;
876             }
877 38 50 100     212 if (@$leaves == 1 && ref($self->{Data}) eq 'HASH' && $self->{Data}->{DBI}) {
      66        
878 0         0 $detail = ""; # hide the "DBI" from DBI_PROFILE=1
879             }
880             }
881 40 50       90 return ($prologue, $detail) if wantarray;
882 40         142 return $prologue.$detail;
883             }
884              
885              
886             sub format_profile_leaf {
887 106     106 0 251 my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
888 106 50       192 croak "format_profile_leaf called on non-leaf ($thingy)"
889             unless UNIVERSAL::isa($thingy,'ARRAY');
890              
891 106 50       190 push @$leaves, $thingy if $leaves;
892 106         188 my ($count, $total_time, $first_time, $min, $max, $first_called, $last_called) = @$thingy;
893 106 100       467 return sprintf "%s%fs\n", ($pad x $depth), $total_time
894             if $count <= 1;
895 36 50       417 return sprintf "%s%fs / %d = %fs avg (first %fs, min %fs, max %fs)\n",
896             ($pad x $depth), $total_time, $count, $count ? $total_time/$count : 0,
897             $first_time, $min, $max;
898             }
899              
900              
901             sub format_profile_branch {
902 108     108 0 188 my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
903 108 50       196 croak "format_profile_branch called on non-branch ($thingy)"
904             unless UNIVERSAL::isa($thingy,'HASH');
905 108         113 my @chunk;
906 108         279 my @keys = sort keys %$thingy;
907 108         208 while ( @keys ) {
908 176         219 my $k = shift @keys;
909 176         212 my $v = $thingy->{$k};
910 176         216 push @$path, $k;
911 176         340 push @chunk, sprintf "%s'%s' =>\n%s",
912             ($pad x $depth), $k,
913             $self->format_profile_thingy($v, $depth+1, $pad, $path, $leaves);
914 176         370 pop @$path;
915             }
916 108         376 return join "", @chunk;
917             }
918              
919              
920             sub format_profile_thingy {
921 216     216 0 338 my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
922 216 100       312 return "undef" if not defined $thingy;
923 214 100       432 return $self->format_profile_leaf( $thingy, $depth, $pad, $path, $leaves)
924             if UNIVERSAL::isa($thingy,'ARRAY');
925 108 50       300 return $self->format_profile_branch($thingy, $depth, $pad, $path, $leaves)
926             if UNIVERSAL::isa($thingy,'HASH');
927 0         0 return "$thingy\n";
928             }
929              
930              
931             sub on_destroy {
932 50     50 0 62 my $self = shift;
933 50 50       102 return unless $ON_DESTROY_DUMP;
934 50 100       97 return unless $self->{Data};
935 38         94 my $detail = $self->format();
936 38 50       142 $ON_DESTROY_DUMP->($detail) if $detail;
937 38         154 $self->{Data} = undef;
938             }
939              
940             sub DESTROY {
941 56     56   23043 my $self = shift;
942 56         79 local $@;
943             DBI->trace_msg("profile data DESTROY\n",0)
944 56 50 50     260 if (($self->{Trace}||0) >= 2);
945 56         91 eval { $self->on_destroy };
  56         129  
946 56 50       988 if ($@) {
947 0           chomp $@;
948 0   0       my $class = ref($self) || $self;
949 0           DBI->trace_msg("$class on_destroy failed: $@", 0);
950             }
951             }
952              
953             1;
954