526 lines
14 KiB
Perl
526 lines
14 KiB
Perl
package WebGUI::PerformanceProfiler;
|
|
|
|
=head1 LEGAL
|
|
,
|
|
,o
|
|
:o
|
|
_....._ `:o
|
|
.' ``-. \o
|
|
/ _ _ \ \o
|
|
: /*\ /*\ ) ;o
|
|
| \_/ \_/ / ;o
|
|
( U / ;o
|
|
\ (\_____/) / /o
|
|
\ \_m_/ ( /o
|
|
\ ( ,o:
|
|
) \, .o;o' ,o'o'o.
|
|
./ /\o;o,,,,,;o;o;'' _,-o,-'''-o:o.
|
|
. ./o./) \ 'o'o'o'' _,-'o,o' o
|
|
o ./o./ / .o \. __,-o o,o'
|
|
\o. ,/o / /o/) | o o'-..____,,-o'o o_o-'
|
|
`o:o...-o,o-' ,o,/ | \ 'o.o_o_o_o,o--''
|
|
., ``o-o' ,.oo/ 'o /\.o`.
|
|
`o`o-....o'o,-' /o / \o \. ,o.. o
|
|
``o-o.o-- /o / \o.o--.. ,,,o-o'o.--o:o:o,,..:o
|
|
(oo( `--o.o`o---o'o'o,o,-''' o'o'o
|
|
\ o\ ``-o-o''''
|
|
,-o;o \o \
|
|
/o/ )o ) WebGUI::PerformanceProfiler
|
|
(o( /o / By Len Kranendonk
|
|
\o\. ...-o'o / ilance.nl
|
|
\o`o`-o'o o,o,--'
|
|
```o--'''
|
|
|
|
=cut
|
|
|
|
=head1 USAGE
|
|
|
|
This module provides functionality to profile your
|
|
WebGUI code, and find slow routines.
|
|
|
|
Using this module is simple, just add:
|
|
|
|
PerlModule WebGUI::PerformanceProfiler
|
|
PerlChildInitHandler WebGUI::PerformanceProfiler
|
|
PerlOutputFilterHandler WebGUI::PerformanceProfiler
|
|
|
|
To the apache configuration. Make sure these directives
|
|
are not inside your WebGUI vhost block, but instead above it.
|
|
|
|
By default all preloaded WebGUI code will get profiled.
|
|
You can limit the profiling to specific modules like this:
|
|
|
|
PerlSetVar whatToProfile WebGUI::Asset::Wobject
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use Time::HiRes qw(time);
|
|
use Apache2::Const -compile => qw(OK DECLINED NOT_FOUND);
|
|
use Apache2::Connection;
|
|
use Apache2::ServerUtil;
|
|
use Apache2::Filter;
|
|
use Apache2::FilterRec;
|
|
use Apache2::RequestIO;
|
|
use Apache2::RequestRec;
|
|
use ModPerl::Util;
|
|
use Net::Subnets;
|
|
|
|
my @subTimes = ();
|
|
my $depth = 0;
|
|
my %pointer;
|
|
|
|
=head2 handler
|
|
|
|
In Init, adds profiles code to subroutines.
|
|
|
|
For all other calls, adds profiler output to the file.
|
|
|
|
=cut
|
|
|
|
sub handler {
|
|
##This method does double duty as a ChildInitHandler and as an Output filter.
|
|
##therefore we don't know what kind of object we get.
|
|
my $object = shift;
|
|
my $callback = ModPerl::Util::current_callback();
|
|
if($callback eq 'PerlChildInitHandler') {
|
|
return addProfilerCode();
|
|
} else {
|
|
return output($object);
|
|
}
|
|
}
|
|
|
|
=head2 addProfilerCode
|
|
|
|
Based on the Apache config setting WhatToProfile, generate a list of all subs to
|
|
profile and adds profiling code to them. Certain subroutines are excluded, such as this sub,
|
|
AUTOLOADS and CONSTANTS.
|
|
|
|
=cut
|
|
|
|
sub addProfilerCode {
|
|
my $r = shift;
|
|
my $s = Apache2::ServerUtil->server;
|
|
my $whatToProfile = $s->dir_config('WhatToProfile') || 'WebGUI';
|
|
|
|
my %subs = findSubs($whatToProfile);
|
|
my $myself = __PACKAGE__;
|
|
while(my($name, $ref) = each(%subs)) {
|
|
unless($name =~ /$myself/i # Dont instrument ourself.
|
|
|| $name =~ /AUTOLOAD/i # Dont instrument AUTOLOAD
|
|
|| is_constant($name,$ref) # Dont instrument CONSTANTS
|
|
){
|
|
instrumentSub($name, $ref);
|
|
}
|
|
}
|
|
return Apache2::Const::DECLINED;
|
|
}
|
|
|
|
sub output {
|
|
my $f = shift;
|
|
return Apache2::Const::DECLINED unless($f->r->content_type =~ 'text/html');
|
|
my $server = Apache2::ServerUtil->server;
|
|
my $sn = $server->dir_config('ProfileSubnet');
|
|
my $subnet = [ $sn ];
|
|
if ($sn) {
|
|
my $conn = $f->c;
|
|
my $ipAddress = $conn->remote_ip;
|
|
my $net = Net::Subnets->new();
|
|
$net->subnets($subnet);
|
|
if (!$net->check(\$ipAddress)) {
|
|
return Apache2::Const::DECLINED;
|
|
}
|
|
}
|
|
while($f->read(my $buffer, 1024)) {
|
|
my $content .= $buffer;
|
|
if ($content =~ /(<\/body)/i) {
|
|
my $results = results();
|
|
$content =~ s/<\/body(.*)/${results}<\/body$1/i;
|
|
}
|
|
$f->print($content);
|
|
}
|
|
return Apache2::Const::OK;
|
|
}
|
|
|
|
=head2 findSubs
|
|
|
|
Walk the symbol tree and return a list of all subroutines with a given module
|
|
hierachy. Returns a hash of full subroutine names along with a code ref
|
|
to that sub.
|
|
|
|
=head3 pkg
|
|
|
|
A string indicating which parts of the module namespace should be searched
|
|
for subroutines.
|
|
|
|
=cut
|
|
|
|
sub findSubs {
|
|
my $pkg = shift;
|
|
my %_subs;
|
|
my @symbols;
|
|
eval('@symbols = keys(%'.$pkg.'::);');
|
|
foreach my $sym (@symbols) {
|
|
next if ($sym eq $pkg.'::'); # Self refering routine
|
|
next if ($sym =~ /^__/);
|
|
if($sym =~ /\:\:$/) {
|
|
$sym =~ s/\:\:$//;
|
|
%_subs = (%_subs, findSubs($pkg . '::' . $sym));
|
|
next;
|
|
}
|
|
next if ($sym =~ /\W/);
|
|
my $code_ref;
|
|
eval('$code_ref = *'.$pkg.'::'.$sym.'{CODE};');
|
|
next unless($code_ref);
|
|
$_subs{$pkg."::".$sym} = $code_ref;
|
|
}
|
|
return %_subs;
|
|
}
|
|
|
|
=head2 instrumentSub
|
|
|
|
Wrap profiling code around a subroutine by manipulating the symbol table.
|
|
|
|
=cut
|
|
|
|
sub instrumentSub {
|
|
my $name = shift;
|
|
my $coderef = shift;
|
|
my $prototype;
|
|
if(defined(prototype($name))) {
|
|
$prototype = '('.prototype($name).')';
|
|
}
|
|
my $instrumented_body = q(
|
|
{
|
|
profileSubStart( $name );
|
|
my $ret_val_scalar;
|
|
my @ret_val_array;
|
|
|
|
if(wantarray) {
|
|
eval { @ret_val_array = &$coderef; };
|
|
} else {
|
|
eval { $ret_val_scalar = &$coderef; };
|
|
}
|
|
die ($@) if ($@);
|
|
profileSubEnd( $name );
|
|
if(wantarray) {
|
|
return @ret_val_array;
|
|
} else {
|
|
return $ret_val_scalar;
|
|
}
|
|
};
|
|
);
|
|
eval "no warnings 'redefine'; *$name = sub $prototype $instrumented_body" ;
|
|
}
|
|
|
|
=head2 profileSubStart
|
|
|
|
Record the name of the subroutine, the time it was called and increment the depth.
|
|
|
|
=cut
|
|
|
|
sub profileSubStart {
|
|
my $routine = shift;
|
|
push(@subTimes, {
|
|
routine => $routine,
|
|
'start' => time(),
|
|
depth => ++$depth
|
|
});
|
|
$pointer{$routine} = $#subTimes;
|
|
}
|
|
|
|
=head2 profileSubEnd
|
|
|
|
Record when a subroutine was exited and decrement the depth.
|
|
|
|
=cut
|
|
|
|
sub profileSubEnd {
|
|
my $routine = shift;
|
|
my $call = $subTimes[$pointer{$routine}];
|
|
$call->{end} = time();
|
|
$depth--;
|
|
}
|
|
|
|
|
|
=head2 results
|
|
|
|
Produce the output of the profiler. The expandable,
|
|
collapsible tree of subroutine calls. Will soon
|
|
include line number of the caller (parent) subroutine,
|
|
and optionally a dump of all the parameters (!). Will
|
|
also soon include a tabular display akin to Devel::DProf's
|
|
formatted tabular output: percent total time spent in sub,
|
|
aggregate exclusive time spent in sub, aggregate inclusive
|
|
time spent in sub, number of calls to the sub, mean
|
|
exclusive time per sub call, mean inclusive time per sub
|
|
call, subroutine name, sorted by aggregate exclusive time
|
|
per sub, descending.
|
|
|
|
=cut
|
|
|
|
sub results {
|
|
my @parents = ();
|
|
my $exclTimes = {};
|
|
my $inclTimes = {};
|
|
my $output = qq|
|
|
<script>
|
|
function showhide(id){
|
|
if (document.getElementById){
|
|
obj = document.getElementById(id);
|
|
if (obj.style.display == "none"){
|
|
obj.style.display = "";
|
|
} else {
|
|
obj.style.display = "none";
|
|
}
|
|
}
|
|
}
|
|
</script>|;
|
|
$output .= '<h2>Stack Profiler</h2>';
|
|
my $total = sprintf("%.4f",($subTimes[-1]->{'end'} - $subTimes[0]->{'start'}));
|
|
$output .= '<i>Function calls: '.scalar(@subTimes).' took: '.$total.'s</i><br><br>';
|
|
for(my $entry=0;$entry <= $#subTimes;$entry++) {
|
|
my $call = $subTimes[$entry];
|
|
$call->{entry} = $entry;
|
|
$call->{duration} = $call->{end} - $call->{start};
|
|
$call->{excl} = $call->{duration};
|
|
if (defined $parents[0]) {
|
|
$subTimes[$parents[-1]]->{excl} -= $call->{duration};
|
|
}
|
|
if($subTimes[$entry + 1] && ($subTimes[$entry + 1]->{depth} > $call->{depth})) {
|
|
# Do stuff to the next line if it's at a deeper depth.
|
|
push(@parents,$entry);
|
|
}
|
|
my $nextDepth;
|
|
if(ref($subTimes[$entry +1])) {
|
|
$nextDepth = $subTimes[$entry + 1]->{depth};
|
|
} else {
|
|
$nextDepth = 1;
|
|
}
|
|
if($nextDepth < $call->{depth}) {
|
|
$nextDepth++;
|
|
for(1 .. ($call->{depth} - $nextDepth + 1)) {
|
|
pop @parents;
|
|
}
|
|
}
|
|
}
|
|
|
|
for(my $entry=0;$entry <= $#subTimes;$entry++) {
|
|
my $call = $subTimes[$entry];
|
|
$output .= "\n".' ';
|
|
$output .= ' | ' for(2..($call->{depth}));
|
|
$exclTimes->{$call->{routine}} = [] unless exists $exclTimes->{$call->{routine}};
|
|
push(@{$exclTimes->{$call->{routine}}},$call->{excl});
|
|
$inclTimes->{$call->{routine}} = [] unless exists $inclTimes->{$call->{routine}};
|
|
push(@{$inclTimes->{$call->{routine}}},$call->{duration});
|
|
if($subTimes[$entry + 1] && ($subTimes[$entry + 1]->{depth} > $call->{depth})) {
|
|
# Do stuff to the next line if it's at a deeper depth.
|
|
$output .= qq|<a href="#" onclick="showhide('profile$call->{entry}'); return(false);"> + </a>|;
|
|
} else {
|
|
$output .= '— ';
|
|
}
|
|
$output .= "<b>" if($total < ($call->{duration} * 40));
|
|
$output .= $call->{routine} . " ( ".sprintf("%.4f",$call->{duration})."s )";
|
|
$output .= " ". sprintf("%.2f",(($call->{duration} / $total)*100)).'%</b>' if($total < ($call->{duration} * 40));
|
|
$output .= "<b> Exclusive: ".sprintf("%.4f",$call->{excl})."s </b>" if ($call->{excl} ne $call->{duration});
|
|
$output .= "<br>\n";
|
|
my $nextDepth;
|
|
if(ref($subTimes[$entry +1])) {
|
|
$output .= qq|<div id="profile$entry" style="display:none;">| if ($subTimes[$entry + 1]->{depth} > $call->{depth});
|
|
$nextDepth = $subTimes[$entry + 1]->{depth};
|
|
} else {
|
|
$nextDepth = 1;
|
|
}
|
|
if($nextDepth < $call->{depth}) {
|
|
$nextDepth++;
|
|
for(0 .. ($call->{depth} - $nextDepth)) {
|
|
$output .= "\n</div>\n";
|
|
}
|
|
}
|
|
}
|
|
$output .= "<br>\n<br>\n";
|
|
$output .= '<h2>Subroutine Calls Aggregate Data</h2>';
|
|
$output .= '"Exclusive" measures the time spent in the subroutine call, excluding the time spent in its called subroutines. Inclusive measures...'."<br>\n<br>\n";
|
|
$output .= qq|
|
|
<style>
|
|
.sort-table {
|
|
font: Icon;
|
|
border: 1px Solid ThreeDShadow;
|
|
background: Window;
|
|
color: WindowText;
|
|
}
|
|
.evenST {
|
|
background: #eee;
|
|
}
|
|
|
|
.oddST {
|
|
|
|
}
|
|
.sort-table thead {
|
|
background: ButtonFace;
|
|
}
|
|
|
|
.sort-table td {
|
|
padding: 2px 5px;
|
|
}
|
|
|
|
.sort-table thead td {
|
|
border: 1px solid;
|
|
border-color: ButtonHighlight ButtonShadow
|
|
ButtonShadow ButtonHighlight;
|
|
cursor: default;
|
|
}
|
|
|
|
.sort-table thead td:active {
|
|
border-color: ButtonShadow ButtonHighlight
|
|
ButtonHighlight ButtonShadow;
|
|
padding: 3px 4px 1px 6px;
|
|
}
|
|
|
|
.sort-table thead td[_sortType=None]:active {
|
|
border-color: ButtonHighlight ButtonShadow
|
|
ButtonShadow ButtonHighlight;
|
|
padding: 2px 5px;
|
|
}
|
|
|
|
.sort-arrow {
|
|
width: 11px;
|
|
height: 11px;
|
|
background-position: center center;
|
|
background-repeat: no-repeat;
|
|
margin: 0 2px;
|
|
}
|
|
|
|
.sort-arrow.descending {
|
|
background-image: url("/extras/wobject/Profiler/downsimple.png");
|
|
|
|
}
|
|
|
|
.sort-arrow.ascending {
|
|
background-image: url("/extras/wobject/Profiler/upsimple.png");
|
|
}
|
|
|
|
</style>
|
|
<script type="text/javascript" src="/extras/wobject/Profiler/sortabletable.js"></script>
|
|
<table class="sort-table" id="subStatsTable" cellspacing="0">
|
|
<thead>
|
|
<tr>
|
|
<td>Inclusive %</td>
|
|
<td>Inclusive Total</td>
|
|
<td>Inclusive Mean</td>
|
|
<td>Calls Total</td>
|
|
<td>Exclusive %</td>
|
|
<td>Exclusive Total</td>
|
|
<td>Exclusive Mean</td>
|
|
<td>Sub Name</td>
|
|
</tr>
|
|
</thead>
|
|
<tbody>|;
|
|
my $rawtotal = ($subTimes[-1]->{'end'} - $subTimes[0]->{'start'});
|
|
foreach my $rout (keys %{$inclTimes}) {
|
|
my $totExcl = sum($exclTimes->{$rout});
|
|
my $totIncl = sum($inclTimes->{$rout});
|
|
next if ((($totExcl+0) > 1000000) || (($totExcl+0) < -1000000)); # skip problem subs.
|
|
$output .= sprintf("<tr><td>%.2f%%</td><td>%.5f</td><td>%.5f</td><td>%u</td><td>%.2f%%</td><td>%.5f</td><td>%.5f</td><td>%s</td></tr>",
|
|
(100 * $totIncl / $rawtotal ), # Inclusive %
|
|
$totIncl, # Inclusive Total
|
|
($totIncl / (scalar(@{$inclTimes->{$rout}}))), # Inclusive Mean
|
|
(scalar(@{$inclTimes->{$rout}})), # Calls Total
|
|
(100 * $totExcl / $rawtotal), # Exclusive %
|
|
$totExcl, # Exclusive Total
|
|
($totExcl / (scalar(@{$exclTimes->{$rout}}))), # Exclusive Mean
|
|
$rout # Sub Name
|
|
);
|
|
}
|
|
$output .= q@
|
|
</tbody>
|
|
</table>
|
|
|
|
<script type="text/javascript">
|
|
//<![CDATA[
|
|
|
|
function addSTClassName(el, sClassName) {
|
|
var s = el.className;
|
|
var p = s.split(" ");
|
|
var l = p.length;
|
|
for (var i = 0; i < l; i++) {
|
|
if (p[i] == sClassName)
|
|
return undef;
|
|
}
|
|
p[p.length] = sClassName;
|
|
el.className = p.join(" ").replace( /(^\s+)|(\s+$)/g, "" );
|
|
}
|
|
|
|
function removeSTClassName(el, sClassName) {
|
|
var s = el.className;
|
|
var p = s.split(" ");
|
|
var np = [];
|
|
var l = p.length;
|
|
var j = 0;
|
|
for (var i = 0; i < l; i++) {
|
|
if (p[i] != sClassName) {
|
|
np[j++] = p[i]; }
|
|
}
|
|
el.className = np.join(" ").replace( /(^\s+)|(\s+$)/g, "" );
|
|
}
|
|
|
|
function perceST(str) {
|
|
return Number(str.replace(
|
|
/%/,""));
|
|
}
|
|
|
|
SortableTable.prototype.addSortType( "Percent", perceST );
|
|
var stST = new SortableTable( document.getElementById("subStatsTable"),
|
|
["Percent", "Number", "Number", "Number", "Percent", "Number", "Number", "String"] );
|
|
|
|
// restore the class names
|
|
stST.onsort = function () {
|
|
var rows = stST.tBody.rows;
|
|
var l = rows.length;
|
|
for (var i = 0; i < l; i++) {
|
|
removeSTClassName(rows[i], i % 2 ? "oddST" : "evenST");
|
|
addSTClassName(rows[i], i % 2 ? "evenST" : "oddST");
|
|
}
|
|
};
|
|
|
|
|
|
|
|
stST.sort( 6 , 1 ); // sort by exclusive mean, descending.
|
|
|
|
//]]>
|
|
</script>@;
|
|
|
|
$output .= "<br>\n<br>\n<br>\n<br>\n";
|
|
undef(@subTimes);
|
|
return $output;
|
|
}
|
|
|
|
=head2 is_constant
|
|
|
|
Determine if a given subroutine is used to generate constants, such as subroutines created
|
|
by C<use constant foo => 2>.
|
|
|
|
=cut
|
|
|
|
sub is_constant {
|
|
no strict 'refs';
|
|
my ($name, $code) = @_;
|
|
my $proto = prototype($code);
|
|
return 0 if defined $proto and length $proto;
|
|
my $is_const;
|
|
{
|
|
local $SIG{__WARN__} = sub { $is_const = 1 if $_[0] =~ /^Constant/ };
|
|
eval { *{$name} = sub { "TEST" } };
|
|
eval { *{$name} = $code; };
|
|
}
|
|
return $is_const;
|
|
}
|
|
|
|
sub sum {
|
|
my $sum = 0;
|
|
my $arrRef = shift;
|
|
foreach my $elem (@{$arrRef}) { $sum += $elem; }
|
|
return($sum);
|
|
}
|
|
|
|
1;
|