/usr/share/perl5/TAP/Base.pm is in libtest-harness-perl 3.30-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | package TAP::Base;
use strict;
use warnings;
use base 'TAP::Object';
=head1 NAME
TAP::Base - Base class that provides common functionality to L<TAP::Parser>
and L<TAP::Harness>
=head1 VERSION
Version 3.30
=cut
our $VERSION = '3.30';
use constant GOT_TIME_HIRES => do {
eval 'use Time::HiRes qw(time);';
$@ ? 0 : 1;
};
=head1 SYNOPSIS
package TAP::Whatever;
use base 'TAP::Base';
# ... later ...
my $thing = TAP::Whatever->new();
$thing->callback( event => sub {
# do something interesting
} );
=head1 DESCRIPTION
C<TAP::Base> provides callback management.
=head1 METHODS
=head2 Class Methods
=cut
sub _initialize {
my ( $self, $arg_for, $ok_callback ) = @_;
my %ok_map = map { $_ => 1 } @$ok_callback;
$self->{ok_callbacks} = \%ok_map;
if ( my $cb = delete $arg_for->{callbacks} ) {
while ( my ( $event, $callback ) = each %$cb ) {
$self->callback( $event, $callback );
}
}
return $self;
}
=head3 C<callback>
Install a callback for a named event.
=cut
sub callback {
my ( $self, $event, $callback ) = @_;
my %ok_map = %{ $self->{ok_callbacks} };
$self->_croak('No callbacks may be installed')
unless %ok_map;
$self->_croak( "Callback $event is not supported. Valid callbacks are "
. join( ', ', sort keys %ok_map ) )
unless exists $ok_map{$event};
push @{ $self->{code_for}{$event} }, $callback;
return;
}
sub _has_callbacks {
my $self = shift;
return keys %{ $self->{code_for} } != 0;
}
sub _callback_for {
my ( $self, $event ) = @_;
return $self->{code_for}{$event};
}
sub _make_callback {
my $self = shift;
my $event = shift;
my $cb = $self->_callback_for($event);
return unless defined $cb;
return map { $_->(@_) } @$cb;
}
=head3 C<get_time>
Return the current time using Time::HiRes if available.
=cut
sub get_time { return time() }
=head3 C<time_is_hires>
Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available).
=cut
sub time_is_hires { return GOT_TIME_HIRES }
1;
|