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 = 17; # 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,
- '%^H' => $hinthash,
- );
-}
-
$/ = "\n####\n";
while (<DATA>) {
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;
}
}
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;
}
($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");
$regex =~ s/\s+/\\s+/g;
$regex = '^\{\s*' . $regex . '\s*\}$';
- local $::TODO = $reason{todo};
+ local $::TODO = $meta{todo};
like($deparsed, qr/$regex/, $desc);
}
}
$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';
}
EOCODF
+# [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 "@{*}" }),
print "@-";
}>, 'no need to curly around to interpolate "@-"');
-done_testing();
+# 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';
+ `;
+}
+
+done_testing($tests);
__DATA__
# A constant
# 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 } 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;
my $d = \[];
####
# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
+# CONTEXT use feature ':5.10';
# implicit smartmatch in given/when
given ('foo') {
when ('bar') { continue; }
# 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.
# 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 $';
$a[0] = 1;
####
# feature features without feature
-BEGIN {
- delete $^H{'feature_say'};
- delete $^H{'feature_state'};
- delete $^H{'feature_switch'};
+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
+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::evalbytes '';
() = CORE::__SUB__;
####
+# (the above test with CONTEXT, and the output is equivalent but different)
+# CONTEXT use feature ':5.10';
+# 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 = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
() = *#;
() = "${#}a";
####
+# [perl #86060] $( $| $) in regexps need braces
+/${(}/;
+/${|}/;
+/${)}/;
+/${(}${|}${)}/;
+####
# ()[...]
my(@a) = ()[()];
####
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{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'; }
{
() = (-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 <binop>
+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 {
+ ();
+}
https://perl5.git.perl.org / perl5.git / blobdiff