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