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