Astro-App-Satpass2
view release on metacpan or search on metacpan
lib/Astro/App/Satpass2/FormatValue.pm view on Meta::CPAN
alias => 'gmt',
},
},
formatter => '_format_time',
},
);
# The following was for a utility script to generate documentation for
# the dimensions.
#
# sub __get_dimension_data {
# my ( $class, $name ) = @_;
# return $dimensions{$name};
# }
# The following hash is used for generating formatter methods, as
# a way of avoiding the replication of common code. The keys are
# the method names, and the values are hashes which specify the
# method to generate. If the named method already exists, it is
# not replaced.
#
# The hash specifying each method contains the following keys,
# which are all requited unless the documentation for the key says
# otherwise.
#
# {chain} - An optional code reference which may (but need not)
# expand the formatter to produce multiple representations of
# the same value. It takes the arguments ( $self, $name,
# $value, $arg ) where $self is the invocant, $name is the
# name of the formatter method, $value is the value being
# formatted, and $arg is the formatter arguments, which have
# already had the defaults applied. It returns at least one
# argument hash. If it returns more than one, the same value
# is formatted using each set of arguments, with the results
# made into a single string using join( ' ', ... ). The
# returned argument sets MUST keep the same field width for
# the same arguments.
#
# This is used only for azimuth(), to process the 'bearing'
# argument.
#
# {default} - A hash specifying all legal arguments, and their
# default values. You can specify undef to make the argument
# legal but give it no value (i.e. to pick up the value from
# somewhere else).
#
# {dimension} - A hash specifying the dimension of the value to be
# formatted. This must contain a {dimension} key specifying
# the name of the dimension, and may contain a {units} value
# overriding the default units.
#
# {fetch} - A code reference which returns the value to be
# formatted. It will be passed arguments ( $self, $name, $arg
# ), where $self is the invocant, $name is the name of the
# formatter method, and $arg is a refernce to the arguments
# hash, which has already had _apply_defaults() called on it.
# This code is _not_ called if the invocant was initialized
# with title => 1.
#
# {locale} - A hash specifying last-ditch localization
# information. The keys are locale, the formatter name
# (yes, this is a duplicate) and the item name.
my %formatter_data = ( # For generating formatters
almanac => {
default => {
width => 40,
},
dimension => {
dimension => 'almanac_pseudo_units',
},
fetch => sub {
my ( $self, undef, $arg ) = @_; # $name unused
my $field = $arg->{units} ||= 'description';
return $self->_get( data => almanac => $field );
},
},
altitude => {
default => {
places => 1,
width => 7,
},
dimension => {
dimension => 'length',
},
fetch => sub {
my ( $self ) = @_; # $name, $arg unused
my $value;
if ( my $body = $self->_get_eci( 'body' ) ) {
$value = ( $body->geodetic() )[2];
}
return $value;
},
},
angle => {
default => {
places => 1,
width => 5,
},
dimension => {
dimension => 'angle_units',
},
fetch => sub {
my ( $self ) = @_; # $name, $arg unused
return $self->_get( data => 'angle' );
},
},
apoapsis => {
default => {
as_altitude => 1,
places => 0,
width => 6,
},
dimension => {
dimension => 'length',
},
fetch => sub {
lib/Astro/App/Satpass2/FormatValue.pm view on Meta::CPAN
and next;
my $fq = "${class}::$fmtr_name";
no strict qw{ refs };
*$fq = __PACKAGE__->__make_formatter_code( $fmtr );
}
return;
}
__PACKAGE__->__make_formatter_methods();
# Title control
# sub is_valid_title_gravity would normally be here, but in order to
# reduce technical debt it shares a hash with _do_title(), and is placed
# with it, below.
sub more_title_lines {
my ( $self ) = @_;
exists $self->{internal}{_title_info}
or return 1;
my $more;
if ( $more = delete $self->{internal}{_title_info}{more} ) {
$self->{internal}{_title_info}{inx}++
} else {
$self->reset_title_lines();
}
return $more;
}
sub reset_title_lines {
my ( $self ) = @_;
delete $self->{internal}{_title_info};
return;
}
# Private methods and subroutines of all sorts.
{
my @always = qw{ align_left missing title };
sub _apply_defaults {
my ( $self, $arg, $fmtr ) = @_;
my $fmtr_name = $fmtr->{name};
my $dflt = $fmtr->{default} || {};
defined $arg->{width}
or $self->{fixed_width}
or $arg->{width} = '';
if ( defined $arg->{format} && ! defined $arg->{width} ) {
$arg->{width} = $self->{time_formatter}->
format_datetime_width( $arg->{format} );
}
# TODO maybe apply locale here? But see also _do_title.
APPLY_DEFAULT_LOOP:
foreach my $key ( keys %{ $dflt }, @always ) {
defined $arg->{$key} and next;
foreach my $source ( qw{ default internal } ) {
defined( $arg->{$key} = $self->_get( $source, $fmtr_name,
$key ) )
and next APPLY_DEFAULT_LOOP;
}
defined( $arg->{$key} = __localize(
text => [ $fmtr_name, $key ],
locale => $fmtr->{locale},
) )
and next;
my $default = $dflt->{$key};
$arg->{$key} = CODE_REF eq ref $default ?
$default->( $self, $fmtr_name, $arg ) : $default
}
defined $arg->{width}
or $arg->{width} = '';
$arg->{width} =~ m/ \D /sxm
and $arg->{width} = '';
if ( $self->{report} ) {
my $report = "-$self->{report}";
foreach my $key ( qw{ literal missing title } ) {
defined $arg->{$key}
or next;
$arg->{$key} = __localize(
text => [ $report, 'string', $arg->{$key} ],
default => $arg->{$key},
locale => $fmtr->{locale},
);
}
}
return;
}
}
sub _apply_dimension {
my ( $self, $value, $arg, $fmtr ) = @_;
my $fmtr_name = $fmtr->{name};
defined( my $dim_name = $fmtr->{dimension}{dimension} )
or $self->weep( 'No dimension specified' );
my $dim;
$dim = $dimensions{$dim_name}
and defined( my $unit_name = _dor( $arg->{units}, $fmtr->{dimension}{units},
$self->_get( default => $fmtr_name, 'units' ),
$dim->{default} ) )
or $self->weep( "Dimension $dim_name undefined" );
my $unit = $dim->{define}{$unit_name}
or $self->{warner}->wail(
"Units $unit_name not valid for $dim_name" );
if ( defined $unit->{alias} ) {
my $alias = $dim->{define}{$unit->{alias}}
or $self->weep( "Undefined alias '$unit->{alias}'" );
$unit_name = $unit->{alias};
$unit = $alias;
}
defined $arg->{align_left}
or $arg->{align_left} = _dor( $unit->{align_left},
$dim->{align_left} );
$self->{title}
and return $self->_do_title( $arg, $fmtr );
defined $value
or return $self->_format_undef( undef, $arg, $fmtr );
defined $unit->{method}
and do {
my $method = $unit->{method};
defined( $value = $self->$method( $value ) )
or return $self->_format_undef( undef, $arg, $fmtr );
};
defined $unit->{factor}
and $value *= $unit->{factor};
defined $unit->{gmt}
and not defined $arg->{gmt}
and $arg->{gmt} = $unit->{gmt};
$arg->{units} = $unit_name;
$value = __localize(
text => [ $fmtr_name, 'localize_value', $value ],
default => $value,
locale => $fmtr->{locale},
);
defined( my $formatter = _dor( $unit->{formatter},
$fmtr->{dimension}{formatter},
$dim->{formatter},
) )
or $self->weep( "No formatter for $dim_name $unit_name" );
return $self->$formatter( $value, $arg, $fmtr );
}
sub _arguments {
my @arg = @_;
my $obj = shift @arg;
my $hash = HASH_REF eq ref $arg[-1] ? pop @arg : {};
my ( @clean, @append );
foreach my $item ( @arg ) {
if ( has_method( $item, 'dereference' ) ) {
push @append, $item->dereference();
} else {
push @clean, $item;
}
}
@clean % 2 and splice @clean, 0, 0, 'title';
return ( $obj, %{ $hash }, @clean, @append );
}
=begin comment
# TODO remove this after October 1 2016
# It's only still here because, although I can't find a call for it, and
# testcover shows it is not called, I'm paranoid that I did something
# tricky that I can not now remember and is not covered by the tests.
sub _attrib_hash {
my ( $self, $name, @arg ) = @_;
if ( @arg ) {
my $value = shift @arg;
ref $value
and HASH_REF eq reftype( $value )
or $self->{warner}->wail(
"Attribute $name must be a hash reference" );
$self->{$name} = $value;
return $self;
} else {
return $self->{$name};
}
}
=end comment
=cut
{
my %do_title = (
lib/Astro/App/Satpass2/FormatValue.pm view on Meta::CPAN
foreach my $thing ( $body, $station ) {
embodies( $thing, 'Astro::Coord::ECI' )
or return;
}
# TODO need to set station time from body? I think not now, but
# Astro::App::Satpass2::FormatValue needed this.
if ( my $equinox = $self->{desired_equinox_dynamical} ) {
foreach my $thing ( $body, $station ) {
$thing = $thing->clone()->precess_dynamical( $equinox );
}
}
return $station->$method( $body );
}
sub _get_tle {
my ( $self, @arg ) = @_;
my $tle = $self->_get( data => @arg );
embodies( $tle, 'Astro::Coord::ECI::TLE' )
and return $tle;
return NONE;
}
sub _get_tle_attr {
my ( $self, @arg ) = @_;
my $attr = pop @arg;
my $tle = $self->_get( data => @arg );
embodies( $tle, 'Astro::Coord::ECI::TLE' )
and $tle->attribute( $attr )
or return NONE;
return $tle->get( $attr );
}
# $string = $self->_format_*( $value, \%arg, \%fmtr );
#
# These methods take the value and turn it into a string.
# Recognized arguments are:
# {places} => decimal places, ignored if not a non-negative
# number;
# {width} => field width, ignored if not a non-negative
# number;
# Called as $self->$method()
sub _format_bearing { ## no critic (ProhibitUnusedPrivateSubroutines)
my ( $self, $value, $arg, $fmtr ) = @_;
defined $value
or goto &_format_undef;
my $table;
foreach my $source ( qw{ default } ) {
$table = $self->_get( $source => bearing => 'table' )
and last;
}
$table ||= __localize(
text => [ bearing => 'table' ],
default => [],
locale => $fmtr->{locale},
);
$arg->{bearing}
or $arg->{bearing} = ( $arg->{width} || 2 );
$arg->{width}
and $arg->{bearing} > $arg->{width}
and $arg->{bearing} = $arg->{width};
my $inx = min( $arg->{bearing} || 2, scalar @{ $table } ) - 1;
my $tags = $table->[$inx];
my $bins = @{ $tags };
$inx = floor ($value / TWOPI * $bins + .5) % $bins;
return $self->_format_string( $tags->[$inx], $arg, $fmtr );
}
# Called as $self->$method()
sub _format_duration { ## no critic (ProhibitUnusedPrivateSubroutines)
my ( $self, $value, $arg, $fmtr ) = @_;
defined $arg->{align_left}
or $arg->{align_left} = 0;
defined $value
or goto &_format_undef;
my $secs = floor ($value + .5);
my $mins = floor ($secs / 60);
$secs %= 60;
my $hrs = floor ($mins / 60);
$mins %= 60;
my $days = floor ($hrs / 24);
$hrs %= 24;
my $buffer;
if ($days > 0) {
$buffer = sprintf '%d %02d:%02d:%02d', $days, $hrs, $mins, $secs;
} else {
$buffer = sprintf '%02d:%02d:%02d', $hrs, $mins, $secs;
}
'' eq $arg->{width}
and return $buffer;
length $buffer <= $arg->{width}
or $self->{overflow}
or return '*' x $arg->{width};
$arg->{width} - length $buffer
or return $buffer;
return $self->_format_string( $buffer, $arg, $fmtr );
}
# Called as $self->$method()
sub _format_event { ## no critic (ProhibitUnusedPrivateSubroutines)
my ( $self, $value, $arg, $fmtr ) = @_;
defined $value
or goto &_format_undef;
lib/Astro/App/Satpass2/FormatValue.pm view on Meta::CPAN
$width or return $buffer;
if ($width && length $buffer > $width && $width >= 7) {
$arg->{places} = $width - 7;
return $self->_format_number_scientific( $value, $arg, $fmtr );
}
length $buffer <= $width
or $self->{overflow}
or return '*' x $width;
return $buffer;
}
sub _format_number_scientific {
my ( $self, $value, $arg ) = @_; # $fmtr unused
defined $value
and $value ne ''
or goto &_format_undef;
my $width = ( $arg->{width} && $arg->{width} =~ RE_ALL_DIGITS )
? $arg->{width} : '';
my $tplt = "%$width";
defined $arg->{places}
and $arg->{places} =~ RE_ALL_DIGITS
and $tplt .= ".$arg->{places}";
$tplt .= 'e';
my $buffer = sprintf $tplt, $value;
$buffer =~ s/ e ( [-+]? ) 0 ( [0-9]{2} ) \z /e$1$2/smx # Normalize
and $width
and $width > length $buffer
and $buffer = ' ' . $buffer; # Preserve width after normalize
$width
or return $buffer;
length $buffer <= $width
or $self->{overflow}
or return '*' x $width;
return $buffer;
}
# Called as $self->$method()
sub _format_phase { ## no critic (ProhibitUnusedPrivateSubroutines)
my ( $self, $value, $arg, $fmtr ) = @_;
defined $value
or goto &_format_undef;
my $angle = rad2deg( $value );
my $table;
foreach my $source ( qw{ default } ) {
$table = $self->_get( $source => phase => 'table' )
and last;
}
$table ||= __localize(
text => [ phase => 'table' ],
default => [],
locale => $fmtr->{locale},
);
foreach my $entry ( @{ $table } ) {
$entry->[0] > $angle or next;
return $self->_format_string( $entry->[1], $arg, $fmtr );
}
return $self->_format_string( $table->[0][1], $arg, $fmtr );
}
# Called as $self->$method()
sub _format_right_ascension { ## no critic (ProhibitUnusedPrivateSubroutines)
my ( $self, $value, $arg, $fmtr ) = @_;
defined $value
or goto &_format_undef;
my $sec = $value / PI * 12;
my $hr = floor($sec);
$sec = ($sec - $hr) * 60;
my $min = floor($sec);
$sec = ($sec - $min) * 60;
my ( $ps, $wid );
if ( defined $arg->{places} && $arg->{places} =~ RE_ALL_DIGITS )
{
$ps = ".$arg->{places}";
$wid = $arg->{places} ? 3 + $arg->{places} : 2;
} else {
$ps = '';
$wid = 2;
}
defined $arg->{align_left}
or $arg->{align_left} = 0;
return $self->_format_string(
sprintf( "%02d:%02d:%0$wid${ps}f", $hr, $min, $sec ), $arg,
$fmtr );
}
sub _format_string {
my ( $self, $value, $arg ) = @_; # $fmtr unused
defined $value
or goto &_format_undef;
defined $arg->{width}
and $arg->{width} =~ RE_ALL_DIGITS
or return "$value";
my $left = defined $arg->{align_left} ? $arg->{align_left} : 1;
$left = $left ? '-' : '';
my $buffer = sprintf "%$left*s", $arg->{width}, $value;
length $buffer <= $arg->{width}
or $self->{overflow}
or return substr $buffer, 0, $arg->{width};
return $buffer;
}
# Called as $self->$method()
sub _format_time { ## no critic (ProhibitUnusedPrivateSubroutines)
my ( $self, $value, $arg, $fmtr ) = @_;
defined $value
( run in 1.053 second using v1.01-cache-2.11-cpan-ceb78f64989 )