view release on metacpan or  search on metacpan

lib/Astro/App/Satpass2/ParseTime/Code.pm  view on Meta::CPAN

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.057';

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__

=head1 NAME

Astro::App::Satpass2::ParseTime::Code - Astro::App::Satpass2 wrapper for custom code to parse time

=head1 SYNOPSIS

No user-serviceable parts inside.

=head1 DESCRIPTION

This class wraps code to parse a time string and return the epoch.

=head1 METHODS

This class supports the following public methods over and above those
documented in its superclass
L<Astro::App::Satpass2::ParseTime|Astro::App::Satpass2::ParseTime>.

=head2 code

 my $value = $pt->code();
 $pt->code( 'my_time_parser' );
 $pt->code( 'Some::Package::time_parser' );
 $pt->code( sub { ... } );
 $pt->code( sub { ... }, 'name_of_record' );

This method acts as both accessor and mutator for the C<code> attribute,