# Use this instead of "print STDERR" when outputing failure diagnostic
# messages
sub _diag {
+ return unless @_;
+ my @mess = map { /^#/ ? "$_\n" : "# $_\n" }
+ map { split /\n/ } @_;
my $fh = $TODO ? *STDOUT : *STDERR;
- print $fh @_;
+ print $fh @mess;
+
}
sub skip_all {
if (@_) {
- print STDOUT "1..0 - @_\n";
+ print STDOUT "1..0 # Skipped: @_\n";
} else {
print STDOUT "1..0\n";
}
}
# Ensure that the message is properly escaped.
- _diag map { /^#/ ? "$_\n" : "# $_\n" }
- map { split /\n/ } @mess if @mess;
+ _diag @mess;
$test++;
sub is {
my ($got, $expected, $name, @mess) = @_;
- my $pass = $got eq $expected;
+
+ my $pass;
+ if( !defined $got || !defined $expected ) {
+ # undef only matches undef
+ $pass = !defined $got && !defined $expected;
+ }
+ else {
+ $pass = $got eq $expected;
+ }
+
unless ($pass) {
unshift(@mess, "# got "._q($got)."\n",
"# expected "._q($expected)."\n");
sub isnt {
my ($got, $isnt, $name, @mess) = @_;
- my $pass = $got ne $isnt;
+
+ my $pass;
+ if( !defined $got || !defined $isnt ) {
+ # undef only matches undef
+ $pass = defined $got || defined $isnt;
+ }
+ else {
+ $pass = $got ne $isnt;
+ }
+
unless( $pass ) {
unshift(@mess, "# it should not be "._q($got)."\n",
"# but it is.\n");
}
sub curr_test {
+ $test = shift if @_;
return $test;
}
sub next_test {
- $test++
+ $test++;
}
# Note: can't pass multipart messages since we try to
# switches => [ command-line switches ]
# nolib => 1 # don't use -I../lib (included by default)
# prog => one-liner (avoid quotes)
+# progs => [ multi-liner (avoid quotes) ]
# progfile => perl script
# stdin => string to feed the stdin
# stderr => redirect stderr to stdout
}
}
-sub runperl {
+sub _create_runperl { # Create the string to qx in runperl().
my %args = @_;
- my $runperl = $^X;
- if ($args{switches}) {
- _quote_args(\$runperl, $args{switches});
- }
+ my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
unless ($args{nolib}) {
if ($is_macos) {
$runperl .= ' -I::lib';
$runperl .= ' "-I../lib"'; # doublequotes because of VMS
}
}
+ if ($args{switches}) {
+ _quote_args(\$runperl, $args{switches});
+ }
if (defined $args{prog}) {
- if ($is_mswin || $is_netware || $is_vms) {
- $runperl .= qq( -e ") . $args{prog} . qq(");
- }
- else {
- $runperl .= qq( -e ') . $args{prog} . qq(');
- }
+ $args{progs} = [$args{prog}]
+ }
+ if (defined $args{progs}) {
+ foreach my $prog (@{$args{progs}}) {
+ if ($is_mswin || $is_netware || $is_vms) {
+ $runperl .= qq ( -e "$prog" );
+ }
+ else {
+ $runperl .= qq ( -e '$prog' );
+ }
+ }
} elsif (defined $args{progfile}) {
$runperl .= qq( "$args{progfile}");
}
if (defined $args{stdin}) {
- # so we don't try to put literal newlines and crs onto the
- # command line.
- $args{stdin} =~ s/\n/\\n/g;
- $args{stdin} =~ s/\r/\\r/g;
+ # so we don't try to put literal newlines and crs onto the
+ # command line.
+ $args{stdin} =~ s/\n/\\n/g;
+ $args{stdin} =~ s/\r/\\r/g;
if ($is_mswin || $is_netware || $is_vms) {
$runperl = qq{$^X -e "print qq(} .
$args{stdin} . q{)" | } . $runperl;
}
+ elsif ($is_macos) {
+ # MacOS can only do two processes under MPW at once;
+ # the test itself is one; we can't do two more, so
+ # write to temp file
+ my $stdin = qq{$^X -e 'print qq(} . $args{stdin} . qq{)' > teststdin; };
+ if ($args{verbose}) {
+ my $stdindisplay = $stdin;
+ $stdindisplay =~ s/\n/\n\#/g;
+ print STDERR "# $stdindisplay\n";
+ }
+ `$stdin`;
+ $runperl .= q{ < teststdin };
+ }
else {
$runperl = qq{$^X -e 'print qq(} .
$args{stdin} . q{)' | } . $runperl;
$runperldisplay =~ s/\n/\n\#/g;
print STDERR "# $runperldisplay\n";
}
+ return $runperl;
+}
+
+sub runperl {
+ my $runperl = &_create_runperl;
my $result = `$runperl`;
$result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
return $result;
}
+*run_perl = \&runperl; # Nice alias.
sub DIE {
print STDERR "# @_\n";
unless (defined $Perl) {
$Perl = $^X;
+ # VMS should have 'perl' aliased properly
+ return $Perl if $^O eq 'VMS';
+
my $exe;
eval "require Config; Config->import";
if ($@) {
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";
+ _diag "# PROG: \n$prog\n";
+ _diag "# EXPECTED:\n", $resolve->(), "\n";
+ _diag "# GOT:\n$results\n";
+ _diag "# STATUS: $status\n";
}
# Use the first line of the program as a name if none was given