view release on metacpan or  search on metacpan

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

    use constant HAVE_DATETIME => eval {
	require DateTime;
	require DateTime::TimeZone;
	1;
    } || 0;
}

use constant OS_IS_WINDOWS	=> {
    dos		=> 1,
    MSWin32	=> 1,
}->{$^O} || 0;

# Documented in POD

{

    my @default_config = qw{default pass_through};

    sub __arguments {
	my ( $self, @args ) = @_;

	has_method( $self, '__parse_time_reset' )
	    and $self->__parse_time_reset();

	@args = map {
	    has_method( $_, 'dereference' ) ?  $_->dereference() : $_
	} @args;

	my $code = \&{ ( caller 1 )[3] };

	if ( HASH_REF eq ref $args[0] ) {
	    my $opt = shift @args;
	    my @orig_keys = sort keys %{ $opt };
	    my $lgl = $self->__legal_options( $code, $opt );
	    my %opt_name = (
		level1	=> 1,
	    );
	    my $name;
	    foreach my $inx ( 0 .. $#$lgl ) {
		if ( CODE_REF eq ref $lgl->[$inx] ) {
		    defined $name
			or die "Bug - \$name undefined. Inx $inx; lgl @$lgl";
		    if ( exists $opt->{$name} ) {
			$lgl->[$inx]->( $name, $opt->{$name} );
		    }
		} else {
		    ( $name = $lgl->[ $inx ] ) =~ s/ \W .* //smx;
		    $opt_name{$name} = 1;
		}
	    }
	    foreach my $key ( @orig_keys ) {
		$opt_name{$key}
		    or __error_out( $self, wail => "Illegal option '$key'" );
	    }
	    _apply_default( $self, $opt, \@args );
	    return( $self, $opt, @args );
	}

=begin comment

	my @data = caller(1);
	my $code = \&{$data[3]};

	my ( $err, %opt );
	my $lgl = $self->__get_attr($code, 'Verb') || [];
	if ( @{ $lgl } && ':compute' eq $lgl->[0] ) {
	    my $method = $lgl->[1];
	    unless ( defined $method ) {
		( $method = $data[3] ) =~ s/ .* :: //smx;
		$method = "__${method}_options";
	    }
	    $lgl = $self->$method( \%opt, $lgl );
	}

=end comment

=cut


	my ( $err, %opt );
	my $lgl = $self->__legal_options( $code, \%opt );

	local $SIG{__WARN__} = sub {$err = $_[0]};
	my $config =
	    $self->__get_attr($code, 'Configure') || \@default_config;
	my $go = Getopt::Long::Parser->new(config => $config);
	if ( !  $go->getoptionsfromarray(
		\@args, \%opt, 'default=s', @$lgl) ) {
	    __error_out( $self, wail => $err );
	}

	_apply_default( $self, \%opt, \@args );

	return ( $self, \%opt, @args );
    }
}

sub __legal_options {
    my ( $self, $code, $opt ) = @_;
    $code ||= \&{ ( caller 1 )[3] };
    CODE_REF eq ref $code
	or __error_out( $self, weep => "$code not a CODE ref" );
    $opt ||= {};
    my $lgl = $self->__get_attr( $code, Verb => [] );
    if ( @{ $lgl } && ':compute' eq $lgl->[0] ) {
	my $method = $lgl->[1]
	    or __error_out( $self, weep => ':compute did not specify method' );
	$lgl = $self->$method( $opt, $lgl );
    }
    return $lgl;
}

sub _apply_default {
    my ( $self, $opt, $args ) = @_;

    my $dflt = delete $opt->{default}
	or return;

    if ( ARRAY_REF eq ref $dflt ) {
	# Do nothing -- we already have what we want
    } elsif ( ref $dflt ) {