X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Ftest.pl;h=1e8ed9cf860124ec935b77dde5fb7115014f9a1c;hb=7f6b17e490f2974227b30f0c61ca2e8729fa877f;hp=0c315561405a56c95032e436c5dc84c56f2ccc65;hpb=21820af6ee0f53064e14544ea51007cc83a40989;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/test.pl b/t/test.pl index 0c31556..1e8ed9c 100644 --- a/t/test.pl +++ b/t/test.pl @@ -5,6 +5,7 @@ $Level = 1; my $test = 1; my $planned; +my $noplan; $TODO = 0; $NO_ENDING = 0; @@ -13,18 +14,27 @@ 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"; + print STDOUT "1..$n\n" unless $noplan; $planned = $n; } END { my $ran = $test - 1; - if (!$NO_ENDING && defined $planned && $planned != $ran) { - print STDERR "# Looks like you planned $planned tests but ran $ran.\n"; + 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"; + } } } @@ -91,8 +101,8 @@ sub _q { my $x = shift; return 'undef' unless defined $x; my $q = $x; - $q =~ s/\\/\\\\/; - $q =~ s/'/\\'/; + $q =~ s/\\/\\\\/g; + $q =~ s/'/\\'/g; return "'$q'"; } @@ -235,21 +245,18 @@ sub within ($$$@) { } # Note: this isn't quite as fancy as Test::More::like(). -sub like ($$@) { - my ($got, $expected, $name, @mess) = @_; + +sub like ($$@) { like_yn (0,@_) }; # 0 for - +sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- + +sub like_yn ($$$@) { + my ($flip, $got, $expected, $name, @mess) = @_; my $pass; - if (ref $expected eq 'Regexp') { - $pass = $got =~ $expected; - unless ($pass) { - unshift(@mess, "# got '$got'\n", - "# expected /$expected/\n"); - } - } else { - $pass = $got =~ /$expected/; - unless ($pass) { - unshift(@mess, "# got '$got'\n", - "# expected /$expected/\n"); - } + $pass = $got =~ /$expected/ if !$flip; + $pass = $got !~ /$expected/ if $flip; + unless ($pass) { + unshift(@mess, "# got '$got'\n", + "# expected /$expected/\n"); } _ok($pass, _where(), $name, @mess); } @@ -284,10 +291,25 @@ sub skip { last SKIP; } +sub todo_skip { + my $why = shift; + my $n = @_ ? shift : 1; + + for (1..$n) { + print STDOUT "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; @@ -368,6 +390,10 @@ sub _quote_args { 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'; @@ -402,6 +428,12 @@ sub _create_runperl { # Create the string to qx in runperl(). } } 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 @@ -445,6 +477,8 @@ sub _create_runperl { # Create the string to qx in 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 @@ -545,7 +579,7 @@ sub _fresh_perl { {if (-e _ and -f _)} } - print TEST $prog, "\n"; + print TEST $prog; close TEST or die "Cannot close $tmpfile: $!"; my $results = runperl(%$runperl_args); @@ -586,7 +620,7 @@ sub _fresh_perl { } # -# run_perl_is +# fresh_perl_is # # Combination of run_perl() and is(). # @@ -600,7 +634,7 @@ sub fresh_perl_is { } # -# run_perl_like +# fresh_perl_like # # Combination of run_perl() and like(). # @@ -615,4 +649,66 @@ sub fresh_perl_like { $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 <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;