home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-convex / profiling / profiler.pl < prev    next >
Encoding:
Perl Script  |  1993-07-14  |  6.9 KB  |  303 lines
  1. #!/bin/perl --         -*- Mode: Perl -*- 
  2. # 
  3. # pprof - Perl Profiler
  4. # 
  5. # Copyright (C) 1991 Kresten Krab Thorup (krab@iesd.auc.dk).
  6. # 
  7. # $Id: pprof,v 1.4 1992/03/11 03:49:09 krab Exp krab $
  8. # 
  9. # Author          : Kresten Krab Thorup
  10. # Created On      : Wed Mar 11 02:09:48 1992
  11. # Last Modified By: Kresten Krab Thorup
  12. # Last Modified On: Wed Mar 11 04:49:28 1992
  13. # Update Count    : 114
  14. # 
  15. # HISTORY
  16. # 
  17.  
  18. #                                                                   
  19. # Parse profiler options
  20. #                                                                   
  21.  
  22. die "Usage:\tpprof [-o file] script [args..]\n\tpprof -m  for manual page\n"
  23.     if (@ARGV==0);
  24.  
  25. $out = '&STDERR';
  26. if($ARGV[0] =~ /^-o(\w*)/) {
  27.     shift @ARGV;
  28.     if($1 ne '') {
  29.     $out = $1;
  30.     } else {
  31.     $out = shift @ARGV;
  32.     }
  33. } 
  34.  
  35. #
  36. # '-m' will show the manual page
  37. #
  38.  
  39. if($ARGV[0] =~ /^-m/) {
  40.     while(<DATA>) {
  41.     last if (/__END__/);
  42.     }
  43.     $pager = (defined $ENV{PAGER} ? $ENV{PAGER} : 'more');
  44.     open(MAN,"|nroff -t -man|$pager");
  45.     while(<DATA>) {
  46.     last if (/__END__/);
  47.     print MAN $_;
  48.     }
  49.     close(MAN);
  50.     wait;
  51.     exit(0);
  52. } 
  53.  
  54. #                                                                   
  55. # Create the profiler to be do'ne from the script
  56. #                                                                   
  57.  
  58. $TEMP = '/tmp';
  59.  
  60. mkdir("$TEMP/pdb.$$",0744)
  61.     || die "pprof: cannot create $TEMP/pdb.$$\n";
  62. open(PERLDB,">$TEMP/pdb.$$/perldb.pl") 
  63.     || die "pprof: cannot write $TEMP/pdb.$$/perldb.pl\n";
  64. while(<DATA>) {
  65.     last if (/__END__/);
  66.     print PERLDB $_;
  67. }
  68. close(PERLDB);
  69.  
  70. #                                                                   
  71. # Fix options for perl
  72. #                                                                   
  73.  
  74. $program = $ARGV[0];
  75.  
  76. unshift(@ARGV,'-S') 
  77.     unless(-r $ARGV[0]);
  78.  
  79. unshift(@ARGV,'perl',"-I$TEMP/pdb.$$",'-d');
  80.  
  81. #                                                                   
  82. # Ready, steady...
  83. #                                                                   
  84.  
  85. $SIG{'INT'} = $SIG{'TERM'} = $SIG{'QUIT'} = $SIG{'HUP'} = 'cleanup';
  86.  
  87. if(fork) {
  88.     # this is the parent (original) process
  89.  
  90.     # wait for the program to terminate
  91.     $child = wait;
  92.     die "pprof failed!\n" if ($child == -1);
  93.  
  94.     # remove the profiler
  95.     unlink("$TEMP/pdb.$$/perldb.pl");
  96.     rmdir("$TEMP/pdb.$$");
  97.  
  98.     open(PPROF,"<$ENV{HOME}/pprof.$ENV{HOST}.$child") 
  99.     || die "could not open ~/pprof.$child\n";
  100.  
  101.     while(<PPROF>) {
  102.     ($con,$sub,$u,$s,$cu,$cs) = split(/:/);
  103.  
  104.     $User{$sub} += $u;
  105.     $Sys{$sub} += $s;
  106.     $CUser{$sub} += $cu;
  107.     $CSys{$sub} += $cs;
  108.  
  109.     $User{$con} -= $u;
  110.     $Sys{$con} -= $s;
  111.     $CUser{$con} -= $cu;
  112.     $CSys{$con} -= $cs;
  113.  
  114.     $NumCalls{$sub}++;
  115.     }
  116.  
  117.     close(PROF);
  118.     unlink("$ENV{HOME}/pprof.$ENV{HOST}.$child");
  119.  
  120.     open(OUT,">$out");
  121.  
  122.     print OUT "\nProfile of $program:\n\n";
  123.  
  124.     foreach $sub (sort(keys %NumCalls)) {
  125.     ($user, $sys, $cuser, $csys, $calls)
  126.         = ($User{$sub},
  127.            $Sys{$sub},
  128.            $CUser{$sub},
  129.            $CSys{$sub},
  130.            $NumCalls{$sub});
  131.     next if($sub eq '!');
  132.     write OUT;
  133.     }
  134.  
  135.     print OUT "\n";
  136.  
  137. } else {
  138.     # child process
  139.     exec @ARGV;
  140.     die "exec failed";
  141. }
  142.  
  143. sub cleanup {
  144.     warn "pprof: abnormal exit; cleaning up\n";
  145.     unlink("$ENV{HOME}/pprof.$ENV{HOST}.$child");
  146.     unlink("$TEMP/pdb.$$/perldb.pl");
  147.     rmdir("$TEMP/pdb.$$");
  148.     exit(1);
  149. }
  150.  
  151.  
  152. format OUT_TOP = 
  153. Subroutine               User   System CUser  Csystem     Calls
  154. ----------------------------------------------------------------------
  155. .
  156.  
  157. format OUT =
  158. @<<<<<<<<<<<<<<<<<<<<< @##.## @##.## @##.## @##.##      @####
  159. $sub,                  $user, $sys,  $cuser,$csys,      $calls
  160. .
  161.  
  162. __END__
  163. #
  164. # perldb.pl generating profile information in the file
  165. #           $HOME/pprof.$HOST.$PID
  166. #
  167. # Copyright (C) Kresten Krab Thorup 1992
  168. #
  169. package DB;
  170.  
  171. open(PPROF,">$ENV{HOME}/pprof.$ENV{HOST}.$$");
  172.  
  173. sub DB {
  174.     ($stop,$action) = split(/\0/,$dbline{$line});
  175.     eval "package (caller)[0]; $action;";
  176. }
  177.  
  178. sub sub {
  179.     local($context) = $subname;
  180.     local($subname,$user,$sys,$cuser,$csys) = ($sub,times);
  181.     
  182.     # enter statements
  183.     if (wantarray) {
  184.     @i = &$sub;
  185.     print PPROF 
  186.         $context, ':',
  187.         $subname, ':', 
  188.         (times)[0]-$user, ':',
  189.         (times)[1]-$sys, ':',
  190.         (times)[2]-$cuser, ':',
  191.         (times)[3]-$csys, "\n";
  192.     @i;
  193.     }
  194.     else {
  195.     $i = &$sub;
  196.     print PPROF 
  197.         $context, ':',
  198.         $subname, ':', 
  199.         (times)[0]-$user, ':',
  200.         (times)[1]-$sys, ':',
  201.         (times)[2]-$cuser, ':',
  202.         (times)[3]-$csys, "\n";
  203.     $i;
  204.     }
  205. }
  206.  
  207. $subname = '!';
  208.  
  209. 1;
  210.  
  211. __END__
  212. .TH PPROF 1 "10 March 1992" "$Revision: 1.4 $"
  213. .SH NAME
  214. pprof \- profile perl scripts
  215. .SH SYNOPSIS
  216. .B pprof
  217. [
  218. .B \-o 
  219. .I file
  220. ] 
  221. .I perl-script 
  222. [ 
  223. .I options... 
  224. ]
  225. .SH DESCRIPTION
  226. .I pprof
  227. runs a perl script (as perl scripts are usually run), but collects 
  228. .I profiling
  229. information as the scripts is running.  The profiling calculated is
  230. the total time a subroutine has consumed, that is, without the time
  231. used in it's own subroutine calls.
  232.  
  233. If 
  234. .B \-o
  235. .I file
  236. is given,  the output is written to 
  237. .I file
  238. instead of STDERR which is default.  Further [ 
  239. .I options... 
  240. ] applied to the perl script is simply passed on to it.
  241.  
  242. .SH OUTPUT
  243. A sample run may look like:
  244.  
  245. host$ pprof cvs uv
  246. .br
  247. .I "...Output from cvs uv "
  248.  
  249. Profile of cvs:
  250. .nf
  251. Subroutine               User  System  CUser  Csystem   Calls
  252. -------------------------------------------------------------
  253. main'CatFile             0.00   0.02   0.00   0.00         1
  254. main'CollectSets         0.12   0.00   0.00   0.00         1
  255. main'EntriesToFiles      0.00   0.03   0.00   0.00         1
  256. main'FindNames           0.05   0.05   0.02   0.17         1
  257. main'NameRepository      0.02   0.03   0.00   0.00         1
  258. main'ReadEntries         0.02   0.00   0.00   0.00         1
  259. main'SetLock             0.00   0.02   0.00   0.00         1
  260. main'VersionAndTime      0.10   0.20   0.00   0.00        17
  261. main'VersionNumber       0.08   0.15   0.00   0.00        17
  262. main'WriteEntries        0.02   0.00   0.00   0.00         1
  263. .fi
  264.  
  265. The table shows the consumed time in seconds for each subroutine, as
  266. well as the entire script.  The entries are:
  267. .TP 8
  268. .BI User
  269. Is the time consumed evaluating user code (actually running perl)
  270. .TP 8
  271. .BI System
  272. Is the time consumed during system calls (mostly input/output operations)
  273. .TP 8
  274. .BI CUser
  275. User time consumed by `childs' of the script, that is, mostly calls to
  276. `system' or things evaluated in back quotes
  277. .TP 8
  278. .BI CSystem
  279. Ditto for system
  280. .TP 8
  281. .BI Calls
  282. is the number of times the given subroutine has been called
  283. .SH FILES
  284. .PD 0
  285. .TP 30
  286. .B $HOME/pprof.$HOST.$PID
  287. profile information stored by the script as is is running
  288. .TP
  289. .B /tmp/pdb.$PID/perldb.pl
  290. the actual profiler (both files are removed before you'll ever see
  291. them) 
  292. .SH SEE ALSO
  293. .BR perl(1)
  294. .SH BUGS
  295. Cannot detect time consumption in the main program (i.e. not
  296. inside some subroutine)   
  297. .SH AUTHOR
  298. Kresten Krab Thorup, Aalborg University (krab@iesd.auc.dk)
  299. ----------------------------------------------------------------------
  300.  
  301. --
  302. What you can't do idaw, maybe you can do imorn'
  303.