#!perl

use strict;
use warnings;
use Test::More;
use Fatal qw(open close);

BEGIN {
  unless ($] >= 5.008) {
    plan skip_all => 'due to test code no good for 5.006 yet';
  }
  plan tests => 9;
}

use lib 't/lib';
use Test::Weaken::Test;

BEGIN { Test::More::use_ok('Test::Weaken') }

use Carp;

package My_Object;

use Math::BigInt;
use Math::BigFloat;

sub new {
    my $obj1 = Math::BigInt->new('42');
    my $obj2 = Math::BigFloat->new('7.11');
    return [ $obj1, $obj2 ];
}

package Buggy_Object;
use Scalar::Util qw(weaken);

sub new {
    my $array = [ 42, 711 ];
    my $weak_ref;
    weaken( $weak_ref = $array );
    my $strong_ref = $array;
    push @{$array}, $array;
    push @{$array}, \$weak_ref;
    push @{$array}, \$strong_ref;
    return $array;
}

package main;

my $test_output;

package Test::Weaken::Test::Snippet::leaks;

sub destroy_buggy_object { }

$test_output = do {

    open my $save_stdout, '>&STDOUT';
    close STDOUT;
    my $code_output = q{};
    open STDOUT, q{>}, \$code_output;

    ## use Marpa::Test::Display leaks snippet

    use Test::Weaken;
    use English qw( -no_match_vars );

    my $tester = Test::Weaken::leaks(
        {   constructor => sub { Buggy_Object->new() },
            destructor  => \&destroy_buggy_object,
        }
    );
    if ($tester) {
        print "There are leaks\n"
            or Carp::croak("Cannot print to STDOUT: $ERRNO");
    }

    ## no Marpa::Test::Display

    open STDOUT, q{>&}, $save_stdout;
    close $save_stdout;
    $code_output;
};

Test::Weaken::Test::is( $test_output, <<'EOS', 'leaks snippet' );
There are leaks
EOS

package Test::Weaken::Test::Snippet::unfreed_proberefs;

$test_output = do {

    open my $save_stdout, '>&STDOUT';
    close STDOUT;
    my $code_output = q{!!!};
    open STDOUT, q{>}, \$code_output;

## use Marpa::Test::Display unfreed_proberefs snippet

    use Test::Weaken;
    use English qw( -no_match_vars );

    my $tester = Test::Weaken::leaks( sub { Buggy_Object->new() } );
    if ($tester) {
        my $unfreed_proberefs = $tester->unfreed_proberefs();
        my $unfreed_count     = @{$unfreed_proberefs};
        printf "%d of %d references were not freed\n",
            $tester->unfreed_count(), $tester->probe_count()
            or Carp::croak("Cannot print to STDOUT: $ERRNO");
        print "These are the probe references to the unfreed objects:\n"
            or Carp::croak("Cannot print to STDOUT: $ERRNO");
        for my $ix ( 0 .. $#{$unfreed_proberefs} ) {
            print Data::Dumper->Dump( [ $unfreed_proberefs->[$ix] ],
                ["unfreed_$ix"] )
                or Carp::croak("Cannot print to STDOUT: $ERRNO");
        }
    }

## no Marpa::Test::Display

    open STDOUT, q{>&}, $save_stdout;
    close $save_stdout;
    $code_output;
};

Test::Weaken::Test::is( $test_output, <<'EOS', 'unfreed_proberefs snippet' );
8 of 9 references were not freed
These are the probe references to the unfreed objects:
$unfreed_0 = [
               42,
               711,
               $unfreed_0,
               \$unfreed_0,
               \$unfreed_0
             ];
$unfreed_1 = \42;
$unfreed_2 = \711;
$unfreed_3 = \[
                 42,
                 711,
                 ${$unfreed_3},
                 \${$unfreed_3},
                 \${$unfreed_3}
               ];
$unfreed_4 = \\[
                   42,
                   711,
                   ${${$unfreed_4}},
                   ${$unfreed_4},
                   \${${$unfreed_4}}
                 ];
$unfreed_5 = \\[
                   42,
                   711,
                   ${${$unfreed_5}},
                   \${${$unfreed_5}},
                   ${$unfreed_5}
                 ];
$unfreed_6 = \[
                 42,
                 711,
                 ${$unfreed_6},
                 \${$unfreed_6},
                 $unfreed_6
               ];
$unfreed_7 = \[
                 42,
                 711,
                 ${$unfreed_7},
                 $unfreed_7,
                 \${$unfreed_7}
               ];
EOS

package Test::Weaken::Test::Snippet::unfreed_count;

$test_output = do {

    open my $save_stdout, '>&STDOUT';
    close STDOUT;
    my $code_output = q{};
    open STDOUT, q{>}, \$code_output;

    TEST: for my $i (0) {

## use Marpa::Test::Display unfreed_count snippet

        use Test::Weaken;
        use English qw( -no_match_vars );

        my $tester = Test::Weaken::leaks( sub { Buggy_Object->new() } );
        next TEST if not $tester;
        printf "%d objects were not freed\n", $tester->unfreed_count(),
            or Carp::croak("Cannot print to STDOUT: $ERRNO");

## no Marpa::Test::Display

    }    # TEST

    open STDOUT, q{>&}, $save_stdout;
    close $save_stdout;
    $code_output;
};

Test::Weaken::Test::is( $test_output, <<'EOS', 'unfreed_count snippet' );
8 objects were not freed
EOS

package Test::Weaken::Test::Snippet::probe_count;

sub destroy_buggy_object { }

$test_output = do {

    open my $save_stdout, '>&STDOUT';
    close STDOUT;
    my $code_output = q{};
    open STDOUT, q{>}, \$code_output;

    TEST: for my $i (0) {

        ## use Marpa::Test::Display probe_count snippet

        use Test::Weaken;
        use English qw( -no_match_vars );

        my $tester = Test::Weaken::leaks(
            {   constructor => sub { Buggy_Object->new() },
                destructor  => \&destroy_buggy_object,
            }
        );
        next TEST if not $tester;
        printf "%d of %d objects were not freed\n",
            $tester->unfreed_count(), $tester->probe_count()
            or Carp::croak("Cannot print to STDOUT: $ERRNO");

        ## no Marpa::Test::Display

    }    # TEST

    open STDOUT, q{>&}, $save_stdout;
    close $save_stdout;
    $code_output;
};

Test::Weaken::Test::is( $test_output, <<'EOS', 'probe_count snippet' );
8 of 9 objects were not freed
EOS

package Test::Weaken::Test::Snippet::weak_probe_count;

$test_output = do {
    open my $save_stdout, '>&STDOUT';
    close STDOUT;
    my $code_output = q{};
    open STDOUT, q{>}, \$code_output;

    TEST: for my $i (0) {
## use Marpa::Test::Display weak_probe_count snippet

        use Test::Weaken;
        use Scalar::Util qw(isweak);
        use English qw( -no_match_vars );

        my $tester = Test::Weaken::leaks( sub { Buggy_Object->new() }, );
        next TEST if not $tester;
        my $weak_unfreed_reference_count =
            scalar grep { ref $_ eq 'REF' and isweak( ${$_} ) }
            @{ $tester->unfreed_proberefs() };
        printf "%d of %d weak references were not freed\n",
            $weak_unfreed_reference_count, $tester->weak_probe_count(),
            or Carp::croak("Cannot print to STDOUT: $ERRNO");

## no Marpa::Test::Display
    }    # TEST

    open STDOUT, q{>&}, $save_stdout;
    close $save_stdout;
    $code_output;

};

Test::Weaken::Test::is( $test_output, <<'EOS', 'weak_probe_count snippet' );
1 of 1 weak references were not freed
EOS

package Test::Weaken::Test::Snippet::strong_probe_count;

sub destroy_buggy_object { }

$test_output = do {

    open my $save_stdout, '>&STDOUT';
    close STDOUT;
    my $code_output = q{};
    open STDOUT, q{>}, \$code_output;

    TEST: for my $i (0) {
## use Marpa::Test::Display strong_probe_count snippet

        use Test::Weaken;
        use English qw( -no_match_vars );
        use Scalar::Util qw(isweak);

        my $tester = Test::Weaken::leaks(
            {   constructor => sub { Buggy_Object->new() },
                destructor  => \&destroy_buggy_object,
            }
        );
        next TEST if not $tester;
        my $proberefs = $tester->unfreed_proberefs();
        my $strong_unfreed_object_count =
            grep { ref $_ ne 'REF' or not isweak( ${$_} ) } @{$proberefs};
        my $strong_unfreed_reference_count =
            grep { ref $_ eq 'REF' and not isweak( ${$_} ) } @{$proberefs};

        printf "%d of %d strong objects were not freed\n",
            $strong_unfreed_object_count, $tester->strong_probe_count(),
            or Carp::croak("Cannot print to STDOUT: $ERRNO");
        printf "%d of the unfreed strong objects were references\n",
            $strong_unfreed_reference_count
            or Carp::croak("Cannot print to STDOUT: $ERRNO");

## no Marpa::Test::Display
    }    # TEST

    open STDOUT, q{>&}, $save_stdout;
    close $save_stdout;
    $code_output;

};

Test::Weaken::Test::is( $test_output, <<'EOS', 'strong_probe_count snippet' );
7 of 8 strong objects were not freed
4 of the unfreed strong objects were references
EOS

package Test::Weaken::Test::Snippet::new;

$test_output = do {

    open my $save_stdout, '>&STDOUT';
    close STDOUT;
    my $code_output;
    open STDOUT, q{>}, \$code_output;

    no warnings 'redefine';

    use warnings;

## use Marpa::Test::Display new snippet

    use Test::Weaken;
    use English qw( -no_match_vars );

    my $tester        = Test::Weaken->new( sub { My_Object->new() } );
    my $unfreed_count = $tester->test();
    my $proberefs     = $tester->unfreed_proberefs();
    printf "%d of %d objects freed\n", $unfreed_count, $tester->probe_count()
        or Carp::croak("Cannot print to STDOUT: $ERRNO");

## no Marpa::Test::Display

    open STDOUT, q{>&}, $save_stdout;
    close $save_stdout;
    $code_output;

};

Test::Weaken::Test::is( $test_output, <<'EOS', 'new snippet' );
0 of 18 objects freed
EOS

package Test::Weaken::Test::Snippet::test;

sub destroy_my_object { }

$test_output = do {

    open my $save_stdout, '>&STDOUT';
    close STDOUT;
    my $code_output;
    open STDOUT, q{>}, \$code_output;

    no warnings 'redefine';

    use warnings;

## use Marpa::Test::Display test snippet

    use Test::Weaken;
    use English qw( -no_match_vars );

    my $tester = Test::Weaken->new(
        {   constructor => sub { My_Object->new() },
            destructor  => \&destroy_my_object,
        }
    );
    printf "There are %s\n", ( $tester->test() ? 'leaks' : 'no leaks' )
        or Carp::croak("Cannot print to STDOUT: $ERRNO");

## no Marpa::Test::Display

    open STDOUT, q{>&}, $save_stdout;
    close $save_stdout;
    $code_output;

};

Test::Weaken::Test::is( $test_output, <<'EOS', 'test snippet' );
There are no leaks
EOS