home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / SmallProf.pm < prev    next >
Encoding:
Perl POD Document  |  2004-04-15  |  6.5 KB  |  271 lines
  1. package Apache::SmallProf;
  2.  
  3. use strict;
  4. use vars qw($VERSION @ISA);
  5. use Apache::DB 0.06;
  6. @ISA = qw(DB);
  7.  
  8. $VERSION = '0.04';
  9.  
  10. $Apache::Registry::MarkLine = 0;
  11.  
  12. BEGIN { 
  13.     use constant MP2 => eval { require mod_perl; $mod_perl::VERSION > 1.99 };
  14.     die "mod_perl is required to run this module: $@" if $@; 
  15.  
  16.     if (MP2) { 
  17.         require Apache2; 
  18.         require APR::Pool; 
  19.     }
  20. }
  21.  
  22. sub handler {
  23.     my $r = shift;
  24.     my $sdir = $r->dir_config('SmallProfDir') || 'logs/smallprof';
  25.     my $dir = $r->server_root_relative($sdir);
  26.     mkdir $dir, 0755 unless -d $dir;
  27.  
  28.     unless (-d $dir) {
  29.     die "$dir does not exist: $!";
  30.     }
  31.  
  32.     (my $uri = $r->uri) =~ s,/,::,g;
  33.     $uri =~ s/^:+//;
  34.  
  35.     my $db = Apache::SmallProf->new(file => "$dir/$uri", dir => $dir);
  36.     $db->begin;
  37.  
  38.     if (MP2) { 
  39.         $r->pool->cleanup_register(sub { 
  40.         local $DB::profile = 0;
  41.         $db->end;
  42.         0;
  43.         });
  44.     }
  45.     else { 
  46.         $r->register_cleanup(sub { 
  47.         local $DB::profile = 0;
  48.         $db->end;
  49.         0;
  50.         });
  51.     }
  52.     0;
  53. }
  54.  
  55. package DB;
  56.  
  57. sub new {
  58.     my $class = shift;
  59.     my $self = bless {@_}, $class;
  60.  
  61.     Apache::DB->init;
  62.  
  63.     $self;
  64. }
  65.  
  66. use strict;
  67. use Time::HiRes qw(time);
  68. $DB::profile = 0; #skip startup profiles
  69.  
  70. sub begin {
  71.     $DB::trace = 1;
  72.  
  73.     $DB::drop_zeros = 0;
  74.     $DB::profile = 1;
  75.     if (-e '.smallprof') {
  76.     do '.smallprof';
  77.     }
  78.     $DB::prevf = '';
  79.     $DB::prevl = 0;
  80.     my($diff,$cdiff);
  81.     my($testDB) = sub {
  82.     my($pkg,$filename,$line) = caller;
  83.     $DB::profile || return;
  84.     %DB::packages && !$DB::packages{$pkg} && return;
  85.     };
  86.  
  87.     # "Null time" compensation code
  88.     $DB::nulltime = 0;
  89.     for (1..100) {
  90.     my($u,$s,$cu,$cs) = times;
  91.     $DB::cstart = $u+$s+$cu+$cs;
  92.     $DB::start = time;
  93.     &$testDB;
  94.     ($u,$s,$cu,$cs) = times;
  95.     $DB::cdone = $u+$s+$cu+$cs;
  96.     $DB::done = time;
  97.     $diff = $DB::done - $DB::start;
  98.     $DB::nulltime += $diff;
  99.     }
  100.     $DB::nulltime /= 100;
  101.  
  102.     my($u,$s,$cu,$cs) = times;
  103.     $DB::cstart = $u+$s+$cu+$cs;
  104.     $DB::start = time;
  105. }
  106.  
  107. sub DB {
  108.     my($pkg,$filename,$line) = caller;
  109.     $DB::profile || return;
  110.     %DB::packages && !$DB::packages{$pkg} && return;
  111.     my($u,$s,$cu,$cs) = times;
  112.     $DB::cdone = $u+$s+$cu+$cs;
  113.     $DB::done = time;
  114.  
  115.     # Now save the _< array for later reference.  If we don't do this here, 
  116.     # evals which do not define subroutines will disappear.
  117.     no strict 'refs';
  118.     $DB::listings{$filename} = \@{"main::_<$filename"} if 
  119.     defined(@{"main::_<$filename"});
  120.     use strict 'refs';
  121.  
  122.     my $delta = $DB::done - $DB::start;
  123.     $delta = ($delta > $DB::nulltime) ? $delta - $DB::nulltime : 0;
  124.     $DB::profiles{$filename}->[$line]++;
  125.     $DB::times{$DB::prevf}->[$DB::prevl] += $delta;
  126.     $DB::ctimes{$DB::prevf}->[$DB::prevl] += ($DB::cdone - $DB::cstart);
  127.     ($DB::prevf, $DB::prevl) = ($filename, $line);
  128.  
  129.     ($u,$s,$cu,$cs) = times;
  130.     $DB::cstart = $u+$s+$cu+$cs;
  131.     $DB::start = time;
  132. }
  133.  
  134. use File::Basename qw(dirname basename);
  135.  
  136. sub out_file {
  137.     my($self, $fname) = @_;
  138.     if($fname =~ /eval/) {
  139.     $fname = basename($self->{file}) || "smallprof.out";
  140.     } 
  141.     elsif($fname =~ s/^Perl.*Handler subroutine \`(.*)\'$/$1/) {
  142.     }
  143.     else {
  144.     for (keys %INC) {
  145.         if($fname =~ s,.*$_,$_,) {
  146.         $fname =~ s,/+,::,g;
  147.         last;
  148.         }
  149.     }
  150.     if($fname =~ m,/,) {
  151.         $fname = basename($fname);
  152.     }
  153.     }
  154.     return "$self->{dir}/$fname.prof";
  155. }
  156.  
  157. sub end {
  158.     my $self = shift;
  159.  
  160.     # Get time on last line executed.
  161.     my($u,$s,$cu,$cs) = times;
  162.     $DB::cdone = $u+$s+$cu+$cs;
  163.     $DB::done = time;
  164.     my $delta = $DB::done - $DB::start;
  165.     $delta = ($delta > $DB::nulltime) ? $delta - $DB::nulltime : 0;
  166.     $DB::times{$DB::prevf}->[$DB::prevl] += $delta;
  167.     $DB::ctimes{$DB::prevf}->[$DB::prevl] += ($DB::cdone - $DB::cstart);
  168.  
  169.     my($i, $stat, $time, $ctime, $line, $file);
  170.  
  171.     my %cnt = ();
  172.     foreach $file (sort keys %DB::profiles) {
  173.     my $out = $self->out_file($file);
  174.     open(OUT, ">$out") or die "can't open $out $!";
  175.     if (defined($DB::listings{$file})) {
  176.         $i = -1;
  177.         foreach $line (@{$DB::listings{$file}}) {
  178.         ++$i or next;
  179.         chomp $line;
  180.         $stat = $DB::profiles{$file}->[$i] || 0 
  181.             or !$DB::drop_zeros or next;
  182.         $time = defined($DB::times{$file}->[$i]) ?
  183.             $DB::times{$file}->[$i] : 0;
  184.         $ctime = defined($DB::ctimes{$file}->[$i]) ?
  185.           $DB::ctimes{$file}->[$i] : 0;
  186.         printf OUT "%10d %.6f %.6f %10d:%s\n", 
  187.         $stat, $time, $ctime, $i, $line;
  188.         }
  189.     } 
  190.     else {
  191.         $line = "The code for $file is not in the symbol table.";
  192.         warn $line;
  193.         for ($i=1; $i <= $#{$DB::profiles{$file}}; $i++) {
  194.         next unless 
  195.             ($stat = $DB::profiles{$file}->[$i] || 0 
  196.              or !$DB::drop_zeros);
  197.         $time = defined($DB::times{$file}->[$i]) ?
  198.             $DB::times{$file}->[$i] : 0;
  199.         $ctime = defined($DB::ctimes{$file}->[$i]) ?
  200.           $DB::ctimes{$file}->[$i] : 0;
  201.         printf OUT "%10d %.6f %.6f %10d:%s\n", 
  202.         $stat, $time, $ctime, $i, $line;
  203.         } 
  204.     }
  205.     close OUT;
  206.     }
  207. }
  208.  
  209. sub sub {
  210.     no strict 'refs';
  211.     local $^W = 0;
  212.  
  213.     goto &$DB::sub unless $DB::profile;
  214.  
  215.     if (defined($DB::sub{$DB::sub})) {
  216.     my($m,$s) = ($DB::sub{$DB::sub} =~ /.+(?=:)|[^:-]+/g);
  217.     $DB::profiles{$m}->[$s]++;
  218.     $DB::listings{$m} = \@{"main::_<$m"} if defined(@{"main::_<$m"});
  219.     }
  220.     goto &$DB::sub;
  221. }
  222.  
  223. 1;
  224. __END__
  225.  
  226. =head1 NAME
  227.  
  228. Apache::SmallProf - Hook Devel::SmallProf into mod_perl
  229.  
  230. =head1 SYNOPSIS
  231.  
  232.  <IfDefine PERLSMALLPROF>
  233.  
  234.     <Perl>
  235.      use Apache::DB ();
  236.      Apache::DB->init;
  237.     </Perl>
  238.  
  239.     <Location />
  240.      PerlFixupHandler Apache::SmallProf
  241.     </Location>
  242.  </IfDefine>
  243.  
  244. =head1 DESCRIPTION
  245.  
  246. Devel::SmallProf is a line-by-line code profiler.  Apache::SmallProf provides
  247. this profiler in the mod_perl environment.  Profiles are written to
  248. I<ServerRoot/logs/smallprof> and unlike I<Devel::SmallProf> the profile is
  249. split into several files based on package name.
  250.  
  251. The I<Devel::SmallProf> documentation explains how to analyize the profiles,
  252. e.g.:
  253.  
  254.  % sort -nrk 2  logs/smallprof/CGI.pm.prof | more
  255.          1 0.104736       629:     eval "package $pack; $$auto";
  256.          2 0.002831       647:       eval "package $pack; $code";
  257.          5 0.002002       259:    return $self->all_parameters unless @p;
  258.          5 0.000867       258:    my($self,@p) = self_or_default(@_);
  259.          ...
  260.  
  261. =head1 SEE ALSO
  262.  
  263. Devel::SmallProf(3), Apache::DB(3), Apache::DProf(3)
  264.  
  265. =head1 AUTHOR
  266.  
  267. Devel::SmallProf - Ted Ashton
  268. Apache::SmallProf derived from Devel::SmallProf - Doug MacEachern
  269.  
  270. Currently maintained by Frank Wiles <frank@wiles.org>
  271.