#!/usr/bin/env perl

use strict;
use warnings;

use Test::More tests => 63;

# We need IO::Capture::Std(out|err) only for this test, so rather than
# make the user install it for us, we have a copy for use in testing
use lib 't/lib';
use lib 'lib';
use lib '../lib';

use Test::Resub qw(resub);

use IO::Capture::Stdout;
use IO::Capture::Stderr;

sub _std_of {
  my ($class, $code) = @_;
  my $capture = $class->new;
  $capture->start;
  $code->();
  $capture->stop;
  return join "\n", $capture->read;
}

sub stderr_of { return _std_of('IO::Capture::Stderr', @_) }
sub stdout_of { return _std_of('IO::Capture::Stdout', @_) }

{
  my $orig_msg = 'aklejave geagk';

  {
    package TestResub;
    sub resub_me { 'uh uh' }
    sub resub_me2 { $orig_msg }
    sub resub_me3 { $orig_msg }
  }

  my $msg = 'yes, please';
  # successful resub method in scalar context
  is( TestResub::resub_me2(), $orig_msg );
  {
    my $resub = Test::Resub->new({
      name => "TestResub::resub_me2",
      code => sub { $msg },
    });
    ok( $resub->not_called, 'start out uncalled' );

    is( TestResub::resub_me2(), $msg );
    is( $resub->called, 1, 'call counter increments' );
    ok( ! $resub->not_called, 'no longer uncalled' );

    # increment called counter
    TestResub::resub_me2();
    is( $resub->called, 2, 'call counter increments again' );

    # reset should reset the called counter, not the was_called flag
    $resub->reset;
    is( $resub->called, 0 );
    ok( $resub->was_called );
  }
  is( TestResub::resub_me2(), $orig_msg );

  # multiple resubs on the same method play nicely together
  {
    is( TestResub::resub_me2(), $orig_msg );
    {
      my $resub1 = Test::Resub->new({
        name => "TestResub::resub_me2",
        code => sub { 'one' },
      });
      is( TestResub::resub_me2(), 'one' );
      my $resub2 = Test::Resub->new({
        name => "TestResub::resub_me2",
        code => sub { 'two' },
      });
      is( TestResub::resub_me2(), 'two', 'can reresub');
    }
    is( TestResub::resub_me2(), $orig_msg );
  }

  # Argument capturing
  {
    # Don't capture arguments w/o 'capture => 1',
    {
      my $resub = Test::Resub->new({
        name => "TestResub::resub_me2",
        code => sub { $msg },
      });
      TestResub::resub_me2(1..10);
      like( stderr_of(sub { $resub->args }), qr/capture.*flag/i );
    }

    # capture arguments with 'capture => 1',
    {
      my $resub = Test::Resub->new({
        name => "TestResub::resub_me2",
        code => sub { $msg },
        capture => 1,
      });
      is_deeply( $resub->args, [] );
      is_deeply( $resub->method_args, [] );
      TestResub::resub_me2();
      TestResub::resub_me2('abc', [1,2,3]);
      is_deeply( $resub->args, [[], ['abc', [1,2,3]]] );
      is_deeply( $resub->method_args, [[], [[1,2,3]]] );
      $resub->reset;
      is_deeply( $resub->args, [] );
      is_deeply( $resub->method_args, [] );
      is_deeply( $resub->named_args, [] );

      # named args
      TestResub::resub_me2(dog => 'bark', cat => 'meow');
      is_deeply( $resub->named_args, [{
        dog => 'bark',
        cat => 'meow',
      }] );
      $resub->reset;
      
      # named method args
      TestResub->resub_me2(dog => 'bark', cat => 'meow');
      is_deeply( $resub->named_method_args, [{
        dog => 'bark',
        cat => 'meow',
      }] );

      # Make sure we can call the puppy twice in a row.  No, seriously.
      is_deeply( $resub->named_method_args, [{
        dog => 'bark',
        cat => 'meow',
      }] );

      # allow us to shift off the first N scalars before the %args
      $resub->reset;
      TestResub->resub_me2('timestamp', dog => 'bark', cat => 'meow');
      is_deeply( [$resub->named_method_args(scalars => 1)], [[
        'timestamp',
        {
          dog => 'bark',
          cat => 'meow',
        },
      ]] );
      is_deeply( [$resub->named_method_args(scalars => 3)], [[
        'timestamp',
        'dog',
        'bark',
        {
          cat => 'meow',
        },
      ]] );

      # really, really shift off the first N scalars before the %args
      is_deeply( $resub->named_method_args(arg_start_index => 3), [{
        cat => 'meow',
      }] );
      is_deeply( $resub->named_args(arg_start_index => 4), [{
        cat => 'meow',
      }] );
    }

    # default replacement code is 'sub {}'
    {
      {
        package DifferentDefault;
        use base qw(Test::Resub);
        sub default_replacement_sub { sub { 'bell-bottoms' } }
      }
      my $no_specified_code = DifferentDefault->new({
        name => 'TestResub::resub_me2',
        call => 'optional',
      });
      is( TestResub::resub_me2, 'bell-bottoms' );

    }
    {
      {
        package Test::Resub;
        use Data::Dumper;
        use strict;
        local $Data::Dumper::Deparse = 1;
        main::is( Dumper(Test::Resub->default_replacement_sub),
          Dumper(sub {}) );
      }
    }
  }

  # error when trying to resub improperly named method
  {
    local $@;
    eval {
      my $rs = Test::Resub->new({name => 'Hello->world', code => sub { 1 }});
    };
    like( $@, qr/bad method name/i, 'catch bad method names' );
    like( $@, qr/01-main/, "error is from caller's perspective" );
  }

  # won't resub things into existence without create flag
  {
    local $@;
    eval {
      my $rs = resub "TestResub::kinks_Flourtown";
    };
    like( $@,
      qr/Package TestResub doesn't have a kinks_Flourtown.*'create' flag/,
      "Don't create nonexistent functions unless told to",
    );

    my $rs = resub "TestResub::countersunk_hilltopped", sub { 2336 }, create => 1;
    is( TestResub->countersunk_hilltopped(), 2336 );
  }

  # error when passing bad 'call' argument
  {
    local $@;
    eval {
      my $rs = Test::Resub->new({name => 'main::function', call => 'spork'});
    };
    like( $@, qr/call.*spork/i );
  }
}

{
  package TestBase;
  sub base_method { 1; }

  package TestChild;
  use base qw(TestBase);
  sub child_method { }

  package main;

  $TestChild::base_method = (my $keep_scalar = "Don't hurt me!");
  @TestChild::base_method = my @keep_array = qw(leave us alone);
  %TestChild::base_method = my %keep_hash = ('eliminate?' => 'no!');
  $TestChild::keep_me_too = (my $keep_me_too = "Me either!");
  @TestChild::keep_me_too = my @keep_me_too = qw(don't throw me out);
  %TestChild::keep_me_too = my %keep_me_too = (keep => 1);
  {
    my $rs = Test::Resub->new({
      name => 'TestChild::base_method',
      code => sub { 0 },
    });

    is( TestChild->base_method(), 0 );
  }

  is( TestChild->base_method(), 1 );

  {
    my $rs2 = Test::Resub->new({
      name => 'TestChild::base_method',
      code => sub { 18 },
    });
    my $rs3 = Test::Resub->new({
      name => 'TestChild::dont_exist',
      code => sub { 22 },
      create => 1,
    });

    # this next test is important; it used to break.
    is( TestChild->base_method(), 18 );
    is( TestChild->dont_exist(), 22 );
  }

  is( TestChild->base_method(), 1 );
  ok( not UNIVERSAL::can('TestChild', 'dont_exist') )
    or warn TestChild->dont_exist;

  is( eval '$TestChild::base_method', $keep_scalar );
  is_deeply( [eval '@TestChild::base_method'], \@keep_array );
  is_deeply( {eval '%TestChild::base_method'}, \%keep_hash );
  is( eval '$TestChild::keep_me_too', $keep_me_too );  # sanity check
  is_deeply( [eval '@TestChild::keep_me_too'], \@keep_me_too );
  is_deeply( {eval '%TestChild::keep_me_too'}, \%keep_me_too );

  # resub'd methods that don't specify otherwise cause failures if not called
  {
    my $rs = resub 'TestChild::base_method', sub { };
    like( stdout_of(sub{ undef $rs }), qr/not ok 1000/ );
  }

  # resub'd methods that specify 'required' cause failures if not called
  # this is also the default
  {
    my $rs = Test::Resub->new({
      name => 'TestChild::base_method',
      code => sub { },
    });
    my $output = stdout_of(sub { undef $rs });
    like( $output, qr/not ok 1000/, q{not ok 1000 if not called} );
    unlike( $output, qr/Class::Std/, q{don't have any Class::Std stuff in the longmess} );

    $rs = Test::Resub->new({
      name => 'TestChild::base_method',
      code => sub { },
      call => 'required',
    });
    like( stdout_of(sub{ undef $rs }), qr/not ok 1000/ );
  }

  # don't fail if we're required and called
  {
    my $rs = Test::Resub->new({
      name => 'TestChild::base_method',
      code => sub { },
    });
    TestChild->base_method();
  }

  # we don't fail if uncalled and we've declared that to be o.k.
  {
    my $rs = Test::Resub->new({
      name => 'TestChild::base_method',
      code => sub { },
      call => 'forbidden',
    });
  }

  # we DO fail if called when we don't expect to be
  {
    my $rs = Test::Resub->new({
      name => 'TestChild::base_method',
      code => sub { },
      call => 'forbidden',
    });
    TestChild->base_method();
    my $output = stdout_of(sub{ undef $rs });
    like( $output, qr/not ok 1000/ );
    unlike( $output, qr/Test::Resub/ );
    unlike( $output, qr/Class::Std/ );
  }

  # we don't fail if uncalled and we've declared calling optional
  {
    my $rs = Test::Resub->new({
      name => 'TestChild::base_method',
      code => sub { },
      call => 'optional',
    });
  }

  # we don't fail if called and we've declared calling optional
  {
    my $rs = Test::Resub->new({
      name => 'TestChild::base_method',
      code => sub { },
      call => 'optional',
    });
    TestChild->base_method();
  }
}

# A resubbed inherited method gets restored back to undef
{
  {
    package InheritBase;
    sub method { 10 }
  }
  {
    package Inherit;
    use base qw(InheritBase);
  }

  is( Inherit->method, 10 );
  {
    my $rs1 = Test::Resub->new({
      name => 'InheritBase::method',
      code => sub { 15 },
    });
    is( Inherit->method, 15 );
    {
      my $rs2 = Test::Resub->new({
        name => 'Inherit::method',
        code => sub { 20 },
      });
      is( Inherit->method, 20 );
    }
    is( Inherit->method, 15 );
  }
  is( Inherit->method, 10 );
}

# Resub objects don't get destroyed where we expect if we close over them
{
  {
    package CloseOverMe;
    sub close_over_me { 'close_over_me' }
  }

  {
    my $d;
    $d = Test::Resub->new({
      name => 'CloseOverMe::close_over_me',
      code => sub {
        my $count = $d->called;
        return 'CLOSE_OVER_ME';
      },
    });

    is( CloseOverMe::close_over_me(), 'CLOSE_OVER_ME' );
  }
  is( CloseOverMe::close_over_me(), 'CLOSE_OVER_ME' );
}

# When capturing args, don't save off the actual args, save off a copy. This
#  lets us capture args when resub'ing a method or function which uses pass-by-
#  reference to change its caller's values (like perl's built-in select)
{
  sub capture_test { 99 }
  my $rs = Test::Resub->new({
    name => 'main::eternalised',
    code => sub { $_[0] = 88 },
    capture => 1,
    create => 1,
  });

  my $arg = 'sagittiform';
  eternalised($arg);

  is_deeply( $rs->args, [['sagittiform']] );  # Not 88!
}

# Coderefs can be captured
{
  my $rs = Test::Resub->new({
    name => 'main::some_random_function',
    create => 1,
    capture => 1,
  });
  some_random_function(sub {});
  is( ref($rs->args->[0][0]), 'CODE', 'saved a coderef' );
}