X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2Ft%2Fdeparse.t;h=7aeb159b008304c9b8f9da78e3e6bc64149b6fd3;hb=0707d6cc81b12c5d582707b1575b1be4695dd7fc;hp=8d8a1db10045f3a69e5abcee414446d061f53358;hpb=579a54dc04b9dcea01ec0ba30460602ef4a7315c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t index 8d8a1db..7aeb159 100644 --- a/ext/B/t/deparse.t +++ b/ext/B/t/deparse.t @@ -19,33 +19,56 @@ BEGIN { } } -$| = 1; use warnings; use strict; -use Config; - -print "1..39\n"; +BEGIN { + # BEGIN block is acutally a subroutine :-) + return unless $] > 5.009; + require feature; + feature->import(':5.10'); +} +use Test::More tests => 57; use B::Deparse; -my $deparse = B::Deparse->new() or print "not "; -my $i=1; -print "ok " . $i++ . "\n"; - +my $deparse = B::Deparse->new(); +ok($deparse); # Tell B::Deparse about our ambient pragmas -{ my ($hint_bits, $warning_bits); - BEGIN { ($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS}); } +{ my ($hint_bits, $warning_bits, $hinthash); + BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); } $deparse->ambient_pragmas ( hint_bits => $hint_bits, warning_bits => $warning_bits, - '$[' => 0 + $[ + '$[' => 0 + $[, + '%^H' => $hinthash, ); } $/ = "\n####\n"; while () { chomp; - s/#.*$//mg; + # This code is pinched from the t/lib/common.pl for TODO. + # It's not clear how to avoid duplication + my ($skip, $skip_reason); + s/^#\s*SKIP\s*(.*)\n//m and $skip_reason = $1; + # If the SKIP reason starts ? then it's taken as a code snippet to evaluate + # This provides the flexibility to have conditional SKIPs + if ($skip_reason && $skip_reason =~ s/^\?//) { + my $temp = eval $skip_reason; + if ($@) { + die "# In SKIP code reason:\n# $skip_reason\n$@"; + } + $skip_reason = $temp; + } + + s/#\s*(.*)$//mg; + my ($num, $testname) = $1 =~ m/(\d+)\s*(.*)/; + + if ($skip_reason) { + # Like this to avoid needing a label SKIP: + Test::More->builder->skip($skip_reason); + next; + } my ($input, $expected); if (/(.*)\n>>>>\n(.*)/s) { @@ -58,47 +81,31 @@ while () { my $coderef = eval "sub {$input}"; if ($@) { - print "not ok " . $i++ . "\n"; - print "# $@"; + diag("$num deparsed: $@"); + ok(0, $testname); } else { my $deparsed = $deparse->coderef2text( $coderef ); - my $regex = quotemeta($expected); - do { - no warnings 'misc'; - $regex =~ s/\s+/\s+/g; - }; - - my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/); - print (($ok ? "ok " : "not ok ") . $i++ . "\n"); - if (!$ok) { - print "# EXPECTED:\n"; - $regex =~ s/^/# /mg; - print "$regex\n"; - - print "\n# GOT: \n"; - $deparsed =~ s/^/# /mg; - print "$deparsed\n"; - } + my $regex = $expected; + $regex =~ s/(\S+)/\Q$1/g; + $regex =~ s/\s+/\\s+/g; + $regex = '^\{\s*' . $regex . '\s*\}$'; + like($deparsed, qr/$regex/, $testname); } } use constant 'c', 'stuff'; -print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff'; -print "ok " . $i++ . "\n"; +is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff'); -$a = 0; -print "not " if "{\n (-1) ** \$a;\n}" - ne $deparse->coderef2text(sub{(-1) ** $a }); -print "ok " . $i++ . "\n"; +my $a = 0; +is("{\n (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a })); use constant cr => ['hello']; my $string = "sub " . $deparse->coderef2text(\&cr); -my $val = (eval $string)->(); -print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello'; -print "ok " . $i++ . "\n"; +my $val = (eval $string)->() or diag $string; +is(ref($val), 'ARRAY'); +is($val->[0], 'hello'); -my $a; my $Is_VMS = $^O eq 'VMS'; my $Is_MacOS = $^O eq 'MacOS'; @@ -117,7 +124,7 @@ BEGIN { $^W = 1; } BEGIN { $/ = "\n"; $\ = "\n"; } LINE: while (defined($_ = )) { chomp $_; - our(@F) = split(" ", $_, 0); + our(@F) = split(' ', $_, 0); '???'; } EOF @@ -127,8 +134,7 @@ $b =~ s/(LINE:)/sub BEGIN { 'XL'->bootstrap; } $1/ if $Is_MacOS; -print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b; -print "ok " . $i++ . "\n"; +is($a, $b); #Re: perlbug #35857, patch #24505 #handle warnings::register-ed packages properly. @@ -147,7 +153,7 @@ use warnings; sub test { my $val = shift; my $res = B::Deparse::Wrapper::getcode($val); - print $res =~ /use warnings/ ? '' : 'not ', 'ok ', $i++, "\n"; + like( $res, qr/use warnings/); } my ($q,$p); my $x=sub { ++$q,++$p }; @@ -269,7 +275,7 @@ my $i; while ($i) { my $z = 1; } continue { $i = 99; } #### # 23 -foreach $i (1, 2) { +foreach my $i (1, 2) { my $z = 1; } #### @@ -320,3 +326,72 @@ print $_ foreach (reverse @a); # 33 our @a; print $_ foreach (reverse 1, 2..5); +#### +# 34 (bug #38684) +our @ary; +@ary = split(' ', 'foo', 0); +#### +# 35 (bug #40055) +do { () }; +#### +# 36 (ibid.) +do { my $x = 1; $x }; +#### +# 37 <20061012113037.GJ25805@c4.convolution.nl> +my $f = sub { + +{[]}; +} ; +#### +# 38 (bug #43010) +'!@$%'->(); +#### +# 39 (ibid.) +::(); +#### +# 40 (ibid.) +'::::'->(); +#### +# 41 (ibid.) +&::::; +#### +# 42 +my $bar; +'Foo'->$bar('orz'); +#### +# 43 +'Foo'->bar('orz'); +#### +# 44 +'Foo'->bar; +#### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# 45 say +say 'foo'; +#### +# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" +# 46 state vars +state $x = 42; +#### +# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" +# 47 state var assignment +{ + my $y = (state $x = 42); +} +#### +# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" +# 48 state vars in anoymous subroutines +$a = sub { + state $x; + return $x++; +} +; +#### +# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' +# 49 each @array; +each @ARGV; +each @$a; +#### +# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' +# 50 keys @array; values @array +keys @$a if keys @ARGV; +values @ARGV if values @$a;