| 1 | package TAP::Base; |
| 2 | |
| 3 | use strict; |
| 4 | use vars qw($VERSION @ISA); |
| 5 | |
| 6 | use TAP::Object; |
| 7 | |
| 8 | @ISA = qw(TAP::Object); |
| 9 | |
| 10 | =head1 NAME |
| 11 | |
| 12 | TAP::Base - Base class that provides common functionality to L<TAP::Parser> |
| 13 | and L<TAP::Harness> |
| 14 | |
| 15 | =head1 VERSION |
| 16 | |
| 17 | Version 3.16 |
| 18 | |
| 19 | =cut |
| 20 | |
| 21 | $VERSION = '3.16'; |
| 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 | |
| 55 | =cut |
| 56 | |
| 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 | |
| 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; |