File Coverage

blib/lib/Astro/App/Satpass2/ParseTime/Code.pm

Criterion	Covered	Total	%
statement	41	55	74.5
branch	5	20	25.0
condition	2	2	100.0
subroutine	13	16	81.2
pod	7	7	100.0
total	68	100	68.0

package Astro::App::Satpass2::ParseTime::Code;

use 5.008;

use strict;
use warnings;

use parent qw{ Astro::App::Satpass2::ParseTime };

use Astro::App::Satpass2::Utils qw{ CODE_REF HASH_REF @CARP_NOT };

our $VERSION = '0.051';

use constant DUMMY	=> 'DUMMY';

# __arguments() is normally called as a subroutine, but it needs access
# to this namespace to figure out the options, so we just load this
# module and then call __arguments() as a static method.
require Astro::App::Satpass2;

sub attribute_names {
    my ( $self ) = @_;
    return ( $self->SUPER::attribute_names(), qw{ code } );
}

sub class_name_of_record {
    my ( $self ) = @_;
    my $code = $self->code();
    ref $code
	and $code = DUMMY;
    return $code;
}

sub code {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my ( $val, $name ) = @args;
	if ( my $ref = ref $val ) {
	    if ( CODE_REF eq $ref ) {
		defined $name
		    or $name = $val;
		return $self->_code_storage( $name, $val );
	    }
	} elsif ( $val =~ m/ ( .* ) :: ( .* ) /smx ) {
	    if ( my $code = $1->can( $2 ) ) {
		return $self->_code_storage( $val, $code );
	    }
	} elsif ( my $code = caller->can( $val ) ) {
	    return $self->_code_storage( $val, $code );
	}
	$self->wail(
	    'Code attribute must be a CODE ref or a subroutine name' );
    }
    return $self->_attr()->{code};
}

sub delegate {
    return __PACKAGE__;
}

sub parse_time_absolute {
    my ( $self, $string ) = @_;
    return $self->_call_code( parse => $string );
}

sub tz {
    my ( $self, @args ) = @_;
    @args
	and $self->_call_code( tz	=> $args[0] );
    return $self->SUPER::tz( @args );
}

sub use_perltime {
    my ( $self ) = @_;
    return $self->_call_code( 'use_perltime' );
}

sub _attr {
    my ( $self ) = @_;
    my $pkg = __PACKAGE__;
    return $self->{$pkg} ||= {};
}

sub _call_code {
    my ( $self, @args ) = @_;
    ( undef, @args ) = Astro::App::Satpass2->__arguments( @args );
    my $code = $self->_attr()->{_code}
	or $self->wail( 'No code specified' );
    return $code->( $self, @args );
}

sub _code_storage {
    my ( $self, $name, $code ) = @_;
    my $attr = $self->_attr();
    $attr->{code} = $name;
    $attr->{_code} = $code;
    return $self;
}

1;

__END__