view release on metacpan or  search on metacpan

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

    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 = (
	TITLE_GRAVITY_TOP() => sub {
	    my ( $self, $wrapped, $arg, $fmtr ) = @_;
	    defined $self->{internal}{_title_info}{inx}
		or $self->{internal}{_title_info}{inx} = 0;
	    my $inx = $self->{internal}{_title_info}{inx};
	    $self->{internal}{_title_info}{more} ||=
		defined $wrapped->[$inx + 1];

	    return defined $wrapped->[$inx] ?
		$wrapped->[$inx] :
		$self->_format_string( '', $arg, $fmtr );
	},
	TITLE_GRAVITY_BOTTOM() => sub {
	    my ( $self, $wrapped, $arg, $fmtr ) = @_;
	    defined $self->{internal}{_title_info}{inx}
		or do {
		$self->{internal}{_title_info}{inx} = -1;
		$self->{internal}{_title_info}{max} = 0;
	    };
	    my $size = @{ $wrapped };
	    my $inx = $self->{internal}{_title_info}{inx};
	    if ( $inx < 0 ) {
		$self->{internal}{_title_info}{max} = max(
		    $size,
		    $self->{internal}{_title_info}{max},
		);
	    }
	    my $max = $self->{internal}{_title_info}{max};
	    $self->{internal}{_title_info}{more} ||= $inx + 1 < $max;
	    $inx = $inx - $max + $size;
	    return ( $inx >= 0 && defined $wrapped->[$inx] ) ?
		$wrapped->[$inx] :
		$self->_format_string( '', $arg, $fmtr );
	},
    );

    sub _do_title {
	my ( $self, $arg, $fmtr ) = @_;
	my $fmtr_name = $fmtr->{name};
	# TODO this looks like a good place to insert localized title
	# code. But see also _apply_defaults().
	defined $arg->{title}
	    or $arg->{title} = '';
	my $title = $arg->{title};
	my $wrapped = $self->{internal}{$fmtr_name}{_title}{$title}{$arg->{width}}
	    ||= $self->_do_title_wrap( $arg, $fmtr );

	return $do_title{$self->{title_gravity}}->( $self, $wrapped,
	    $arg, $fmtr );
    }

    sub is_valid_title_gravity {
	my ( @args ) = @_;
	defined( my $value = pop @args )
	    or return 0;
	return $do_title{$value} ? 1 : 0;
    }

}

sub _do_title_wrap {
    my ( $self, $arg, $fmtr ) = @_;
    my $title = $arg->{title};
    $arg->{width} eq ''
	and return [ $title ];
    $arg->{width}
	or return [ '' ];
    local $Text::Wrap::columns = $arg->{width} + 1;
    local $Text::Wrap::huge = 'overflow';
    my $wrap = Text::Wrap::wrap( '', '', $title );
    my @lines = split qr{ \n }sxm, $wrap;
    return [ map { $self->_format_string( $_, $arg, $fmtr ) } @lines ];
}

sub __chain_bearing {
    my ( undef, undef, $value, $arg ) = @_;	# Invocant, $name unused
    $arg->{bearing}
	and $arg->{bearing} =~ RE_ALL_DIGITS
	or $arg->{bearing} = 0;

    $arg->{bearing} or return $arg;

    if ( defined $value ) {
	my $ab = { %{ $arg } };	# Shallow clone
	$ab->{width} and $ab->{width} = $ab->{bearing};
	$ab->{units} = 'bearing';
	return ( $arg, $ab );
    } else {
	$arg->{width}
	    and $arg->{width} += $arg->{bearing} + 1;
	return $arg;
    }
}

sub _dor {
    foreach ( @_ ) {
	defined $_ and return $_;
    }
    return $_[-1];
}

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

		and last;
	}
    }
    $table ||= __localize(
	text	=> [ event => 'table' ],
	default	=> [],
    );

    return $self->_format_string( $table->[$value] || '', $arg, $fmtr );
}

# Called as $self->$method()
sub _format_integer {	## no critic (ProhibitUnusedPrivateSubroutines)
    my ( $self, $value, $arg ) = @_;	# $fmtr unused
    defined $value
	or goto &_format_undef;

    $arg->{width}
	and $arg->{width} =~ RE_ALL_DIGITS
	or return sprintf '%d', $value;

    my $buffer = sprintf '%*d', $arg->{width}, $value;

    length $buffer <= $arg->{width}
	or $self->{overflow}
	or return '*' x $arg->{width};

    return $buffer;
}

# Called as $self->$method()
sub _format_lower_case {	## no critic (ProhibitUnusedPrivateSubroutines)
    my ( $self, $value, $arg, $fmtr ) = @_;
    defined $value
	or goto &_format_undef;

    return $self->_format_string( lc $value, $arg, $fmtr );
}

# Called as $self->$method()
sub _format_number {	## no critic (ProhibitUnusedPrivateSubroutines)
    my ( $self, $value, $arg, $fmtr ) = @_;
    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}";

    '%' eq $tplt
	and return "$value";

    my $buffer = sprintf $tplt . 'f', $value;

    # The following line is because sprintf '%.1f', 0.04 produces
    # '-0.0'. This may not be a bug, given what 'perldoc -f sprintf'
    # says, but it sure looks like a wart to me.
    $buffer =~ s/ \A ( \s* ) - ( 0* [.]? 0* \s* ) \z /$1 $2/smx;

    $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' ],