File Coverage

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

Criterion	Covered	Total	%
statement	208	236	88.1
branch	60	100	60.0
condition	14	27	51.8
subroutine	42	45	93.3
pod	11	11	100.0
total	335	419	79.9

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

use strict;
use warnings;

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

use Astro::App::Satpass2::Locale qw{ __localize };
# use Astro::App::Satpass2::FormatValue;
use Astro::App::Satpass2::FormatValue::Formatter;
use Astro::App::Satpass2::Utils qw{
    instance
    ARRAY_REF
    HASH_REF
    SCALAR_REF
    @CARP_NOT
};
use Astro::App::Satpass2::Wrap::Array;
use Astro::Coord::ECI::TLE 0.059 qw{ :constants };
use Astro::Coord::ECI::Utils 0.059 qw{
    deg2rad embodies julianday PI rad2deg TWOPI
};
use Clone qw{ };
use POSIX qw{ floor };
use Template;
use Template::Provider;
use Text::Abbrev;
use Text::Wrap qw{ wrap };

our $VERSION = '0.051';

use constant FORMAT_VALUE	=> 'Astro::App::Satpass2::FormatValue';

sub new {
    my ($class, @args) = @_;
    my $self = $class->SUPER::new( @args );

    # As of 0.020_002 the template definitions are in the
    # locale system. The attribute simply holds modifications.
    $self->{canned_template} = {};

    $self->_new_tt( $self->permissive() );

    $self->{default} = {};
    $self->{formatter_method} = {};

    return $self;
}

sub _new_tt {
    my ( $self, $permissive ) = @_;

    $self->{tt} = Template->new(
	{
	    LOAD_TEMPLATES => [
		Template::Provider->new(
		    ABSOLUTE	=> $permissive,
		    RELATIVE	=> $permissive,
		),
	    ],
	}
    ) or $self->weep(
	"Failed to instantate tt: $Template::ERROR" );

    return;
}

sub add_formatter_method {
    # TODO I want the arguments to be ( $self, $fmtr ), but for the
    # moment I have to live with an unreleased version that passed the
    # name as the first argument. I will go to the desired signature as
    # soon as I get this version installed on my own machine.
    my ( $self, @arg ) = @_;
    my $fmtr = HASH_REF eq ref $arg[0] ? $arg[0] : $arg[1];
    HASH_REF eq ref $fmtr
	or $self->wail(
	'Formatter definition must be a HASH reference' );
    defined( my $fmtr_name = $fmtr->{name} )
	or $self->wail(
	    'Formatter definition must have {name} defined' );
    $self->{formatter_method}{$fmtr_name}
	and $self->{warner}->wail(
	"Formatter method $fmtr_name already exists" );
    FORMAT_VALUE->can( $fmtr_name )
	and $self->{warner}->wail(
	"Formatter $fmtr_name can not override built-in formatter" );
    $self->{formatter_method}{$fmtr_name} =
    Astro::App::Satpass2::FormatValue::Formatter->new( $fmtr );
    return $self;
}

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

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

    # TODO support for the {default} key.

    foreach my $name (
	sort $args{changes} ?
	    keys %{ $self->{canned_template} } :
	    $self->__list_templates()
    ) {
	push @data, [ template => $name,
	    $self->{canned_template}{$name} ];
    }

    return wantarray ? @data : \@data;
}

# Return the names of all known templates, in no particular order. No
# arguments other than the invocant.
sub __list_templates {
    my ( $self ) = @_;
    return ( _uniq( map { keys %{ $_ } } $self->{canned_template},
	    __localize(
		text	=> '+template',
		default	=> {},
	    ) ) );
}

{
    my %decoder = (
	template	=> sub {
	    my ( $self, $method, @args ) = @_;

=begin comment

	    1 == @args
		and return ( @args, $self->$method( @args ) );
	    $self->$method( @args );
	    return $self;

=end comment

=cut

	    1 == @args
		or return $self->$method( @args );
	    return ( @args, $self->$method( @args ) );
	},
    );

    sub decode {
	my ( $self, $method, @args ) = @_;
	my $dcdr = $decoder{$method}
	    or return $self->SUPER::decode( $method, @args );
	goto $dcdr;
    }
}

sub __default {
    my ( $self, @arg ) = @_;
    @arg or return $self->{default};
    my $action = shift @arg;
    @arg or return $self->{default}{$action};
    my $attrib = shift @arg;
    defined $attrib
	or return delete $self->{default}{$action};
    @arg or return $self->{default}{$action}{$attrib};
    my $value = shift @arg;
    defined $value
	or return delete $self->{default}{$action}{$attrib};
    $self->{default}{$action}{$attrib} = $value;
    return $value;
}

sub format : method {	## no critic (ProhibitBuiltInHomonyms)
    my ( $self, %data ) = @_;

    exists $data{data}
	and $data{data} = $self->_wrap(
	    data	=> $data{data},
	    report	=> $data{template},
	);

    _is_format() and return $data{data};

    my $tplt = delete $data{template}
	or $self->wail( 'template argument is required' );

    my $tplt_name = SCALAR_REF eq ref $tplt ? ${ $tplt } : $tplt;

    $data{default} ||= $self->__default();

    $data{instantiate} = sub {
	my @args = @_;
	my $class = Astro::App::Satpass2::Utils::load_package( @args );
	return $class->new();
    };

    $data{provider} ||= $self->provider();

    if ( $data{time} ) {
	ref $data{time}
	    or $data{time} = $self->_wrap(
		data => { time => $data{time} },
		report	=> $tplt_name,
	    );
    } else {
	$data{time} = $self->_wrap(
	    data	=> { time => time },
	    report	=> $tplt_name,
	);
    }

    my $value_formatter = $self->value_formatter();

    $data{title} = $self->_wrap(
	default	=> $data{default},
	report	=> $tplt_name,
    );
    $data{TITLE_GRAVITY_BOTTOM} =
	$value_formatter->TITLE_GRAVITY_BOTTOM;
    $data{TITLE_GRAVITY_TOP} =
	$value_formatter->TITLE_GRAVITY_TOP;

    local $Template::Stash::LIST_OPS->{bodies} = sub {
	my ( $list ) = @_;
	return [ map { $_->body() } @{ $list } ];
    };

    local $Template::Stash::LIST_OPS->{events} = sub {
	my @args = @_;
	return $self->_all_events( $args[0] );
    };

    local $Template::Stash::LIST_OPS->{fixed_width} = sub {
	my ( $list, $value ) = @_;
	foreach my $item ( @{ $list } ) {
	    my $code = $item->can( 'fixed_width' )
		or next;
	    $code->( $item, $value );
	}
	return;
    };

    $data{localize} = sub {
	return _localize( $tplt_name, @_ );
    };

    # NOTE - must come after $data{localize} because
    # $data{format_detail} uses $data{localize}
    $data{format_detail} = sub {
	my ( $kind, $evt ) = @_;

	instance( $evt, 'Astro::App::Satpass2::FormatValue' )
	    or return;
	defined ( my $type = $evt->$kind( width => '' ) )
	    or return;
	$type =~ s/ \s+ \z //smx;

	foreach my $name ( "$kind:$type", $kind ) {
	    defined ( my $tplt = $self->template( "$tplt:$name" ) )
		or next;
	    my $output = $self->_process( \$tplt,
		evt		=> $evt,
		localize	=> $data{localize},
		sp		=> $data{sp},
	    );

	    chomp $output;
	    return $output;
	}
	return __localize(
	    text	=> [ '+template', "$tplt:$kind" ],
	);
    };

    my $output = $self->_process( $tplt, %data );

    # TODO would love to use \h here, but that needs 5.10.
    $output =~ s/ [ \t]+ (?= \n ) //sxmg;
    $data{title}->title_gravity() eq $data{TITLE_GRAVITY_BOTTOM}
	and $output =~ s/ \A \n //smx;

    return $output;
}

sub gmt {
    my ( $self, @args ) = @_;
    if ( @args ) {
	$self->time_formatter()->gmt( @args );
	return $self->SUPER::gmt( @args );
    } else {
	return $self->SUPER::gmt();
    }
}

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

	defined $self->template( $val )
	    or $self->wail(
		'Unknown local coordinate specification', $val );

	return $self->SUPER::local_coord( @args );
    } else {
	return $self->SUPER::local_coord();
    }
}

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

sub template {
    my ( $self, $name, @value ) = @_;
    defined $name
	or $self->wail( 'Template name not specified' );

    if ( @value ) {
	my $tplt_text;
	if ( ! defined $value[0]
	    || defined( $tplt_text = __localize(
		    text	=> '+template',
		    default	=> $value[0] )
	    )
	    && $value[0] eq $tplt_text
	) {
	    delete $self->{canned_template}{$name};
	} else {
	    $self->{canned_template}{$name} = $value[0];
	}

	return $self;
    } else {
	defined $self->{canned_template}{$name}
	    and return $self->{canned_template}{$name};
	return __localize(
	    text	=> [ '+template', $name ],
	);
    }
}

sub tz {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my $tf = $self->time_formatter();
	# We go through the following because the time formatter may
	# modify the zone (e.g. if it's using DateTime, zones are
	# case-sensitive so we may have done case conversion before
	# storing). We want this object to have the time formatter's
	# version of the zone.
	$tf->tz( @args );
	return $self->SUPER::tz( $tf->tz() );
    } else {
	return $self->SUPER::tz();
    }
}

sub _all_events {
    my ( $self, $data ) = @_;
    ARRAY_REF eq ref $data or return;

    my @events;
    foreach my $pass ( @{ $data } ) {
	push @events, $pass->__raw_events();
    }
    @events or return;
    @events = sort { $a->{time} <=> $b->{time} } @events;

    return [ map { $self->_wrap( data => $_ ) } @events ];
}

#	_is_format()
#
#	Returns true if the format() method is above us on the call
#	stack, otherwise returns false.

use constant REPORT_CALLER => __PACKAGE__ . '::format';
sub _is_format {
    my $level = 2;	# Start with caller's caller.
    while ( my @info = caller( $level ) ) {
	REPORT_CALLER eq $info[3]
	    and return $level;
	$level++;
    }
    return;
}

sub _localize {
    my ( $report, $source, $default ) = @_;
    defined $default
	or $default = $source;
    defined $report
	or return defined $source ? $source : $default;

    return scalar __localize(
	text	=> [ "-$report", 'string', $source ],
	default	=> $source,
    );
}

sub _process {
    my ( $self, $tplt, %arg ) = @_;
    ARRAY_REF eq ref $arg{arg}
	and $arg{arg} = Astro::App::Satpass2::Wrap::Array->new(
	$arg{arg} );
    my $output;
    my $tt = $self->{tt};

    my $tplt_text;
    not ref $tplt
	and defined( $tplt_text = $self->template( $tplt ) )
	and $tplt = \$tplt_text;

    $tt->process( $tplt, \%arg, \$output )
	or $self->wail( $tt->error() );
    return $output;
}

# Cribbed shamelessly from List::MoreUtils. The author reserves the
# right to relocate, rename or otherwise mung with this without notice
# to anyone. Caveat user.
sub _uniq {
    my %found;
    return ( grep { ! $found{$_}++ } @_ );
}

sub _wrap {
    my ( $self, %arg ) = @_;

    my $data = $arg{data};
    my $default = $arg{default};
    my $report = $arg{report};

    my $title = ! $data;
    $data ||= {};
    $default ||= $self->__default();

    if ( instance( $data, FORMAT_VALUE ) ) {
	# Do nothing
    } elsif ( ! defined $data || HASH_REF eq ref $data ) {
	my $value_formatter = $self->value_formatter();
	$data = $value_formatter->new(
	    data	=> $data,
	    default	=> $default,
	    date_format => $self->date_format(),
	    desired_equinox_dynamical =>
			    $self->desired_equinox_dynamical(),
	    provider	=> $self->provider(),
	    round_time	=> $self->round_time(),
	    time_format => $self->time_format(),
	    time_formatter => $self->time_formatter(),
	    local_coordinates => sub {
		my ( $data, @arg ) = @_;
		return $self->_process( $self->local_coord(),
		    data	=> $data,
		    arg		=> \@arg,
		    title	=> $self->_wrap(
			default	=> $default,
			report	=> $report,
		    ),
		    localize	=> sub {
			return _localize( $report, @_ );
		    },
		);
	    },
	    list_formatter => sub {
		my ( $data, @arg ) = @_;
		my $body = $data->body();
		my $list_type = $body ? $body->__list_type() : 'inertial';
		return $self->_process( "list_$list_type",
		    data	=> $data,
		    arg		=> \@arg,
		    title	=> $self->_wrap(
			default => $default,
			report	=> $report,
		    ),
		);
	    },
	    report	=> $report,
	    title	=> $title,
	    warner	=> $self->warner(),
	);
	$data->add_formatter_method( values %{ $self->{formatter_method} } );
    } elsif ( ARRAY_REF eq ref $data ) {
	$data = [ map { $self->_wrap( data => $_, report => $report ) } @{ $data } ];
    } elsif ( embodies( $data, 'Astro::Coord::ECI' ) ) {
	$data = $self->_wrap(
	    data	=> { body => $data },
	    report	=> $report,
	);
    }

    return $data;
}

__PACKAGE__->create_attribute_methods();

1;

__END__