#!./perl
# Adapted from Deparse.t
use File::Basename qw(dirname basename); use File::Spec;
use English;

use warnings;
use strict;
use Text::Diff;
use rlib '../lib';

use constant data_dir => File::Spec->catfile(dirname(__FILE__), 'testdata');

use Test::More;

if ($] < 5.020 || $] > 5.0209) {
    plan skip_all => 'Customized to Perl 5.20 interpreter';
}

my $tests = 12; # not counting those in the __DATA__ section

use B::Deparse;
use B::DeparseTree;
my $deparse_orig = B::Deparse->new();
my $deparse = B::DeparseTree->new();
isa_ok($deparse, 'B::DeparseTree', 'instantiate a B::DeparseTree object');
my %deparse;

my $short_name = $ARGV[0] || 'P520.pm';
my $test_data = File::Spec->catfile(data_dir, $short_name);

local $INPUT_RECORD_SEPARATOR = "\n";
open(my $fh, '<', $test_data) or die "Can't open $test_data: $!";
while (<$fh>) {
    chomp;
    last if $_ eq '__DATA__'
}

local $INPUT_RECORD_SEPARATOR = "\n####\n";
while (<$fh>) {
    chomp;
    $tests ++;
    # This code is pinched from the t/lib/common.pl for TODO.
    # It's not clear how to avoid duplication
    my %meta = (context => '');
    foreach my $what (qw(skip todo context options)) {
	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 ($meta{$what} && $meta{$what} =~ s/^\?//) {
	    my $temp = eval $meta{$what};
	    if ($@) {
		die "# In \U$what\E code reason:\n# $meta{$what}\n$@";
	    }
	    $meta{$what} = $temp;
	}
    }

    s/^\s*#\s*(.*)$//mg;
    my $desc = $1;
    die "Missing name in test $_" unless defined $desc;

    if ($meta{skip}) {
	# Like this to avoid needing a label SKIP:
	Test::More->builder->skip($meta{skip});
	next;
    }

    my ($input, $expected);
    if (/(.*)\n>>>>\n(.*)/s) {
	($input, $expected) = ($1, $2);
    }
    else {
	($input, $expected) = ($_, $_);
    }

    # parse options if necessary
    my $deparse = $meta{options}
	? $deparse{$meta{options}} ||=
	    new B::Deparse split /,/, $meta{options}
	: $deparse;

    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");
    }
    else {
	my $deparsed = $deparse->coderef2text( $coderef );
	my $regex = $expected;
	$regex =~ s/(\S+)/\Q$1/g;
	$regex =~ s/\s+/\\s+/g;
	$regex = '^\{\s*' . $regex . '\s*\}$';

	local $::TODO = $meta{todo};
        like($deparsed, qr/$regex/, $desc);
    }
}

use constant 'c', 'stuff';
is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff',
   'the subroutine generated by use constant deparses');

# my $a = 0;
# is($deparse->coderef2text(sub{(-1) ** $a }), "{\n    (-1) ** \$a;\n}",
#    'anon sub capturing an external lexical');

# use constant cr => ['hello'];
# my $string = "sub " . $deparse->coderef2text(\&cr);
# my $val = (eval $string)->() or diag $string;
# is(ref($val), 'ARRAY', 'constant array references deparse');
# is($val->[0], 'hello', 'and return the correct value');

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';
# BEGIN { $^I = ".bak"; }
# BEGIN { $^W = 1; }
# BEGIN { $/ = "\n"; $\ = "\n"; }
# LINE: while (defined($_ = <ARGV>)) {
#     chomp $_;
#     our(@F) = split(' ', $_, 0);
#     '???';
# }
# EOF
# is($a, $b,
#    'command line flags deparse as BEGIN blocks setting control variables');

# $a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
# $a =~ s/-e syntax OK\n//g;
# is($a, "use constant ('PI', 4);\n",
#    "Proxy Constant Subroutines must not show up as (incorrect) prototypes");

#Re: perlbug #35857, patch #24505
#handle warnings::register-ed packages properly.
package B::Deparse::Wrapper;
use strict;
use warnings;
use warnings::register;
sub getcode {
   my $deparser = B::Deparse->new();
   return $deparser->coderef2text(shift);
}

package Moo;
use overload '0+' => sub { 42 };

package main;
use strict;
use warnings;
use constant GLIPP => 'glipp';
use constant PI => 4;
use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
BEGIN { delete $::Fcntl::{O_APPEND}; }
use POSIX qw/O_CREAT/;
sub test {
   my $val = shift;
   my $res = B::Deparse::Wrapper::getcode($val);
   like($res, qr/use warnings/,
	'[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly');
}
my ($q,$p);
my $x=sub { ++$q,++$p };
test($x);
eval <<EOFCODE and test($x);
   package bar;
   use strict;
   use warnings;
   use warnings::register;
   package main;
   1
EOFCODE

# # Exotic sub declarations
# $a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
# $a =~ s/-e syntax OK\n//g;
# is($a, <<'EOCODG', "sub :::: and sub ::::::");
# sub :::: {

# }
# sub :::::: {

# }
# EOCODG

# [perl #117311]
$a = `$^X $path "-MO=Deparse,-l" -e "map{ eval(0) }()" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, <<'EOCODH', "[perl #117311] [PATCH] -l option ('#line ...') does not emit ^Ls in the output");
#line 1 "-e"
map {
#line 1 "-e"
eval 0;} ();
EOCODH

# [perl #33752]
{
  my $code = <<"EOCODE";
{
    our \$\x{1e1f}\x{14d}\x{14d};
}
EOCODE
  my $deparsed
   = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
  s/$ \n//x for $deparsed, $code;
  is $deparsed, $code, 'our $funny_Unicode_chars';
}

# [perl #62500]
$a =
  `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick");
sub BEGIN {
    *CORE::GLOBAL::require = sub {
        1;
    }
    ;
}
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 "@{]}" }),
# 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

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


done_testing($tests);
