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