File Coverage

eg/My/Macros.pm

Criterion	Covered	Total	%
statement	66	130	50.7
branch	0	26	0.0
condition	0	14	0.0
subroutine	23	28	82.1
pod			n/a
total	89	198	44.9

package My::Macros;

use 5.008;

use strict;
use warnings;

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

use Astro::App::Satpass2::Utils qw{ __arguments };
use Astro::Coord::ECI::Utils 0.059 qw{ rad2deg };
use Attribute::Handlers;
use Scalar::Util 1.26 qw{ refaddr };

our $VERSION = '0.051';

{
    my %operands;

    sub Operands : ATTR(CODE,RAWDATA) {
	my ( undef, undef, $code, $name, $data ) = @_;
	$operands{$code}{$name} = 0 + $data;
	return;
    }

    sub operands {
	my ( $code ) = @_;
	return defined $code ? $operands{$code} || 0 : \%operands;
    }
}

sub after_load : Verb() {
    my ( undef, $opt, @args ) = @_;	# Invocant unused
    my $rslt;
    foreach my $key ( keys %{ $opt } ) {
	$rslt .= "-$key $opt->{$key}\n";
    }
    foreach my $val ( @args ) {
	$rslt .= "$val\n";
    }
    return $rslt;
}

sub angle : Verb( radians! places=i ) {
    my ( $self, $opt, $name1, $name2, $time ) = __arguments( @_ );
    $time = $self->__parse_time( $time, time );
    defined $name1
	and defined $name2
	or $self->wail( 'Two names or OIDs must be provided' );
    my @things = $self->__choose(
	{ bodies => 1, sky => 1 },
	[ $name1, $name2 ],
    );
    @things
	or $self->wail( 'No bodies chosen' );
    @things < 2
	and $self->wail( 'Only 1 body (',
	    $things[0]->get( 'name' ),
	    ') chosen' );
    @things > 2
	and $self->wail( scalar @things, ' bodies chosen' );
    my $station = $self->station()->universal( $time );
    foreach my $body ( @things ) {
	$body->universal( $time );
    }
    my $angle = $station->angle( @things );
    $opt->{radians}
    or $angle = rad2deg( $angle );
    defined $opt->{places}
	or return "$angle\n";
    return sprintf "%.*f\n", $opt->{places}, $angle;
}

sub hi : Verb() {
    my ( undef, undef, $name ) = __arguments( @_ );
    defined $name
	or $name = 'world';
    return "Hello, $name!\n";
}

{
    my %operator = (
	and		=> sub : Operands(2) {
	    my ( undef, $stack ) = @_;	# Invocant unused
	    push @{ $stack }, pop @{ $stack } && pop @{ $stack };
	    return;
	},
	choose	=> sub : Operands(1) {
	    my ( $self, $stack ) = @_;
	    # We want the number of bodies, but __choose(), for better
	    # or worse, provides a reference to the array of bodies in
	    # scalar context. So the empty parens provide list context
	    # to __choose(), hiding the fact that ultimately we do a
	    # scalar assign.
	    my $count = () = $self->__choose(
		{ bodies	=> 1 },
		[ pop @{ $stack } ],
	    );
	    push @{ $stack }, $count;
	    return;
	},
	else		=> sub : Operands(1) {
	    my ( undef, $stack ) = @_;	# Invocant unused
	    $stack->[-1] = ! $stack->[-1];
	    no warnings qw{ exiting };
	    last TEST_LOOP;
	},
	not		=> sub : Operands(1) {
	    my ( undef, $stack ) = @_;	# Invocant unused
	    $stack->[-1] = ! $stack->[-1];
	    return;
	},
	or		=> sub : Operands(2) {
	    my ( undef, $stack ) = @_;	# Invocant unused
	    push @{ $stack }, pop @{ $stack } || pop @{ $stack };
	    return;
	},
	then		=> sub : Operands(1) {
	    no warnings qw{ exiting };
	    last TEST_LOOP;
	},
    );

    sub test : Verb() {
	my ( $self, undef, @arg ) = __arguments( @_ );
	my @stack;

	eval {
	    TEST_LOOP:
	    while ( @arg ) {
		my $current = shift @arg;
		if ( my $code = $operator{$current} ) {
		    my $operands = operands( $code );
		    @stack >= $operands
			or $self->wail( "Not enough operands. Need $operands" );
		    $code->( $self, \@stack );
		} else {
		    push @stack, $current;
		}
	    }
	    1;
	} or $self->wail( $@ );
	@stack > 1
	    and $self->wail( 'More than one value left on stack' );
	$stack[-1]
	    and @arg
	    or return;
	return $self->dispatch( @arg );
    }
}

sub dumper : Verb() {
    my ( $self, @args ) = @_;
    use YAML;
    return ref( $self ) . "\n" . Dump( \@args );
}

1;

__END__