END {
my $ran = $test - 1;
if (!$NO_ENDING && defined $planned && $planned != $ran) {
- print STDOUT "# Looks like you planned $planned tests but ran $ran.\n";
+ print STDERR "# Looks like you planned $planned tests but ran $ran.\n";
}
}
+# Use this instead of "print STDERR" when outputing failure diagnostic
+# messages
+sub _diag {
+ my $fh = $TODO ? *STDOUT : *STDERR;
+ print $fh @_;
+}
+
sub skip_all {
if (@_) {
print STDOUT "1..0 - @_\n";
print STDOUT "$out\n";
unless ($pass) {
- print STDOUT "# Failed $where\n";
+ _diag "# Failed $where\n";
}
# Ensure that the message is properly escaped.
- print STDOUT map { /^#/ ? "$_\n" : "# $_\n" }
- map { split /\n/ } @mess if @mess;
+ _diag map { /^#/ ? "$_\n" : "# $_\n" }
+ map { split /\n/ } @mess if @mess;
$test++;
if (ref $expected eq 'Regexp') {
$pass = $got =~ $expected;
unless ($pass) {
- unshift(@mess, "# got '$got'\n");
+ unshift(@mess, "# got '$got'\n",
+ "# expected /$expected/\n");
}
} else {
$pass = $got =~ /$expected/;
$key = "" . $key;
if (exists $orig->{$key}) {
if ($orig->{$key} ne $value) {
- print "# key ", _qq($key), " was ", _qq($orig->{$key}),
- " now ", _qq($value), "\n";
+ print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}),
+ " now ", _qq($value), "\n";
$fail = 1;
}
} else {
- print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n";
+ print STDOUT "# key ", _qq($key), " is ", _qq($value),
+ ", not in original.\n";
$fail = 1;
}
}
# Force a hash recompute if this perl's internals can cache the hash key.
$_ = "" . $_;
next if (exists $suspect->{$_});
- print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
+ print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
$fail = 1;
}
!$fail;
if ($args{verbose}) {
my $runperldisplay = $runperl;
$runperldisplay =~ s/\n/\n\#/g;
- print STDOUT "# $runperldisplay\n";
+ print STDERR "# $runperldisplay\n";
}
my $result = `$runperl`;
$result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
}
-sub BAILOUT {
- print STDOUT "Bail out! @_\n";
- exit;
+sub DIE {
+ print STDERR "# @_\n";
+ exit 1;
}
# A somewhat safer version of the sometimes wrong $^X.
} else {
$exe = $Config{_exe};
}
+ $exe = '' unless defined $exe;
# This doesn't absolutize the path: beware of future chdirs().
# We could do File::Spec->abs2rel() but that does getcwd()s,
$Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
}
}
-
- # Its like this. stat on Cygwin treats 'perl' to mean 'perl.exe'
- # but open does not. This can get confusing, so to be safe we
- # always put the .exe on the end on Cygwin.
- $Perl .= $exe if $^O eq 'cygwin' && $Perl !~ /\Q$exe\E$/;
+
+ # Build up the name of the executable file from the name of
+ # the command.
+
+ if ($Perl !~ /\Q$exe\E$/i) {
+ $Perl .= $exe;
+ }
warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
return $Perl;
}
+sub unlink_all {
+ foreach my $file (@_) {
+ 1 while unlink $file;
+ print STDERR "# Couldn't unlink '$file': $!\n" if -f $file;
+ }
+}
+
+
+my $tmpfile = "misctmp000";
+1 while -f ++$tmpfile;
+END { unlink_all $tmpfile }
+
+#
+# _fresh_perl
+#
+# The $resolve must be a subref that tests the first argument
+# for success, or returns the definition of success (e.g. the
+# expected scalar) if given no arguments.
+#
+
+sub _fresh_perl {
+ my($prog, $resolve, $runperl_args, $name) = @_;
+
+ $runperl_args ||= {};
+ $runperl_args->{progfile} = $tmpfile;
+ $runperl_args->{stderr} = 1;
+
+ open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
+
+ # VMS adjustments
+ if( $^O eq 'VMS' ) {
+ $prog =~ s#/dev/null#NL:#;
+
+ # VMS file locking
+ $prog =~ s{if \(-e _ and -f _ and -r _\)}
+ {if (-e _ and -f _)}
+ }
+
+ print TEST $prog, "\n";
+ close TEST or die "Cannot close $tmpfile: $!";
+
+ my $results = runperl(%$runperl_args);
+ my $status = $?;
+
+ # Clean up the results into something a bit more predictable.
+ $results =~ s/\n+$//;
+ $results =~ s/at\s+misctmp\d+\s+line/at - line/g;
+ $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g;
+
+ # bison says 'parse error' instead of 'syntax error',
+ # various yaccs may or may not capitalize 'syntax'.
+ $results =~ s/^(syntax|parse) error/syntax error/mig;
+
+ if ($^O eq 'VMS') {
+ # some tests will trigger VMS messages that won't be expected
+ $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
+
+ # pipes double these sometimes
+ $results =~ s/\n\n/\n/g;
+ }
+
+ my $pass = $resolve->($results);
+ unless ($pass) {
+ print STDERR "# PROG: $switch\n$prog\n";
+ print STDERR "# EXPECTED:\n", $resolve->(), "\n";
+ print STDERR "# GOT:\n$results\n";
+ print STDERR "# STATUS: $status\n";
+ }
+
+ ($name) = $prog =~ /^(.{1,35})/ unless $name;
+
+ _ok($pass, _where(), "fresh_perl - $name");
+}
+
+#
+# run_perl_is
+#
+# Combination of run_perl() and is().
+#
+
+sub fresh_perl_is {
+ my($prog, $expected, $runperl_args, $name) = @_;
+ _fresh_perl($prog,
+ sub { @_ ? $_[0] eq $expected : $expected },
+ $runperl_args, $name);
+}
+
+#
+# run_perl_like
+#
+# Combination of run_perl() and like().
+#
+
+sub fresh_perl_like {
+ my($prog, $expected, $runperl_args, $name) = @_;
+ _fresh_perl($prog,
+ sub { @_ ?
+ $_[0] =~ (ref $expected ? $expected : /$expected/) :
+ $expected },
+ $runperl_args, $name);
+}
+
1;