t/lib/dprof/V.pm

   1 package V;
   2
   3 use Getopt::Std 'getopts';
   4 getopts('vp:d:');
   5
   6 require Exporter;
   7 @ISA = 'Exporter';
   8
   9 @EXPORT = qw( dprofpp $opt_v $results $expected report @results );
  10 @EXPORT_OK = qw( notok ok $num );
  11
  12 $num = 0;
  13 $results = $expected = '';
  14 $perl = $opt_p || $^X;
  15 $dpp = $opt_d || '../utils/dprofpp';
  16 $dpp .= '.com' if $^O eq 'VMS';
  17
  18 print "\nperl: $perl\n" if $opt_v;
  19 if( ! -f $perl ){ die "Where's Perl?" }
  20 if( ! -f $dpp ) {
  21     ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@;
  22     die "Where's dprofpp?" if( ! -f $dpp );
  23 }
  24
  25 sub dprofpp {
  26         my $switches = shift;
  27
  28         open( D, "$perl \"-I../lib\" $dpp \"$switches\" 2> err |" ) || warn "$0: Can't run. $!\n";
  29         @results = <D>;
  30         close D;
  31
  32         open( D, "<err" ) || warn "$0: Can't open: $!\n";
  33         @err = <D>;
  34         close D;
  35         push( @results, @err ) if @err;
  36
  37         $results = qq{@results};
  38         # ignore Loader (Dyna/Auto etc), leave newline
  39         $results =~ s/^\w+Loader::import//;
  40         $results =~ s/\n /\n/gm;
  41         $results;
  42 }
  43
  44 sub report {
  45         $num = shift;
  46         my $sub = shift;
  47         my $x;
  48
  49         $x = &$sub;
  50         $x ? &ok : &notok;
  51 }
  52
  53 sub ok {
  54         print "ok $num\n";
  55 }
  56
  57 sub notok {
  58         print "not ok $num\n";
  59         print "\nResult\n{$results}\n";
  60         print "Expected\n{$expected}\n";
  61 }
  62
  63 1;