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.31
  16
  17 =cut
  18
  19 our $VERSION = '3.31';
  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 1;