Commit | Line | Data |
---|---|---|
b965d173 NC |
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 | ||
12 | Version 3.05 | |
13 | ||
14 | =cut | |
15 | ||
16 | $VERSION = '3.05'; | |
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; |