view release on metacpan or  search on metacpan

lib/B/Deparse.t  view on Meta::CPAN

    skip "requires 5.11", 1 unless $] >= 5.011;
    eval q`
	BEGIN {
	    # Clear out all hints
	    %^H = ();
	    $^H = 0;
	    B::Deparse->new->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

SKIP: {
    skip("Your perl was built without taint support", 1)
        unless $Config::Config{taint_support};

    is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-T' ],
           prog => "format =\n\@\n\$;\n.\n"),
        <<~'EOCODM', '$; on format line';
        format STDOUT =
        @
        $;
        .
        EOCODM
}

is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse,-l', $path ],
           prog => "format =\n\@\n\$foo\n.\n"),
   <<'EOCODM', 'formats with -l';
format STDOUT =
@
$foo
.
EOCODM

is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => "{ my \$x; format =\n\@\n\$x\n.\n}"),
   <<'EOCODN', 'formats nested inside blocks';
{
    my $x;
    format STDOUT =
@
$x
.
}
EOCODN

# CORE::format
$a = readpipe qq`$^X $path "-MO=Deparse" -e "use feature q|:all|;`
             .qq` my sub format; CORE::format =" -e. 2>&1`;
like($a, qr/CORE::format/, 'CORE::format when lex format sub is in scope');

# literal big chars under 'use utf8'
is($deparse->coderef2text(sub{ use utf8; /€/; }),
'{
    /\x{20ac}/;
}',
"qr/euro/");

# STDERR when deparsing sub calls
# For a short while the output included 'While deparsing'
$a = `$^X $path "-MO=Deparse" -e "foo()" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, <<'EOCODI', 'no extra output when deparsing foo()');
foo();
EOCODI

# Sub calls compiled before importation
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
             prog => 'BEGIN {
                       require Test::More;
                       Test::More::->import;
                       is(*foo, *foo)
                     }'),
     qr/&is\(/,
    'sub calls compiled before importation of prototype subs';

# [perl #121050] Prototypes with whitespace
is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => <<'EOCODO'),
sub _121050(\$ \$) { }
_121050($a,$b);
sub _121050empty( ) {}
() = _121050empty() + 1;
EOCODO
   <<'EOCODP', '[perl #121050] prototypes with whitespace';
sub _121050 (\$ \$) {
    
}
_121050 $a, $b;
sub _121050empty ( ) {
    
}
() = _121050empty + 1;
EOCODP

# 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;\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;\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.*CORE::__DATA__/s,
    'CORE::__DATA__ after my sub __DATA__');

# sub declarations
$a = readpipe qq`$^X $path "-MO=Deparse" -e "sub foo{}" 2>&1`;
like($a, qr/sub foo\s*\{\s+\}/, 'sub declarations');
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => 'sub f($); sub f($){}'),
     qr/sub f\s*\(\$\)\s*\{\s*\}/,
    'predeclared prototyped subs';
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => 'sub f($);
                    BEGIN { use builtin q-weaken-; weaken($_=\$::{f}) }'),
     qr/sub f\s*\(\$\)\s*;/,
    'prototyped stub with weak reference to the stash entry';
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => 'sub f () { 42 }'),
     qr/sub f\s*\(\)\s*\{\s*42;\s*\}/,
    'constant perl sub declaration';

# BEGIN blocks
SKIP : {
    skip "BEGIN output is wrong on old perls", 1 if $] < 5.021006;
    my $prog = '
      BEGIN { pop }
      {
        BEGIN { pop }
        {
          no overloading;
          {
            BEGIN { pop }
            die
          }
        }
      }';
    $prog =~ s/\n//g;
    $a = readpipe qq`$^X $path "-MO=Deparse" -e "$prog" 2>&1`;
    $a =~ s/-e syntax OK\n//g;
    is($a, <<'EOCODJ', 'BEGIN blocks');
sub BEGIN {
    pop @ARGV;
}
{
    sub BEGIN {
        pop @ARGV;
    }
    {
        no overloading;
        {
            sub BEGIN {
                pop @ARGV;
            }
            die;
        }
    }
}
EOCODJ
}
is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], prog => '