#!./perl
# Adapted from Deparse.t

use rlib '.'; use helper;
use warnings; use strict;
use File::Temp qw/ tempfile tempdir /;

if ($] < 5.018 || $] > 5.0269) {
    plan skip_all => 'Customized to Perl 5.18 - 5.26 interpreters';
}

if ($ENV{'CIRCLECI'}) {
    plan skip_all => 'Something is funky with CircleCI';
}

use Config;
my $is_cperl = $Config::Config{usecperl};

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

my %deparse;

$/ = "\n####\n";
my $eval_but_skip = $tests+1;

my @test_files = ('subst.pm', 'small.pm');

use constant MAX_ERROR_COUNT => 2;
my $error_count = 0;

for my $file (@test_files) {

    my ($data_fh, $line_no) = open_data($file);
    while (<$data_fh>) {
	# FIXME w need to count \n's in $_
	$line_no += (length split /\n/, $_);
	chomp;
	$tests ++;

	# This code was adapted from the t/lib/common.pl for TODO.
	my %meta = (context => '');
	my %orig_meta = ();
	foreach my $what (qw(skip todo context options)) {
	    if (s/^#\s*\U$what\E\s*(.*)\n//m) {
		$orig_meta{$what} = $_;
		$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} =~ s/^\?//) {
		    my $temp = eval $meta{$what};
		    ok ! $@;
		    if ($@) {
			die "# In \U$what\E code reason:\n# $meta{$what}\n$@";
		    }
		    $meta{$what} = $temp;
		}
		# We tolerate many "skip", "todo", and "context lines;
		# last unless $what eq 'skip';
	    }
	}

	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::DeparseTree split /,/, $meta{options}
	: $deparse;

	my $code_string = "$meta{context};\n" . <<'EOC' . "sub {$input}";

# Tell B::Deparse about our ambient pragmas so it doesn't add pragmas to
# its output.
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

	my $coderef = eval $code_string;
	if ($@) {
	    is($@, "", "compilation of $desc");
	}
	else {
	    my ($deparsed, $deparsed_check);
	    $deparsed_check = $deparse_orig->coderef2text( $coderef );
	    eval {
		$deparsed = $deparse->coderef2text( $coderef );
	    };
	    if ($@) {
		die "$coderef\n$@";
	    }
	    # Something is funky with testing against final }.
	    if (substr($expected, -1) eq '}') {
		$expected = substr($expected, 0, -1);
	    }
	    $expected =~ s/;$//;
	    my $regex = $expected;
	    $regex =~ s/(\S+)/\Q$1/g;
	    $regex =~ s/\s+/\\s+/g;
	    $regex = '^\s*\{\s*' . $regex;

	    local $::TODO = $meta{todo};
	    unless(like($deparsed, qr/$regex/, $desc)) {
		::diag "\n", '-' x 30, "\n";
		::diag diff \$deparsed, \$expected, { STYLE => "Context" };
		::diag "\n", '=' x 30, "\n";
		::diag "Data file $file\n";
		my ($fh, $filename) = tempfile( "deparse-bug-XXXX",
						TMPDIR => 1,
						UNLINK => 0,
						SUFFIX => '.pl');
		foreach my $key (keys %orig_meta) {
		    print $fh $orig_meta{$key};
		}
		print $fh "sub {$input\n}\n";
		::diag "Wrote failed Perl program to $filename";
		close($fh);

		if (++$error_count >= MAX_ERROR_COUNT) {
		    done_testing;
		    exit $error_count;
		}
	    }
	    ok $tests, $desc;
	}
    }

    close($data_fh);
}

use constant 'c', 'stuff';
# ROCKY: FIXME
# 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
# FIXME rocky
# is($a, $b,
#    'command line flags deparse as BEGIN blocks setting control variables');
$b &&= undef;

$a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
$a =~ s/-e syntax OK\n//g;
if (!$is_cperl) {
    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::DeparseTree->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;
  ## FIXME
  ## 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 panic") if !$is_cperl;
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");

# FIXME rocky
# # [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';
   `;
}

if (!$is_cperl) {
    # 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'
# FIXME
# is($deparse->coderef2text(sub{ use utf8; /€/; }),
# '{
#     /\x{20ac}/;
# }',
# "qr/euro/");
};

done_testing();
