File Coverage

blib/lib/Astro/App/Satpass2/Utils.pm

Criterion	Covered	Total	%
statement	187	252	74.2
branch	78	128	60.9
condition	13	33	39.3
subroutine	34	41	82.9
pod	9	9	100.0
total	321	463	69.3

package Astro::App::Satpass2::Utils;

use 5.008;

use strict;
use warnings;

use parent qw{ Exporter };

use Cwd ();
use File::HomeDir;
use File::Spec;
use Getopt::Long 2.33;
use Scalar::Util 1.26 qw{ blessed looks_like_number };
use Text::ParseWords ();

our $VERSION = '0.051';

our @CARP_NOT = qw{
    Astro::App::Satpass2
    Astro::App::Satpass2::Copier
    Astro::App::Satpass2::Format
    Astro::App::Satpass2::Format::Dump
    Astro::App::Satpass2::Format::Template
    Astro::App::Satpass2::FormatTime
    Astro::App::Satpass2::FormatTime::Cldr
    Astro::App::Satpass2::FormatTime::DateTime
    Astro::App::Satpass2::FormatTime::DateTime::Cldr
    Astro::App::Satpass2::FormatTime::DateTime::Strftime
    Astro::App::Satpass2::FormatTime::POSIX::Strftime
    Astro::App::Satpass2::FormatTime::Strftime
    Astro::App::Satpass2::FormatValue
    Astro::App::Satpass2::FormatValue::Formatter
    Astro::App::Satpass2::Geocode
    Astro::App::Satpass2::Geocode::OSM
    Astro::App::Satpass2::Locale
    Astro::App::Satpass2::Locale::C
    Astro::App::Satpass2::Macro
    Astro::App::Satpass2::Macro::Code
    Astro::App::Satpass2::Macro::Command
    Astro::App::Satpass2::ParseTime
    Astro::App::Satpass2::ParseTime::Code
    Astro::App::Satpass2::ParseTime::Date::Manip
    Astro::App::Satpass2::ParseTime::Date::Manip::v5
    Astro::App::Satpass2::ParseTime::Date::Manip::v6
    Astro::App::Satpass2::ParseTime::ISO8601
    Astro::App::Satpass2::Utils
    Astro::App::Satpass2::Warner
    Astro::App::Satpass2::Wrap::Array
};

our @EXPORT_OK = qw{
    __arguments
    back_end
    __back_end_class_name_of_record
    expand_tilde find_package_pod
    has_method instance load_package merge_hashes my_dist_config quoter
    __date_manip_backend
    __legal_options
    __parse_class_and_args
    ARRAY_REF CODE_REF HASH_REF REGEXP_REF SCALAR_REF
    HAVE_DATETIME
    @CARP_NOT
};

our %EXPORT_TAGS = (
    ref	=> [ grep { m/ _REF \z /smx } @EXPORT_OK ],
);

use constant ARRAY_REF	=> ref [];
use constant CODE_REF	=> ref sub {};
use constant HASH_REF	=> ref {};
use constant REGEXP_REF	=> ref qr{};
use constant SCALAR_REF	=> ref \1;

{
    local $@ = undef;

    use constant HAVE_DATETIME => eval {
	require DateTime;
	require DateTime::TimeZone;
	1;
    } || 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 ) {
	__error_out( $self,
	    wail => "Invalid default specification $dflt" );
    } elsif ( my $code = $self->can( '__tokenize' ) ) {
	( $dflt ) = $code->( $self, $dflt );
    } else {
	$dflt = [ Text::ParseWords::shellwords( $dflt ) ];
    }

    foreach my $inx ( 0 .. $#$dflt ) {
	defined $args->[$inx]
	    and '' ne $args->[$inx]
	    or $args->[$inx] = $dflt->[$inx];
    }

    return;
}

sub back_end {
    my ( $self, @arg ) = @_;
    if ( @arg ) {
	my ( $pkg, @cls_arg ) = ( $self->__parse_class_and_args(
	    $self->__back_end_default( $arg[0] ) ), @arg[ 1 .. $#arg ] );
	my $cls = $self->load_package( { fatal => 1 }, $pkg,
	    'DateTime::Calendar' );
	$self->__back_end_validate( $cls, @cls_arg );
	$self->{_back_end} = {
	    arg		=> \@cls_arg,
	    class	=> $cls,
	    pkg		=> $pkg,
	};
	$self->{back_end} = shift @arg;
	while ( @arg ) {
	    my ( $name, $value ) = splice @arg, 0, 2;
	    $self->{back_end} .= ",$name=$value";
	}
	return $self;
    } else {
	wantarray
	    and return ( $self->{_back_end}{pkg}, @{
	    $self->{_back_end}{arg} } );
	return $self->{back_end};
    }
}

sub __back_end_class_name_of_record {
    my ( $self, $name ) = @_;
    defined( my $back_end = $self->{_back_end}{class} )
	or return $name;
    $back_end eq $self->__back_end_default()
	and return $name;
    $back_end =~ s/ \A DateTime::Calendar:: //smx;
    @{ $self->{_back_end}{arg} }
	or return "$name,back_end=$back_end";
    my %dt_arg = @{ $self->{_back_end}{arg} };
    foreach my $key ( sort keys %dt_arg ) {
	$back_end .= ",$key=$dt_arg{$key}";
    }
    return "$name,back_end='$back_end'";
}

# $backend = __date_manip_backend()
#
# This subroutine loads Date::Manip and returns the backend available,
# either 5 or 6. If Date::Manip can not be loaded it returns undef.
#
# The idea here is to return 6 if the O-O interface is available, and 5
# if it is not but Date::Manip is.

sub __date_manip_backend {
    load_package( 'Date::Manip' )
	or return;
    Date::Manip->isa( 'Date::Manip::DM6' )
	and return 6;
    return 5;
}

{
    my %method_to_sub = (
	whinge	=> 'carp',
	wail	=> 'croak',
	weep	=> 'confess',
    );

    # __error_out( $invocant, $method, @arg )
    #
    # $method must be 'carp', 'croak', or 'confess'.
    #
    # If the $invocant is a blessed reference having method $method,
    # that method is called with @arg as arguments.
    #
    # Otherwise Carp is loaded, $method is mapped to the corresponding
    # Carp subroutine, and that subroutine is called with @arg as
    # arguments.
    #
    # If we have not thrown an exception as a result of all this, we
    # just return.
    sub __error_out {
	my ( $obj, $method, @arg ) = @_;
	$method_to_sub{$method}
	    or $method = 'weep';
	if ( blessed( $obj ) && $obj->can( $method )
	) {
	    $obj->$method( @arg );
	} else {
	    require Carp;
	    if ( my $code = Carp->can( $method_to_sub{ $method } ) ) {
		$code->( @arg );
	    } else {
		Carp::confess( @arg );
	    }
	}
	return;
    }
}

sub expand_tilde {
    my @args = @_;
    my ( $self, $fn ) = @args > 1 ? @args : ( undef, @args );
    defined $fn
	and $fn =~ s{ \A ~ ( [^/]* ) }{ _user_home_dir( $self, $1 ) }smxe;
    return $fn;
}

{
    my %special = (
	'+'	=> sub { return Cwd::cwd() },
	'~'	=> sub {
	    return my_dist_config();
	},
	''	=> sub { return File::HomeDir->my_home() },
    );
#	$dir = $self->_user_home_dir( $user );
#
#	Find the home directory for the given user, croaking if this can
#	not be done. If $user is '' or undef, returns the home directory
#	for the current user.

    sub _user_home_dir {
	my ( $self, $user ) = @_;
	defined $user
	    or $user = '';

	if ( my $code = $special{$user} ) {
	    defined( my $special_dir = $code->( $user ) )
		or _wail( $self, "Unable to find ~$user" );
	    return $special_dir;
	} else {
	    defined( my $home_dir = File::HomeDir->users_home( $user ) )
		or _wail( $self, "Unable to find home for $user" );
	    return $home_dir;
	}
    }
}

sub find_package_pod {
    my ( $pkg ) = @_;
    ( my $fn = $pkg ) =~ s{ :: }{/}smxg;
    foreach my $dir ( @INC ) {
	defined $dir
	    and not ref $dir
	    and -d $dir
	    and -x _
	    or next;
	foreach my $sfx ( qw{ pod pm } ) {
	    my $path = "$dir/$fn.$sfx";
	    -r $path
		or next;
	    return Cwd::abs_path( $path );
	}
    }
    return;
}

sub _wail {
    my ( $invocant, @msg ) = @_;
    __error_out( $invocant, wail => @msg );
    return;	# We should never get here, but Perl::Critic does not
		# know this.
}

sub has_method {
    my ( $object, $method ) = @_;

    ref $object or return;
    blessed( $object ) or return;
    return $object->can( $method );
}

sub instance {
    my ( $object, $class ) = @_;
    ref $object or return;
    blessed( $object ) or return;
    return $object->isa( $class );
}

sub _get_my_lib {
    my $my_lib = my_dist_config();
    if ( defined $my_lib ) {
	$my_lib = File::Spec->catdir( $my_lib, 'lib' );
	-d $my_lib
	    or $my_lib = undef;
    }
    return $my_lib;
}

{
    my %loaded;

    # CAVEAT:
    #
    # Unfortunately as things currently stand, the version needs to be
    # maintained three places:
    # - lib/Astro/App/Satpass2/Utils.pm
    # - inc/My/Module/Recommend.pm
    # - inc/My/Module/Test/App.pm
    # These all need to stay the same. Sigh.
    # Any such should be in xt/author/consistent_module_versions.t

    my %version = (
	'DateTime::Calendar::Christian'	=> 0.06,
    );

    # Expose the module version so we can test for consistent definition.
    # IM(NS)HO the following annotation silences a false positive.
    sub __module_version {	## no critic (RequireArgUnpacking)
	my $module = $_[-1];
	require Carp;
	exists $version{$module}
	    or Carp::confess( "Bug - Module $module has no defined version" );
	return $version{$module};
    }

#    my %valid_complaint = map { $_ => 1 } qw{ whinge wail weep };

    sub load_package {
#	my ( $module, @prefix ) = @_;
	my @prefix = @_;
	my $self;
	blessed( $prefix[0] )
	    and $self = shift @prefix;
	my $opt = HASH_REF eq ref $prefix[0] ? shift @prefix : {};
	my $module = shift @prefix;

	local @INC = @INC;

	my $use_lib = exists $opt->{lib} ? $opt->{lib} : _get_my_lib();
	if ( defined $use_lib ) {
	    require lib;
	    lib->import( $use_lib );
	}

	foreach ( $module, @prefix ) {
	    '' eq $_
		and next;
	    m/ \A [[:alpha:]]\w* (?: :: [[:alpha:]]\w* )* \z /smx
		and next;

	    __error_out( $self, $opt->{complaint} || 'weep',
		"Invalid package name '$_'",
	    );
	}

	my $key = join ' ', $module, @prefix;
	exists $loaded{$key}
	    and return $loaded{$key};

	local $@ = undef;

	push @prefix, '';
	foreach my $pfx ( @prefix ) {
	    my $package = join '::', grep { $_ ne '' } $pfx, $module;
	    '' eq $package
		and next;
	    ( my $fn = $package ) =~ s{ :: }{/}smxg;
	    eval {
		require "$fn.pm";	## no critic (RequireBarewordIncludes)
		1;
	    } or next;

	    not $version{$package}
		or $package->VERSION( $version{$package} );

	    return ( $loaded{$key} = $package );
	}

	if ( $opt->{fatal} ) {
	    __error_out( $self, $opt->{fatal}, "Can not load $module: $@" );
	}

	$loaded{$key} = undef;

	return;
    }
}

# The Perl::Critic annotation on the following line should not (strictly
# speaking) be necessary - but Subroutines::RequireArgUnpacking does not
# understand the unpacking to be subject to the configuration
#     allow_arg_unpacking = grep
sub merge_hashes {	## no critic (RequireArgUnpacking)
    my @args = grep { HASH_REF eq ref $_ } @_;
    @args == 1
	and return $args[0];
    my %rslt;
    foreach my $hash ( @args ) {
	@rslt{ keys %{ $hash } } = values %{ $hash };
    }
    return \%rslt;
}

use constant MY_PACKAGE_NAME	=> 'Astro-App-Satpass2';

sub my_dist_config {
    my ( $opt ) = @_;

    defined $ENV{ASTRO_APP_SATPASS2_CONFIG_DIR}
	and return Cwd::abs_path( $ENV{ASTRO_APP_SATPASS2_CONFIG_DIR} );

    my $code = __PACKAGE__->can( "_my_dist_config_$^O" ) || \&_my_dist_config_;
    return $code->( $opt );
}

sub _my_dist_config_ {
    my ( $opt ) = @_;
    return File::HomeDir->my_dist_config(
	MY_PACKAGE_NAME,
	{ create => $opt->{'create-directory'} },
    );
}

# Called dynamically by my_dist_config() if $^O is 'darwin'.
sub _my_dist_config_darwin {	## no critic (ProhibitUnusedPrivateSubroutines)
    # my ( $opt ) = @_;
    my $rslt = File::HomeDir->my_dist_data( MY_PACKAGE_NAME )
	or goto &_my_dist_config_;
    return $rslt;
}

sub __parse_class_and_args {
    my ( $self, $arg, @rest ) = @_;
    my ( $cls, @val ) =
	Text::ParseWords::parse_line( qr{ , }smx, 0, $arg );
    unless ( defined $cls &&
	$cls =~ m/ \A [_[:alpha:]] \w* (?: :: \w+ )* \z /smx ) {
	$cls = defined $cls ? "'$cls'" : 'undef';
	my $warner = $self->can( 'wail' ) ? $self : $self->warner();
	$warner->wail( "Invalid class name $cls" );
    }
    foreach ( @val ) {
	m/ = /smx
	    or $_ .= '=';
    };
    return ( $cls, ( map { split qr{ = }smx, $_, 2 } @val ), @rest );
}

sub quoter {
    my @args = @_;
    my @rslt = map { _quoter( $_ ) } @args;
    return wantarray ? @rslt : join ' ', @rslt;
}

sub _quoter {
    my ( $string ) = @_;
    return 'undef' unless defined $string;
    return $string if looks_like_number ($string);
    return q{''} unless $string;
    return $string unless $string =~ m/ [\s'"\$] /smx;
    $string =~ s/ ( [\\'] ) /\\$1/smxg;
    return qq{'$string'};
}

1;

__END__