ext/Devel/DProf/test.pl

   1 # perl
   2
   3 require 5.003;
   4
   5 use Benchmark qw( timediff timestr );
   6 use Getopt::Std 'getopts';
   7 use Config '%Config';
   8 getopts('vI:p:');
   9
  10 # -v   Verbose
  11 # -I   Add to @INC
  12 # -p   Name of perl binary
  13
  14 unless (-r 'dprofpp' and -M 'dprofpp' <= -M 'dprofpp.PL') {
  15   print STDERR "dprofpp out of date, extracting...\n";
  16   system 'perl', 'dprofpp.PL' and die 'perl dprofpp.PL: exit code $?, $!';
  17 }
  18 die "Need dprofpp, could not make it" unless -r 'dprofpp';
  19
  20 chdir( 't' ) if -d 't';
  21 @tests = @ARGV ? @ARGV : sort <*.t *.v>;  # glob-sort, for OS/2
  22
  23 $path_sep = $Config{path_sep} || ':';
  24 if( -d '../blib' ){
  25         unshift @INC, '../blib/arch', '../blib/lib';
  26 }
  27 $perl5lib = $opt_I || join( $path_sep, @INC );
  28 $perl = $opt_p || $^X;
  29
  30 if( $opt_v ){
  31         print "tests: @tests\n";
  32         print "perl: $perl\n";
  33         print "perl5lib: $perl5lib\n";
  34 }
  35 if( $perl =~ m|^\./| ){
  36         # turn ./perl into ../perl, because of chdir(t) above.
  37         $perl = ".$perl";
  38 }
  39 if( ! -f $perl ){ die "Where's Perl?" }
  40
  41 sub profile {
  42         my $test = shift;
  43         my @results;
  44         local $ENV{PERL5LIB} = $perl5lib;
  45         my $opt_d = '-d:DProf';
  46
  47         my $t_start = new Benchmark;
  48         open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n";
  49         @results = <R>;
  50         close R;
  51         my $t_total = timediff( new Benchmark, $t_start );
  52
  53         if( $opt_v ){
  54                 print "\n";
  55                 print @results
  56         }
  57
  58         print timestr( $t_total, 'nop' ), "\n";
  59 }
  60
  61
  62 sub verify {
  63         my $test = shift;
  64
  65         system $perl, '-I.', $test, $opt_v?'-v':'', '-p', $perl;
  66 }
  67
  68
  69 $| = 1;
  70 while( @tests ){
  71         $test = shift @tests;
  72         print $test . '.' x (20 - length $test);
  73         if( $test =~ /t$/ ){
  74                 profile $test;
  75         }
  76         else{
  77                 verify $test;
  78         }
  79 }