dslinux/user/perl/t README TEST TestInit.pm harness perl.supp test.pl
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:47 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/t
In directory antilope:/tmp/cvs-serv17422/t
Added Files:
README TEST TestInit.pm harness perl.supp test.pl
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: TestInit.pm ---
# This is a replacement for the old BEGIN preamble which heads (or
# should head) up every core test program to prepare it for running.
# Now instead of:
#
# BEGIN {
# chdir 't' if -d 't';
# @INC = '../lib';
# }
#
# t/TEST will use -MTestInit. You may "use TestInit" in the test
# programs but it is not required.
#
# P.S. This documentation is not in POD format in order to avoid
# problems when there are fundamental bugs in perl.
package TestInit;
$VERSION = 1.01;
chdir 't' if -d 't';
@INC = '../lib';
# Don't interfere with the taintedness of %ENV, this could perturbate tests
$ENV{PERL_CORE} = 1 unless ${^TAINT};
$0 =~ s/\.dp$//; # for the test.deparse make target
1;
--- NEW FILE: README ---
This is the perl test library. To run the test suite, just type './TEST'
or 'make test' from the build directory above t/. See also the section
"Special Make Test Targets" in pod/perlhack.pod to learn about other
specific test commands.
To add new tests, just look at the current tests and do likewise.
The library t/test.pl provides some utility functions that you can use
in most tests, except in the most basic ones.
If a test fails, run it by itself to see if it prints any informative
diagnostics. If not, modify the test to print informative diagnostics.
If you put out extra lines with a '#' character on the front, you don't
have to worry about removing the extra print statements later since TEST
ignores lines beginning with '#'.
If you know that Perl is basically working but expect that some tests
will fail, you may want to use Test::Harness thusly:
cd t
./perl -I../lib harness
This method pinpoints failed tests automatically.
If you come up with new tests, please send them to perlbug at perl.org.
Tests in the t/base/ directory ought to be runnable with plain miniperl.
That is, they should not require Config.pm nor should they require any
extensions to have been built. TEST will abort if any tests in the
t/base/ directory fail.
Tests in the t/comp/, t/cmd/, t/run/, t/io/, t/op/ and t/uni/ directories
should also be runnable by miniperl and not require Config.pm, but
failures to comply will not cause TEST to abort like for t/base/.
--- NEW FILE: test.pl ---
#
# t/test.pl - most of Test::More functionality without the fuss
#
$Level = 1;
my $test = 1;
my $planned;
my $noplan;
$TODO = 0;
$NO_ENDING = 0;
sub plan {
my $n;
if (@_ == 1) {
$n = shift;
if ($n eq 'no_plan') {
undef $n;
$noplan = 1;
}
} else {
my %plan = @_;
$n = $plan{tests};
}
print STDOUT "1..$n\n" unless $noplan;
$planned = $n;
}
END {
my $ran = $test - 1;
if (!$NO_ENDING) {
if (defined $planned && $planned != $ran) {
print STDERR
"# Looks like you planned $planned tests but ran $ran.\n";
} elsif ($noplan) {
print "1..$ran\n";
}
}
}
# 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 @mess;
}
sub skip_all {
if (@_) {
print STDOUT "1..0 # Skipped: @_\n";
} else {
print STDOUT "1..0\n";
}
exit(0);
}
sub _ok {
my ($pass, $where, $name, @mess) = @_;
# Do not try to microoptimize by factoring out the "not ".
# VMS will avenge.
my $out;
if ($name) {
# escape out '#' or it will interfere with '# skip' and such
$name =~ s/#/\\#/g;
$out = $pass ? "ok $test - $name" : "not ok $test - $name";
} else {
$out = $pass ? "ok $test" : "not ok $test";
}
$out .= " # TODO $TODO" if $TODO;
print STDOUT "$out\n";
unless ($pass) {
_diag "# Failed $where\n";
}
# Ensure that the message is properly escaped.
_diag @mess;
$test++;
return $pass;
}
sub _where {
my @caller = caller($Level);
return "at $caller[1] line $caller[2]";
}
# DON'T use this for matches. Use like() instead.
sub ok ($@) {
my ($pass, $name, @mess) = @_;
_ok($pass, _where(), $name, @mess);
}
sub _q {
my $x = shift;
return 'undef' unless defined $x;
my $q = $x;
$q =~ s/\\/\\\\/g;
$q =~ s/'/\\'/g;
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;
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");
}
_ok($pass, _where(), $name, @mess);
}
sub isnt ($$@) {
my ($got, $isnt, $name, @mess) = @_;
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");
}
_ok($pass, _where(), $name, @mess);
}
sub cmp_ok ($$$@) {
my($got, $type, $expected, $name, @mess) = @_;
my $pass;
{
local $^W = 0;
local($@,$!); # don't interfere with $@
# eval() sometimes resets $!
$pass = eval "\$got $type \$expected";
}
unless ($pass) {
# It seems Irix long doubles can have 2147483648 and 2147483648
# that stringify to the same thing but are acutally numerically
# different. Display the numbers if $type isn't a string operator,
# and the numbers are stringwise the same.
# (all string operators have alphabetic names, so tr/a-z// is true)
# This will also show numbers for some uneeded cases, but will
# definately be helpful for things such as == and <= that fail
if ($got eq $expected and $type !~ tr/a-z//) {
unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
}
unshift(@mess, "# got "._q($got)."\n",
"# expected $type "._q($expected)."\n");
}
_ok($pass, _where(), $name, @mess);
}
# Check that $got is within $range of $expected
# if $range is 0, then check it's exact
# else if $expected is 0, then $range is an absolute value
# otherwise $range is a fractional error.
# Here $range must be numeric, >= 0
# Non numeric ranges might be a useful future extension. (eg %)
sub within ($$$@) {
my ($got, $expected, $range, $name, @mess) = @_;
my $pass;
if (!defined $got or !defined $expected or !defined $range) {
# This is a fail, but doesn't need extra diagnostics
} elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) {
# This is a fail
unshift @mess, "# got, expected and range must be numeric\n";
} elsif ($range < 0) {
# This is also a fail
unshift @mess, "# range must not be negative\n";
} elsif ($range == 0) {
# Within 0 is ==
$pass = $got == $expected;
} elsif ($expected == 0) {
# If expected is 0, treat range as absolute
$pass = ($got <= $range) && ($got >= - $range);
} else {
my $diff = $got - $expected;
$pass = abs ($diff / $expected) < $range;
}
unless ($pass) {
if ($got eq $expected) {
unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
}
unshift at mess, "# got "._q($got)."\n",
"# expected "._q($expected)." (within "._q($range).")\n";
}
_ok($pass, _where(), $name, @mess);
}
# Note: this isn't quite as fancy as Test::More::like().
sub like ($$@) { like_yn (0, at _) }; # 0 for -
sub unlike ($$@) { like_yn (1, at _) }; # 1 for un-
sub like_yn ($$$@) {
my ($flip, $got, $expected, $name, @mess) = @_;
my $pass;
$pass = $got =~ /$expected/ if !$flip;
$pass = $got !~ /$expected/ if $flip;
unless ($pass) {
unshift(@mess, "# got '$got'\n",
"# expected /$expected/\n");
}
local $Level = 2;
_ok($pass, _where(), $name, @mess);
}
sub pass {
_ok(1, '', @_);
}
sub fail {
_ok(0, _where(), @_);
}
sub curr_test {
$test = shift if @_;
return $test;
}
sub next_test {
$test++;
}
# Note: can't pass multipart messages since we try to
# be compatible with Test::More::skip().
sub skip {
my $why = shift;
my $n = @_ ? shift : 1;
for (1..$n) {
print STDOUT "ok $test # skip: $why\n";
$test++;
}
local $^W = 0;
last SKIP;
}
sub todo_skip {
my $why = shift;
my $n = @_ ? shift : 1;
for (1..$n) {
print STDOUT "not ok $test # TODO & SKIP: $why\n";
$test++;
}
local $^W = 0;
last TODO;
}
sub eq_array {
my ($ra, $rb) = @_;
return 0 unless $#$ra == $#$rb;
for my $i (0..$#$ra) {
next if !defined $ra->[$i] && !defined $rb->[$i];
return 0 if !defined $ra->[$i];
return 0 if !defined $rb->[$i];
return 0 unless $ra->[$i] eq $rb->[$i];
}
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;
require $require;
REQUIRE_OK
_ok(!$@, _where(), "require $require");
}
sub use_ok ($) {
my ($use) = @_;
eval <<USE_OK;
use $use;
USE_OK
_ok(!$@, _where(), "use $use");
}
# runperl - Runs a separate perl interpreter.
# Arguments :
# 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
# args => [ command-line arguments to the perl program ]
# verbose => print the command line
my $is_mswin = $^O eq 'MSWin32';
my $is_netware = $^O eq 'NetWare';
my $is_macos = $^O eq 'MacOS';
my $is_vms = $^O eq 'VMS';
sub _quote_args {
my ($runperl, $args) = @_;
foreach (@$args) {
# In VMS protect with doublequotes because otherwise
# DCL will lowercase -- unless already doublequoted.
$_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0;
$$runperl .= ' ' . $_;
}
}
sub _create_runperl { # Create the string to qx in runperl().
my %args = @_;
my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
#- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind
if ($ENV{PERL_RUNPERL_DEBUG}) {
$runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl";
}
unless ($args{nolib}) {
if ($is_macos) {
$runperl .= ' -I::lib';
# Use UNIX style error messages instead of MPW style.
$runperl .= ' -MMac::err=unix' if $args{stderr};
}
else {
$runperl .= ' "-I../lib"'; # doublequotes because of VMS
}
}
if ($args{switches}) {
local $Level = 2;
die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where()
unless ref $args{switches} eq "ARRAY";
_quote_args(\$runperl, $args{switches});
}
if (defined $args{prog}) {
die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where()
if defined $args{progs};
$args{progs} = [$args{prog}]
}
if (defined $args{progs}) {
die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where()
unless ref $args{progs} eq "ARRAY";
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}");
} else {
# You probaby didn't want to be sucking in from the upstream stdin
die "test.pl:runperl(): none of prog, progs, progfile, args, "
. " switches or stdin specified"
unless defined $args{args} or defined $args{switches}
or defined $args{stdin};
}
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;
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;
}
}
if (defined $args{args}) {
_quote_args(\$runperl, $args{args});
}
$runperl .= ' 2>&1' if $args{stderr} && !$is_macos;
$runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos;
if ($args{verbose}) {
my $runperldisplay = $runperl;
$runperldisplay =~ s/\n/\n\#/g;
print STDERR "# $runperldisplay\n";
}
return $runperl;
}
sub runperl {
die "test.pl:runperl() does not take a hashref"
if ref $_[0] and ref $_[0] eq 'HASH';
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";
exit 1;
}
# A somewhat safer version of the sometimes wrong $^X.
my $Perl;
sub which_perl {
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 ($@) {
warn "test.pl had problems loading Config: $@";
$exe = '';
} 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,
# which is a bit heavyweight to do here.
if ($Perl =~ /^perl\Q$exe\E$/i) {
my $perl = "perl$exe";
eval "require File::Spec";
if ($@) {
warn "test.pl had problems loading File::Spec: $@";
$Perl = "./$perl";
} else {
$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.
$ENV{PERLEXE} = $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;
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) {
_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
unless( $name ) {
($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
$name .= '...' if length $first_line > length $name;
}
_ok($pass, _where(), "fresh_perl - $name");
}
#
# fresh_perl_is
#
# Combination of run_perl() and is().
#
sub fresh_perl_is {
my($prog, $expected, $runperl_args, $name) = @_;
local $Level = 2;
_fresh_perl($prog,
sub { @_ ? $_[0] eq $expected : $expected },
$runperl_args, $name);
}
#
# fresh_perl_like
#
# Combination of run_perl() and like().
#
sub fresh_perl_like {
my($prog, $expected, $runperl_args, $name) = @_;
local $Level = 2;
_fresh_perl($prog,
sub { @_ ?
$_[0] =~ (ref $expected ? $expected : /$expected/) :
$expected },
$runperl_args, $name);
}
sub can_ok ($@) {
my($proto, @methods) = @_;
my $class = ref $proto || $proto;
unless( @methods ) {
return _ok( 0, _where(), "$class->can(...)" );
}
my @nok = ();
foreach my $method (@methods) {
local($!, $@); # don't interfere with caller's $@
# eval sometimes resets $!
eval { $proto->can($method) } || push @nok, $method;
}
my $name;
$name = @methods == 1 ? "$class->can('$methods[0]')"
: "$class->can(...)";
_ok( !@nok, _where(), $name );
}
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
my $diag;
$obj_name = 'The object' unless defined $obj_name;
my $name = "$obj_name isa $class";
if( !defined $object ) {
$diag = "$obj_name isn't defined";
}
elsif( !ref $object ) {
$diag = "$obj_name isn't a reference";
}
else {
# We can't use UNIVERSAL::isa because we want to honor isa() overrides
local($@, $!); # eval sometimes resets $!
my $rslt = eval { $object->isa($class) };
if( $@ ) {
if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
if( !UNIVERSAL::isa($object, $class) ) {
my $ref = ref $object;
$diag = "$obj_name isn't a '$class' it's a '$ref'";
}
} else {
die <<WHOA;
WHOA! I tried to call ->isa on your object and got some weird error.
This should never happen. Please contact the author immediately.
Here's the error.
$@
WHOA
}
}
elsif( !$rslt ) {
my $ref = ref $object;
$diag = "$obj_name isn't a '$class' it's a '$ref'";
}
}
_ok( !$diag, _where(), $name );
}
1;
--- NEW FILE: harness ---
#!./perl
# We suppose that perl _mostly_ works at this moment, so may use
# sophisticated testing.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib'; # pick up only this build's lib
$ENV{PERL5LIB} = '../lib'; # so children will see it too
}
my $torture; # torture testing?
use Test::Harness;
$Test::Harness::switches = ""; # Too much noise otherwise
$Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v';
if ($ARGV[0] && $ARGV[0] eq '-torture') {
shift;
$torture = 1;
}
# Let tests know they're running in the perl core. Useful for modules
# which live dual lives on CPAN.
$ENV{PERL_CORE} = 1;
#fudge DATA for now.
%datahandle = qw(
lib/bigint.t 1
lib/bigintpm.t 1
lib/bigfloat.t 1
lib/bigfloatpm.t 1
op/gv.t 1
lib/complex.t 1
lib/ph.t 1
lib/soundex.t 1
op/misc.t 1
op/runlevel.t 1
op/tie.t 1
op/lex_assign.t 1
);
foreach (keys %datahandle) {
unlink "$_.t";
}
my @tests = ();
# [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV
@ARGV = grep $_ && length( $_ ) => @ARGV;
sub _populate_hash {
return map {$_, 1} split /\s+/, $_[0];
}
if ($ARGV[0] && $ARGV[0]=~/^-re/) {
if ($ARGV[0]!~/=/) {
shift;
$re=join "|", at ARGV;
@ARGV=();
} else {
(undef,$re)=split/=/,shift;
}
}
if (@ARGV) {
if ($^O eq 'MSWin32') {
@tests = map(glob($_), at ARGV);
}
else {
@tests = @ARGV;
}
} else {
unless (@tests) {
push @tests, <base/*.t>;
push @tests, <comp/*.t>;
push @tests, <cmd/*.t>;
push @tests, <run/*.t>;
push @tests, <io/*.t>;
push @tests, <op/*.t>;
push @tests, <uni/*.t>;
push @tests, <lib/*.t>;
push @tests, <japh/*.t> if $torture;
push @tests, <win32/*.t> if $^O eq 'MSWin32';
use Config;
my %skip;
{
my %extensions = _populate_hash $Config{'extensions'};
my %known_extensions = _populate_hash $Config{'known_extensions'};
foreach (keys %known_extensions) {
$skip{$_}++ unless $extensions{$_};
}
}
use File::Spec;
my $updir = File::Spec->updir;
my $mani = File::Spec->catfile(File::Spec->updir, "MANIFEST");
if (open(MANI, $mani)) {
while (<MANI>) { # similar code in t/TEST
if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
my ($test, $extension) = ($1, $2);
if (defined $extension) {
$extension =~ s!/t$!!;
# XXX Do I want to warn that I'm skipping these?
next if $skip{$extension};
}
push @tests, File::Spec->catfile($updir, $test);
}
}
close MANI;
} else {
warn "$0: cannot open $mani: $!\n";
}
push @tests, <pod/*.t>;
push @tests, <x2p/*.t>;
}
}
if ($^O eq 'MSWin32') {
s,\\,/,g for @tests;
}
@tests=grep /$re/, @tests
if $re;
Test::Harness::runtests @tests;
exit(0) unless -e "../testcompile";
# %infinite = qw (
# op/bop.t 1
# lib/hostname.t 1
# op/lex_assign.t 1
# lib/ph.t 1
# );
my $dhwrapper = <<'EOT';
open DATA,"<".__FILE__;
until (($_=<DATA>) =~ /^__END__/) {};
EOT
@tests = grep (!$infinite{$_}, @tests);
@tests = map {
my $new = $_;
if ($datahandle{$_} && !( -f "$new.t") ) {
$new .= '.t';
local(*F, *T);
open(F,"<$_") or die "Can't open $_: $!";
open(T,">$new") or die "Can't open $new: $!";
print T $dhwrapper, <F>;
close F;
close T;
}
$new;
} @tests;
print "The tests ", join(' ', keys(%infinite)),
" generate infinite loops! Skipping!\n";
$ENV{'HARNESS_COMPILE_TEST'} = 1;
$ENV{'PERLCC_TIMEOUT'} = 120 unless $ENV{'PERLCC_TIMEOUT'};
Test::Harness::runtests @tests;
foreach (keys %datahandle) {
unlink "$_.t";
}
--- NEW FILE: perl.supp ---
## Catch various leaks during dlopen...
{
calloc
Memcheck:Leak
fun:calloc
obj:/lib/ld-2.*.so
}
{
malloc
Memcheck:Leak
fun:malloc
obj:/lib/ld-2.*.so
}
{
realloc
Memcheck:Leak
fun:malloc
fun:realloc
obj:/lib/ld-2.*.so
}
{
calloc
Memcheck:Leak
fun:calloc
obj:/lib/libdl-2.*.so
}
{
malloc
Memcheck:Leak
fun:malloc
obj:/lib/libdl-2.*.so
}
{
realloc
Memcheck:Leak
fun:malloc
fun:realloc
obj:/lib/libdl-2.*.so
}
--- NEW FILE: TEST ---
#!./perl
# This is written in a peculiar style, since we're trying to avoid
# most of the constructs we'll be testing for. (This comment is
# probably obsolete on the avoidance side, though still currrent
# on the peculiarity side.)
$| = 1;
# for testing TEST only
#BEGIN { require '../lib/strict.pm'; strict->import() };
#BEGIN { require '../lib/warnings.pm'; warnings->import() };
# Let tests know they're running in the perl core. Useful for modules
# which live dual lives on CPAN.
$ENV{PERL_CORE} = 1;
# remove empty elements due to insertion of empty symbols via "''p1'" syntax
@ARGV = grep($_, at ARGV) if $^O eq 'VMS';
our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0;
# Cheesy version of Getopt::Std. Maybe we should replace it with that.
{
my @argv = ();
foreach my $idx (0..$#ARGV) {
push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/;
$::core = 1 if $1 eq 'core';
$::verbose = 1 if $1 eq 'v';
$::torture = 1 if $1 eq 'torture';
$::with_utf8 = 1 if $1 eq 'utf8';
$::with_utf16 = 1 if $1 eq 'utf16';
$::bytecompile = 1 if $1 eq 'bytecompile';
$::compile = 1 if $1 eq 'compile';
$::taintwarn = 1 if $1 eq 'taintwarn';
$ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest';
if ($1 =~ /^deparse(,.+)?$/) {
$::deparse = 1;
$::deparse_opts = $1;
}
}
@ARGV = @argv;
}
chdir 't' if -f 't/TEST';
die "You need to run \"make test\" first to set things up.\n"
unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm';
if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack
unless (-x 'perl.third') {
unless (-x '../perl.third') {
die "You need to run \"make perl.third first.\n";
}
else {
print "Symlinking ../perl.third as perl.third...\n";
die "Failed to symlink: $!\n"
unless symlink("../perl.third", "perl.third");
die "Symlinked but no executable perl.third: $!\n"
unless -x 'perl.third';
}
}
}
# check leakage for embedders
$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
$ENV{EMXSHELL} = 'sh'; # For OS/2
# Roll your own File::Find!
use TestInit;
use File::Spec;
if ($show_elapsed_time) { require Time::HiRes }
my $curdir = File::Spec->curdir;
my $updir = File::Spec->updir;
sub _find_tests {
my($dir) = @_;
opendir DIR, $dir or die "Trouble opening $dir: $!";
foreach my $f (sort { $a cmp $b } readdir DIR) {
next if $f eq $curdir or $f eq $updir or
$f =~ /^(?:CVS|RCS|SCCS|\.svn)$/;
my $fullpath = File::Spec->catfile($dir, $f);
_find_tests($fullpath) if -d $fullpath;
$fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS';
push @ARGV, $fullpath if $f =~ /\.t$/;
}
}
sub _quote_args {
my ($args) = @_;
my $argstring = '';
foreach (split(/\s+/,$args)) {
# In VMS protect with doublequotes because otherwise
# DCL will lowercase -- unless already doublequoted.
$_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
$argstring .= ' ' . $_;
}
return $argstring;
}
sub _populate_hash {
return map {$_, 1} split /\s+/, $_[0];
}
unless (@ARGV) {
foreach my $dir (qw(base comp cmd run io op uni)) {
_find_tests($dir);
}
_find_tests("lib") unless $::core;
# Config.pm may be broken for make minitest. And this is only a refinement
# for skipping tests on non-default builds, so it is allowed to fail.
# What we want to to is make a list of extensions which we did not build.
my $configsh = File::Spec->catfile($updir, "config.sh");
my %skip;
if (-f $configsh) {
my (%extensions, %known_extensions);
open FH, $configsh or die "Can't open $configsh: $!";
while (<FH>) {
if (/^extensions=['"](.*)['"]$/) {
# Deliberate string interpolation to avoid triggering possible
# $1 resetting bugs.
%extensions = _populate_hash ("$1");
}
elsif (/^known_extensions=['"](.*)['"]$/) {
%known_extensions = _populate_hash ($1);
}
}
if (%extensions) {
if (%known_extensions) {
foreach (keys %known_extensions) {
$skip{$_}++ unless $extensions{$_};
}
} else {
warn "No known_extensions line found in $configsh";
}
} else {
warn "No extensions line found in $configsh";
}
}
my $mani = File::Spec->catfile($updir, "MANIFEST");
if (open(MANI, $mani)) {
while (<MANI>) { # similar code in t/harness
if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
my $t = $1;
my $extension = $2;
if (!$::core || $t =~ m!^lib/[a-z]!)
{
if (defined $extension) {
$extension =~ s!/t$!!;
# XXX Do I want to warn that I'm skipping these?
next if $skip{$extension};
}
my $path = File::Spec->catfile($updir, $t);
push @ARGV, $path;
$::path_to_name{$path} = $t;
}
}
}
close MANI;
} else {
warn "$0: cannot open $mani: $!\n";
}
unless ($::core) {
_find_tests('pod');
_find_tests('x2p');
_find_tests('japh') if $::torture;
}
}
# Tests known to cause infinite loops for the perlcc tests.
# %::infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
%::infinite = ();
if ($::deparse) {
_testprogs('deparse', '', @ARGV);
}
elsif( $::compile ) {
_testprogs('compile', '', @ARGV);
}
elsif( $::bytecompile ) {
_testprogs('bytecompile', '', @ARGV);
}
elsif ($::with_utf16) {
for my $e (0, 1) {
for my $b (0, 1) {
print STDERR "# ENDIAN $e BOM $b\n";
my @UARGV;
for my $a (@ARGV) {
my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : "");
my $f = $e ? "v" : "n";
push @UARGV, $u;
unlink($u);
if (open(A, $a)) {
if (open(U, ">$u")) {
print U pack("$f", 0xFEFF) if $b;
while (<A>) {
print U pack("$f*", unpack("C*", $_));
}
close(U);
}
close(A);
}
}
_testprogs('perl', '', @UARGV);
unlink(@UARGV);
}
}
}
else {
_testprogs('compile', '', @ARGV) if -e "../testcompile";
_testprogs('perl', '', @ARGV);
}
sub _testprogs {
my ($type, $args, @tests) = @_;
print <<'EOT' if ($type eq 'compile');
------------------------------------------------------------------------------
TESTING COMPILER
------------------------------------------------------------------------------
EOT
print <<'EOT' if ($type eq 'deparse');
------------------------------------------------------------------------------
TESTING DEPARSER
------------------------------------------------------------------------------
EOT
print <<EOT if ($type eq 'bytecompile');
------------------------------------------------------------------------------
TESTING BYTECODE COMPILER
------------------------------------------------------------------------------
EOT
$ENV{PERLCC_TIMEOUT} = 120
if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT});
$::bad_files = 0;
foreach my $t (@tests) {
unless (exists $::path_to_name{$t}) {
my $tname = File::Spec->catfile('t',$t);
$tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS';
$::path_to_name{$t} = $tname;
}
}
my $maxlen = 0;
foreach (@::path_to_name{@tests}) {
s/\.\w+\z/./;
my $len = length ;
$maxlen = $len if $len > $maxlen;
}
# + 3 : we want three dots between the test name and the "ok"
my $dotdotdot = $maxlen + 3 ;
my $valgrind = 0;
my $valgrind_log = 'current.valgrind';
my $total_files = @tests;
my $good_files = 0;
my $tested_files = 0;
my $totmax = 0;
while (my $test = shift @tests) {
my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0;
if ( $::infinite{$test} && $type eq 'compile' ) {
print STDERR "$test creates infinite loop! Skipping.\n";
next;
}
if ($test =~ /^$/) {
next;
}
if ($type eq 'deparse') {
if ($test eq "comp/redef.t") {
# Redefinition happens at compile time
next;
}
elsif ($test =~ m{lib/Switch/t/}) {
# B::Deparse doesn't support source filtering
next;
}
}
my $te = $::path_to_name{$test} . '.'
x ($dotdotdot - length($::path_to_name{$test}));
if ($^O ne 'VMS') { # defer printing on VMS due to piping bug
print $te;
$te = '';
}
# XXX DAPM %OVER not defined anywhere
# $test = $OVER{$test} if exists $OVER{$test};
open(SCRIPT,"<",$test) or die "Can't run $test.\n";
$_ = <SCRIPT>;
close(SCRIPT) unless ($type eq 'deparse');
if ($::with_utf16) {
$_ =~ tr/\0//d;
}
my $switch;
if (/#!.*\bperl.*\s-\w*([tT])/) {
$switch = qq{"-$1"};
}
else {
if ($::taintwarn) {
# not all tests are expected to pass with this option
$switch = '"-t"';
}
else {
$switch = '';
}
}
my $test_executable; # for 'compile' tests
my $file_opts = "";
if ($type eq 'deparse') {
# Look for #line directives which change the filename
while (<SCRIPT>) {
$file_opts .= ",-f$3$4"
if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
}
close(SCRIPT);
}
my $utf8 = $::with_utf8 ? '-I../lib -Mutf8' : '';
my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
if ($type eq 'deparse') {
my $deparse_cmd =
"./perl $testswitch $switch -I../lib -MO=-qq,Deparse,-sv1.,".
"-l$::deparse_opts$file_opts ".
"$test > $test.dp ".
"&& ./perl $testswitch $switch -I../lib $test.dp |";
open(RESULTS, $deparse_cmd)
or print "can't deparse '$deparse_cmd': $!.\n";
}
elsif ($type eq 'bytecompile') {
my ($pwd, $null);
if( $^O eq 'MSWin32') {
$pwd = `cd`;
$null = 'nul';
} else {
$pwd = `pwd`;
$null = '/dev/null';
}
chomp $pwd;
my $perl = $ENV{PERL} || "$pwd/perl";
my $bswitch = "-MO=Bytecode,-H,-TI,-s$pwd/$test,";
$bswitch .= "-TF$test.plc,"
if $test =~ m(chdir|pod/|CGI/t/carp|lib/DB);
$bswitch .= "-k,"
if $test =~ m(deparse|terse|ext/Storable/t/code);
$bswitch .= "-b,"
if $test =~ m(op/getpid);
my $bytecompile_cmd =
"$perl $testswitch $switch -I../lib $bswitch".
"-o$test.plc $test 2>$null &&".
"$perl $testswitch $switch -I../lib $utf8 $test.plc |";
open(RESULTS,$bytecompile_cmd)
or print "can't byte-compile '$bytecompile_cmd': $!.\n";
}
elsif ($type eq 'perl') {
my $perl = $ENV{PERL} || './perl';
my $redir = $^O eq 'VMS' ? '2>&1' : '';
if ($ENV{PERL_VALGRIND}) {
$perl = "valgrind --suppressions=perl.supp --leak-check=yes "
. "--leak-resolution=high --show-reachable=yes "
. "--num-callers=50 --logfile-fd=3 $perl";
$redir = "3>$valgrind_log";
}
my $run = "$perl" . _quote_args("$testswitch $switch $utf8")
. " $test $redir|";
open(RESULTS,$run) or print "can't run '$run': $!.\n";
}
else {
my $compile_cmd;
my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " .
# -O9 for good measure, -fcog is broken ATM
"$switch -Wb=-O9,-fno-cog -L .. " .
"-I \".. ../lib/CORE\" $args $utf8 $test -o ";
if( $^O eq 'MSWin32' ) {
$test_executable = "$test.exe";
# hopefully unused name...
open HACK, "> xweghyz.pl";
print HACK <<EOT;
#!./perl
open HACK, '.\\perl $pl2c $test_executable |';
# cl.exe prints the name of the .c file on stdout (\%^\$^#)
while(<HACK>) {m/^\\w+\\.[cC]\$/ && next;print}
open HACK, '$test_executable |';
while(<HACK>) {print}
EOT
close HACK;
$compile_cmd = 'xweghyz.pl |';
}
else {
$test_executable = "$test.plc";
$compile_cmd
= "./perl $pl2c $test_executable && $test_executable |";
}
unlink $test_executable if -f $test_executable;
open(RESULTS, $compile_cmd)
or print "can't compile '$compile_cmd': $!.\n";
}
my $failure;
my $next = 0;
my $seen_leader = 0;
my $seen_ok = 0;
my $trailing_leader = 0;
my $max;
my %todo;
while (<RESULTS>) {
next if /^\s*$/; # skip blank lines
if ($::verbose) {
print $_;
}
unless (/^\#/) {
if ($trailing_leader) {
# shouldn't be anything following a postfix 1..n
$failure = 'FAILED--extra output after trailing 1..n';
last;
}
if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
if ($seen_leader) {
$failure = 'FAILED--seen duplicate leader';
last;
}
$max = $1;
%todo = map { $_ => 1 } split / /, $3 if $3;
$totmax += $max;
$tested_files++;
if ($seen_ok) {
# 1..n appears at end of file
$trailing_leader = 1;
if ($next != $max) {
$failure = "FAILED--expected $max tests, saw $next";
last;
}
}
else {
$next = 0;
}
$seen_leader = 1;
}
else {
if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) {
unless ($seen_leader) {
unless ($seen_ok) {
$next = 0;
}
}
$seen_ok = 1;
$next++;
my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
$num = $next unless $num;
if ($num == $next) {
# SKIP is essentially the same as TODO for t/TEST
# this still conforms to TAP:
# http://search.cpan.org/dist/Test-Harness/lib/Test/Harness/TAP.pod
$extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
$istodo = 1 if $todo{$num};
if( $not && !$istodo ) {
$failure = "FAILED at test $num";
last;
}
}
else {
$failure ="FAILED--expected test $next, saw test $num";
last;
}
}
elsif (/^Bail out!\s*(.*)/i) { # magic words
die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
}
else {
$failure = "FAILED--unexpected output at test $next";
last;
}
}
}
}
close RESULTS;
if (not defined $failure) {
$failure = 'FAILED--no leader found' unless $seen_leader;
}
if ($ENV{PERL_VALGRIND}) {
my @valgrind;
if (-e $valgrind_log) {
if (open(V, $valgrind_log)) {
@valgrind = <V>;
close V;
} else {
warn "$0: Failed to open '$valgrind_log': $!\n";
}
}
if (@valgrind) {
my $leaks = 0;
my $errors = 0;
for my $i (0..$#valgrind) {
local $_ = $valgrind[$i];
if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
$errors += $1; # there may be multiple error summaries
} elsif (/^==\d+== LEAK SUMMARY:/) {
for my $off (1 .. 4) {
if ($valgrind[$i+$off] =~
/(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
$leaks += $1;
}
}
}
}
if ($errors or $leaks) {
if (rename $valgrind_log, "$test.valgrind") {
$valgrind++;
} else {
warn "$0: Failed to create '$test.valgrind': $!\n";
}
}
} else {
warn "No valgrind output?\n";
}
if (-e $valgrind_log) {
unlink $valgrind_log
or warn "$0: Failed to unlink '$valgrind_log': $!\n";
}
}
if ($type eq 'deparse') {
unlink "./$test.dp";
}
if ($ENV{PERL_3LOG}) {
my $tpp = $test;
$tpp =~ s:^\.\./::;
$tpp =~ s:/:_:g;
$tpp =~ s:\.t$:.3log:;
rename("perl.3log", $tpp) ||
die "rename: perl3.log to $tpp: $!\n";
}
# test if the compiler compiled something
if( $type eq 'compile' && !-e "$test_executable" ) {
$failure = "Test did not compile";
}
if (not defined $failure and $next != $max) {
$failure="FAILED--expected $max tests, saw $next";
}
if (defined $failure) {
print "${te}$failure\n";
$::bad_files++;
$_ = $test;
if (/^base/) {
die "Failed a basic test--cannot continue.\n";
}
}
else {
if ($max) {
my $elapsed;
if ( $show_elapsed_time ) {
$elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 );
}
else {
$elapsed = "";
}
print "${te}ok$elapsed\n";
$good_files++;
}
else {
print "${te}skipping test on this platform\n";
$tested_files -= 1;
}
}
} # while tests
if ($::bad_files == 0) {
if ($good_files) {
print "All tests successful.\n";
# XXX add mention of 'perlbug -ok' ?
}
else {
die "FAILED--no tests were run for some reason.\n";
}
}
else {
my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
if ($::bad_files == 1) {
warn "Failed 1 test script out of $tested_files, $pct% okay.\n";
}
else {
warn "Failed $::bad_files test scripts out of $tested_files, $pct% okay.\n";
}
warn <<'SHRDLU_1';
### Since not all tests were successful, you may want to run some of
### them individually and examine any diagnostic messages they produce.
### See the INSTALL document's section on "make test".
SHRDLU_1
warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
### You have a good chance to get more information by running
### ./perl harness
### in the 't' directory since most (>=80%) of the tests succeeded.
SHRDLU_2
if (eval {require Config; import Config; 1}) {
if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
warn <<SHRDLU_3;
### You may have to set your dynamic library search path,
### $p, to point to the build directory:
SHRDLU_3
if (exists $ENV{$p} && $ENV{$p} ne '') {
warn <<SHRDLU_4a;
### setenv $p `pwd`:\$$p; cd t; ./perl harness
### $p=`pwd`:\$$p; export $p; cd t; ./perl harness
### export $p=`pwd`:\$$p; cd t; ./perl harness
SHRDLU_4a
} else {
warn <<SHRDLU_4b;
### setenv $p `pwd`; cd t; ./perl harness
### $p=`pwd`; export $p; cd t; ./perl harness
### export $p=`pwd`; cd t; ./perl harness
SHRDLU_4b
}
warn <<SHRDLU_5;
### for csh-style shells, like tcsh; or for traditional/modern
### Bourne-style shells, like bash, ksh, and zsh, respectively.
SHRDLU_5
}
}
}
my ($user,$sys,$cuser,$csys) = times;
print sprintf("u=%.2f s=%.2f cu=%.2f cs=%.2f scripts=%d tests=%d\n",
$user,$sys,$cuser,$csys,$tested_files,$totmax);
if ($ENV{PERL_VALGRIND}) {
my $s = $valgrind == 1 ? '' : 's';
print "$valgrind valgrind report$s created.\n", ;
}
}
exit ($::bad_files != 0);
More information about the dslinux-commit
mailing list