view release on metacpan or  search on metacpan

t/core/base.t  view on Meta::CPAN

$except = $@;
ok( $except, 'thrown frisbee' );
is( $except->type(), 'frisbee', 'a small plastic disc' );
is( $except->info(), 'threw frisbee', 'it spins, it hovers!' );

ok( ! $obj->try('cheese'), 'cheese fail' );
$except = $obj->reason;
is( $except->type, 'cheese', 'cheese thrown' );
is( $except->info, 'Your Camembert is too runny', $except->info );


#-----------------------------------------------------------------------
# and the same via T::Class
#-----------------------------------------------------------------------

package Another::Thrower;
use Badger::Class
    version => 3.00,
    base    => 'Badger::Base',
    throws  => 'frisbee';

package Another::SubClass;
use Badger::Class
    base    => 'Another::Thrower',
    version => 3.00;

package main;

is( Another::Thrower->throws, 'frisbee', 'Another::Thrower throws frisbee' );
is( Another::SubClass->throws, 'frisbee', 'Another::SubClass throws frisbee' );


#------------------------------------------------------------------------
# test the throw() method in throwing and re-throwing exceptions
#------------------------------------------------------------------------

my $base = Badger::Base->new();
my $ee = Badger::Exception->new( type => 'engine',
                                   info => 'warp drive offline' );

eval { $base->throw( engine => $ee ) };
is( "$@", 'engine error - warp drive offline', 'warp drive is offline' );

eval { $base->throw( propulsion => $ee ) };
is( "$@", 'propulsion error - engine error - warp drive offline',
    'propulsion system is NFG' );



#------------------------------------------------------------------------
# error_msg()
#------------------------------------------------------------------------

package My::Base;
use base qw( Badger::Base );

our $MESSAGES = {
    no_pony    => 'Missing pony! (got "%s")',
    no_buffy   => 'Missing Buffy! (got %s and %s)',
    one_louder => '%1$s. Exactly. %2$s louder',
    not_ten    => "Well, it's %2\$s louder, isn't it? It's not %1\$s.",
};

package main;

$base = My::Base->new();

eval { $base->error_msg( no_pony => 'donkey' ) };
ok( $@, 'pony error' );
is( $base->error(), 'Missing pony! (got "donkey")', 'no pony!' );

eval { $base->error_msg( no_buffy => 'Angel', 'Willow' ) };
ok( $@, 'Buffy error' );
is( $base->error(), 'Missing Buffy! (got Angel and Willow)', 'no Buffy!' );

eval { $base->error_msg( one_louder => 'Eleven', 'One' ) };
ok( $@, 'One louder error' );
is( $base->error(), 'Eleven. Exactly. One louder', 'Eleven is one louder' );

eval { $base->error_msg( not_ten => 'ten', 'one' ) };
ok( $@, 'Not ten error' );
is( $base->error(), "Well, it's one louder, isn't it? It's not ten.", "It's not ten" );


#------------------------------------------------------------------------
# error_msg() with subclass
#------------------------------------------------------------------------

package My::Sub;
use base qw( My::Base );

our $MESSAGES = {
    no_buffy => 'Buffy still missing! (%s is here)',
    no_angel => 'Angel is slain! (by %s)',
};

package main;

my $sub = My::Sub->new();

eval { $sub->error_msg( no_pony => 'ass' ) };
ok( $@,  'ass error' );
is( $sub->error(), 'Missing pony! (got "ass")', 'still no pony!' );

eval { $sub->error_msg( no_buffy => 'Giles' ) };
ok( $@, 'Giles error' );
is( $sub->error(), 'Buffy still missing! (Giles is here)', 'still no Buffy!' );

eval { $sub->error_msg( no_angel => 'Buffy' ) };
ok( $@, 'Angel error' );
is( $sub->error(), 'Angel is slain! (by Buffy)', 'Angle is slain!' );


#------------------------------------------------------------------------
# test the on_error() method
#------------------------------------------------------------------------

package My::OnError;
use base 'Badger::Base';

My::OnError->on_error(\&complain);

our @COMPLAINT;

sub complain {
    push(@COMPLAINT, @_);
    return @_;
}

package main;

my $complainer = My::OnError->new();
eval { $complainer->error("it's raining") };
ok( $@, "it's raining" );
is( $My::OnError::COMPLAINT[0], "it's raining", "raining error reported" );
is( $@->type, "my.onerror", "raining error type" );

$complainer = My::OnError->new( throws => 'umbrella' );
eval { $complainer->error("it's pouring") };
ok( $@, "it's pouring" );
is( $My::OnError::COMPLAINT[1], "it's pouring", "pouring error reported" );
is( $@->type, "umbrella", "umbrella error type" );
is( $@->info, "it's pouring", "umbrella error info" );


#-----------------------------------------------------------------------
# test the not_implemented() and todo() methods
#-----------------------------------------------------------------------

our ($foo_line, $bar_line, $wam_line, $bam_line) = (0) x 4;

package My::Incomplete;
use base 'Badger::Base';

sub foo {
    $main::foo_line = __LINE__ + 1;
    shift->not_implemented;
}

sub bar {
    $main::bar_line = __LINE__ + 1;
    shift->not_implemented('first test case');
}

sub wam {
    $main::wam_line = __LINE__ + 1;
    shift->todo;
}

sub bam {
    $main::bam_line = __LINE__ + 1;
    shift->todo('second test case');
}

package main;
my $incomplete = My::Incomplete->new();

eval { $incomplete->foo };
like( $@,
    qr/my.incomplete error - foo\(\) is not implemented .*?base.t at line $foo_line/,
    'foo not implemented' );

eval { $incomplete->bar };
like( $@,
    qr/my.incomplete error - bar\(\) first test case is not implemented .*?base.t at line $bar_line/,
    'bar not implemented' );

eval { $incomplete->wam };
like( $@,
      qr/my\.incomplete error - wam\(\) is TODO for My::Incomplete in .*? at line $wam_line/,
      'wam todo' );

eval { $incomplete->bam };
like( $@,
      qr/my\.incomplete error - bam\(\) second test case is TODO for My::Incomplete in .*? at line $bam_line/,
      'bam not implemented' );


#-----------------------------------------------------------------------
# test decline() method an friends
#-----------------------------------------------------------------------

package Badger::Test::Decliner;
use base 'Badger::Base';

sub barf {
    shift->error("failed in a miserable way");
}

sub yelp {
    shift->decline("decline in a wishy-washy way");
}

package main;

my $dec = Badger::Test::Decliner->new;
ok( ! $dec->yelp, 'yelp declined' );
is( $dec->reason, 'decline in a wishy-washy way', 'got reason' );
ok( $dec->declined, 'declined flag set' );

# try() puts an eval { ... } wrapper around a methods
eval { $dec->barf };
is( $dec->reason, 'failed in a miserable way', 'barfed error' );
ok( ! $dec->declined, 'declined flag cleared' );



#-----------------------------------------------------------------------
# test try/catch
#-----------------------------------------------------------------------

package Danger::Mouse;
use base 'Badger::Base';

sub hurl {
    shift->error("HURLING: ", @_);
}

sub missing {
    shift->not_implemented;
}

sub not_done {
    my $self = shift;
    my $item = shift || $self->todo;
    $self->todo('with argument');
}

sub sensitive {
    return wantarray
        ? ('called', 'in', 'list', 'context')
        : 'called in scalar context';
}

package main;
my $mouse = Danger::Mouse->new();
ok( ! eval { $mouse->hurl('cheese') }, 'eval failed' );
is( $@, 'danger.mouse error - HURLING: cheese', 'danger mouse error' );

ok( ! $mouse->try( hurl => 'cheese' ), 'try failed' );
is( $mouse->reason, 'danger.mouse error - HURLING: cheese', 'danger mouse error' );

ok( ! $mouse->try('missing'), 'try missing' );
like( $mouse->reason, qr/danger\.mouse error - missing\(\) is not implemented for Danger::Mouse/, 'danger mouse missing' );

ok( ! $mouse->try('not_done'), 'not_done' );
like( $mouse->reason, qr/danger\.mouse error - not_done\(\) is TODO for Danger::Mouse/, 'danger mouse todo' );

ok( ! $mouse->try( not_done => 10 ), 'not_done with arg' );
like( $mouse->reason, qr/danger\.mouse error - not_done\(\) with argument is TODO for Danger::Mouse/, 'danger mouse todo' );

my $result = $mouse->try('sensitive');
is( $result, 'called in scalar context', 'try() preserves scalar context' );

my @result = $mouse->try('sensitive');
is( join(', ', @result), 'called, in, list, context', 'try() preserves list context' );


#-----------------------------------------------------------------------
# test try nomad
#-----------------------------------------------------------------------

ok( ! $mouse->try->hurl('cheese'), 'try trial failed' );
is( $mouse->reason, 'danger.mouse error - HURLING: cheese', 'danger mouse trial error' );

ok( ! $mouse->try->missing, 'try trial missing' );
like( $mouse->reason, qr/danger\.mouse error - missing\(\) is not implemented for Danger::Mouse/, 'danger mouse trial missing' );

ok( ! $mouse->try->not_done, 'trial not_done' );
like( $mouse->reason, qr/danger\.mouse error - not_done\(\) is TODO for Danger::Mouse/, 'danger mouse trial todo' );

ok( ! $mouse->try->not_done(10), 'not_done trial with arg' );
like( $mouse->reason, qr/danger\.mouse error - not_done\(\) with argument is TODO for Danger::Mouse/, 'danger mouse trial todo' );

$result = $mouse->try->sensitive;
is( $result, 'called in scalar context', 'try-> preserves scalar context' );

@result = $mouse->try->sensitive;
is( join(', ', @result), 'called, in, list, context', 'try-> preserves list context' );



#-----------------------------------------------------------------------
# test fatal
#-----------------------------------------------------------------------

eval { $mouse->fatal('sun exploded') };
like( $@, qr/Fatal badger error: sun exploded/, 'fatal error' );

package Your::Badger::Module;
use base 'Badger::Base';
our $THROWS = 'YBM';

package main;
eval { Your::Badger::Module->error('Fail!') };
is( $@, 'YBM error - Fail!', 'YBM Fail!' );

Your::Badger::Module->throws('BadgerMod');
eval { Your::Badger::Module->error('Fail!') };
is( $@, 'BadgerMod error - Fail!', 'BadgerMod Fail!' );


#-----------------------------------------------------------------------------
# test messages
#-----------------------------------------------------------------------------

package Badger::Testing::Messages;
use base 'Badger::Base';

sub init {
    my ($self, $config) = @_;
    $self->{ messages } = $config->{ messages };
    return $self;
}

package main;

my $btm = Badger::Testing::Messages->new(
    messages => {
        hello => "Hello %s!",
    }
);

is( $btm->message( hello => 'World' ), 'Hello World!', 'got custom message' );

__END__

# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#