use strict;
use warnings;

use Test::More;
use Test::Deep;
use Storable (qw( dclone ));

use Error::Base;
my $QRTRUE       = $Error::Base::QRTRUE    ;
my $QRFALSE      = $Error::Base::QRFALSE   ;

#----------------------------------------------------------------------------#

my $tc          ;
my $base        = 'Error-Base: acc-put: ';
my $diag        = $base;
my @rv          ;
my $got         ;
my $self        ;
my $want        ;

#----------------------------------------------------------------------------#
# SKIP OPTIONAL TEST

# Load non-core modules conditionally
BEGIN{
    my $diag   = 'load-test-trap';
    eval{
        require Test::Trap;         # Block eval on steroids
        Test::Trap->import (qw/ :default /);
    };
    my $module_loaded    = !$@;          # loaded if no error
                                            #   must be package variable
                                            #       to escape BEGIN block
    if ( $module_loaded ) {
        note($diag);
    }
    else {
        diag('Test::Trap required to execute this test script; skipping.');
        pass;
        done_testing(1);
        exit 0;
    };

}; ## BEGIN

#----------------------------------------------------------------------------#

my @td  = (
    
    {
        -case   => 'null',
        -code   => sub {
                    my $err = Error::Base->cuss( );
                    my $old = dclone($err);
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_base-null',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $err->put_base(  );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_base-foo',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $old->{-base} = 'foo';
                    $err->put_base( 'foo' );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_mesg-null',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $err->put_mesg(  );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_mesg-foo',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $old->{-mesg} = 'foo';
                    $err->put_mesg( 'foo' );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_mesg-foo-aryref',
        -code   => sub {
                    my $err = Error::Base->new( -mesg => 'foo' );
                    my $old = dclone($err);
                    $old->{-mesg} = [ 1, 2, 3];
                    $err->put_mesg( [ 1, 2, 3] );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_mesg-aryref-bar',
        -code   => sub {
                    my $err = Error::Base->new( -mesg => [ 1, 2, 3] );
                    my $old = dclone($err);
                    $old->{-mesg} = 'bar';
                    $err->put_mesg( 'bar' );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_quiet-null',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $err->put_quiet(  );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_quiet-0-1',
        -code   => sub {
                    my $err = Error::Base->new( -quiet => 0 );
                    my $old = dclone($err);
                    $old->{-quiet} = 1;
                    $err->put_quiet( 1 );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_quiet-1-0',
        -code   => sub {
                    my $err = Error::Base->new( -quiet => 1 );
                    my $old = dclone($err);
                    $old->{-quiet} = 0;
                    $err->put_quiet( 0 );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_nest-null',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $err->put_nest(  );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_nest-0-1',
        -code   => sub {
                    my $err = Error::Base->new( -nest => 0 );
                    my $old = dclone($err);
                    $old->{-nest} = 1;
                    $old->{-top} = $old->{-nest} + $Error::Base::BASETOP;
                    $err->put_nest( 1 );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'put_nest-1-0',
        -code   => sub {
                    my $err = Error::Base->new( -nest => 1 );
                    my $old = dclone($err);
                    $old->{-nest} = 0;
                    $old->{-top} = $old->{-nest} + $Error::Base::BASETOP;
                    $err->put_nest( 0 );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'pre-int-null',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $err->put_prepend(  );
                    $err->put_indent(  );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'pre-int-AAB',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $old->{-prepend} = 'AA';
                    $err->put_prepend( 'AA' );
                    $old->{-indent} = 'B';
                    $err->put_indent( 'B' );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'pre-int-AA-null',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $old->{-prepend} = 'AA';
                    $err->put_prepend( 'AA' );
                    $old->{-indent} = 'A ';
                    # $err->put_indent( 'B' );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'pre-int-null-B',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $old->{-prepend} = 'B';
                    # $err->put_prepend( 'AA' );
                    $old->{-indent} = 'B';
                    $err->put_indent( 'B' );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'pre-int-AA-empty',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $old->{-prepend} = 'AA';
                    $err->put_prepend( 'AA' );
                    $old->{-indent} = q{};
                    $err->put_indent( q{} );
                    return ( $err   => $old );
                },
    },
    
    {
        -case   => 'pre-int-empty-B',
        -code   => sub {
                    my $err = Error::Base->new( );
                    my $old = dclone($err);
                    $old->{-prepend} = q{};
                    $err->put_prepend( q{} );
                    $old->{-indent} = 'B';
                    $err->put_indent( 'B' );
                    return ( $err   => $old );
                },
    },
    
    { -end    => 1 },   # # # # # # # END TESTING HERE # # # # # # # # # 
    
); ## td

#----------------------------------------------------------------------------#

# Extra-verbose dump optional for test script debug.
my $Verbose     = 0;
#~    $Verbose++;

for (@td) {
    last if     $_->{-end};
#~     next unless $_->{-do};
    $tc++;
    my $case        = $base . $_->{-case};   
    note( "---- $case" );
    subtest $case => sub { exck($_) };
}; ## for
    
sub exck {
    my $t           = shift;
    my $code        = $t->{-code};
    my $leaveby     = $t->{-lby};
    my $want        = $t->{-want};
    my $cranky      = $t->{-cranky};
    my $xtra        = $t->{-xtra};
    
    $diag           = 'execute';
    @rv             = trap{ 
        &$code;
    };
    pass( $diag );          # test didn't blow up
    
#~     diag('#=======#');
#~     diag(explain(\@rv));
#~     diag('#=======#');


        $diag           = 'should-return';
        $trap->did_return   ( $diag );
        $diag           = 'return-compare';
        $got            = $trap->return(0);
        $want           = $trap->return(1);
        cmp_deeply          ( $got, $want, $diag );
        $diag           = 'return-quietly';
        $trap->quiet        ( $diag ) unless $cranky;
    
#~     if    ( $leaveby eq 'die' and defined $want ) {
#~         $diag           = 'should-die';
#~         $trap->did_die      ( $diag );
#~         $diag           = 'die-like';
#~         $trap->die_like     ( $want, $diag );       # fail if !die
#~         $diag           = 'die-quietly';
#~         $trap->quiet        ( $diag ) unless $cranky;
#~     }
#~     elsif ( $leaveby eq 'return-scalar' and defined $want ) {
#~         $diag           = 'should-return';
#~         $trap->did_return   ( $diag );
#~         $diag           = 'return-like';
#~         $trap->return_like  ( 0, $want, $diag );    # always returns aryref
#~         $diag           = 'return-quietly';
#~         $trap->quiet        ( $diag ) unless $cranky;
#~     } 
#~     elsif ( $leaveby eq 'return-object' and defined $want ) {
#~         $diag           = 'should-return';
#~         $trap->did_return   ( $diag );
#~         $diag           = 'return-object';
#~         $trap->return_isa_ok ( 0, 'Error::Base', $diag);
#~         $diag           = 'return-like';
#~         $self           = $rv[0];
#~         $got            = join qq{\n}, explain( $self );
#~         like( $got, $want, $diag );
#~         $diag           = 'return-quietly';
#~         $trap->quiet        ( $diag ) unless $cranky;
#~     }
#~     elsif ( $leaveby eq 'warn' and defined $want ) {
#~         
#~         $diag           = 'should-return';
#~         $trap->did_return   ( $diag );
#~         $diag           = 'warning-like';
#~         $trap->warn_like  ( 0, $want, $diag );      # always returns aryref
#~         $diag           = 'no-stdout';
#~         ok( !$trap->stdout, $diag );
#~     } 
#~     else {
#~         fail('Test script failure: unimplemented gimmick.');
#~     };
    
#~     # Extra-verbose dump optional for test script debug.
#~     if ( $Verbose >= 1 ) {
#~         note( ''                            );
#~         $trap->diag_all;
#~         note( ''                            );
#~     };
#~     
}; ## subtest

#----------------------------------------------------------------------------#

END {
    # Extra-verbose dump optional for test script debug.
    if ( $Verbose >= 1 ) {
        note( ''                            );
        $trap->diag_all;
        note( ''                            );
    };
    
    done_testing($tc);
    exit 0;
}

#============================================================================#

sub words {                         # sloppy match these strings
    my @words   = @_;
    my $regex   = q{};
    
    for (@words) {
        $_      = lc $_;
        $regex  = $regex . $_ . '.*';
    };
    
    return qr/$regex/is;
};