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