1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
#!/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 $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 $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' );
}
|
