print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
- require 'test.pl';
+ require './test.pl';
}
use warnings;
use strict;
-my $tests = 44; # not counting those in the __DATA__ section
+my $tests = 46; # not counting those in the __DATA__ section
use B::Deparse;
my $deparse = B::Deparse->new();
$regex =~ s/\s+/\\s+/g;
$regex = '^\{\s*' . $regex . '\s*\}$';
- like($deparsed, qr/$regex/, $desc);
+ like($deparsed, qr/$regex/, $desc)
+ or diag "=============================================\n"
+ . "CODE:\n--------\n$input\n--------\n"
+ . "EXPECTED:\n--------\n{\n$expected\n}\n--------\n"
+ . "GOT:\n--------\n$deparsed\n--------\n"
+ . "=============================================\n";
}
}
BEGIN { $^I = ".bak"; }
BEGIN { $^W = 1; }
BEGIN { $/ = "\n"; $\ = "\n"; }
-LINE: while (defined($_ = <ARGV>)) {
+LINE: while (defined($_ = readline ARGV)) {
chomp $_;
our(@F) = split(' ', $_, 0);
'???';
# CORE::no
$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
.qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`;
-like($a, qr/my sub no;\nCORE::no less;/,
+like($a, qr/my sub no;\n.*CORE::no less;/s,
'CORE::no after my sub no');
# CORE::use
$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
.qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`;
-like($a, qr/my sub use;\nCORE::use less;/,
+like($a, qr/my sub use;\n.*CORE::use less;/s,
'CORE::use after my sub use');
# CORE::__DATA__
$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
.qq`"use feature q|:all|; my sub __DATA__; `
.qq`CORE::__DATA__" 2>&1`;
-like($a, qr/my sub __DATA__;\n.*\nCORE::__DATA__/s,
+like($a, qr/my sub __DATA__;\n.*CORE::__DATA__/s,
'CORE::__DATA__ after my sub __DATA__');
# sub declarations
qr/^sub foo \{\s+foo\(\)/m,
'recursive sub';
+like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
+ prog => 'use feature lexical_subs=>state=>;
+ state sub sb5; sub { sub sb5 { } }'),
+ qr/sub \{\s*\(\);\s*sub sb5 \{/m,
+ 'state sub in anon sub but declared outside';
+
+is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
+ prog => 'BEGIN { $::{f}=\!0 }'),
+ "sub BEGIN {\n \$main::{'f'} = \\1;\n}\n",
+ '&PL_sv_yes constant (used to croak)';
+
is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-T' ],
prog => '$x =~ (1?/$a/:0)'),
'$x =~ ($_ =~ /$a/);'."\n",
####
# <>
my $foo;
-$_ .= <ARGV> . <$foo>;
+$_ .= <> . <ARGV> . <$foo>;
+<$foo>;
+<${foo}>;
+<$ foo>;
+>>>>
+my $foo;
+$_ .= readline(ARGV) . readline(ARGV) . readline($foo);
+readline $foo;
+glob $foo;
+glob $foo;
####
# readline
readline 'FH';
readline *$_;
+readline *{$_};
+readline ${"a"};
+>>>>
+readline 'FH';
+readline *$_;
readline *{$_;};
+readline ${'a';};
+####
+# <<>>
+$_ = <<>>;
####
# \x{}
my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
our @ary;
@ary = split(' ', 'foo', 0);
####
+my @ary;
+@ary = split(' ', 'foo', 0);
+####
# Split to our array
our @array = split(//, 'foo', 0);
####
# Split to my array
my @array = split(//, 'foo', 0);
####
+our @array;
+my $c;
+@array = split(/x(?{ $c++; })y/, 'foo', 0);
+####
+my($x, $y, $p);
+our $c;
+($x, $y) = split(/$p(?{ $c++; })y/, 'foo', 2);
+####
+our @ary;
+my $pat;
+@ary = split(/$pat/, 'foo', 0);
+####
+my @ary;
+our $pat;
+@ary = split(/$pat/, 'foo', 0);
+####
+our @array;
+my $pat;
+local @array = split(/$pat/, 'foo', 0);
+####
+our $pat;
+my @array = split(/$pat/, 'foo', 0);
+####
# bug #40055
do { () };
####
print /a/d, s/b/c/d;
}
####
+# all the flags (qr//)
+$_ = qr/X/m;
+$_ = qr/X/s;
+$_ = qr/X/i;
+$_ = qr/X/x;
+$_ = qr/X/p;
+$_ = qr/X/o;
+$_ = qr/X/u;
+$_ = qr/X/a;
+$_ = qr/X/l;
+$_ = qr/X/n;
+####
+use feature 'unicode_strings';
+$_ = qr/X/d;
+####
+# all the flags (m//)
+/X/m;
+/X/s;
+/X/i;
+/X/x;
+/X/p;
+/X/o;
+/X/u;
+/X/a;
+/X/l;
+/X/n;
+/X/g;
+/X/cg;
+####
+use feature 'unicode_strings';
+/X/d;
+####
+# all the flags (s///)
+s/X//m;
+s/X//s;
+s/X//i;
+s/X//x;
+s/X//p;
+s/X//o;
+s/X//u;
+s/X//a;
+s/X//l;
+s/X//n;
+s/X//g;
+s/X/'';/e;
+s/X//r;
+####
+use feature 'unicode_strings';
+s/X//d;
+####
+# all the flags (tr///)
+tr/X/Y/c;
+tr/X//d;
+tr/X//s;
+tr/X//r;
+####
# [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
s/foo/\(3);/eg;
####
####
# [perl #90898]
<a,>;
+glob 'a,';
+>>>>
+glob 'a,';
+glob 'a,';
####
# [perl #91008]
+# SKIP ?$] >= 5.023 && "autoderef deleted in this Perl version"
# CONTEXT no warnings 'experimental::autoderef';
each $@;
keys $~;
@x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
@x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
@x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
-@x = ($#{;}, $#{:}, $#{1});
+@x = ($#{;}, $#{:}, $#{1}), $#_;
####
# ${#} interpolated
# It's a known TODO that warnings are deparsed as bits, not textually.
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical subroutine
-use feature 'lexical_subs';
+# CONTEXT use feature 'lexical_subs';
no warnings "experimental::lexical_subs";
my sub f {}
print f();
>>>>
-use feature 'lexical_subs';
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x05\x55\x01"}
+BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
my sub f {
- BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x05\x01"}
}
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x05\x01"}
print f();
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical "state" subroutine
-use feature 'state', 'lexical_subs';
+# CONTEXT use feature 'state', 'lexical_subs';
no warnings 'experimental::lexical_subs';
state sub f {}
print f();
>>>>
-use feature 'lexical_subs';
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x05\x55\x01"}
-CORE::state sub f {
- BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x05\x01"}
- use feature 'state';
+BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
+state sub f {
}
-BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x54\x05\x01"}
-use feature 'state';
print f();
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
sub f { }
}
####
+# TODO only partially fixed
+# lexical state subroutine with outer declaration and inner definition
+# CONTEXT use feature 'lexical_subs', 'state'; no warnings 'experimental::lexical_subs';
+();
+state sub sb4;
+state sub a {
+ ();
+ sub sb4 { }
+}
+state sub sb5;
+sub {
+ ();
+ sub sb5 { }
+} ;
+####
# Elements of %# should not be confused with $#{ array }
() = ${#}{'foo'};
####
####
# multideref with leading expression
my $r;
-my $x = ($r // [])->{'foo'}[0];
+my $x = +($r // [])->{'foo'}[0];
####
# multideref with complex middle index
my(%h, $i, $j, $k);
my $x = $h{'foo'}[$i + $j]{$k};
####
+# multideref with trailing non-simple index that initially looks simple
+# (i.e. the constant "3")
+my($r, $i, $j, $k);
+my $x = +($r || {})->{'foo'}[$i + $j]{3 + $k};
+####
# chdir
chdir 'file';
chdir FH;
chdir;
+####
+# 5.22 bitops
+# CONTEXT use feature "bitwise"; no warnings "experimental::bitwise";
+$_ = $_ | $_;
+$_ = $_ & $_;
+$_ = $_ ^ $_;
+$_ = ~$_;
+$_ = $_ |. $_;
+$_ = $_ &. $_;
+$_ = $_ ^. $_;
+$_ = ~.$_;
+$_ |= $_;
+$_ &= $_;
+$_ ^= $_;
+$_ |.= $_;
+$_ &.= $_;
+$_ ^.= $_;
+####
+####
+# Should really use 'no warnings "experimental::signatures"',
+# but it doesn't yet deparse correctly.
+# anon subs used because this test framework doesn't deparse named subs
+# in the DATA code snippets.
+#
+# general signature
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $, $b = $glo::bal, $c = $a, $d = 'foo', $e = -37, $f = 0, $g = 1, $h = undef, $i = $a + 1, $j = /foo/, @) {
+ $x++;
+}
+;
+$x++;
+####
+# Signature and prototype
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : prototype($$) {
+ $x++;
+}
+;
+$x++;
+####
+# Signature and prototype and attrs
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : prototype($$) lvalue {
+ $x++;
+}
+;
+$x++;
+####
+# Signature and attrs
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : lvalue method {
+ $x++;
+}
+;
+$x++;
+####
+# named array slurp, null body
+no warnings;
+use feature 'signatures';
+sub (@a) {
+ ;
+}
+;
+####
+# named hash slurp
+no warnings;
+use feature 'signatures';
+sub ($key, %h) {
+ $h{$key};
+}
+;
+####
+# anon hash slurp
+no warnings;
+use feature 'signatures';
+sub ($a, %) {
+ $a;
+}
+;
+####
+# parenthesised default arg
+no warnings;
+use feature 'signatures';
+sub ($a, $b = (/foo/), $c = 1) {
+ $a + $b + $c;
+}
+;
+####
+# parenthesised default arg with TARGMY
+no warnings;
+use feature 'signatures';
+sub ($a, $b = ($a + 1), $c = 1) {
+ $a + $b + $c;
+}
+;
+####
+# empty default
+no warnings;
+use feature 'signatures';
+sub ($a, $=) {
+ $a;
+}
+;
https://perl5.git.perl.org / perl5.git / blobdiff