X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f4002a4b28f07b3fb42d7d9f51824195afcc07b2..4545d2f2cf8d44c666a31b8bc4bea3a5c699fd74:/dist/B-Deparse/t/deparse.t diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t index b1bd1e2..d17f649 100644 --- a/dist/B-Deparse/t/deparse.t +++ b/dist/B-Deparse/t/deparse.t @@ -11,47 +11,31 @@ BEGIN { use warnings; use strict; -BEGIN { - # BEGIN block is actually a subroutine :-) - return unless $] > 5.009; - require feature; - feature->import(':5.10'); -} use Test::More; -use Config (); + +my $tests = 18; # not counting those in the __DATA__ section use B::Deparse; my $deparse = B::Deparse->new(); isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object'); -# Tell B::Deparse about our ambient pragmas -{ 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 + $[, - '%^H' => $hinthash, - ); -} - $/ = "\n####\n"; while () { chomp; + $tests ++; # This code is pinched from the t/lib/common.pl for TODO. # It's not clear how to avoid duplication - # Now tweaked a bit to do skip or todo - my %reason; - foreach my $what (qw(skip todo)) { - s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; + my %meta = (context => ''); + foreach my $what (qw(skip todo context)) { + s/^#\s*\U$what\E\s*(.*)\n//m and $meta{$what} = $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 ($reason{$what} && $reason{$what} =~ s/^\?//) { - my $temp = eval $reason{$what}; + if ($meta{$what} && $meta{$what} =~ s/^\?//) { + my $temp = eval $meta{$what}; if ($@) { - die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; + die "# In \U$what\E code reason:\n# $meta{$what}\n$@"; } - $reason{$what} = $temp; + $meta{$what} = $temp; } } @@ -59,9 +43,9 @@ while () { my $desc = $1; die "Missing name in test $_" unless defined $desc; - if ($reason{skip}) { + if ($meta{skip}) { # Like this to avoid needing a label SKIP: - Test::More->builder->skip($reason{skip}); + Test::More->builder->skip($meta{skip}); next; } @@ -73,7 +57,18 @@ while () { ($input, $expected) = ($_, $_); } - my $coderef = eval "sub {$input}"; + my $coderef = eval "$meta{context};\n" . <<'EOC' . "sub {$input}"; +# Tell B::Deparse about our ambient pragmas +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, + '%^H' => $hinthash, +); +EOC if ($@) { is($@, "", "compilation of $desc"); @@ -85,7 +80,7 @@ while () { $regex =~ s/\s+/\\s+/g; $regex = '^\{\s*' . $regex . '\s*\}$'; - local $::TODO = $reason{todo}; + local $::TODO = $meta{todo}; like($deparsed, qr/$regex/, $desc); } } @@ -109,6 +104,7 @@ my $path = join " ", map { qq["-I$_"] } @INC; $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`; $a =~ s/-e syntax OK\n//g; $a =~ s/.*possible typo.*\n//; # Remove warning line +$a =~ s/.*-i used with no filenames.*\n//; # Remove warning line $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' $b = <<'EOF'; @@ -208,7 +204,57 @@ sub BEGIN { } EOCODF -done_testing(); +# [perl #91384] +$a = + `$^X $path "-MO=Deparse" -e "BEGIN{*Acme::Acme:: = *Acme::}" 2>&1`; +like($a, qr/-e syntax OK/, + "Deparse does not hang when traversing stash circularities"); + +# [perl #93990] +@] = (); +is($deparse->coderef2text(sub{ print "@{]}" }), +q<{ + print "@{]}"; +}>, 'curly around to interpolate "@{]}"'); +is($deparse->coderef2text(sub{ print "@{-}" }), +q<{ + print "@-"; +}>, 'no need to curly around to interpolate "@-"'); + +# Strict hints in %^H are mercilessly suppressed +$a = + `$^X $path "-MO=Deparse" -e "use strict; print;" 2>&1`; +unlike($a, qr/BEGIN/, + "Deparse does not emit strict hh hints"); + +# ambient_pragmas should not mess with strict settings. +SKIP: { + skip "requires 5.11", 1 unless $] >= 5.011; + eval q` + BEGIN { + # Clear out all hints + %^H = (); + $^H = 0; + new B::Deparse -> ambient_pragmas(strict => 'all'); + } + use 5.011; # should enable strict + ok !eval '$do_noT_create_a_variable_with_this_name = 1', + 'ambient_pragmas do not mess with compiling scope'; + `; +} + +# multiple statements on format lines +$a = `$^X $path "-MO=Deparse" -e "format =" -e "\@" -e "x();z()" -e. 2>&1`; +$a =~ s/-e syntax OK\n//g; +is($a, <<'EOCODH', 'multiple statements on format lines'); +format STDOUT = +@ +x(); z() +. +EOCODH + + +done_testing($tests); __DATA__ # A constant @@ -276,6 +322,8 @@ my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ"; #### # s///e s/x/'y';/e; +s/x/$a;/e; +s/x/complex_expression();/e; #### # block { my $x; } @@ -389,9 +437,17 @@ my $f = sub { # bug #43010 &::::; #### +# [perl #77172] +package rt77172; +sub foo {} foo & & & foo; +>>>> +package rt77172; +foo(&{&} & foo()); +#### # variables as method names my $bar; 'Foo'->$bar('orz'); +'Foo'->$bar('orz') = 'a stranger stranger than before'; #### # constants as method names 'Foo'->bar('orz'); @@ -399,21 +455,121 @@ my $bar; # constants as method names without () 'Foo'->bar; #### +# [perl #47359] "indirect" method call notation +our @bar; +foo{@bar}+1,->foo; +(foo{@bar}+1),foo(); +foo{@bar}1 xor foo(); +>>>> +our @bar; +(foo { @bar } 1)->foo; +(foo { @bar } 1), foo(); +foo { @bar } 1 xor foo(); +#### # SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# CONTEXT use feature ':5.10'; # say say 'foo'; #### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# CONTEXT use 5.10.0; +# say in the context of use 5.10.0 +say 'foo'; +#### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# say with use 5.10.0 +use 5.10.0; +say 'foo'; +>>>> +no feature; +use feature ':5.10'; +say 'foo'; +#### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# say with use feature ':5.10'; +use feature ':5.10'; +say 'foo'; +>>>> +use feature 'say', 'state', 'switch'; +say 'foo'; +#### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# CONTEXT use feature ':5.10'; +# say with use 5.10.0 in the context of use feature +use 5.10.0; +say 'foo'; +>>>> +no feature; +use feature ':5.10'; +say 'foo'; +#### +# SKIP ?$] < 5.010 && "say not implemented on this Perl version" +# CONTEXT use 5.10.0; +# say with use feature ':5.10' in the context of use 5.10.0 +use feature ':5.10'; +say 'foo'; +>>>> +say 'foo'; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# CONTEXT use feature ':5.15'; +# __SUB__ +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# CONTEXT use 5.15.0; +# __SUB__ in the context of use 5.15.0 +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# __SUB__ with use 5.15.0 +use 5.15.0; +__SUB__; +>>>> +no feature; +use feature ':5.16'; +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# __SUB__ with use feature ':5.15'; +use feature ':5.15'; +__SUB__; +>>>> +use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval'; +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# CONTEXT use feature ':5.15'; +# __SUB__ with use 5.15.0 in the context of use feature +use 5.15.0; +__SUB__; +>>>> +no feature; +use feature ':5.16'; +__SUB__; +#### +# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" +# CONTEXT use 5.15.0; +# __SUB__ with use feature ':5.15' in the context of use 5.15.0 +use feature ':5.15'; +__SUB__; +>>>> +__SUB__; +#### # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" +# CONTEXT use feature ':5.10'; # state vars state $x = 42; #### # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" +# CONTEXT use feature ':5.10'; # state var assignment { my $y = (state $x = 42); } #### # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" +# CONTEXT use feature ':5.10'; # state vars in anonymous subroutines $a = sub { state $x; @@ -438,6 +594,7 @@ my $c = []; my $d = \[]; #### # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version" +# CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch'; # implicit smartmatch in given/when given ('foo') { when ('bar') { continue; } @@ -618,9 +775,16 @@ warn O_EXCL; # tests for deparsing of blessed constant with overloaded numification warn OVERLOADED_NUMIFICATION; #### -# TODO Only strict 'refs' currently supported # strict no strict; +print $x; +use strict 'vars'; +print $main::x; +use strict 'subs'; +print $main::x; +use strict 'refs'; +print $main::x; +no strict 'vars'; $x; #### # TODO Subsets of warnings could be encoded textually, rather than as bitflips. @@ -703,12 +867,63 @@ pop @_; #[perl #20444] "foo" =~ (1 ? /foo/ : /bar/); "foo" =~ (1 ? y/foo// : /bar/); +"foo" =~ (1 ? y/foo//r : /bar/); "foo" =~ (1 ? s/foo// : /bar/); >>>> 'foo' =~ ($_ =~ /foo/); 'foo' =~ ($_ =~ tr/fo//); +'foo' =~ ($_ =~ tr/fo//r); 'foo' =~ ($_ =~ s/foo//); #### +# The fix for [perl #20444] broke this. +'foo' =~ do { () }; +#### +# [perl #81424] match against aelemfast_lex +my @s; +print /$s[1]/; +#### +# /$#a/ +print /$#main::a/; +#### +# [perl #91318] /regexp/applaud +print /a/a, s/b/c/a; +print /a/aa, s/b/c/aa; +print /a/p, s/b/c/p; +print /a/l, s/b/c/l; +print /a/u, s/b/c/u; +{ + use feature "unicode_strings"; + print /a/d, s/b/c/d; +} +{ + use re "/u"; + print /a/d, s/b/c/d; +} +{ + use 5.012; + print /a/d, s/b/c/d; +} +>>>> +print /a/a, s/b/c/a; +print /a/aa, s/b/c/aa; +print /a/p, s/b/c/p; +print /a/l, s/b/c/l; +print /a/u, s/b/c/u; +{ + use feature 'unicode_strings'; + print /a/d, s/b/c/d; +} +{ + BEGIN { $^H{'reflags'} = '0'; + $^H{'reflags_charset'} = '2'; } + print /a/d, s/b/c/d; +} +{ + no feature; + use feature ':5.12'; + print /a/d, s/b/c/d; +} +#### # Test @threadsv_names under 5005threads foreach $' (1, 2) { sleep $'; @@ -730,3 +945,442 @@ values $!; #### # readpipe with complex expression readpipe $a + $b; +#### +# aelemfast +$b::a[0] = 1; +#### +# aelemfast for a lexical +my @a; +$a[0] = 1; +#### +# feature features without feature +# CONTEXT no warnings 'experimental::smartmatch'; +CORE::state $x; +CORE::say $x; +CORE::given ($x) { + CORE::when (3) { + continue; + } + CORE::default { + CORE::break; + } +} +CORE::evalbytes ''; +() = CORE::__SUB__; +() = CORE::fc $x; +#### +# feature features when feature has been disabled by use VERSION +# CONTEXT no warnings 'experimental::smartmatch'; +use feature (sprintf(":%vd", $^V)); +use 1; +CORE::state $x; +CORE::say $x; +CORE::given ($x) { + CORE::when (3) { + continue; + } + CORE::default { + CORE::break; + } +} +CORE::evalbytes ''; +() = CORE::__SUB__; +>>>> +CORE::state $x; +CORE::say $x; +CORE::given ($x) { + CORE::when (3) { + continue; + } + CORE::default { + CORE::break; + } +} +CORE::evalbytes ''; +() = CORE::__SUB__; +#### +# (the above test with CONTEXT, and the output is equivalent but different) +# CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch'; +# feature features when feature has been disabled by use VERSION +use feature (sprintf(":%vd", $^V)); +use 1; +CORE::state $x; +CORE::say $x; +CORE::given ($x) { + CORE::when (3) { + continue; + } + CORE::default { + CORE::break; + } +} +CORE::evalbytes ''; +() = CORE::__SUB__; +>>>> +no feature; +use feature ':default'; +CORE::state $x; +CORE::say $x; +CORE::given ($x) { + CORE::when (3) { + continue; + } + CORE::default { + CORE::break; + } +} +CORE::evalbytes ''; +() = CORE::__SUB__; +#### +# Feature hints +use feature 'current_sub', 'evalbytes'; +print; +use 1; +print; +use 5.014; +print; +no feature 'unicode_strings'; +print; +>>>> +use feature 'current_sub', 'evalbytes'; +print $_; +no feature; +use feature ':default'; +print $_; +no feature; +use feature ':5.12'; +print $_; +no feature 'unicode_strings'; +print $_; +#### +# $#- $#+ $#{%} etc. +my @x; +@x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}); +@x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,}); +@x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-); +@x = ($#{;}, $#{:}); +#### +# $#{*} +# It's a known TODO that warnings are deparsed as bits, not textually. +no warnings; +() = $#{*}; +#### +# ${#} interpolated +# It's a known TODO that warnings are deparsed as bits, not textually. +no warnings; +() = "${#}a"; +#### +# [perl #86060] $( $| $) in regexps need braces +/${(}/; +/${|}/; +/${)}/; +/${(}${|}${)}/; +#### +# ()[...] +my(@a) = ()[()]; +#### +# sort(foo(bar)) +# sort(foo(bar)) is interpreted as sort &foo(bar) +# sort foo(bar) is interpreted as sort foo bar +# parentheses are not optional in this case +print sort(foo('bar')); +>>>> +print sort(foo('bar')); +#### +# substr assignment +substr(my $a, 0, 0) = (foo(), bar()); +$a++; +#### +# This following line works around an unfixed bug that we are not trying to +# test for here: +# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised +# hint hash +BEGIN { $^H{'foo'} = undef; } +{ + BEGIN { $^H{'bar'} = undef; } + { + BEGIN { $^H{'baz'} = undef; } + { + print $_; + } + print $_; + } + print $_; +} +BEGIN { $^H{q[']} = '('; } +print $_; +#### +# This following line works around an unfixed bug that we are not trying to +# test for here: +# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised +# hint hash changes that serialise the same way with sort %hh +BEGIN { $^H{'a'} = 'b'; } +{ + BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; } + print $_; +} +print $_; +#### +# [perl #47361] do({}) and do +{} (variants of do-file) +do({}); +do +{}; +sub foo::do {} +package foo; +CORE::do({}); +CORE::do +{}; +>>>> +do({}); +do({}); +package foo; +CORE::do({}); +CORE::do({}); +#### +# [perl #77096] functions that do not follow the llafr +() = (return 1) + time; +() = (return ($1 + $2) * $3) + time; +() = (return ($a xor $b)) + time; +() = (do 'file') + time; +() = (do ($1 + $2) * $3) + time; +() = (do ($1 xor $2)) + time; +() = (goto 1) + 3; +() = (require 'foo') + 3; +() = (require foo) + 3; +() = (CORE::dump 1) + 3; +() = (last 1) + 3; +() = (next 1) + 3; +() = (redo 1) + 3; +() = (-R $_) + 3; +() = (-W $_) + 3; +() = (-X $_) + 3; +() = (-r $_) + 3; +() = (-w $_) + 3; +() = (-x $_) + 3; +#### +# [perl #97476] not() *does* follow the llafr +$_ = ($a xor not +($1 || 2) ** 2); +#### +# Precedence conundrums with argument-less function calls +() = (eof) + 1; +() = (return) + 1; +() = (return, 1); +() = warn; +() = warn() + 1; +() = setpgrp() + 1; +#### +# loopexes have assignment prec +() = (CORE::dump a) | 'b'; +() = (goto a) | 'b'; +() = (last a) | 'b'; +() = (next a) | 'b'; +() = (redo a) | 'b'; +#### +# [perl #63558] open local(*FH) +open local *FH; +pipe local *FH, local *FH; +#### +# [perl #91416] open "string" +open 'open'; +open '####'; +open '^A'; +open "\ca"; +>>>> +open *open; +open '####'; +open '^A'; +open *^A; +#### +# "string"->[] ->{} +no strict 'vars'; +() = 'open'->[0]; #aelemfast +() = '####'->[0]; +() = '^A'->[0]; +() = "\ca"->[0]; +() = 'a::]b'->[0]; +() = 'open'->[$_]; #aelem +() = '####'->[$_]; +() = '^A'->[$_]; +() = "\ca"->[$_]; +() = 'a::]b'->[$_]; +() = 'open'->{0}; #helem +() = '####'->{0}; +() = '^A'->{0}; +() = "\ca"->{0}; +() = 'a::]b'->{0}; +>>>> +no strict 'vars'; +() = $open[0]; +() = '####'->[0]; +() = '^A'->[0]; +() = $^A[0]; +() = 'a::]b'->[0]; +() = $open[$_]; +() = '####'->[$_]; +() = '^A'->[$_]; +() = $^A[$_]; +() = 'a::]b'->[$_]; +() = $open{'0'}; +() = '####'->{'0'}; +() = '^A'->{'0'}; +() = $^A{'0'}; +() = 'a::]b'->{'0'}; +#### +# [perl #74740] -(f()) vs -f() +$_ = -(f()); +#### +# require +require 'a' . $1; +#### +#[perl #30504] foreach-my postfix/prefix difference +$_ = 'foo' foreach my ($foo1, $bar1, $baz1); +foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' } +foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' } +>>>> +$_ = 'foo' foreach (my($foo1, $bar1, $baz1)); +foreach $_ (my($foo2, $bar2, $baz2)) { + $_ = 'foo'; +} +foreach my $i (my($foo3, $bar3, $baz3)) { + $i = 'foo'; +} +#### +#[perl #108224] foreach with continue block +foreach (1 .. 3) { print } continue { print "\n" } +foreach (1 .. 3) { } continue { } +foreach my $i (1 .. 3) { print $i } continue { print "\n" } +foreach my $i (1 .. 3) { } continue { } +>>>> +foreach $_ (1 .. 3) { + print $_; +} +continue { + print "\n"; +} +foreach $_ (1 .. 3) { + (); +} +continue { + (); +} +foreach my $i (1 .. 3) { + print $i; +} +continue { + print "\n"; +} +foreach my $i (1 .. 3) { + (); +} +continue { + (); +} +#### +# file handles +no strict; +my $mfh; +open F; +open *F; +open $fh; +open $mfh; +open 'a+b'; +select *F; +select F; +select $f; +select $mfh; +select 'a+b'; +#### +# 'my' works with padrange op +my($z, @z); +my $m1; +$m1 = 1; +$z = $m1; +my $m2 = 2; +my($m3, $m4); +($m3, $m4) = (1, 2); +@z = ($m3, $m4); +my($m5, $m6) = (1, 2); +my($m7, undef, $m8) = (1, 2, 3); +@z = ($m7, undef, $m8); +($m7, undef, $m8) = (1, 2, 3); +#### +# 'our/local' works with padrange op +no strict; +our($z, @z); +our $o1; +local $o11; +$o1 = 1; +local $o1 = 1; +$z = $o1; +$z = local $o1; +our $o2 = 2; +our($o3, $o4); +($o3, $o4) = (1, 2); +local($o3, $o4) = (1, 2); +@z = ($o3, $o4); +@z = local($o3, $o4); +our($o5, $o6) = (1, 2); +our($o7, undef, $o8) = (1, 2, 3); +@z = ($o7, undef, $o8); +@z = local($o7, undef, $o8); +($o7, undef, $o8) = (1, 2, 3); +local($o7, undef, $o8) = (1, 2, 3); +#### +# 'state' works with padrange op +no strict; +use feature 'state'; +state($z, @z); +state $s1; +$s1 = 1; +$z = $s1; +state $s2 = 2; +state($s3, $s4); +($s3, $s4) = (1, 2); +@z = ($s3, $s4); +# assignment of state lists isn't implemented yet +#state($s5, $s6) = (1, 2); +#state($s7, undef, $s8) = (1, 2, 3); +#@z = ($s7, undef, $s8); +($s7, undef, $s8) = (1, 2, 3); +#### +# anon lists with padrange +my($a, $b); +my $c = [$a, $b]; +my $d = {$a, $b}; +#### +# slices with padrange +my($a, $b); +my(@x, %y); +@x = @x[$a, $b]; +@x = @y{$a, $b}; +#### +# binops with padrange +my($a, $b, $c); +$c = $a cmp $b; +$c = $a + $b; +$a += $b; +$c = $a - $b; +$a -= $b; +$c = my $a1 cmp $b; +$c = my $a2 + $b; +$a += my $b1; +$c = my $a3 - $b; +$a -= my $b2; +#### +# 'x' with padrange +my($a, $b, $c, $d, @e); +$c = $a x $b; +$a x= $b; +@e = ($a) x $d; +@e = ($a, $b) x $d; +@e = ($a, $b, $c) x $d; +@e = ($a, 1) x $d; +#### +# @_ with padrange +my($a, $b, $c) = @_; +#### +# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" +# TODO unimplemented in B::Deparse; RT #116553 +# lexical subroutine +use feature 'lexical_subs'; +no warnings "experimental::lexical_subs"; +my sub f {} +print f();