line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
1
|
|
|
1
|
|
20649
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
25
|
|
2
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
55
|
|
3
|
|
|
|
|
|
|
package Plack::Debugger::Panel::DBIProfile; |
4
|
|
|
|
|
|
|
$Plack::Debugger::Panel::DBIProfile::VERSION = '0.01'; |
5
|
|
|
|
|
|
|
|
6
|
1
|
|
|
1
|
|
712
|
use parent 'Plack::Debugger::Panel'; |
|
1
|
|
|
|
|
334
|
|
|
1
|
|
|
|
|
6
|
|
7
|
|
|
|
|
|
|
use DBI::Profile; |
8
|
|
|
|
|
|
|
use Time::HiRes qw(gettimeofday tv_interval); |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
my $DBI_PROFILE_FORMAT = '%1$s XXX %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub new { |
13
|
|
|
|
|
|
|
my $class = shift; |
14
|
|
|
|
|
|
|
my %args = @_ == 1 && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
$args{'title'} ||= 'DBI Profile'; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
my $dbi_profile = delete $args{dbi_profile} || 6; |
19
|
|
|
|
|
|
|
my $dbi_profile_format = delete $args{dbi_profile_format} || $DBI_PROFILE_FORMAT; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# This is the JS formatter function that places the data in the panel. |
22
|
|
|
|
|
|
|
# https://metacpan.org/source/STEVAN/Plack-Debugger-0.03/example/app.psgi has some examples of formatters |
23
|
|
|
|
|
|
|
# The JS source is at $app/debugger/static/js/plack-debugger.js - search for 'formatters' |
24
|
|
|
|
|
|
|
# Options available are: pass_through, generic_data_formatter, ordered_key_value_pairs, |
25
|
|
|
|
|
|
|
# simple_data_table, simple_data_table_w_headers, multiple_data_table, multiple_data_table_w_headers, |
26
|
|
|
|
|
|
|
# ordered_keys_with_nested_data, nested_data, subrequest_formatter |
27
|
|
|
|
|
|
|
$args{'formatter'} ||= 'simple_data_table'; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
$args{'before'} = sub { |
31
|
|
|
|
|
|
|
my ($self, $env) = @_; |
32
|
|
|
|
|
|
|
my $profile_obj = _set_profile_on_all_dbi_handles($dbi_profile); |
33
|
|
|
|
|
|
|
$self->stash({ start => [ gettimeofday ], profile_obj => $profile_obj}); |
34
|
|
|
|
|
|
|
}; |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
$args{'after'} = sub { |
37
|
|
|
|
|
|
|
my ($self, $env, $resp) = @_; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
my $start = $self->stash->{start}; |
40
|
|
|
|
|
|
|
my $end = [ gettimeofday ]; |
41
|
|
|
|
|
|
|
my $elapsed = tv_interval( $start, $end ); |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
$self->set_subtitle( $elapsed ); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
if (my $profile_obj = $self->stash->{profile_obj}) { |
46
|
|
|
|
|
|
|
#my $duration = gettimeofday() - $start_time; |
47
|
|
|
|
|
|
|
my $time_in_dbi = dbi_profile_merge_nodes(my $totals=[], $profile_obj->{Data}); |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
# 'Profile Path: %1$s XXX Profile Data: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)' |
50
|
|
|
|
|
|
|
my @items = $profile_obj->as_text({ |
51
|
|
|
|
|
|
|
format => $dbi_profile_format, |
52
|
|
|
|
|
|
|
sortsub => sub { |
53
|
|
|
|
|
|
|
my $ary = shift; |
54
|
|
|
|
|
|
|
@$ary = sort { $b->[0][1] <=> $a->[0][1] } @$ary; |
55
|
|
|
|
|
|
|
}, |
56
|
|
|
|
|
|
|
}); |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
my $i = 1; my $n; |
59
|
|
|
|
|
|
|
my @rows = map {[$i++ %2 ? do {$n = $i * 0.5; "$n. $_"} : ' ' x 6 . $_]} |
60
|
|
|
|
|
|
|
map {split /XXX/} @items; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
$self->set_result( [ @rows ] ); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
my $subtitle = sprintf "%.3f s (%d%%)", |
65
|
|
|
|
|
|
|
$time_in_dbi, ($elapsed) ? $time_in_dbi/$elapsed*100 : "-"; |
66
|
|
|
|
|
|
|
# only show item count if >1 because they'll always be one |
67
|
|
|
|
|
|
|
# for profile==1, the default, so it's only noise, and for other |
68
|
|
|
|
|
|
|
# profile levels they'll always be an extra 'empty' item for |
69
|
|
|
|
|
|
|
# calls that can't be associated with a particular statement etc. |
70
|
|
|
|
|
|
|
$subtitle .= " #".@items if @items > 1; |
71
|
|
|
|
|
|
|
$self->set_subtitle($subtitle); |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# disable profiling and silently discard profile data |
74
|
|
|
|
|
|
|
local $DBI::Profile::ON_DESTROY_DUMP = sub { }; |
75
|
|
|
|
|
|
|
_set_profile_on_all_dbi_handles(undef); |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
}; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
$class->SUPER::new( \%args ); |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
sub _set_profile_on_all_dbi_handles { |
83
|
|
|
|
|
|
|
my ($profile_spec) = @_; |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# for drivers we've not loaded yet |
86
|
|
|
|
|
|
|
$DBI::shared_profile = ($profile_spec) |
87
|
|
|
|
|
|
|
? DBI::Profile->_auto_new($profile_spec) # XXX not documented |
88
|
|
|
|
|
|
|
: undef; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# for any existing handles |
91
|
|
|
|
|
|
|
DBI->visit_handles(sub { |
92
|
|
|
|
|
|
|
shift->{Profile} = $DBI::shared_profile; |
93
|
|
|
|
|
|
|
return 1; # keep going to visit all |
94
|
|
|
|
|
|
|
}); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
return $DBI::shared_profile; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
1; |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
__END__ |