package Astro::App::Satpass2::Utils;
use 5.008;
use strict;
use warnings;
use base 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 };
our $VERSION = '0.031';
our @EXPORT_OK = qw{
__arguments expand_tilde
has_method instance load_package merge_hashes my_dist_config quoter
__date_manip_backend
};
# 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;
'HASH' eq ref $args[0]
and return ( $self, @args );
my @data = caller(1);
my $code = \&{$data[3]};
local @ARGV = @args;
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 );
}
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->getoptions(\%opt, @$lgl) ) {
$self->can( 'wail' )
and $self->wail($err);
require Carp;
Carp::croak( $err );
}
return ( $self, \%opt, @ARGV );
}
}
# $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;
}
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 _wail {
my ( $invocant, @msg ) = @_;
ref $invocant
and $invocant->wail( @msg );
require Carp;
Carp::croak( @msg );
}
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 );
}
{
my %loaded;
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;
}
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' eq ref $prefix[0] ? shift @prefix : {};
my $module = shift @prefix;
local @INC = @INC;
my $use_lib = exists $opt->{lib} ? $opt->{lib} : $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;
my $msg = "Invalid package name '$_'";
if ( $self ) {
my $method = $opt->{complaint} || 'weep';
$valid_complaint{$method}
or $method = 'weep';
$self->can( $method )
and return $self->$method( $msg );
}
require Carp;
Carp::confess(
"Programming error - $msg"
);
}
my $key = join ' ', $module, @prefix;
exists $loaded{$key}
and return $loaded{$key};
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;
return ( $loaded{$key} = $package );
}
if ( $opt->{fatal} ) {
my $msg = "Can not load $module: $@";
my $method = $opt->{fatal};
$valid_complaint{$method}
or $method = 'wail';
$self
and $self->can( $method )
and return $self->$method( $msg );
require Carp;
Carp::croak( $msg );
}
$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' eq ref $_ } @_;
@args == 1
and return $args[0];
my %rslt;
foreach my $hash ( @args ) {
@rslt{ keys %{ $hash } } = values %{ $hash };
}
return \%rslt;
}
sub my_dist_config {
my ( $opt ) = @_;
defined $ENV{ASTRO_APP_SATPASS2_CONFIG_DIR}
and return $ENV{ASTRO_APP_SATPASS2_CONFIG_DIR};
return File::HomeDir->my_dist_config(
'Astro-App-Satpass2',
{ create => $opt->{'create-directory'} },
);
}
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__
=head1 NAME
Astro::App::Satpass2::Utils - Utilities for Astro::App::Satpass2
=head1 SYNOPSIS
use Astro::App::Satpass2::Utils qw{ instance };
instance( $foo, 'Bar' )
or die '$foo is not an instance of Bar';
=head1 DESCRIPTION
This module is a grab-bag of utilities needed by
L<Astro::App::Satpass2|Astro::App::Satpass2>.
This module is B<private> to the
L<Astro::App::Satpass2|Astro::App::Satpass2> package. Any and all
functions in it can be modified or revoked without prior notice. The
documentation is for the convenience of the author.
All documented subroutines can be exported, but none are exported by
default.
=head1 SUBROUTINES
This module supports the following exportable subroutines:
=head2 expand_tilde
$expansion = $self->expand_tilde( $file_name );
This mixin (so-called) performs tilde expansion on the argument,
returning the result. Arguments that do not begin with a tilde are
returned unmodified. In addition to the usual F<~/> and F<~user/>, we
support F<~+/> (equivalent to F<./>) and F<~~/> (the user's
configuration directory). The expansion of F<~~/> will result in an
exception if the configuration directory does not exist.
All that is required of the invocant is that it support the package's
suite of error-reporting methods C<whinge()>, C<wail()>, and C<weep()>.
=head2 has_method
has_method( $object, $method );
This exportable subroutine returns a code reference to the named method
if the given object has the method, or a false value otherwise. What you
actually get is the result of C<< $invocant->can( $method ) >> if the
invocant is a blessed reference, or a return otherwise.
=head2 instance
instance( $object, $class )
This exportable subroutine returns a true value if C<$object> is an
instance of C<$class>, and false otherwise. The C<$object> argument need
not be a reference, nor need it be blessed, though in these cases the
return is false.
=head2 load_package
load_package( $module );
load_package( $module, 'Astro::App::Satpass2' );
load_package( { lib => '.lib' }, $module );
$object->load_package( { complaint => 'wail' }. $module );
This exportable subroutine loads a Perl module. The first argument is
the name of the module itself. Subsequent arguments are prefixes to try,
B<without> any trailing colons.
This subroutine can also be called as a method. If this is done errors
will be reported with a call to the invocant's C<weep()> method if that
exists. Otherwise C<Carp> will be loaded and errors will be reported by
C<Carp::confess()>.
An optional first argument is a reference to a hash of option values.
The supported values are:
=over
=item complaint
This specifies how to report errors if C<load_package()> is called as a
method. Valid values are C<'whinge'>, C<'wail'>, and C<'weep'>. An
invalid value is equivalent to C<'weep'>, which is the default. If not
called as a method, this option is ignored and a call to
C<Carp::confess()> is done.
=item fatal
If C<load_package()> is called as a method, this argument specifies how
to report a failure to load the requested module. Valid values are
C<'whinge'>, C<'wail'> and C<'weep'>. An invalid value is equivalent to
C<'wail'>, which is the default. If C<load_package()> is not called as a
method, any true value will cause C<Carp::croak()> to be called, and the
failure B<not> to be recorded, so that the load can be retried with a
different path.
Either way, a false value causes C<load_package()> to simply return if
the requested module can not be loaded.
=item lib
This specifies a directory to add to C<@INC> before attempting the load.
If it is not specified, F<lib/> in the configuration directory is used.
If it is specified as C<undef>, nothing is added to C<@INC>. No
expansion is done on the directory name.
=back
In the examples, if C<$module> contains C<'Foo'>, the first example will
try to C<require 'Foo'>, and the second will try to
C<require 'Astro::App::Satpass2::Foo'> and C<require 'Foo'>, in that
order. The first attempt that succeeds returns the name of the module
actually loaded. If no attempt succeeds, C<undef> is returned.
Arguments are cached, and subsequent attempts to load a module simply
return the contents of the cache.
=head2 merge_hashes
my $hash_ref = merge_hashes( \%hash1, \%hash2, ... );
This subroutine returns a reference to a hash that contains keys merged
from all the hash references passed as arguments. Arguments which are
not hash references are removed before processing. If there are no
arguments, an empty hash is returned. If there is exactly one argument,
it is returned. If there is more than one argument, a new hash is
constructed from all keys of all hashes, and that hash is returned. If
the same key appears in more than one argument, the value from the
right-most argument is the one returned.
=head2 my_dist_config
my $cfg_dir = my_dist_config( { 'create-directory' => 1 } );
This subroutine returns a path to the user's configuration directory. If
environment variable C<ASTRO_APP_SATPASS2_CONFIG_DIR> is defined, that
is returned regardless of any arguments. Otherwise it simply wraps
File::HomeDir->my_dist_config( 'Astro-App-Satpass2' );
You can pass an optional reference to an options hash (sic!). The only
supported option is {'create-directory'}, which is passed verbatim to
the C<File::HomeDir> C<'create'> option.
If the configuration directory is found or successfully created, the
path to it is returned. Otherwise C<undef> is returned.
=head2 quoter
say scalar quoter( @vals );
say quoter( @vals );
This exportable subroutine quotes and escapes its arguments as necessary
for the parser. Specifically, if an argument is:
* undef, C<'undef'> is returned;
* a number, C<$string> is returned unmodified;
* an empty string, C<''> is returned;
* a string containing white space, quotes, or dollar signs, the value is
escaped and enclosed in double quotes (C<"">).
* anything else is returned unmodified.
If called in scalar context, the results are concatenated with
C<< join ' ', ... >>. Otherwise they are simply returned.
=head2 __arguments
my ( $self, $opt, @args ) = __arguments( @_ );
This subroutine is intended to be used to unpack the arguments of an
C<Astro::App::Satpass2> interactive method or a code macro.
Specifically, this subroutine expects to be called from a subroutine or
method that has the C<Verb()> attribute, and expects the contents of the
parentheses in the C<Verb()> attribute to be a set of
white-space-delimited L<Getopt::Long|Getopt::Long> option
specifications. Further, if the subroutine has a C<Configure()>
attribute, it will be used to configure the L<Getopt::Long|Getopt::Long>
object.
The first argument is expected to be the invocant, and is always
returned intact.
Subsequent arguments are preprocessed by calling their C<dereference()>
method if it exists. This is a severe wart on the code, but was needed
(I thought) to get certain arguments through C<Template-Toolkit>.
Arguments that do not have a C<dereference()> method are left
unmodified, as are any unblessed arguments.
If the first remaining argument after preprocessing is a hash reference,
it is assumed that the options have already been processed, and we
simply return the invocant and the remaining arguments as they now
stand.
If the first remaining argument after preprocessing is B<not> a hash
reference, we run all the remaining arguments through
L<Getopt::Long|Getopt::Long>, and return the invocant, the options hash
populated by L<Getopt::Long>, and all remaining arguments. If
L<Getopt::Long|Getopt::Long> encounters an error an exception is thrown.
This is done using the invocant's C<wail()> method if it has one,
otherwise C<Carp> is loaded and C<Carp::croak()> is called.
=head1 SUPPORT
Support is by the author. Please file bug reports at
L<http://rt.cpan.org>, or in electronic mail to the author.
=head1 AUTHOR
Thomas R. Wyant, III F<wyant at cpan dot org>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2011-2016 by Thomas R. Wyant, III
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl 5.10.0. For more details, see the full text
of the licenses in the directory LICENSES.
This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.
=cut
# ex: set textwidth=72 :