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++;
my $x = shift;
return 'undef' unless defined $x;
my $q = $x;
+ $q =~ s/\\/\\\\/;
$q =~ s/'/\\'/;
return "'$q'";
}
+sub _qq {
+ my $x = shift;
+ return defined $x ? '"' . display ($x) . '"' : 'undef';
+};
+
+# keys are the codes \n etc map to, values are 2 char strings such as \n
+my %backslash_escape;
+foreach my $x (split //, 'nrtfa\\\'"') {
+ $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
+}
+# A way to display scalars containing control characters and Unicode.
+# Trying to avoid setting $_, or relying on local $_ to work.
+sub display {
+ my @result;
+ foreach my $x (@_) {
+ if (defined $x and not ref $x) {
+ my $y = '';
+ foreach my $c (unpack("U*", $x)) {
+ if ($c > 255) {
+ $y .= sprintf "\\x{%x}", $c;
+ } elsif ($backslash_escape{$c}) {
+ $y .= $backslash_escape{$c};
+ } else {
+ my $z = chr $c; # Maybe we can get away with a literal...
+ $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/;
+ $y .= $z;
+ }
+ }
+ $x = $y;
+ }
+ return $x unless wantarray;
+ push @result, $x;
+ }
+ return @result;
+}
+
sub is {
my ($got, $expected, $name, @mess) = @_;
my $pass = $got eq $expected;
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/;
return 1;
}
+sub eq_hash {
+ my ($orig, $suspect) = @_;
+ my $fail;
+ while (my ($key, $value) = each %$suspect) {
+ # Force a hash recompute if this perl's internals can cache the hash key.
+ $key = "" . $key;
+ if (exists $orig->{$key}) {
+ if ($orig->{$key} ne $value) {
+ print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}),
+ " now ", _qq($value), "\n";
+ $fail = 1;
+ }
+ } else {
+ print STDOUT "# key ", _qq($key), " is ", _qq($value),
+ ", not in original.\n";
+ $fail = 1;
+ }
+ }
+ foreach (keys %$orig) {
+ # Force a hash recompute if this perl's internals can cache the hash key.
+ $_ = "" . $_;
+ next if (exists $suspect->{$_});
+ print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
+ $fail = 1;
+ }
+ !$fail;
+}
+
sub require_ok {
my ($require) = @_;
eval <<REQUIRE_OK;
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;
-}
-
-
-# A way to display scalars containing control characters and Unicode.
-sub display {
- map { join("", map { $_ > 255 ? sprintf("\\x{%x}", $_) : chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\%03o", $_) : chr($_) } unpack("U*", $_)) } @_;
+sub DIE {
+ print STDERR "# @_\n";
+ exit 1;
}
-
# A somewhat safer version of the sometimes wrong $^X.
my $Perl;
sub which_perl {
} 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);
}
}
-
+
+ # 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;
# For subcommands to use.
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;
https://perl5.git.perl.org / perl5.git / blobdiff