Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
compat	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
data	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
lib	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
proverc	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
sample-tests	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
source_tests	[ DIR ]	drwxr-xr-x	2016-10-10 18:24
subclass_tests	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
aggregator.t	9.35 KB	-r--r--r--	2014-12-27 11:48
bailout.t	3.12 KB	-r--r--r--	2014-12-27 11:48
base.t	4.68 KB	-r--r--r--	2014-12-27 11:48
callbacks.t	2.57 KB	-r--r--r--	2014-12-27 11:48
console.t	1.06 KB	-r--r--r--	2014-12-27 11:48
errors.t	4.64 KB	-r--r--r--	2014-12-27 11:48
file.t	13.61 KB	-r--r--r--	2014-12-27 11:48
glob-to-regexp.t	988 B	-r--r--r--	2014-12-27 11:48
grammar.t	11.55 KB	-r--r--r--	2014-12-27 11:48
harness-bailout.t	1.19 KB	-r--r--r--	2014-12-27 11:48
harness-subclass.t	1.58 KB	-r--r--r--	2014-12-27 11:48
harness.t	28.38 KB	-r--r--r--	2014-12-27 11:48
iterator_factory.t	4.8 KB	-r--r--r--	2014-12-27 11:48
iterators.t	5.68 KB	-r--r--r--	2014-12-27 11:48
multiplexer.t	4.53 KB	-r--r--r--	2014-12-27 11:48
nested.t	860 B	-r--r--r--	2014-12-27 11:48
nofork-mux.t	119 B	-r--r--r--	2014-12-27 11:48
nofork.t	1.55 KB	-r--r--r--	2014-12-27 11:48
object.t	772 B	-r--r--r--	2014-12-27 11:48
parse.t	30.97 KB	-r--r--r--	2014-12-27 11:48
parser-config.t	731 B	-r--r--r--	2014-12-27 11:48
parser-subclass.t	2.2 KB	-r--r--r--	2014-12-27 11:48
perl5lib.t	1.13 KB	-r--r--r--	2014-12-27 11:48
premature-bailout.t	2.32 KB	-r--r--r--	2014-12-27 11:48
process.t	1015 B	-r--r--r--	2014-12-27 11:48
prove.t	47.6 KB	-r--r--r--	2014-12-27 11:49
proveenv.t	338 B	-r--r--r--	2014-12-27 11:49
proverc.t	472 B	-r--r--r--	2014-12-27 11:48
proverun.t	4.14 KB	-r--r--r--	2014-12-27 11:48
proveversion.t	763 B	-r--r--r--	2014-12-27 11:48
regression.t	111.62 KB	-r--r--r--	2014-12-27 11:48
results.t	7.68 KB	-r--r--r--	2014-12-27 11:48
scheduler.t	5.33 KB	-r--r--r--	2014-12-27 11:48
source.t	8.21 KB	-r--r--r--	2014-12-27 11:48
source_handler.t	12.32 KB	-r--r--r--	2014-12-27 11:48
spool.t	3.12 KB	-r--r--r--	2014-12-27 11:48
state.t	7.7 KB	-r--r--r--	2014-12-27 11:48
state_results.t	4.95 KB	-r--r--r--	2014-12-27 11:48
streams.t	6.33 KB	-r--r--r--	2014-12-27 11:48
taint.t	1.3 KB	-r--r--r--	2014-12-27 11:49
testargs.t	4.95 KB	-r--r--r--	2014-12-27 11:48
unicode.t	3.73 KB	-r--r--r--	2014-12-27 11:48
yamlish-output.t	2.44 KB	-r--r--r--	2014-12-27 11:48
yamlish-writer.t	7.17 KB	-r--r--r--	2014-12-27 11:48
yamlish.t	15.01 KB	-r--r--r--	2014-12-27 11:48

Rename

#!/usr/bin/perl -wT

use strict;
use warnings;
use lib 't/lib';

use Test::More tests => 38;

use TAP::Base;

{

# No callbacks allowed
    can_ok 'TAP::Base', 'new';
    my $base = TAP::Base->new();
    isa_ok $base, 'TAP::Base', 'object of correct type';
    for my $method (qw(callback _croak _callback_for _initialize)) {
        can_ok $base, $method;
    }

eval {
        $base->callback(
            some_event => sub {

# do nothing
            }
        );
    };
    like( $@, qr/No callbacks/, 'no callbacks allowed croaks OK' );
    my $cb = $base->_callback_for('some_event');
    ok( !$cb, 'no callback installed' );
}

{

# No callbacks allowed, constructor should croak
    eval {
        my $base = TAP::Base->new(
            {   callbacks => {
                    some_event => sub {

# do nothing
                      }
                }
            }
        );
    };
    like(
        $@, qr/No callbacks/,
        'no callbacks in constructor croaks OK'
    );
}

package CallbackOK;

use TAP::Base;
use base 'TAP::Base';

sub _initialize {
    my $self = shift;
    my $args = shift;
    $self->SUPER::_initialize( $args, [qw( nice_event other_event )] );
    return $self;
}

package main;
{
    my $base = CallbackOK->new();
    isa_ok $base, 'TAP::Base';

eval {
        $base->callback(
            some_event => sub {

# do nothing
            }
        );
    };
    like( $@, qr/Callback some_event/, 'illegal callback croaks OK' );

my ( $nice, $other ) = ( 0, 0 );

eval {
        $base->callback( other_event => sub { $other-- } );
        $base->callback( nice_event => sub { $nice++; return shift() . 'OK' }
        );
    };

ok( !$@, 'callbacks installed OK' );

my $nice_cbs = $base->_callback_for('nice_event');
    is( ref $nice_cbs,     'ARRAY', 'callbacks type ok' );
    is( scalar @$nice_cbs, 1,       'right number of callbacks' );
    my $nice_cb = $nice_cbs->[0];
    ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' );
    my $got = $nice_cb->('Is ');
    is( $got, 'Is OK', 'args passed to callback' );
    cmp_ok( $nice, '==', 1, 'callback calls the right sub' );

my $other_cbs = $base->_callback_for('other_event');
    is( ref $other_cbs,     'ARRAY', 'callbacks type ok' );
    is( scalar @$other_cbs, 1,       'right number of callbacks' );
    my $other_cb = $other_cbs->[0];
    ok( ref $other_cb eq 'CODE', 'callback for other_event returned' );
    $other_cb->();
    cmp_ok( $other, '==', -1, 'callback calls the right sub' );

my @got = $base->_make_callback( 'nice_event', 'I am ' );
    is( scalar @got, 1,         'right number of results' );
    is( $got[0],     'I am OK', 'callback via _make_callback works' );
}

{
    my ( $nice, $other ) = ( 0, 0 );

my $base = CallbackOK->new(
        {   callbacks => {
                nice_event => sub { $nice++ }
            }
        }
    );

isa_ok $base, 'TAP::Base', 'object creation with callback succeeds';

eval {
        $base->callback(
            some_event => sub {

# do nothing
            }
        );
    };
    like( $@, qr/Callback some_event/, 'illegal callback croaks OK' );

eval {
        $base->callback( other_event => sub { $other-- } );
    };

ok( !$@, 'callback installed OK' );

my $nice_cbs = $base->_callback_for('nice_event');
    is( ref $nice_cbs,     'ARRAY', 'callbacks type ok' );
    is( scalar @$nice_cbs, 1,       'right number of callbacks' );
    my $nice_cb = $nice_cbs->[0];
    ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' );
    $nice_cb->();
    cmp_ok( $nice, '==', 1, 'callback calls the right sub' );

# my @got = $base->_make_callback( 'nice_event', 'I am ' );
    # is ( scalar @got, 1, 'right number of results' );
    # is( $got[0], 'I am OK', 'callback via _make_callback works' );

my $status = undef;

# Stack another callback
    $base->callback( other_event => sub { $status = 'OK'; return 'Aye' } );

my $new_cbs = $base->_callback_for('other_event');
    is( ref $new_cbs,     'ARRAY', 'callbacks type ok' );
    is( scalar @$new_cbs, 2,       'right number of callbacks' );
    my $new_cb = $new_cbs->[1];
    ok( ref $new_cb eq 'CODE', 'callback for new_event returned' );
    my @got = $new_cb->();
    is( $status, 'OK', 'new callback called OK' );
}