local-lib5/lib/perl5/TAP/Base.pm

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