t/test.pl

   1 #
   2 # t/test.pl - most of Test::More functionality without the fuss
   3 #
   4
   5 my $test = 1;
   6 my $planned;
   7
   8 $TODO = 0;
   9 $NO_ENDING = 0;
  10
  11 sub plan {
  12     my $n;
  13     if (@_ == 1) {
  14         $n = shift;
  15     } else {
  16         my %plan = @_;
  17         $n = $plan{tests};
  18     }
  19     print STDOUT "1..$n\n";
  20     $planned = $n;
  21 }
  22
  23 END {
  24     my $ran = $test - 1;
  25     if (!$NO_ENDING && defined $planned && $planned != $ran) {
  26         print STDOUT "# Looks like you planned $planned tests but ran $ran.\n";
  27     }
  28 }
  29
  30 sub skip_all {
  31     if (@_) {
  32         print STDOUT "1..0 - @_\n";
  33     } else {
  34         print STDOUT "1..0\n";
  35     }
  36     exit(0);
  37 }
  38
  39 sub _ok {
  40     my ($pass, $where, $name, @mess) = @_;
  41     # Do not try to microoptimize by factoring out the "not ".
  42     # VMS will avenge.
  43     my $out;
  44     if ($name) {
  45         # escape out '#' or it will interfere with '# skip' and such
  46         $name =~ s/#/\\#/g;
  47         $out = $pass ? "ok $test - $name" : "not ok $test - $name";
  48     } else {
  49         $out = $pass ? "ok $test" : "not ok $test";
  50     }
  51
  52     $out .= " # TODO $TODO" if $TODO;
  53     print STDOUT "$out\n";
  54
  55     unless ($pass) {
  56         print STDOUT "# Failed $where\n";
  57     }
  58
  59     # Ensure that the message is properly escaped.
  60     print STDOUT map { /^#/ ? "$_\n" : "# $_\n" }
  61                  map { split /\n/ } @mess if @mess;
  62
  63     $test++;
  64
  65     return $pass;
  66 }
  67
  68 sub _where {
  69     my @caller = caller(1);
  70     return "at $caller[1] line $caller[2]";
  71 }
  72
  73 sub ok {
  74     my ($pass, $name, @mess) = @_;
  75     _ok($pass, _where(), $name, @mess);
  76 }
  77
  78 sub _q {
  79     my $x = shift;
  80     return 'undef' unless defined $x;
  81     my $q = $x;
  82     $q =~ s/\\/\\\\/;
  83     $q =~ s/'/\\'/;
  84     return "'$q'";
  85 }
  86
  87 sub _qq {
  88     my $x = shift;
  89     return defined $x ? '"' . display ($x) . '"' : 'undef';
  90 };
  91
  92 # keys are the codes \n etc map to, values are 2 char strings such as \n
  93 my %backslash_escape;
  94 foreach my $x (split //, 'nrtfa\\\'"') {
  95     $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
  96 }
  97 # A way to display scalars containing control characters and Unicode.
  98 # Trying to avoid setting $_, or relying on local $_ to work.
  99 sub display {
 100     my @result;
 101     foreach my $x (@_) {
 102         if (defined $x and not ref $x) {
 103             my $y = '';
 104             foreach my $c (unpack("U*", $x)) {
 105                 if ($c > 255) {
 106                     $y .= sprintf "\\x{%x}", $c;
 107                 } elsif ($backslash_escape{$c}) {
 108                     $y .= $backslash_escape{$c};
 109                 } else {
 110                     my $z = chr $c; # Maybe we can get away with a literal...
 111                     $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/;
 112                     $y .= $z;
 113                 }
 114             }
 115             $x = $y;
 116         }
 117         return $x unless wantarray;
 118         push @result, $x;
 119     }
 120     return @result;
 121 }
 122
 123 sub is {
 124     my ($got, $expected, $name, @mess) = @_;
 125     my $pass = $got eq $expected;
 126     unless ($pass) {
 127         unshift(@mess, "#      got "._q($got)."\n",
 128                        "# expected "._q($expected)."\n");
 129     }
 130     _ok($pass, _where(), $name, @mess);
 131 }
 132
 133 sub isnt {
 134     my ($got, $isnt, $name, @mess) = @_;
 135     my $pass = $got ne $isnt;
 136     unless( $pass ) {
 137         unshift(@mess, "# it should not be "._q($got)."\n",
 138                        "# but it is.\n");
 139     }
 140     _ok($pass, _where(), $name, @mess);
 141 }
 142
 143 # Note: this isn't quite as fancy as Test::More::like().
 144 sub like {
 145     my ($got, $expected, $name, @mess) = @_;
 146     my $pass;
 147     if (ref $expected eq 'Regexp') {
 148         $pass = $got =~ $expected;
 149         unless ($pass) {
 150             unshift(@mess, "#      got '$got'\n");
 151         }
 152     } else {
 153         $pass = $got =~ /$expected/;
 154         unless ($pass) {
 155             unshift(@mess, "#      got '$got'\n",
 156                            "# expected /$expected/\n");
 157         }
 158     }
 159     _ok($pass, _where(), $name, @mess);
 160 }
 161
 162 sub pass {
 163     _ok(1, '', @_);
 164 }
 165
 166 sub fail {
 167     _ok(0, _where(), @_);
 168 }
 169
 170 sub curr_test {
 171     return $test;
 172 }
 173
 174 sub next_test {
 175     $test++
 176 }
 177
 178 # Note: can't pass multipart messages since we try to
 179 # be compatible with Test::More::skip().
 180 sub skip {
 181     my $why = shift;
 182     my $n    = @_ ? shift : 1;
 183     for (1..$n) {
 184         print STDOUT "ok $test # skip: $why\n";
 185         $test++;
 186     }
 187     local $^W = 0;
 188     last SKIP;
 189 }
 190
 191 sub eq_array {
 192     my ($ra, $rb) = @_;
 193     return 0 unless $#$ra == $#$rb;
 194     for my $i (0..$#$ra) {
 195         return 0 unless $ra->[$i] eq $rb->[$i];
 196     }
 197     return 1;
 198 }
 199
 200 sub eq_hash {
 201   my ($orig, $suspect) = @_;
 202   my $fail;
 203   while (my ($key, $value) = each %$suspect) {
 204     # Force a hash recompute if this perl's internals can cache the hash key.
 205     $key = "" . $key;
 206     if (exists $orig->{$key}) {
 207       if ($orig->{$key} ne $value) {
 208         print "# key ", _qq($key), " was ", _qq($orig->{$key}),
 209           " now ", _qq($value), "\n";
 210         $fail = 1;
 211       }
 212     } else {
 213       print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n";
 214       $fail = 1;
 215     }
 216   }
 217   foreach (keys %$orig) {
 218     # Force a hash recompute if this perl's internals can cache the hash key.
 219     $_ = "" . $_;
 220     next if (exists $suspect->{$_});
 221     print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
 222     $fail = 1;
 223   }
 224   !$fail;
 225 }
 226
 227 sub require_ok {
 228     my ($require) = @_;
 229     eval <<REQUIRE_OK;
 230 require $require;
 231 REQUIRE_OK
 232     _ok(!$@, _where(), "require $require");
 233 }
 234
 235 sub use_ok {
 236     my ($use) = @_;
 237     eval <<USE_OK;
 238 use $use;
 239 USE_OK
 240     _ok(!$@, _where(), "use $use");
 241 }
 242
 243 # runperl - Runs a separate perl interpreter.
 244 # Arguments :
 245 #   switches => [ command-line switches ]
 246 #   nolib    => 1 # don't use -I../lib (included by default)
 247 #   prog     => one-liner (avoid quotes)
 248 #   progfile => perl script
 249 #   stdin    => string to feed the stdin
 250 #   stderr   => redirect stderr to stdout
 251 #   args     => [ command-line arguments to the perl program ]
 252 #   verbose  => print the command line
 253
 254 my $is_mswin    = $^O eq 'MSWin32';
 255 my $is_netware  = $^O eq 'NetWare';
 256 my $is_macos    = $^O eq 'MacOS';
 257 my $is_vms      = $^O eq 'VMS';
 258
 259 sub _quote_args {
 260     my ($runperl, $args) = @_;
 261
 262     foreach (@$args) {
 263         # In VMS protect with doublequotes because otherwise
 264         # DCL will lowercase -- unless already doublequoted.
 265         $_ = q(").$_.q(") if $is_vms && !/^\"/;
 266         $$runperl .= ' ' . $_;
 267     }
 268 }
 269
 270 sub runperl {
 271     my %args = @_;
 272     my $runperl = $^X;
 273     if ($args{switches}) {
 274         _quote_args(\$runperl, $args{switches});
 275     }
 276     unless ($args{nolib}) {
 277         if ($is_macos) {
 278             $runperl .= ' -I::lib';
 279             # Use UNIX style error messages instead of MPW style.
 280             $runperl .= ' -MMac::err=unix' if $args{stderr};
 281         }
 282         else {
 283             $runperl .= ' "-I../lib"'; # doublequotes because of VMS
 284         }
 285     }
 286     if (defined $args{prog}) {
 287         if ($is_mswin || $is_netware || $is_vms) {
 288             $runperl .= qq( -e ") . $args{prog} . qq(");
 289         }
 290         else {
 291             $runperl .= qq( -e ') . $args{prog} . qq(');
 292         }
 293     } elsif (defined $args{progfile}) {
 294         $runperl .= qq( "$args{progfile}");
 295     }
 296     if (defined $args{stdin}) {
 297         # so we don't try to put literal newlines and crs onto the
 298         # command line.
 299         $args{stdin} =~ s/\n/\\n/g;
 300         $args{stdin} =~ s/\r/\\r/g;
 301
 302         if ($is_mswin || $is_netware || $is_vms) {
 303             $runperl = qq{$^X -e "print qq(} .
 304                 $args{stdin} . q{)" | } . $runperl;
 305         }
 306         else {
 307             $runperl = qq{$^X -e 'print qq(} .
 308                 $args{stdin} . q{)' | } . $runperl;
 309         }
 310     }
 311     if (defined $args{args}) {
 312         _quote_args(\$runperl, $args{args});
 313     }
 314     $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
 315     $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
 316     if ($args{verbose}) {
 317         my $runperldisplay = $runperl;
 318         $runperldisplay =~ s/\n/\n\#/g;
 319         print STDOUT "# $runperldisplay\n";
 320     }
 321     my $result = `$runperl`;
 322     $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
 323     return $result;
 324 }
 325
 326
 327 sub BAILOUT {
 328     print STDOUT "Bail out! @_\n";
 329     exit;
 330 }
 331
 332 # A somewhat safer version of the sometimes wrong $^X.
 333 my $Perl;
 334 sub which_perl {
 335     unless (defined $Perl) {
 336         $Perl = $^X;
 337
 338         my $exe;
 339         eval "require Config; Config->import";
 340         if ($@) {
 341             warn "test.pl had problems loading Config: $@";
 342             $exe = '';
 343         } else {
 344             $exe = $Config{_exe};
 345         }
 346        $exe = '' unless defined $exe;
 347
 348         # This doesn't absolutize the path: beware of future chdirs().
 349         # We could do File::Spec->abs2rel() but that does getcwd()s,
 350         # which is a bit heavyweight to do here.
 351
 352         if ($Perl =~ /^perl\Q$exe\E$/i) {
 353             my $perl = "perl$exe";
 354             eval "require File::Spec";
 355             if ($@) {
 356                 warn "test.pl had problems loading File::Spec: $@";
 357                 $Perl = "./$perl";
 358             } else {
 359                 $Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
 360             }
 361         }
 362
 363         # Its like this.  stat on Cygwin treats 'perl' to mean 'perl.exe'
 364         # but open does not.  This can get confusing, so to be safe we
 365         # always put the .exe on the end on Cygwin.
 366         $Perl .= $exe if $^O eq 'cygwin' && $Perl !~ /\Q$exe\E$/;
 367
 368         warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
 369
 370         # For subcommands to use.
 371         $ENV{PERLEXE} = $Perl;
 372     }
 373     return $Perl;
 374 }
 375
 376 1;