package TAP::Base; use strict; use vars qw($VERSION @ISA); use TAP::Object; @ISA = qw(TAP::Object); =head1 NAME TAP::Base - Base class that provides common functionality to L and L =head1 VERSION Version 3.23 =cut $VERSION = '3.23'; use constant GOT_TIME_HIRES => do { eval 'use Time::HiRes qw(time);'; $@ ? 0 : 1; }; =head1 SYNOPSIS package TAP::Whatever; use TAP::Base; use vars qw($VERSION @ISA); @ISA = qw(TAP::Base); # ... later ... my $thing = TAP::Whatever->new(); $thing->callback( event => sub { # do something interesting } ); =head1 DESCRIPTION C 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 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 Return the current time using Time::HiRes if available. =cut sub get_time { return time() } =head3 C 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;