File Coverage

blib/lib/Astro/App/Satpass2/Format.pm

Criterion	Covered	Total	%
statement	103	106	97.1
branch	41	58	70.6
condition	10	15	66.6
subroutine	19	20	95.0
pod	9	9	100.0
total	182	208	87.5

package Astro::App::Satpass2::Format;

use strict;
use warnings;

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

use Clone ();
use Astro::App::Satpass2::FormatTime;
use Astro::App::Satpass2::Utils qw{
    instance
    load_package __parse_class_and_args
    CODE_REF
    @CARP_NOT
};
use Scalar::Util 1.26 qw{ weaken };

our $VERSION = '0.051_01';

use constant DEFAULT_LOCAL_COORD => 'azel_rng';

# Note that the fact that new() works when called from
# My::Module::Test::App is unsupported and undocumented, and
# the functionality may be revoked or changed without warning.

my %static = (
    desired_equinox_dynamical => 0,
    gmt		=> 0,
    local_coord	=> DEFAULT_LOCAL_COORD,
    provider	=> 'Astro::App::Satpass2',
    value_formatter	=> 'Astro::App::Satpass2::FormatValue',
);

sub new {
    my ( $class, %args ) = @_;
    ref $class and $class = ref $class;

    my $self = { %static };
    bless $self, $class;

    $self->warner( delete $args{warner} );

    $class eq __PACKAGE__
	and 'My::Module::Test::App' ne caller
	and $self->wail( __PACKAGE__,
	    ' may not be instantiated. Use a subclass' );

    $self->{parent} = delete $args{parent};

    # FIXME the below is verbatim from
    # Astro::App::Satpass2::Macro->init(), ca. line 63.
    defined $self->{parent}
	or $self->wail( q{Attribute 'parent' is required} );
    instance( $self->{parent}, 'Astro::App::Satpass2' )
	or $self->wail( q{Attribute 'parent' must be an Astro::App::Satpass2} );
    weaken( $self->{parent} );

    exists $args{tz} or $args{tz} = $ENV{TZ};

    $self->time_formatter( delete $args{time_formatter} );
    $self->time_formatter()->warner( $self->warner() );

    $args{date_format}
	or $self->date_format( $self->time_formatter()->DATE_FORMAT() );
    $args{time_format}
	or $self->time_format( $self->time_formatter()->TIME_FORMAT() );
    exists $args{round_time}
	or $self->round_time( $self->time_formatter()->ROUND_TIME() );

    $self->value_formatter( delete $args{value_formatter} ||
	$static{value_formatter} );
    $self->value_formatter()->warner( $self->warner() );

    $self->init( %args );

    return $self;
}

sub round_time {
    my ( $self, @arg ) = @_;
    if ( @arg ) {
	$self->time_formatter()->round_time( @arg );
	$self->{round_time} = $arg[0];
	return $self;
    } else {
	return $self->time_formatter()->round_time();
    }
}

sub attribute_names {
    my ( $self ) = @_;
    return ( $self->SUPER::attribute_names(),
	qw{ date_format desired_equinox_dynamical gmt
	    local_coord parent provider round_time
	    time_format time_formatter tz
	    value_formatter
	} );
}

{

    my %original_value = (
	date_format	=> sub {
	    return $_[0]->time_formatter()->DATE_FORMAT()
	},
	round_time	=> sub {
	    return $_[0]->time_formatter()->ROUND_TIME()
	},
	time_format	=> sub {
	    return $_[0]->time_formatter()->TIME_FORMAT()
	},
    );

    foreach my $key ( keys %static ) {
	$original_value{ $key } ||= sub {
	    return $static{$key};
	};
    }

    my %not_part_of_config = map { $_ => 1 } qw{ parent warner };

    sub config {
	my ( $self, %args ) = @_;
	my @data;

	foreach my $name ( $self->attribute_names() ) {

	    $not_part_of_config{$name}
		and next;

	    my $val = $self->$name();
	    $args{decode}
		and ref $val
		and $val = $self->decode( $name );

	    no warnings qw{ uninitialized };

	    next if $args{changes} &&
		$val eq ( $original_value{$name} ?
		    $original_value{$name}->( $self, $name ) :
		    undef );

	    push @data, [ $name, $val ];
	}

	return wantarray ? @data : \@data;
    }

}

{

    my %decoder = (
	desired_equinox_dynamical => sub {
	    my ( $self, $method, @args ) = @_;
	    my $rslt = $self->$method( @args );
	    @args and return $rslt;
	    $rslt or return $rslt;
	    return $self->{time_formatter}->format_datetime(
		$self->{time_formatter}->ISO_8601_FORMAT(),
		$rslt, 1 );
	},
	time_formatter => sub {
	    my ( $self, $method, @args ) = @_;
	    my $rslt = $self->$method( @args );
	    @args and return $rslt;
#	    return ref $rslt || $rslt;
	    return $rslt->class_name_of_record();
	},
    );
    $decoder{value_formatter} = $decoder{time_formatter};

    sub decode {
	my ( $self, $method, @args ) = @_;
	my $dcdr = $decoder{$method}
	    or return $self->$method( @args );
	my $type = ref $dcdr
	    or $self->weep( "Decoder for $method is scalar" );
	CODE_REF eq $type
	    or $self->weep(
		"Decoder for $method is $type reference" );
	return $dcdr->( $self, $method, @args );
    }
}

sub format : method {	## no critic (ProhibitBuiltInHomonyms,RequireFinalReturn)
    my ( $self ) = @_;
    # ->weep() throws an exception.
    $self->weep(
	'The format() method must be overridden' );
}

sub local_coord {
    my ( $self, @args ) = @_;
    if ( @args ) {
	defined $args[0] or $args[0] = DEFAULT_LOCAL_COORD;
	$self->{local_coord} = $args[0];
	return $self;
    } else {
	return $self->{local_coord};
    }
}

foreach my $attribute (
    [ time_formatter => 'Astro::App::Satpass2::FormatTime',
	'Astro::App::Satpass2::FormatTime', sub {
	    my ( $self, $old, $new ) = @_;
	    if ( $old->FORMAT_TYPE() ne $new->FORMAT_TYPE() ) {
		$self->date_format( $new->DATE_FORMAT() );
		$self->time_format( $new->TIME_FORMAT() );
	    }
	    return;
	},
    ],
    [ value_formatter => 'Astro::App::Satpass2::FormatValue',
	'Astro::App::Satpass2', sub {}	],
) {
    my ( $name, $class, $prefix, $pre_set ) = @{ $attribute };
    __PACKAGE__->can( $name )
	and next;
    no strict qw{ refs };
    *$name = sub {
	my ( $self, @args ) = @_;
	if ( @args ) {
	    my $fmtr = shift @args;
	    defined $fmtr and $fmtr ne ''
		or $fmtr = $class;
	    my $old = $self->{$name};
	    ref $fmtr or do {
		my ( $pkg, @fmtr_arg ) = (
		    $self->__parse_class_and_args( $fmtr ), @args );
		my $fatal = $self->parent()->get( 'error_out' ) ?
		    'wail' : 'whinge';
		my $class = $self->load_package(
		    { fatal => $fatal }, $pkg, $prefix )
		    or return $self;
		$fmtr = $class->new(
		    warner	=> scalar $self->warner(),
		    @fmtr_arg,
		);
		ref $old
		    and $old->copy( $fmtr, @fmtr_arg );
	    };
	    ref $old
		and $pre_set->( $self, $old, $fmtr );
	    $self->{$name} = $fmtr;
	    return $self;
	} else {
	    return $self->{$name};
	}
    };
}

sub tz {
    my ( $self, @args ) = @_;
    if ( @args ) {
	$self->{tz} = $args[0];
	return $self;
    } else {
	return $self->{tz};
    }
}

sub warner {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my $warner = $args[0];
	if ( my $fmtr = $self->time_formatter() ) {
	    $fmtr->warner( $warner );
	}
    }
    return $self->SUPER::warner( @args );
}

__PACKAGE__->create_attribute_methods();

1;

=head1 NAME

Astro::App::Satpass2::Format - Format Astro::App::Satpass2 output

=head1 SYNOPSIS

No user-serviceable parts inside.

=head1 DETAILS

This formatter is an abstract class providing output formatting
functionality for L. It
should not be instantiated directly.

This class is a subclass of
L.

=head1 METHODS

This class supports the following public methods:

=head2 Instantiator

=head3 new

 $fmt = Astro::Satpass::Format::Some_Subclass_Thereof->new(...);

This method instantiates a formatter. It may not be called on this
class, but may be called on a subclass. If you wish to modify the
default attribute values you can pass the relevant name/value pairs as
arguments. For example:

 $fmt = Astro::Satpass::Format::Some_Subclass_Thereof->new(
     date_format => '%Y%m%d',
     time_format => 'T%H:%M:%S',
 );

=head2 Accessors and Mutators

=head3 date_format

 print 'Date format: ', $fmt->date_format(), "\n";
 $fmt->date_format( '%d-%b-%Y' );

The C attribute is maintained on behalf of subclasses of
this class, which B (but need not) use it to format dates. This
method B be overridden by subclasses, but the override B call
C, and return values consistent with the following
description.

This method acts as both accessor and mutator for the C
attribute. Without arguments it is an accessor, returning the current
value of the C attribute.

If passed an argument, that argument becomes the new value of
C, and the object itself is returned so that calls may be
chained.

The interpretation of the argument is up to the subclass, but
it is recommended for sanity's sake that the subclasses interpret this
value as a C format producing a date (but not a time),
if they use this attribute at all.

The default value, if used by the subclass at all, should produce a
numeric date of the form year-month-day. For formatters that use
C, this will be '%Y-%m-%d'.

B that this value will be reset to its default if the
L attribute is modified and the new
object has a different C than the old one.

=head3 desired_equinox_dynamical

 print 'Desired equinox: ',
     strftime( '%d-%b-%Y %H:%M:%S dynamical',
         gmtime $fmt->desired_equinox_dynamical() ),
     "\n";
 $fmt->desired_equinox_dynamical(
     timegm( 0, 0, 12, 1, 0, 100 ) );	# J2000.0

The C attribute is maintained on behalf of
subclasses of this class, which B (but need not) use it to
calculate inertial coordinates. If the subclass does not make use of
this attribute it B document the fact.

This method B be overridden by subclasses, but the override B
call C, and return values consistent
with the following description.

This method acts as both accessor and mutator for the
C attribute. Without arguments it is an
accessor, returning the current value of the
C attribute.

If passed an argument, that argument becomes the new value of
C, and the object itself is returned so that
calls may be chained.

The interpretation of the argument is up to the subclass, but it is
recommended for sanity's sake that the subclasses interpret this value
as a dynamical time (even though it is represented as a normal Perl
time) if they use this attribute at all. If the value is true (in the
Perl sense) inertial coordinates should be precessed to the dynamical
time represented by this attribute. If the value is false (in the Perl
sense) they should not be precessed.

=head3 gmt

 print 'Time zone: ', ( $fmt->gmt() ? 'GMT' : 'local' ), "\n";
 $fmt->gmt( 1 );

The C attribute is maintained on behalf of subclasses of this
class, which B (but need not) use it to decide whether to display
dates in GMT or in the local time zone. This method B be overridden
by subclasses, but the override B call C, and return
values consistent with the following description.

This method acts as both accessor and mutator for the C
attribute. Without arguments it is an accessor, returning the current
value of the C attribute. This value is to be interpreted as a
Boolean under the usual Perl rules.

If passed an argument, that argument becomes the new value of
C, and the object itself is returned so that calls may be
chained.

=head3 local_coord

 print 'Local coord: ', $fmt->local_coord(), "\n";
 $fmt->local_coord( 'azel_rng' );

The C attribute is maintained on behalf of subclasses of
this class, which B (but need not) use it to determine what
coordinates to display. This method B be overridden by subclasses,
but the override B call C, and return values
consistent with the following description.

This method acts as both accessor and mutator for the C
attribute. Without arguments it is an accessor, returning the current
value of the C attribute.

If passed an argument, that argument becomes the new value of
C, and the object itself is returned so that calls may be
chained. The interpretation of the argument is up to the subclass, but
it is recommended for sanity's sake that the subclasses support at least
the following values if they use this attribute at all:

 az_rng --------- azimuth and range;
 azel ----------- azimuth and elevation;
 azel_rng ------- azimuth, elevation and range;
 equatorial ----- right ascension and declination;
 equatorial_rng - right ascension, declination and range.

It is further recommended that C be the default.

=head3 provider

 print 'Provider: ', $fmt->provider(), "\n";
 $fmt->provider( 'Astro::App::Satpass2 v' . Astro::App::Satpass2->VERSION() );

The C attribute is maintained on behalf of subclasses of this
class, which B (but need not) use it to identify the provider of
the data for informational purposes. This method B be overridden by
subclasses, but the override B call C, and return
values consistent with the following description.

This method acts as both accessor and mutator for the C
attribute. Without arguments it is an accessor, returning the current
value of the C attribute.

If passed an argument, that argument becomes the new value of
C, and the object itself is returned so that calls may be
chained.

=head3 round_time

 print 'Time rounded to: ', $fmt->round_time(), " seconds\n";
 $fmt->round_time( 60 );

The C attribute is maintained on behalf of subclasses of
this class, which B (but need not) use it to format times. This
method B be overridden by subclasses, but the override B call
C, and return values consistent with the following
description.

This method acts as both accessor and mutator for the C
attribute. Without arguments it is an accessor, returning the current
value of the C attribute.

If passed an argument, that argument becomes the new value of
C, and the object itself is returned so that calls may be
chained.

The interpretation of the argument is up to the subclass, but
it is recommended for sanity's sake that the subclasses interpret this
value in the same way as
L
if they use this attribute at all.

=head3 time_format

 print 'Time format: ', $fmt->time_format(), "\n";
 $fmt->time_format( '%H:%M:%S' );

The C attribute is maintained on behalf of subclasses of
this class, which B (but need not) use it to format times. This
method B be overridden by subclasses, but the override B call
C, and return values consistent with the following
description.

This method acts as both accessor and mutator for the C
attribute. Without arguments it is an accessor, returning the current
value of the C attribute.

If passed an argument, that argument becomes the new value of
C, and the object itself is returned so that calls may be
chained.

The interpretation of the argument is up to the subclass, but
it is recommended for sanity's sake that the subclasses interpret this
value as a C format producing a time (but not a date),
if they use this attribute at all.

The default value, if used by the subclass at all, should produce a
numeric time of the form hour:minute:second. For formatters that use
C, this will be '%H:%M:%S'.

B that this value will be reset to its default if the
L attribute is modified and the new
object has a different C than the old one.

=head3 time_formatter

This method acts as both accessor and mutator for the object used to
format times. It will probably be a
L
object of some sort, and will certainly conform to that interface. When
setting the value, you can specify either a class name or an object. If
a class name, the leading C can be
omitted.

B that setting this will reset the L and
L attributes to values appropriate to the
new time formatter's class, if the new formatter object has a different
C than the old one.

=head3 tz

 print 'Time zone: ', $fmt->tz()->name(), "\n";
 $fmt->tz( 'MST7MDT' );

The C attribute is maintained on behalf of subclasses of this class,
which B (but need not) use it to format times. This method B
be overridden by subclasses, but the override B call C,
and return values consistent with the following description.

This method acts as both accessor and mutator for the C attribute.
Without arguments it is an accessor, returning the current value of the
C attribute.

If passed an argument, that argument becomes the new value of C, and
the object itself is returned so that calls may be chained.

The use of the argument is up to the subclass, but it is
recommended for sanity's sake that the subclasses interpret this value
as a time zone to be used to derive the local time if they use this
attribute at all.

A complication is that subclasses may need to validate zone values. It
is to be hoped that their digestions will be rugged enough to handle the
usual conventions, since convention rather than standard seems to rule
here.

=head3 value_formatter

This method acts as both accessor and mutator for the object used to
format values. It will probably be a
L
object of some sort, and will certainly conform to that interface. When
setting the value, you can specify either a class name or an object. If
a class name, the leading C can be omitted.

Author's note:

This method is B. Documentation is for the
benefit of the author and the curious. I wanted to screw around with
extra formatters, and the best way to do that seemed to be to subclass
C, but then I needed a way to put the
subclass into use. But I am not really ready to document the necessary
interface (and therefore commit to not changing it, or at least not
doing so without going through a deprecation cycle). If you have a need
for this kind of thing, please contact me.

=head2 Formatters

There is actually only one formatter method. The subclass B
provide it, because this class does not.

=head3 format

 print $fmt->format( template => $name, data => $data );

This method takes named arguments.

The only required argument is C