This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bdd70b002b2a3eea6e77e02e633b8a85c48fd86c
[perl5.git] / ext / Devel / DProf / t / DProf.t
1 #!perl
2
3 BEGIN {
4     chdir( 't' ) if -d 't';
5     @INC = '../lib';
6     require './test.pl';      # for which_perl() etc
7     require Config; import Config;
8     if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){
9       print "1..0 # Skip: Devel::DProf was not built\n";
10       exit 0;
11     }
12 }
13
14 END {
15     while(-e 'tmon.out' && unlink 'tmon.out') {}
16     while(-e 'err' && unlink 'err') {}
17 }
18
19 use Benchmark qw( timediff timestr );
20 use Getopt::Std 'getopts';
21 getopts('vI:p:');
22
23 # -v   Verbose
24 # -I   Add to @INC
25 # -p   Name of perl binary
26
27 @tests = @ARGV ? @ARGV : sort (<lib/dprof/*_t>, <lib/dprof/*_v>);  # glob-sort, for OS/2
28
29 $path_sep = $Config{path_sep} || ':';
30 $perl5lib = $opt_I || join( $path_sep, @INC );
31 $perl = $opt_p || which_perl();
32
33 if( $opt_v ){
34         print "tests: @tests\n";
35         print "perl: $perl\n";
36         print "perl5lib: $perl5lib\n";
37 }
38 if( $perl =~ m|^\./| ){
39         # turn ./perl into ../perl, because of chdir(t) above.
40         $perl = ".$perl";
41 }
42 if( ! -f $perl ){ die "Where's Perl?" }
43
44 sub profile {
45         my $test = shift;
46         my @results;
47         local $ENV{PERL5LIB} = $perl5lib;
48         my $opt_d = '-d:DProf';
49
50         my $t_start = new Benchmark;
51         open( R, "$perl -f \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n";
52         @results = <R>;
53         close R or warn "Could not close: $!";
54         my $t_total = timediff( new Benchmark, $t_start );
55
56         if( $opt_v ){
57                 print "\n";
58                 print @results
59         }
60
61         print '# ' . timestr( $t_total, 'nop' ), "\n";
62 }
63
64
65 sub verify {
66         my $test = shift;
67
68         my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test;
69         $command .= ' -v' if $opt_v;
70         $command .= ' -p '. $perl;
71         system $command;
72 }
73
74
75 $| = 1;
76 print "1..20\n";
77 while( @tests ){
78         $test = shift @tests;
79         $test =~ s/\.$// if $^O eq 'VMS';
80         if( $test =~ /_t$/i ){
81                 print "# $test" . '.' x (20 - length $test);
82                 profile $test;
83         }
84         else{
85                 verify $test;
86         }
87 }
88
89 unlink("tmon.out");