home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / dprof.t < prev    next >
Text File  |  1999-10-12  |  1KB  |  81 lines
  1. #!perl
  2.  
  3. BEGIN {
  4.     chdir( 't' ) if -d 't';
  5.     unshift @INC, '../lib';
  6. }
  7.  
  8. END {
  9.     unlink 'tmon.out', 'err';
  10. }
  11.  
  12. use Benchmark qw( timediff timestr );
  13. use Getopt::Std 'getopts';
  14. use Config '%Config';
  15. getopts('vI:p:');
  16.  
  17. # -v   Verbose
  18. # -I   Add to @INC
  19. # -p   Name of perl binary
  20.  
  21. @tests = @ARGV ? @ARGV : sort <lib/dprof/*_t lib/dprof/*_v>;  # glob-sort, for OS/2
  22.  
  23. $path_sep = $Config{path_sep} || ':';
  24. $perl5lib = $opt_I || join( $path_sep, @INC );
  25. $perl = $opt_p || $^X;
  26.  
  27. if( $opt_v ){
  28.     print "tests: @tests\n";
  29.     print "perl: $perl\n";
  30.     print "perl5lib: $perl5lib\n";
  31. }
  32. if( $perl =~ m|^\./| ){
  33.     # turn ./perl into ../perl, because of chdir(t) above.
  34.     $perl = ".$perl";
  35. }
  36. if( ! -f $perl ){ die "Where's Perl?" }
  37.  
  38. sub profile {
  39.     my $test = shift;
  40.     my @results;
  41.     local $ENV{PERL5LIB} = $perl5lib;
  42.     my $opt_d = '-d:DProf';
  43.  
  44.     my $t_start = new Benchmark;
  45.     open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n";
  46.     @results = <R>;
  47.     close R;
  48.     my $t_total = timediff( new Benchmark, $t_start );
  49.  
  50.     if( $opt_v ){
  51.         print "\n";
  52.         print @results
  53.     }
  54.  
  55.     print timestr( $t_total, 'nop' ), "\n";
  56. }
  57.  
  58.  
  59. sub verify {
  60.     my $test = shift;
  61.  
  62.     system $perl, '-I../lib', '-I./lib/dprof', $test,
  63.         $opt_v?'-v':'', '-p', $perl;
  64. }
  65.  
  66.  
  67. $| = 1;
  68. print "1..18\n";
  69. while( @tests ){
  70.     $test = shift @tests;
  71.     if( $test =~ /_t$/i ){
  72.         print "# $test" . '.' x (20 - length $test);
  73.         profile $test;
  74.     }
  75.     else{
  76.         verify $test;
  77.     }
  78. }
  79.  
  80. unlink("tmon.out");
  81.