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


line stmt bran cond sub pod time code
1             package Astro::App::Satpass2::Utils;
2              
3 22     22   138491 use 5.008;
  22         243  
4              
5 22     22   115 use strict;
  22         48  
  22         418  
6 22     22   101 use warnings;
  22         69  
  22         903  
7              
8 22     22   9198 use parent qw{ Exporter };
  22         6589  
  22         115  
9              
10 22     22   1192 use Cwd ();
  22         63  
  22         344  
11 22     22   10807 use File::HomeDir;
  22         116849  
  22         1242  
12 22     22   160 use File::Spec;
  22         76  
  22         527  
13 22     22   4915 use Getopt::Long 2.33;
  22         78254  
  22         451  
14 22     22   3903 use Scalar::Util 1.26 qw{ blessed looks_like_number };
  22         427  
  22         1225  
15 22     22   9979 use Text::ParseWords ();
  22         29477  
  22         3043  
16              
17             our $VERSION = '0.051_01';
18              
19             our @CARP_NOT = qw{
20             Astro::App::Satpass2
21             Astro::App::Satpass2::Copier
22             Astro::App::Satpass2::Format
23             Astro::App::Satpass2::Format::Dump
24             Astro::App::Satpass2::Format::Template
25             Astro::App::Satpass2::FormatTime
26             Astro::App::Satpass2::FormatTime::Cldr
27             Astro::App::Satpass2::FormatTime::DateTime
28             Astro::App::Satpass2::FormatTime::DateTime::Cldr
29             Astro::App::Satpass2::FormatTime::DateTime::Strftime
30             Astro::App::Satpass2::FormatTime::POSIX::Strftime
31             Astro::App::Satpass2::FormatTime::Strftime
32             Astro::App::Satpass2::FormatValue
33             Astro::App::Satpass2::FormatValue::Formatter
34             Astro::App::Satpass2::Geocode
35             Astro::App::Satpass2::Geocode::OSM
36             Astro::App::Satpass2::Locale
37             Astro::App::Satpass2::Locale::C
38             Astro::App::Satpass2::Macro
39             Astro::App::Satpass2::Macro::Code
40             Astro::App::Satpass2::Macro::Command
41             Astro::App::Satpass2::ParseTime
42             Astro::App::Satpass2::ParseTime::Code
43             Astro::App::Satpass2::ParseTime::Date::Manip
44             Astro::App::Satpass2::ParseTime::Date::Manip::v5
45             Astro::App::Satpass2::ParseTime::Date::Manip::v6
46             Astro::App::Satpass2::ParseTime::ISO8601
47             Astro::App::Satpass2::Utils
48             Astro::App::Satpass2::Warner
49             Astro::App::Satpass2::Wrap::Array
50             };
51              
52             our @EXPORT_OK = qw{
53             __arguments
54             back_end
55             __back_end_class_name_of_record
56             expand_tilde find_package_pod
57             has_method instance load_package merge_hashes my_dist_config quoter
58             __date_manip_backend
59             __legal_options
60             __parse_class_and_args
61             ARRAY_REF CODE_REF HASH_REF REGEXP_REF SCALAR_REF
62             HAVE_DATETIME
63             @CARP_NOT
64             };
65              
66             our %EXPORT_TAGS = (
67             ref => [ grep { m/ _REF \z /smx } @EXPORT_OK ],
68             );
69              
70 22     22   178 use constant ARRAY_REF => ref [];
  22         56  
  22         1617  
71 22     22   146 use constant CODE_REF => ref sub {};
  22         66  
  22         1234  
72 22     22   150 use constant HASH_REF => ref {};
  22         49  
  22         1417  
73 22     22   135 use constant REGEXP_REF => ref qr{};
  22         45  
  22         1711  
74 22     22   153 use constant SCALAR_REF => ref \1;
  22         53  
  22         2205  
75              
76             {
77             local $@ = undef;
78              
79 22   50     50 use constant HAVE_DATETIME => eval {
80             require DateTime;
81             require DateTime::TimeZone;
82             1;
83 22     22   222 } || 0;
  22         65  
84              
85             }
86              
87             # Documented in POD
88              
89             {
90              
91             my @default_config = qw{default pass_through};
92              
93             sub __arguments {
94 350     350   1139 my ( $self, @args ) = @_;
95              
96 350 100       961 has_method( $self, '__parse_time_reset' )
97             and $self->__parse_time_reset();
98              
99             @args = map {
100 350 100       809 has_method( $_, 'dereference' ) ? $_->dereference() : $_
  1181         1993  
101             } @args;
102              
103 350         604 my $code = \&{ ( caller 1 )[3] };
  350         3662  
104              
105 350 100       1133 if ( HASH_REF eq ref $args[0] ) {
106 6         16 my $opt = shift @args;
107 6         10 my @orig_keys = sort keys %{ $opt };
  6         33  
108 6         24 my $lgl = $self->__legal_options( $code, $opt );
109 6         22 my %opt_name = (
110             level1 => 1,
111             );
112 6         10 my $name;
113 6         26 foreach my $inx ( 0 .. $#$lgl ) {
114 38 100       81 if ( CODE_REF eq ref $lgl->[$inx] ) {
115 4 50       11 defined $name
116             or die "Bug - \$name undefined. Inx $inx; lgl @$lgl";
117 4 100       18 if ( exists $opt->{$name} ) {
118 2         11 $lgl->[$inx]->( $name, $opt->{$name} );
119             }
120             } else {
121 34         108 ( $name = $lgl->[ $inx ] ) =~ s/ \W .* //smx;
122 34         94 $opt_name{$name} = 1;
123             }
124             }
125 6         21 foreach my $key ( @orig_keys ) {
126 9 50       30 $opt_name{$key}
127             or __error_out( $self, wail => "Illegal option '$key'" );
128             }
129 6         37 _apply_default( $self, $opt, \@args );
130 6         43 return( $self, $opt, @args );
131             }
132              
133             =begin comment
134              
135             my @data = caller(1);
136             my $code = \&{$data[3]};
137              
138             my ( $err, %opt );
139             my $lgl = $self->__get_attr($code, 'Verb') || [];
140             if ( @{ $lgl } && ':compute' eq $lgl->[0] ) {
141             my $method = $lgl->[1];
142             unless ( defined $method ) {
143             ( $method = $data[3] ) =~ s/ .* :: //smx;
144             $method = "__${method}_options";
145             }
146             $lgl = $self->$method( \%opt, $lgl );
147             }
148              
149             =end comment
150              
151             =cut
152              
153              
154 344         605 my ( $err, %opt );
155 344         984 my $lgl = $self->__legal_options( $code, \%opt );
156              
157 344     0   2472 local $SIG{__WARN__} = sub {$err = $_[0]};
  0         0  
158 344   50     1074 my $config =
159             $self->__get_attr($code, 'Configure') || \@default_config;
160 344         1750 my $go = Getopt::Long::Parser->new(config => $config);
161 344 50       31959 if ( ! $go->getoptionsfromarray(
162             \@args, \%opt, 'default=s', @$lgl) ) {
163 0         0 __error_out( $self, wail => $err );
164             }
165              
166 344         119841 _apply_default( $self, \%opt, \@args );
167              
168 344         3875 return ( $self, \%opt, @args );
169             }
170             }
171              
172             sub __legal_options {
173 350     350   841 my ( $self, $code, $opt ) = @_;
174 350   50     876 $code ||= \&{ ( caller 1 )[3] };
  0         0  
175 350 50       969 CODE_REF eq ref $code
176             or __error_out( $self, weep => "$code not a CODE ref" );
177 350   50     712 $opt ||= {};
178 350         1135 my $lgl = $self->__get_attr( $code, Verb => [] );
179 350 100 100     671 if ( @{ $lgl } && ':compute' eq $lgl->[0] ) {
  350         1660  
180 24 50       98 my $method = $lgl->[1]
181             or __error_out( $self, weep => ':compute did not specify method' );
182 24         135 $lgl = $self->$method( $opt, $lgl );
183             }
184 350         736 return $lgl;
185             }
186              
187             sub _apply_default {
188 350     350   845 my ( $self, $opt, $args ) = @_;
189              
190             my $dflt = delete $opt->{default}
191 350 100       1122 or return;
192              
193 2 50       19 if ( ARRAY_REF eq ref $dflt ) {
    50          
    50          
194             # Do nothing -- we already have what we want
195             } elsif ( ref $dflt ) {
196 0         0 __error_out( $self,
197             wail => "Invalid default specification $dflt" );
198             } elsif ( my $code = $self->can( '__tokenize' ) ) {
199 2         6 ( $dflt ) = $code->( $self, $dflt );
200             } else {
201 0         0 $dflt = [ Text::ParseWords::shellwords( $dflt ) ];
202             }
203              
204 2         12 foreach my $inx ( 0 .. $#$dflt ) {
205 14 100 66     42 defined $args->[$inx]
206             and '' ne $args->[$inx]
207             or $args->[$inx] = $dflt->[$inx];
208             }
209              
210 2         6 return;
211             }
212              
213             sub back_end {
214 0     0 1 0 my ( $self, @arg ) = @_;
215 0 0       0 if ( @arg ) {
216 0         0 my ( $pkg, @cls_arg ) = ( $self->__parse_class_and_args(
217             $self->__back_end_default( $arg[0] ) ), @arg[ 1 .. $#arg ] );
218 0         0 my $cls = $self->load_package( { fatal => 1 }, $pkg,
219             'DateTime::Calendar' );
220 0         0 $self->__back_end_validate( $cls, @cls_arg );
221             $self->{_back_end} = {
222 0         0 arg => \@cls_arg,
223             class => $cls,
224             pkg => $pkg,
225             };
226 0         0 $self->{back_end} = shift @arg;
227 0         0 while ( @arg ) {
228 0         0 my ( $name, $value ) = splice @arg, 0, 2;
229 0         0 $self->{back_end} .= ",$name=$value";
230             }
231 0         0 return $self;
232             } else {
233             wantarray
234             and return ( $self->{_back_end}{pkg}, @{
235 0 0       0 $self->{_back_end}{arg} } );
  0         0  
236 0         0 return $self->{back_end};
237             }
238             }
239              
240             sub __back_end_class_name_of_record {
241 0     0   0 my ( $self, $name ) = @_;
242             defined( my $back_end = $self->{_back_end}{class} )
243 0 0       0 or return $name;
244 0 0       0 $back_end eq $self->__back_end_default()
245             and return $name;
246 0         0 $back_end =~ s/ \A DateTime::Calendar:: //smx;
247 0 0       0 @{ $self->{_back_end}{arg} }
  0         0  
248             or return "$name,back_end=$back_end";
249 0         0 my %dt_arg = @{ $self->{_back_end}{arg} };
  0         0  
250 0         0 foreach my $key ( sort keys %dt_arg ) {
251 0         0 $back_end .= ",$key=$dt_arg{$key}";
252             }
253 0         0 return "$name,back_end='$back_end'";
254             }
255              
256             # $backend = __date_manip_backend()
257             #
258             # This subroutine loads Date::Manip and returns the backend available,
259             # either 5 or 6. If Date::Manip can not be loaded it returns undef.
260             #
261             # The idea here is to return 6 if the O-O interface is available, and 5
262             # if it is not but Date::Manip is.
263              
264             sub __date_manip_backend {
265 10 50   10   34 load_package( 'Date::Manip' )
266             or return;
267 0 0       0 Date::Manip->isa( 'Date::Manip::DM6' )
268             and return 6;
269 0         0 return 5;
270             }
271              
272             {
273             my %method_to_sub = (
274             whinge => 'carp',
275             wail => 'croak',
276             weep => 'confess',
277             );
278              
279             # __error_out( $invocant, $method, @arg )
280             #
281             # $method must be 'carp', 'croak', or 'confess'.
282             #
283             # If the $invocant is a blessed reference having method $method,
284             # that method is called with @arg as arguments.
285             #
286             # Otherwise Carp is loaded, $method is mapped to the corresponding
287             # Carp subroutine, and that subroutine is called with @arg as
288             # arguments.
289             #
290             # If we have not thrown an exception as a result of all this, we
291             # just return.
292             sub __error_out {
293 10     10   47 my ( $obj, $method, @arg ) = @_;
294 10 50       47 $method_to_sub{$method}
295             or $method = 'weep';
296 10 100 66     111 if ( blessed( $obj ) && $obj->can( $method )
297             ) {
298 5         25 $obj->$method( @arg );
299             } else {
300 5         41 require Carp;
301 5 50       96 if ( my $code = Carp->can( $method_to_sub{ $method } ) ) {
302 5         8026 $code->( @arg );
303             } else {
304 0         0 Carp::confess( @arg );
305             }
306             }
307 0         0 return;
308             }
309             }
310              
311             sub expand_tilde {
312 37     37 1 139 my @args = @_;
313 37 100       170 my ( $self, $fn ) = @args > 1 ? @args : ( undef, @args );
314 37 50       319 defined $fn
315 20         94 and $fn =~ s{ \A ~ ( [^/]* ) }{ _user_home_dir( $self, $1 ) }smxe;
316 28         370 return $fn;
317             }
318              
319             {
320             my %special = (
321             '+' => sub { return Cwd::cwd() },
322             '~' => sub {
323             return my_dist_config();
324             },
325             '' => sub { return File::HomeDir->my_home() },
326             );
327             # $dir = $self->_user_home_dir( $user );
328             #
329             # Find the home directory for the given user, croaking if this can
330             # not be done. If $user is '' or undef, returns the home directory
331             # for the current user.
332              
333             sub _user_home_dir {
334 20     20   102 my ( $self, $user ) = @_;
335 20 50       64 defined $user
336             or $user = '';
337              
338 20 100       117 if ( my $code = $special{$user} ) {
339 16 100       77 defined( my $special_dir = $code->( $user ) )
340             or _wail( $self, "Unable to find ~$user" );
341 9         92 return $special_dir;
342             } else {
343 4 100       23 defined( my $home_dir = File::HomeDir->users_home( $user ) )
344             or _wail( $self, "Unable to find home for $user" );
345 2         17 return $home_dir;
346             }
347             }
348             }
349              
350             sub find_package_pod {
351 0     0 1 0 my ( $pkg ) = @_;
352 0         0 ( my $fn = $pkg ) =~ s{ :: }{/}smxg;
353 0         0 foreach my $dir ( @INC ) {
354 0 0 0     0 defined $dir
      0        
      0        
355             and not ref $dir
356             and -d $dir
357             and -x _
358             or next;
359 0         0 foreach my $sfx ( qw{ pod pm } ) {
360 0         0 my $path = "$dir/$fn.$sfx";
361 0 0       0 -r $path
362             or next;
363 0         0 return Cwd::abs_path( $path );
364             }
365             }
366 0         0 return;
367             }
368              
369             sub _wail {
370 9     9   521 my ( $invocant, @msg ) = @_;
371 9         252 __error_out( $invocant, wail => @msg );
372 0         0 return; # We should never get here, but Perl::Critic does not
373             # know this.
374             }
375              
376             sub has_method {
377 2709     2709 1 5084 my ( $object, $method ) = @_;
378              
379 2709 100       7922 ref $object or return;
380 995 100       3677 blessed( $object ) or return;
381 970         5107 return $object->can( $method );
382             }
383              
384             sub instance {
385 1501     1501 1 2990 my ( $object, $class ) = @_;
386 1501 100       3625 ref $object or return;
387 1475 100       6046 blessed( $object ) or return;
388 981         5305 return $object->isa( $class );
389             }
390              
391             sub _get_my_lib {
392 127     127   348 my $my_lib = my_dist_config();
393 127 50       13227 if ( defined $my_lib ) {
394 0         0 $my_lib = File::Spec->catdir( $my_lib, 'lib' );
395 0 0       0 -d $my_lib
396             or $my_lib = undef;
397             }
398 127         301 return $my_lib;
399             }
400              
401             {
402             my %loaded;
403              
404             # CAVEAT:
405             #
406             # Unfortunately as things currently stand, the version needs to be
407             # maintained three places:
408             # - lib/Astro/App/Satpass2/Utils.pm
409             # - inc/My/Module/Recommend.pm
410             # - inc/My/Module/Test/App.pm
411             # These all need to stay the same. Sigh.
412             # Any such should be in xt/author/consistent_module_versions.t
413              
414             my %version = (
415             'DateTime::Calendar::Christian' => 0.06,
416             );
417              
418             # Expose the module version so we can test for consistent definition.
419             # IM(NS)HO the following annotation silences a false positive.
420             sub __module_version { ## no critic (RequireArgUnpacking)
421 0     0   0 my $module = $_[-1];
422 0         0 require Carp;
423 0 0       0 exists $version{$module}
424             or Carp::confess( "Bug - Module $module has no defined version" );
425 0         0 return $version{$module};
426             }
427              
428             # my %valid_complaint = map { $_ => 1 } qw{ whinge wail weep };
429              
430             sub load_package {
431             # my ( $module, @prefix ) = @_;
432 148     148 1 538 my @prefix = @_;
433 148         331 my $self;
434 148 100       846 blessed( $prefix[0] )
435             and $self = shift @prefix;
436 148 100       642 my $opt = HASH_REF eq ref $prefix[0] ? shift @prefix : {};
437 148         356 my $module = shift @prefix;
438              
439 148         943 local @INC = @INC;
440              
441 148 100       561 my $use_lib = exists $opt->{lib} ? $opt->{lib} : _get_my_lib();
442 148 100       555 if ( defined $use_lib ) {
443 1         19 require lib;
444 1         10 lib->import( $use_lib );
445             }
446              
447 148         639 foreach ( $module, @prefix ) {
448 212 50       547 '' eq $_
449             and next;
450 212 50       1496 m/ \A [[:alpha:]]\w* (?: :: [[:alpha:]]\w* )* \z /smx
451             and next;
452              
453 0   0     0 __error_out( $self, $opt->{complaint} || 'weep',
454             "Invalid package name '$_'",
455             );
456             }
457              
458 148         578 my $key = join ' ', $module, @prefix;
459             exists $loaded{$key}
460 148 100       1206 and return $loaded{$key};
461              
462 125         284 local $@ = undef;
463              
464 125         313 push @prefix, '';
465 125         313 foreach my $pfx ( @prefix ) {
466 171         460 my $package = join '::', grep { $_ ne '' } $pfx, $module;
  342         1093  
467 171 50       577 '' eq $package
468             and next;
469 171         932 ( my $fn = $package ) =~ s{ :: }{/}smxg;
470 171 100       402 eval {
471 171         30411 require "$fn.pm"; ## no critic (RequireBarewordIncludes)
472 71         5412 1;
473             } or next;
474              
475             not $version{$package}
476 71 50       259 or $package->VERSION( $version{$package} );
477              
478 71         628 return ( $loaded{$key} = $package );
479             }
480              
481 54 100       335 if ( $opt->{fatal} ) {
482 1         12 __error_out( $self, $opt->{fatal}, "Can not load $module: $@" );
483             }
484              
485 53         204 $loaded{$key} = undef;
486              
487 53         476 return;
488             }
489             }
490              
491             # The Perl::Critic annotation on the following line should not (strictly
492             # speaking) be necessary - but Subroutines::RequireArgUnpacking does not
493             # understand the unpacking to be subject to the configuration
494             # allow_arg_unpacking = grep
495             sub merge_hashes { ## no critic (RequireArgUnpacking)
496 0     0 1 0 my @args = grep { HASH_REF eq ref $_ } @_;
  0         0  
497 0 0       0 @args == 1
498             and return $args[0];
499 0         0 my %rslt;
500 0         0 foreach my $hash ( @args ) {
501 0         0 @rslt{ keys %{ $hash } } = values %{ $hash };
  0         0  
  0         0  
502             }
503 0         0 return \%rslt;
504             }
505              
506 22     22   203 use constant MY_PACKAGE_NAME => 'Astro-App-Satpass2';
  22         45  
  22         16042  
507              
508             sub my_dist_config {
509 139     139 1 308 my ( $opt ) = @_;
510              
511             defined $ENV{ASTRO_APP_SATPASS2_CONFIG_DIR}
512 139 100       513 and return Cwd::abs_path( $ENV{ASTRO_APP_SATPASS2_CONFIG_DIR} );
513              
514 136   50     1901 my $code = __PACKAGE__->can( "_my_dist_config_$^O" ) || \&_my_dist_config_;
515 136         463 return $code->( $opt );
516             }
517              
518             sub _my_dist_config_ {
519 136     136   320 my ( $opt ) = @_;
520             return File::HomeDir->my_dist_config(
521             MY_PACKAGE_NAME,
522 136         1146 { create => $opt->{'create-directory'} },
523             );
524             }
525              
526             # Called dynamically by my_dist_config() if $^O is 'darwin'.
527             sub _my_dist_config_darwin { ## no critic (ProhibitUnusedPrivateSubroutines)
528             # my ( $opt ) = @_;
529 0 0   0   0 my $rslt = File::HomeDir->my_dist_data( MY_PACKAGE_NAME )
530             or goto &_my_dist_config_;
531 0         0 return $rslt;
532             }
533              
534             sub __parse_class_and_args {
535 43     43   1094 my ( $self, $arg, @rest ) = @_;
536 43         314 my ( $cls, @val ) =
537             Text::ParseWords::parse_line( qr{ , }smx, 0, $arg );
538 43 50 33     4468 unless ( defined $cls &&
539             $cls =~ m/ \A [_[:alpha:]] \w* (?: :: \w+ )* \z /smx ) {
540 0 0       0 $cls = defined $cls ? "'$cls'" : 'undef';
541 0 0       0 my $warner = $self->can( 'wail' ) ? $self : $self->warner();
542 0         0 $warner->wail( "Invalid class name $cls" );
543             }
544 43         148 foreach ( @val ) {
545 4 50       14 m/ = /smx
546             or $_ .= '=';
547             };
548 43         199 return ( $cls, ( map { split qr{ = }smx, $_, 2 } @val ), @rest );
  4         55  
549             }
550              
551             sub quoter {
552 50     50 1 279 my @args = @_;
553 50         133 my @rslt = map { _quoter( $_ ) } @args;
  100         203  
554 50 100       367 return wantarray ? @rslt : join ' ', @rslt;
555             }
556              
557             sub _quoter {
558 100     100   215 my ( $string ) = @_;
559 100 50       210 return 'undef' unless defined $string;
560 100 100       330 return $string if looks_like_number ($string);
561 84 50       171 return q{''} unless $string;
562 84 100       373 return $string unless $string =~ m/ [\s'"\$] /smx;
563 16         47 $string =~ s/ ( [\\'] ) /\\$1/smxg;
564 16         75 return qq{'$string'};
565             }
566              
567             1;
568              
569             __END__