1package TAP::Base;
2
3use strict;
4use warnings;
5
6use base 'TAP::Object';
7
8=head1 NAME
9
10TAP::Base - Base class that provides common functionality to L<TAP::Parser>
11and L<TAP::Harness>
12
13=head1 VERSION
14
15Version 3.42
16
17=cut
18
19our $VERSION = '3.42';
20
21use constant GOT_TIME_HIRES => do {
22    eval 'use Time::HiRes qw(time);';
23    $@ ? 0 : 1;
24};
25
26=head1 SYNOPSIS
27
28    package TAP::Whatever;
29
30    use base 'TAP::Base';
31
32    # ... later ...
33
34    my $thing = TAP::Whatever->new();
35
36    $thing->callback( event => sub {
37        # do something interesting
38    } );
39
40=head1 DESCRIPTION
41
42C<TAP::Base> provides callback management.
43
44=head1 METHODS
45
46=head2 Class Methods
47
48=cut
49
50sub _initialize {
51    my ( $self, $arg_for, $ok_callback ) = @_;
52
53    my %ok_map = map { $_ => 1 } @$ok_callback;
54
55    $self->{ok_callbacks} = \%ok_map;
56
57    if ( my $cb = delete $arg_for->{callbacks} ) {
58        while ( my ( $event, $callback ) = each %$cb ) {
59            $self->callback( $event, $callback );
60        }
61    }
62
63    return $self;
64}
65
66=head3 C<callback>
67
68Install a callback for a named event.
69
70=cut
71
72sub callback {
73    my ( $self, $event, $callback ) = @_;
74
75    my %ok_map = %{ $self->{ok_callbacks} };
76
77    $self->_croak('No callbacks may be installed')
78      unless %ok_map;
79
80    $self->_croak( "Callback $event is not supported. Valid callbacks are "
81          . join( ', ', sort keys %ok_map ) )
82      unless exists $ok_map{$event};
83
84    push @{ $self->{code_for}{$event} }, $callback;
85
86    return;
87}
88
89sub _has_callbacks {
90    my $self = shift;
91    return keys %{ $self->{code_for} } != 0;
92}
93
94sub _callback_for {
95    my ( $self, $event ) = @_;
96    return $self->{code_for}{$event};
97}
98
99sub _make_callback {
100    my $self  = shift;
101    my $event = shift;
102
103    my $cb = $self->_callback_for($event);
104    return unless defined $cb;
105    return map { $_->(@_) } @$cb;
106}
107
108=head3 C<get_time>
109
110Return the current time using Time::HiRes if available.
111
112=cut
113
114sub get_time { return time() }
115
116=head3 C<time_is_hires>
117
118Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
119
120=cut
121
122sub time_is_hires { return GOT_TIME_HIRES }
123
124=head3 C<get_times>
125
126Return array reference of the four-element list of CPU seconds,
127as with L<perlfunc/times>.
128
129=cut
130
131sub get_times { return [ times() ] }
132
1331;
134