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 STDERR "# 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 STDERR "# Failed $where\n";
  57     }
  58
  59     # Ensure that the message is properly escaped.
  60     print STDERR 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                            "# expected /$expected/\n");
 152         }
 153     } else {
 154         $pass = $got =~ /$expected/;
 155         unless ($pass) {
 156             unshift(@mess, "#      got '$got'\n",
 157                            "# expected /$expected/\n");
 158         }
 159     }
 160     _ok($pass, _where(), $name, @mess);
 161 }
 162
 163 sub pass {
 164     _ok(1, '', @_);
 165 }
 166
 167 sub fail {
 168     _ok(0, _where(), @_);
 169 }
 170
 171 sub curr_test {
 172     return $test;
 173 }
 174
 175 sub next_test {
 176     $test++
 177 }
 178
 179 # Note: can't pass multipart messages since we try to
 180 # be compatible with Test::More::skip().
 181 sub skip {
 182     my $why = shift;
 183     my $n    = @_ ? shift : 1;
 184     for (1..$n) {
 185         print STDOUT "ok $test # skip: $why\n";
 186         $test++;
 187     }
 188     local $^W = 0;
 189     last SKIP;
 190 }
 191
 192 sub eq_array {
 193     my ($ra, $rb) = @_;
 194     return 0 unless $#$ra == $#$rb;
 195     for my $i (0..$#$ra) {
 196         return 0 unless $ra->[$i] eq $rb->[$i];
 197     }
 198     return 1;
 199 }
 200
 201 sub eq_hash {
 202   my ($orig, $suspect) = @_;
 203   my $fail;
 204   while (my ($key, $value) = each %$suspect) {
 205     # Force a hash recompute if this perl's internals can cache the hash key.
 206     $key = "" . $key;
 207     if (exists $orig->{$key}) {
 208       if ($orig->{$key} ne $value) {
 209         print STDERR "# key ", _qq($key), " was ", _qq($orig->{$key}),
 210           " now ", _qq($value), "\n";
 211         $fail = 1;
 212       }
 213     } else {
 214       print STDERR "# key ", _qq($key), " is ", _qq($value),
 215                    ", not in original.\n";
 216       $fail = 1;
 217     }
 218   }
 219   foreach (keys %$orig) {
 220     # Force a hash recompute if this perl's internals can cache the hash key.
 221     $_ = "" . $_;
 222     next if (exists $suspect->{$_});
 223     print STDERR "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
 224     $fail = 1;
 225   }
 226   !$fail;
 227 }
 228
 229 sub require_ok {
 230     my ($require) = @_;
 231     eval <<REQUIRE_OK;
 232 require $require;
 233 REQUIRE_OK
 234     _ok(!$@, _where(), "require $require");
 235 }
 236
 237 sub use_ok {
 238     my ($use) = @_;
 239     eval <<USE_OK;
 240 use $use;
 241 USE_OK
 242     _ok(!$@, _where(), "use $use");
 243 }
 244
 245 # runperl - Runs a separate perl interpreter.
 246 # Arguments :
 247 #   switches => [ command-line switches ]
 248 #   nolib    => 1 # don't use -I../lib (included by default)
 249 #   prog     => one-liner (avoid quotes)
 250 #   progfile => perl script
 251 #   stdin    => string to feed the stdin
 252 #   stderr   => redirect stderr to stdout
 253 #   args     => [ command-line arguments to the perl program ]
 254 #   verbose  => print the command line
 255
 256 my $is_mswin    = $^O eq 'MSWin32';
 257 my $is_netware  = $^O eq 'NetWare';
 258 my $is_macos    = $^O eq 'MacOS';
 259 my $is_vms      = $^O eq 'VMS';
 260
 261 sub _quote_args {
 262     my ($runperl, $args) = @_;
 263
 264     foreach (@$args) {
 265         # In VMS protect with doublequotes because otherwise
 266         # DCL will lowercase -- unless already doublequoted.
 267         $_ = q(").$_.q(") if $is_vms && !/^\"/;
 268         $$runperl .= ' ' . $_;
 269     }
 270 }
 271
 272 sub runperl {
 273     my %args = @_;
 274     my $runperl = $^X;
 275     if ($args{switches}) {
 276         _quote_args(\$runperl, $args{switches});
 277     }
 278     unless ($args{nolib}) {
 279         if ($is_macos) {
 280             $runperl .= ' -I::lib';
 281             # Use UNIX style error messages instead of MPW style.
 282             $runperl .= ' -MMac::err=unix' if $args{stderr};
 283         }
 284         else {
 285             $runperl .= ' "-I../lib"'; # doublequotes because of VMS
 286         }
 287     }
 288     if (defined $args{prog}) {
 289         if ($is_mswin || $is_netware || $is_vms) {
 290             $runperl .= qq( -e ") . $args{prog} . qq(");
 291         }
 292         else {
 293             $runperl .= qq( -e ') . $args{prog} . qq(');
 294         }
 295     } elsif (defined $args{progfile}) {
 296         $runperl .= qq( "$args{progfile}");
 297     }
 298     if (defined $args{stdin}) {
 299         # so we don't try to put literal newlines and crs onto the
 300         # command line.
 301         $args{stdin} =~ s/\n/\\n/g;
 302         $args{stdin} =~ s/\r/\\r/g;
 303
 304         if ($is_mswin || $is_netware || $is_vms) {
 305             $runperl = qq{$^X -e "print qq(} .
 306                 $args{stdin} . q{)" | } . $runperl;
 307         }
 308         else {
 309             $runperl = qq{$^X -e 'print qq(} .
 310                 $args{stdin} . q{)' | } . $runperl;
 311         }
 312     }
 313     if (defined $args{args}) {
 314         _quote_args(\$runperl, $args{args});
 315     }
 316     $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
 317     $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
 318     if ($args{verbose}) {
 319         my $runperldisplay = $runperl;
 320         $runperldisplay =~ s/\n/\n\#/g;
 321         print STDERR "# $runperldisplay\n";
 322     }
 323     my $result = `$runperl`;
 324     $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
 325     return $result;
 326 }
 327
 328
 329 sub DIE {
 330     print STDERR "# @_\n";
 331     exit 1;
 332 }
 333
 334 # A somewhat safer version of the sometimes wrong $^X.
 335 my $Perl;
 336 sub which_perl {
 337     unless (defined $Perl) {
 338         $Perl = $^X;
 339
 340         my $exe;
 341         eval "require Config; Config->import";
 342         if ($@) {
 343             warn "test.pl had problems loading Config: $@";
 344             $exe = '';
 345         } else {
 346             $exe = $Config{_exe};
 347         }
 348        $exe = '' unless defined $exe;
 349
 350         # This doesn't absolutize the path: beware of future chdirs().
 351         # We could do File::Spec->abs2rel() but that does getcwd()s,
 352         # which is a bit heavyweight to do here.
 353
 354         if ($Perl =~ /^perl\Q$exe\E$/i) {
 355             my $perl = "perl$exe";
 356             eval "require File::Spec";
 357             if ($@) {
 358                 warn "test.pl had problems loading File::Spec: $@";
 359                 $Perl = "./$perl";
 360             } else {
 361                 $Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
 362             }
 363         }
 364
 365         # Its like this.  stat on Cygwin treats 'perl' to mean 'perl.exe'
 366         # but open does not.  This can get confusing, so to be safe we
 367         # always put the .exe on the end on Cygwin.
 368         $Perl .= $exe if $^O eq 'cygwin' && $Perl !~ /\Q$exe\E$/;
 369
 370         warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
 371
 372         # For subcommands to use.
 373         $ENV{PERLEXE} = $Perl;
 374     }
 375     return $Perl;
 376 }
 377
 378 sub unlink_all {
 379     foreach my $file (@_) {
 380         1 while unlink $file;
 381         print STDERR "# Couldn't unlink '$file': $!\n" if -f $file;
 382     }
 383 }
 384 1;