Update Test-Harness to CPAN version 3.39
[perl.git] / cpan / Test-Harness / lib / TAP / Base.pm
1 package TAP::Base;
2
3 use strict;
4 use warnings;
5
6 use base 'TAP::Object';
7
8 =head1 NAME
9
10 TAP::Base - Base class that provides common functionality to L<TAP::Parser>
11 and L<TAP::Harness>
12
13 =head1 VERSION
14
15 Version 3.39
16
17 =cut
18
19 our $VERSION = '3.39';
20
21 use 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
42 C<TAP::Base> provides callback management.
43
44 =head1 METHODS
45
46 =head2 Class Methods
47
48 =cut
49
50 sub _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
68 Install a callback for a named event.
69
70 =cut
71
72 sub 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
89 sub _has_callbacks {
90     my $self = shift;
91     return keys %{ $self->{code_for} } != 0;
92 }
93
94 sub _callback_for {
95     my ( $self, $event ) = @_;
96     return $self->{code_for}{$event};
97 }
98
99 sub _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
110 Return the current time using Time::HiRes if available.
111
112 =cut
113
114 sub get_time { return time() }
115
116 =head3 C<time_is_hires>
117
118 Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
119
120 =cut
121
122 sub time_is_hires { return GOT_TIME_HIRES }
123
124 =head3 C<get_times>
125
126 Return array reference of the four-element list of CPU seconds,
127 as with L<perlfunc/times>.
128
129 =cut
130
131 sub get_times { return [ times() ] }
132
133 1;