#!perl
use strict;
use warnings;
use Data::Dumper;
use File::Spec;
use Scalar::Util qw(blessed);

# These tests use an installed Decoder to do testing on horrific
# Perl data structures such as overloaded and tied structures.

use lib File::Spec->catdir(qw(t lib));
BEGIN {
    lib->import('lib')
        if !-d 't';
}

use Sereal::TestSet qw(:all);
use Test::More;

if (not have_encoder_and_decoder()) {
    plan skip_all => 'Did not find right version of decoder';
    exit 0;
}

Sereal::Encoder->import(":all");
Sereal::Decoder->import(":all");

# First, test tied hashes. Expected behaviour: We don't segfault, we don't
# throw exceptions (unless the tied hash is not iterable repeatedly),
# we serialize the tied hash as if it was a normal hash - so no trace of
# tiedness in the output.
{
    SCOPE: {
        package TiedHash;
        require Tie::Hash;
        our @ISA = qw(Tie::StdHash);
    }

    my %testhash = (
        foo => [qw(a b c)],
        baz => 123,
        dfvgbnhmjk => "345ty6ujh",
        a => undef,
    );

    my %tied_hash;
    tie %tied_hash => 'TiedHash';
    %{tied(%tied_hash)} = %testhash;
    is_deeply(\%tied_hash, \%testhash);

    my ($out, $ok, $err, $data);
    $ok = eval {$out = encode_sereal(\%tied_hash); 1};
    $err = $@ || 'Zombie error';
    ok($ok, "serializing tied hash did not die")
        or note("Error was '$err'");
    ok(defined $out, "serializing tied hash returns string");

    $ok = eval {$data = decode_sereal($out); 1;};
    $err = $@ || 'Zombie error';
    ok($ok, "deserializing tied hash did not die")
        or note("Error was '$err', data was:\n"), hobodecode($out);
    ok(defined $data, "deserializing tied hash yields defined output");
    is_deeply($data, \%testhash, "deserializing tied hash yields expected output");
}


# Now tied arrays.
{
    SCOPE: {
        package TiedArray;
        require Tie::Array;
        our @ISA = qw(Tie::StdArray);
    }

    my @testarray = (1, 2, "foo", "bar", []);
    my @tied_array;
    tie @tied_array => 'TiedArray';
    @{tied(@tied_array)} = @testarray;
    is_deeply(\@tied_array, \@testarray);

    my ($out, $ok, $err, $data);
    $ok = eval {$out = encode_sereal(\@tied_array); 1};
    $err = $@ || 'Zombie error';
    ok($ok, "serializing tied array did not die")
        or note("Error was '$err'");
    ok(defined $out, "serializing tied array returns string");

    $ok = eval {$data = decode_sereal($out); 1;};
    $err = $@ || 'Zombie error';
    ok($ok, "deserializing tied array did not die")
        or note("Error was '$err', data was:\n"), hobodecode($out);
    ok(defined $data, "deserializing tied array yields defined output");
    is_deeply($data, \@testarray, "deserializing tied array yields expected output");
}

# Now tied scalars.
{

    SCOPE: {
        package TiedScalar;
        require Tie::Scalar;
        our @ISA = qw(Tie::StdScalar);
    }

    my $testscalar = [qw(foo bar baz)];
    my $tied_scalar;
    tie $tied_scalar => 'TiedScalar';
    ${tied($tied_scalar)} = $testscalar;
    is_deeply($tied_scalar, $testscalar);

    my ($out, $ok, $err, $data);
    $ok = eval {$out = encode_sereal(\$tied_scalar); 1};
    $err = $@ || 'Zombie error';
    ok($ok, "serializing tied scalar did not die")
      or note("Error was '$err'");
    ok(defined $out, "serializing tied scalar returns string");

    $ok = eval {$data = decode_sereal($out); 1;};
    $err = $@ || 'Zombie error';
    ok($ok, "deserializing tied scalar did not die")
      or note("Error was '$err', data was:\n"), hobodecode($out);
    ok(defined $data, "deserializing tied scalar yields defined output");
    is_deeply($data, \$testscalar, "deserializing tied scalar yields expected output");
}

# Now test re-entrancy. DO NOT DO THIS AT HOME!
SCOPE: {
    my $enc = Sereal::Encoder->new;
    my $die_run = 0;
    eval {
        local $SIG{__DIE__} = sub {
            $die_run++;
            ok(defined($enc->encode("foo")), "encode does not segfault");
            $die_run++;
        };
        $enc->encode(["foo", sub{}]);
    };
    ok($die_run == 2, "__DIE__ called, encode 2 did not die ($die_run)");
}

# github Sereal/Sereal issue 7 regression test:
SCOPE: {
    {
        package # hide from PAUSE
            Blessed::Sub::With::Overload;
        use overload '""' => sub { shift->() };
        sub new { bless $_[1] => $_[0] }
    }
    {
        package # hide from PAUSE
            Blessed::Sub::With::Lazy::Overload;
        use overload '""' => sub {
            my ($self) = @_;
            return $self->[1] if defined $self->[1];
            return "OH NOES WE DON'T HAVE A SUB" unless ref $self->[0] eq 'CODE';
            return ($self->[1] = $self->[0]->());
        };
        sub new {
            bless [
                # The callback
                $_[1],
                # Cached value
                undef
            ] => $_[0]
        }
    }
    my $data;
    $data->[0] = sub {};
    $data->[1] = $data->[0];
    $data->[2] = Blessed::Sub::With::Overload->new(sub { "hello there" });
    $data->[3] = $data->[2];
    $data->[4] = Blessed::Sub::With::Overload->new(sub { \"hello there" });
    $data->[5] = $data->[4];
    my $called;
    $data->[6] = Blessed::Sub::With::Overload->new(sub { $called++; "hello there" });
    $data->[7] = $data->[6];
    $data->[8] = $data->[6];
    $data->[9] = $data->[6];
    $data->[10] = Blessed::Sub::With::Lazy::Overload->new(sub { "hello there" });
    $data->[11] = $data->[10];

    my $encode = encode_sereal($data, {stringify_unknown => 1});
    # Before 48d5cdc3dc07fd29ac7be05678a0b614244fec4f, we'd
    # die here because $data->[1] is a ref to something that doesn't exist anymore
    my $decode = decode_sereal($encode);

    is($decode->[0], $decode->[1]);
    is($decode->[2], $decode->[3]);
    is($decode->[4], $decode->[5]);
    is($decode->[6], $decode->[$_]) for 7..9;
    is($called, 4, "We'll call the sub every time, and won't re-use the initial return value");
    ok(blessed($decode->[10]), "We won't be stringifying objects");
    like($decode->[10]->[0], qr/^CODE\(.*?\)$/, "And the subroutine we have will just be stringified as usual in Perl");
    is("$decode->[10]", "OH NOES WE DON'T HAVE A SUB", "So our subroutine won't survive the roundtrip, our object is broken");
    is_deeply($decode->[10], $decode->[11], "Both the original and the reference to it are equally screwed");
}

pass("Alive at end");
done_testing();