lib/TAP/Base.pm

   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;