CET results from the CPAN

Astro-App-Satpass2


use strict;
use warnings;

use Astro::App::Satpass2::Locale qw{ __localize };
use Astro::App::Satpass2::Macro::Command;
use Astro::App::Satpass2::Macro::Code;
use Astro::App::Satpass2::ParseTime;
use Astro::App::Satpass2::Utils qw{
    :os
    :ref
    __arguments __legal_options
    expand_tilde find_package_pod
    has_method instance load_package
    my_dist_config quoter
    __parse_class_and_args
};

use Astro::Coord::ECI 0.077;			# This needs at least 0.049.
use Astro::Coord::ECI::Moon 0.077;
use Astro::Coord::ECI::Star 0.077;
use Astro::Coord::ECI::Sun 0.077;
use Astro::Coord::ECI::TLE 0.077 qw{:constants}; # This needs at least 0.059.
use Astro::Coord::ECI::TLE::Set 0.077;
# The following includes @CARP_NOT.
use Astro::Coord::ECI::Utils 0.112 qw{ :all };	# This needs at least 0.112.

{
    local $@ = undef;
    use constant HAVE_TLE_IRIDIUM	=> eval {
	require Astro::Coord::ECI::TLE::Iridium;
	Astro::Coord::ECI::TLE::Iridium->VERSION( 0.077 );
	1;
    } || 0;
    # Unfortunately the alias code creates the alias even if the version
    # is unacceptable; so we may have to just delete the Iridium aliases
    unless( HAVE_TLE_IRIDIUM ) {
	my %type_map = Astro::Coord::ECI::TLE->alias();
	foreach my $name ( keys %type_map ) {
	    $type_map{$name} eq 'Astro::Coord::ECI::TLE::Iridium'
		and Astro::Coord::ECI::TLE->alias( $name, undef );
	}
    }
}

use Attribute::Handlers;
use Clone ();
use Cwd ();
use File::Glob qw{ :glob };
use File::HomeDir;
use File::Spec;
use File::Temp;
use Getopt::Long 2.33;
use IO::File 1.14;
use IO::Handle;
use POSIX qw{ floor };
use Scalar::Util 1.26 qw{ blessed isdual openhandle };
use Text::Abbrev;
use Text::ParseWords ();	# Used only for {level1} stuff.

use constant ASTRO_SPACETRACK_VERSION => 0.105;
use constant DEFAULT_STDOUT_LAYERS	=> ':encoding(utf-8)';

BEGIN {
    eval {
	load_package( 'Time::y2038' )
	    and Time::y2038->import();
	1;
    }
	or do {
	    require Time::Local;
	    Time::Local->import();
	};
}

# The following is returned by method _attribute_value() when a
# non-existent attribute is specified. We can't use undef for this,
# because the attribute might really be undef.
# NOTE that this used to be just bless \( $x = undef ) ..., but blead
# Perl 6a011f13d7690dbe2e03ad7500756c983bcb1834 did not like this
# (modificatoin of read-only variable).
use constant NULL	=> do {
    my $x = undef;
    bless \$x, 'Null';
};
# The canonical way to see if $rslt actually contains the above is
# NULL_REF eq ref $rslt
use constant NULL_REF	=> ref NULL;

use constant SUN_CLASS_DEFAULT	=> 'Astro::Coord::ECI::Sun';

our $VERSION = '0.058';

# The following 'cute' code is so that we do not determine whether we
# actually have optional modules until we really need them, and yet do
# not repeat the process once it is done.

my $have_time_hires;
$have_time_hires = sub {
    my $value = load_package( 'Time::HiRes' );
    $have_time_hires = sub { return $value };
    return $value;
};

my $have_astro_spacetrack;
$have_astro_spacetrack = sub {
    my $value = load_package( { lib => undef }, 'Astro::SpaceTrack' ) && eval {
	Astro::SpaceTrack->VERSION( ASTRO_SPACETRACK_VERSION );
	1;
    };
    $have_astro_spacetrack = sub { $value };
    return $value;
};

my $default_geocoder;
$default_geocoder = sub {
    my $value =
	_can_use_geocoder( 'Astro::App::Satpass2::Geocode::OSM'
	);
    $default_geocoder = sub { return $value };
    return $value;
};

sub _can_use_geocoder {
    my ( $geocoder ) = @_;
    my $pkg = load_package( $geocoder )
	or return;
    load_package( $pkg->GEOCODER_CLASS() )
	or return;
    return $pkg;
}

my $interrupted = 'Interrupted by user.';

my %twilight_def = (
    civil => deg2rad (-6),
    nautical => deg2rad (-12),
    astronomical => deg2rad (-18),
);
my %twilight_abbr = abbrev (keys %twilight_def);

#	Individual commands are defined by subroutines of the same name,
#	and having the Verb attribute. You can specify additional
#	attributes if you need to. Following are descriptions of the
#	attributes used by  this script.
#
#	Configure(configurations)
#
#	The 'Configure' attribute specifies options to be passed to
#	Getopt::Long::Configure before the options are parsed. For
#	example, if a command wants to keep unrecognized options on the
#	command you would specify:
#	    sub foo : Configure(pass_through) Verb
#
#	Tokenize(options)
#
#	The 'Tokenize' attribute specifies tokenizatino options. These
#	can not take effect until fairly late in the parse when the
#	tokens are known. These options are parsed by Getopt::Long, and
#	the value of the attribute is a reference to the options hash
#	thus generated. Possible options are:
#	  -expand_tilde - Expand tildes in the tokens. For historical
#		reasons this is the default, but it can be negated by
#		specifying -noexpand_tilde. Tildes in redirect
#		specifications are always expanded.
#
#	Tweak(options)
#

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


    sub _set_pass_variant {
	my ( $self, $name, $val ) = @_;
	if ( $val =~ m/ \A (?: 0 x? ) [0-9]* \z /smx ) {
	    $val = oct $val;
	} elsif ( $val !~ m/ \A [0-9]+ \z /smx ) {
	    my @args = split qr{ [^\w-] }smx, $val;
	    foreach ( @args ) {
		s/ \A (?! - ) /-/smx;
	    }
	    $go ||= Getopt::Long::Parser->new();
	    $val = $self->get( $name );
	    $go->getoptionsfromarray( \@args,
		none	=> sub { $val = PASS_VARIANT_NONE },
		map { $_ => sub {
			my ( $name, $value ) = @_;
			my $mask = $variant_def{$name};
			if ( $value ) {
			    $val |= $mask;
			} else {
			    $val &= ~ $mask;
			}
			return;
		    }
		} @option_names )
		or $self->wail( "Invalid $name value '$val'" );
	}
	return ( $self->{$name} = $val );
    }

    sub _show_pass_variant {
	my ( $self, $name ) = @_;
	my $val = $self->get( $name );
	my @options;
	foreach my $key ( keys %variant_def ) {
	    $val & $variant_def{$key}
		and push @options, "$key";
	}
	@options
	    or push @options, 'none';
	return ( set => $name, join ',', @options );
    }

    sub want_pass_variant {
	my ( $self, $variant ) = @_;
	$variant_def{$variant}
	    or $self->wail( "Invalid pass_variant name '$variant'" );
	my $val = $self->get( 'pass_variant' ) & $variant_def{$variant};
	return $val;
    }

}

sub _set_spacetrack {
    my ($self, $name, $val) = @_;
    if (defined $val) {
	instance($val, 'Astro::SpaceTrack')
	    or $self->wail("$name must be an Astro::SpaceTrack instance");
	my $version = $val->VERSION();
	$version =~ s/ _ //smxg;
	$version >= ASTRO_SPACETRACK_VERSION
	    or $self->wail("$name must be Astro::SpaceTrack version ",
	    ASTRO_SPACETRACK_VERSION, ' or greater' );
    }
    return ($self->{$name} = $val);
}

sub _set_stdout {
    my ($self, $name, $val) = @_;
    $self->{frame}
	and $self->{frame}[-1]{$name} = $val;
    return ($self->{$name} = $val);
}

sub _set_sun_class {
    my ( $self, $name, $val ) = @_;
    $self->_attribute_exists( $name );
    return $self->sky( class => $name, $val );
}

sub _set_time_parser {
    my ( $self, $name, $val ) = @_;

    if ( CODE_REF eq ref $val ) {
	$val = _set_time_parser_code( $val );
    } elsif ( defined $val and my $macro = $self->{macro}{$val} ) {
	$val = _set_time_parser_code(
	    $macro->implements( $val, required => 1 ),
	    $val,
	);
    }

    return $self->_set_copyable(
	name	=> $name,
	value	=> $val,
	class	=> 'Astro::App::Satpass2::ParseTime',
	message	=> 'Unknown time parser',
	default	=> 'Astro::App::Satpass2::ParseTime',
	nocopy	=> 1,
	prefix	=> [ 'Astro::App::Satpass2::ParseTime' ],
    );
}

sub _set_time_parser_attribute {
    my ( $self, $name, $val ) = @_;
    defined $val and $val eq 'undef' and $val = undef;
    $self->{time_parser}->$name( $val );
    return $val;
}

sub _set_time_parser_code {
    my ( $code, $name ) = @_;
    require Astro::App::Satpass2::ParseTime::Code;
    my $obj = Astro::App::Satpass2::ParseTime::Code->new();
    return $obj->code( $code, $name );
}

_frame_pop_force_set ( 'twilight' );	# Force use of the set() method
					# in _frame_pop(), because we
					# need to set {_twilight} as
					# well.
sub _set_twilight {
    my ($self, $name, $val) = @_;

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

    if ( ARRAY_REF eq ref $status ) {
	Astro::Coord::ECI::TLE->status (clear => 'iridium');
	foreach (@$status) {
	    Astro::Coord::ECI::TLE->status (add => $_->[0], iridium =>
		$_->[4], $_->[1], $_->[3]);
	}
    } else {
	$self->weep(
	    'Portable status not passed, and unavailable from Astro::SpaceTrack'
	);
    }

    foreach my $tle (@{$self->{bodies}}) {
	$tle->rebless ();
    }

    return;

}

# _is_case_tolerant()
# Returns true if the OS supports case-tolerant file names. Yes, I know
# it's the file system that is important, but I don't have access to
# that level of detail.
{
    my %os = map { $_ => 1 } qw{ darwin };

    sub _is_case_tolerant {
	exists $os{$^O}
	    and return $os{$^O};
	return File::Spec->case_tolerant();
    }
}

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

use constant INTERACTIVE_CALLER => __PACKAGE__ . '::dispatch';
sub _is_interactive {
    my $level = 0;
    while ( my @info = caller( $level ) ) {
	INTERACTIVE_CALLER eq $info[3]
	    and return $level;
	$level++;
    }
    return;
}

#	$self->_load_module ($module_name)

#	Loads the module if it has not yet been loaded. Dies if it
#	can not be loaded.

{	# Begin local symbol block

    my %version;
    BEGIN {
	%version = (
	    'Astro::SpaceTrack' => ASTRO_SPACETRACK_VERSION,
	);
    }

    sub _load_module {
	my ($self, @module) = @_;
	ARRAY_REF eq ref $module[0]
	    and @module = @{$module[0]};
	@module or $self->weep( 'No module specified' );
	my @probs;
	foreach my $module (@module) {
	    load_package ($module) or do {
		push @probs, "$module needed";
		next;
	    };
	    my $modver;
	    ($version{$module} && ($modver = $module->VERSION)) and do {
		$modver =~ s/_//g;
		$modver < $version{$module} and do {
		    push @probs,
		    "$module version $version{$module} needed";
		    next;
		};
	    };
	    return $module;
	}
	{
	    my $inx = 1;
	    while (my @clr = caller($inx++)) {
		$clr[3] eq '(eval)' and next;
		my @raw = split '::', $clr[3];
		substr ($raw[-1], 0, 1) eq '_' and next;
		push @probs, "for method $raw[-1]";
		last;
	    }
	}
	my $pfx = 'Error -';
	$self->wail(map {my $x = "$pfx $_\n"; $pfx = ' ' x 7; $x} @probs);
	return;	# Can't get here, but Perl::Critic does not know this.
    }

}	# end local symbol block.

#	$output = $self->_macro($name,@args)
#
#	Execute the named macro. The @args are of course optional.

sub _macro {
    my ($self, $name, @args) = @_;
    $self->{macro}{$name} or $self->wail("No such macro as '$name'");
    my $frames = $self->_frame_push(macro => [@args]);
    my $macro = $self->{frame}[-1]{macro}{$name} =
	delete $self->{macro}{$name};
    my $output;
    my $err;
    my $ok = eval {
	$output = $macro->execute( $name, @args );
	1;
    } or $err = $@;
    $self->_frame_pop($frames);
    $ok or $self->wail($err);

( run in 1.235 second using v1.01-cache-2.11-cpan-e1769b4cff6 )