1package Astro::App::Satpass2::Utils; 2 3use 5.008; 4 5use strict; 6use warnings; 7 8use parent qw{ Exporter }; 9 10use Cwd (); 11use File::HomeDir; 12use File::Spec; 13use Getopt::Long 2.33; 14use Scalar::Util 1.26 qw{ blessed looks_like_number }; 15use Text::ParseWords (); 16 17our $VERSION = '0.049'; 18 19our @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 52our @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 @CARP_NOT 63}; 64 65our %EXPORT_TAGS = ( 66 ref => [ grep { m/ _REF \z /smx } @EXPORT_OK ], 67); 68 69use constant ARRAY_REF => ref []; 70use constant CODE_REF => ref sub {}; 71use constant HASH_REF => ref {}; 72use constant REGEXP_REF => ref qr{}; 73use constant SCALAR_REF => ref \1; 74 75# Documented in POD 76 77{ 78 79 my @default_config = qw{default pass_through}; 80 81 sub __arguments { 82 my ( $self, @args ) = @_; 83 84 has_method( $self, '__parse_time_reset' ) 85 and $self->__parse_time_reset(); 86 87 @args = map { 88 has_method( $_, 'dereference' ) ? $_->dereference() : $_ 89 } @args; 90 91 if ( HASH_REF eq ref $args[0] ) { 92 my $opt = shift @args; 93 _apply_default( $self, $opt, \@args ); 94 return( $self, $opt, @args ); 95 } 96 97=begin comment 98 99 my @data = caller(1); 100 my $code = \&{$data[3]}; 101 102 my ( $err, %opt ); 103 my $lgl = $self->__get_attr($code, 'Verb') || []; 104 if ( @{ $lgl } && ':compute' eq $lgl->[0] ) { 105 my $method = $lgl->[1]; 106 unless ( defined $method ) { 107 ( $method = $data[3] ) =~ s/ .* :: //smx; 108 $method = "__${method}_options"; 109 } 110 $lgl = $self->$method( \%opt, $lgl ); 111 } 112 113=end comment 114 115=cut 116 117 118 my ( $err, %opt ); 119 my $code = \&{ ( caller 1 )[3] }; 120 my $lgl = $self->__legal_options( $code, \%opt ); 121 122 local $SIG{__WARN__} = sub {$err = $_[0]}; 123 my $config = 124 $self->__get_attr($code, 'Configure') || \@default_config; 125 my $go = Getopt::Long::Parser->new(config => $config); 126 if ( ! $go->getoptionsfromarray( 127 \@args, \%opt, 'default=s', @$lgl) ) { 128 __error_out( $self, wail => $err ); 129 } 130 131 _apply_default( $self, \%opt, \@args ); 132 133 return ( $self, \%opt, @args ); 134 } 135} 136 137sub __legal_options { 138 my ( $self, $code, $opt ) = @_; 139 $code ||= \&{ ( caller 1 )[3] }; 140 CODE_REF eq ref $code 141 or __error_out( $self, weep => "$code not a CODE ref" ); 142 $opt ||= {}; 143 my $lgl = $self->__get_attr( $code, Verb => [] ); 144 if ( @{ $lgl } && ':compute' eq $lgl->[0] ) { 145 my $method = $lgl->[1] 146 or __error_out( $self, weep => ':compute did not specify method' ); 147 $lgl = $self->$method( $opt, $lgl ); 148 } 149 return $lgl; 150} 151 152sub _apply_default { 153 my ( $self, $opt, $args ) = @_; 154 155 my $dflt = delete $opt->{default} 156 or return; 157 158 if ( ARRAY_REF eq ref $dflt ) { 159 # Do nothing -- we already have what we want 160 } elsif ( ref $dflt ) { 161 __error_out( $self, 162 wail => "Invalid default specification $dflt" ); 163 } elsif ( my $code = $self->can( '__tokenize' ) ) { 164 ( $dflt ) = $code->( $self, $dflt ); 165 } else { 166 $dflt = [ Text::ParseWords::shellwords( $dflt ) ]; 167 } 168 169 foreach my $inx ( 0 .. $#$dflt ) { 170 defined $args->[$inx] 171 and '' ne $args->[$inx] 172 or $args->[$inx] = $dflt->[$inx]; 173 } 174 175 return; 176} 177 178sub back_end { 179 my ( $self, @arg ) = @_; 180 if ( @arg ) { 181 my ( $pkg, @cls_arg ) = ( $self->__parse_class_and_args( 182 $self->__back_end_default( $arg[0] ) ), @arg[ 1 .. $#arg ] ); 183 my $cls = $self->load_package( { fatal => 1 }, $pkg, 184 'DateTime::Calendar' ); 185 $self->__back_end_validate( $cls, @cls_arg ); 186 $self->{_back_end} = { 187 arg => \@cls_arg, 188 class => $cls, 189 pkg => $pkg, 190 }; 191 $self->{back_end} = shift @arg; 192 while ( @arg ) { 193 my ( $name, $value ) = splice @arg, 0, 2; 194 $self->{back_end} .= ",$name=$value"; 195 } 196 return $self; 197 } else { 198 wantarray 199 and return ( $self->{_back_end}{pkg}, @{ 200 $self->{_back_end}{arg} } ); 201 return $self->{back_end}; 202 } 203} 204 205sub __back_end_class_name_of_record { 206 my ( $self, $name ) = @_; 207 defined( my $back_end = $self->{_back_end}{class} ) 208 or return $name; 209 $back_end eq $self->__back_end_default() 210 and return $name; 211 $back_end =~ s/ \A DateTime::Calendar:: //smx; 212 @{ $self->{_back_end}{arg} } 213 or return "$name,back_end=$back_end"; 214 my %dt_arg = @{ $self->{_back_end}{arg} }; 215 foreach my $key ( sort keys %dt_arg ) { 216 $back_end .= ",$key=$dt_arg{$key}"; 217 } 218 return "$name,back_end='$back_end'"; 219} 220 221# $backend = __date_manip_backend() 222# 223# This subroutine loads Date::Manip and returns the backend available, 224# either 5 or 6. If Date::Manip can not be loaded it returns undef. 225# 226# The idea here is to return 6 if the O-O interface is available, and 5 227# if it is not but Date::Manip is. 228 229sub __date_manip_backend { 230 load_package( 'Date::Manip' ) 231 or return; 232 Date::Manip->isa( 'Date::Manip::DM6' ) 233 and return 6; 234 return 5; 235} 236 237{ 238 my %method_to_sub = ( 239 whinge => 'carp', 240 wail => 'croak', 241 weep => 'confess', 242 ); 243 244 # __error_out( $invocant, $method, @arg ) 245 # 246 # $method must be 'carp', 'croak', or 'confess'. 247 # 248 # If the $invocant is a blessed reference having method $method, 249 # that method is called with @arg as arguments. 250 # 251 # Otherwise Carp is loaded, $method is mapped to the corresponding 252 # Carp subroutine, and that subroutine is called with @arg as 253 # arguments. 254 # 255 # If we have not thrown an exception as a result of all this, we 256 # just return. 257 sub __error_out { 258 my ( $obj, $method, @arg ) = @_; 259 $method_to_sub{$method} 260 or $method = 'weep'; 261 if ( blessed( $obj ) && $obj->can( $method ) 262 ) { 263 $obj->$method( @arg ); 264 } else { 265 require Carp; 266 if ( my $code = Carp->can( $method_to_sub{ $method } ) ) { 267 $code->( @arg ); 268 } else { 269 Carp::confess( @arg ); 270 } 271 } 272 return; 273 } 274} 275 276sub expand_tilde { 277 my @args = @_; 278 my ( $self, $fn ) = @args > 1 ? @args : ( undef, @args ); 279 defined $fn 280 and $fn =~ s{ \A ~ ( [^/]* ) }{ _user_home_dir( $self, $1 ) }smxe; 281 return $fn; 282} 283 284{ 285 my %special = ( 286 '+' => sub { return Cwd::cwd() }, 287 '~' => sub { 288 return my_dist_config(); 289 }, 290 '' => sub { return File::HomeDir->my_home() }, 291 ); 292# $dir = $self->_user_home_dir( $user ); 293# 294# Find the home directory for the given user, croaking if this can 295# not be done. If $user is '' or undef, returns the home directory 296# for the current user. 297 298 sub _user_home_dir { 299 my ( $self, $user ) = @_; 300 defined $user 301 or $user = ''; 302 303 if ( my $code = $special{$user} ) { 304 defined( my $special_dir = $code->( $user ) ) 305 or _wail( $self, "Unable to find ~$user" ); 306 return $special_dir; 307 } else { 308 defined( my $home_dir = File::HomeDir->users_home( $user ) ) 309 or _wail( $self, "Unable to find home for $user" ); 310 return $home_dir; 311 } 312 } 313} 314 315sub find_package_pod { 316 my ( $pkg ) = @_; 317 ( my $fn = $pkg ) =~ s{ :: }{/}smxg; 318 foreach my $dir ( @INC ) { 319 defined $dir 320 and not ref $dir 321 and -d $dir 322 and -x _ 323 or next; 324 foreach my $sfx ( qw{ pod pm } ) { 325 my $path = "$dir/$fn.$sfx"; 326 -r $path 327 or next; 328 return Cwd::abs_path( $path ); 329 } 330 } 331 return; 332} 333 334sub _wail { 335 my ( $invocant, @msg ) = @_; 336 __error_out( $invocant, wail => @msg ); 337 return; # We should never get here, but Perl::Critic does not 338 # know this. 339} 340 341sub has_method { 342 my ( $object, $method ) = @_; 343 344 ref $object or return; 345 blessed( $object ) or return; 346 return $object->can( $method ); 347} 348 349sub instance { 350 my ( $object, $class ) = @_; 351 ref $object or return; 352 blessed( $object ) or return; 353 return $object->isa( $class ); 354} 355 356sub _get_my_lib { 357 my $my_lib = my_dist_config(); 358 if ( defined $my_lib ) { 359 $my_lib = File::Spec->catdir( $my_lib, 'lib' ); 360 -d $my_lib 361 or $my_lib = undef; 362 } 363 return $my_lib; 364} 365 366{ 367 my %loaded; 368 369 # CAVEAT: 370 # 371 # Unfortunately as things currently stand, the version needs to be 372 # maintained three places: 373 # - lib/Astro/App/Satpass2/Utils.pm 374 # - inc/My/Module/Recommend.pm 375 # - inc/My/Module/Test/App.pm 376 # These all need to stay the same. Sigh. 377 # Any such should be in xt/author/consistent_module_versions.t 378 379 my %version = ( 380 'DateTime::Calendar::Christian' => 0.06, 381 ); 382 383 # Expose the module version so we can test for consistent definition. 384 # IM(NS)HO the following annotation silences a false positive. 385 sub __module_version { ## no critic (RequireArgUnpacking) 386 my $module = $_[-1]; 387 require Carp; 388 exists $version{$module} 389 or Carp::confess( "Bug - Module $module has no defined version" ); 390 return $version{$module}; 391 } 392 393# my %valid_complaint = map { $_ => 1 } qw{ whinge wail weep }; 394 395 sub load_package { 396# my ( $module, @prefix ) = @_; 397 my @prefix = @_; 398 my $self; 399 blessed( $prefix[0] ) 400 and $self = shift @prefix; 401 my $opt = HASH_REF eq ref $prefix[0] ? shift @prefix : {}; 402 my $module = shift @prefix; 403 404 local @INC = @INC; 405 406 my $use_lib = exists $opt->{lib} ? $opt->{lib} : _get_my_lib(); 407 if ( defined $use_lib ) { 408 require lib; 409 lib->import( $use_lib ); 410 } 411 412 foreach ( $module, @prefix ) { 413 '' eq $_ 414 and next; 415 m/ \A [[:alpha:]]\w* (?: :: [[:alpha:]]\w* )* \z /smx 416 and next; 417 418 __error_out( $self, $opt->{complaint} || 'weep', 419 "Invalid package name '$_'", 420 ); 421 } 422 423 my $key = join ' ', $module, @prefix; 424 exists $loaded{$key} 425 and return $loaded{$key}; 426 427 local $@ = undef; 428 429 push @prefix, ''; 430 foreach my $pfx ( @prefix ) { 431 my $package = join '::', grep { $_ ne '' } $pfx, $module; 432 '' eq $package 433 and next; 434 ( my $fn = $package ) =~ s{ :: }{/}smxg; 435 eval { 436 require "$fn.pm"; ## no critic (RequireBarewordIncludes) 437 1; 438 } or next; 439 440 not $version{$package} 441 or $package->VERSION( $version{$package} ); 442 443 return ( $loaded{$key} = $package ); 444 } 445 446 if ( $opt->{fatal} ) { 447 __error_out( $self, $opt->{fatal}, "Can not load $module: $@" ); 448 } 449 450 $loaded{$key} = undef; 451 452 return; 453 } 454} 455 456# The Perl::Critic annotation on the following line should not (strictly 457# speaking) be necessary - but Subroutines::RequireArgUnpacking does not 458# understand the unpacking to be subject to the configuration 459# allow_arg_unpacking = grep 460sub merge_hashes { ## no critic (RequireArgUnpacking) 461 my @args = grep { HASH_REF eq ref $_ } @_; 462 @args == 1 463 and return $args[0]; 464 my %rslt; 465 foreach my $hash ( @args ) { 466 @rslt{ keys %{ $hash } } = values %{ $hash }; 467 } 468 return \%rslt; 469} 470 471use constant MY_PACKAGE_NAME => 'Astro-App-Satpass2'; 472 473sub my_dist_config { 474 my ( $opt ) = @_; 475 476 defined $ENV{ASTRO_APP_SATPASS2_CONFIG_DIR} 477 and return Cwd::abs_path( $ENV{ASTRO_APP_SATPASS2_CONFIG_DIR} ); 478 479 my $code = __PACKAGE__->can( "_my_dist_config_$^O" ) || \&_my_dist_config_; 480 return $code->( $opt ); 481} 482 483sub _my_dist_config_ { 484 my ( $opt ) = @_; 485 return File::HomeDir->my_dist_config( 486 MY_PACKAGE_NAME, 487 { create => $opt->{'create-directory'} }, 488 ); 489} 490 491# Called dynamically by my_dist_config() if $^O is 'darwin'. 492sub _my_dist_config_darwin { ## no critic (ProhibitUnusedPrivateSubroutines) 493 # my ( $opt ) = @_; 494 my $rslt = File::HomeDir->my_dist_data( MY_PACKAGE_NAME ) 495 or goto &_my_dist_config_; 496 return $rslt; 497} 498 499sub __parse_class_and_args { 500 my ( $self, $arg, @rest ) = @_; 501 my ( $cls, @val ) = 502 Text::ParseWords::parse_line( qr{ , }smx, 0, $arg ); 503 unless ( defined $cls && 504 $cls =~ m/ \A [_[:alpha:]] \w* (?: :: \w+ )* \z /smx ) { 505 $cls = defined $cls ? "'$cls'" : 'undef'; 506 my $warner = $self->can( 'wail' ) ? $self : $self->warner(); 507 $warner->wail( "Invalid class name $cls" ); 508 } 509 foreach ( @val ) { 510 m/ = /smx 511 or $_ .= '='; 512 }; 513 return ( $cls, ( map { split qr{ = }smx, $_, 2 } @val ), @rest ); 514} 515 516sub quoter { 517 my @args = @_; 518 my @rslt = map { _quoter( $_ ) } @args; 519 return wantarray ? @rslt : join ' ', @rslt; 520} 521 522sub _quoter { 523 my ( $string ) = @_; 524 return 'undef' unless defined $string; 525 return $string if looks_like_number ($string); 526 return q{''} unless $string; 527 return $string unless $string =~ m/ [\s'"\$] /smx; 528 $string =~ s/ ( [\\'] ) /\\$1/smxg; 529 return qq{'$string'}; 530} 531 5321; 533 534__END__ 535 536=head1 NAME 537 538Astro::App::Satpass2::Utils - Utilities for Astro::App::Satpass2 539 540=head1 SYNOPSIS 541 542 use Astro::App::Satpass2::Utils qw{ instance }; 543 instance( $foo, 'Bar' ) 544 or die '$foo is not an instance of Bar'; 545 546=head1 DESCRIPTION 547 548This module is a grab-bag of utilities needed by 549L<Astro::App::Satpass2|Astro::App::Satpass2>. 550 551This module is B<private> to the 552L<Astro::App::Satpass2|Astro::App::Satpass2> package. Any and all 553functions in it can be modified or revoked without prior notice. The 554documentation is for the convenience of the author. 555 556All documented subroutines can be exported, but none are exported by 557default. 558 559=head1 SUBROUTINES 560 561This module supports the following exportable subroutines: 562 563=head2 back_end 564 565 my ( $class, @args ) = $self->back_end(); 566 my $back_end = $self->back_end(); 567 $self->back_end( 'Christian,reform_date=uk' ); 568 $self->back_end( 'Christian', reform_date => 'uk' ); 569 $self->back_end( undef ); 570 571This mixin is both accessor and mutator for the C<back_end> attribute, 572which defines the class name for a L<DateTime|DateTime> back end module, 573and any class-specific arguments to be passed to its C<new()> method. 574 575If called without arguments it is an accessor. If called in list context 576it returns the class name as specified when it was set, followed by any 577arguments to C<new()> that were specified when it was set. If called in 578scalar context it returns the class name, with the arguments to C<new()> 579appended as C<"name=value"> strings, comma-delimited. 580 581If called with arguments it is a mutator. The first argument is the 582class name, possibly with leading C<'DateTime::Calendar::'> omitted) 583followed optionally by comma-delimited C<"name=value"> arguments to 584C<new()>. Subsequent arguments are name/value pairs of arguments to 585C<new()>. 586 587If called with a single undefined argument, it specifies the default. 588 589=head2 __back_end_class_name_of_record 590 591 sub class_name_of_record { 592 my ( $self ) = @_; 593 return $self->__back_end_class_name_of_record( 594 $self->SUPER::class_name_of_record() ); 595 } 596 597This mixin appends the C<back_end> information, if any, to the class 598name of record. It is called this way because C<SUPER::> is resolved 599with regard to the package it occurs in, not the package of the 600invocant. 601 602=head2 expand_tilde 603 604 $expansion = $self->expand_tilde( $file_name ); 605 606This mixin (so-called) performs tilde expansion on the argument, 607returning the result. Arguments that do not begin with a tilde are 608returned unmodified. In addition to the usual F<~/> and F<~user/>, we 609support F<~+/> (equivalent to F<./>) and F<~~/> (the user's 610configuration directory). The expansion of F<~~/> will result in an 611exception if the configuration directory does not exist. 612 613All that is required of the invocant is that it support the package's 614suite of error-reporting methods C<whinge()>, C<wail()>, and C<weep()>. 615 616=head2 find_package_pod 617 618 my $path = find_package_pod( $package_name ); 619 620This subroutine finds the given package in C<@INC> and returns the path 621to its POD file. C<@INC> entries which are references are ignored. 622 623The code for this subroutine borrows heavily from Neil Bowers' 624L<Module::Path|Module::Path>. In fact, I would probably have used that 625module except for the need to find the F<.pod> file if it was separate 626from the F<.pm> file. 627 628=head2 has_method 629 630 has_method( $object, $method ); 631 632This exportable subroutine returns a code reference to the named method 633if the given object has the method, or a false value otherwise. What you 634actually get is the result of C<< $invocant->can( $method ) >> if the 635invocant is a blessed reference, or a return otherwise. 636 637=head2 instance 638 639 instance( $object, $class ) 640 641This exportable subroutine returns a true value if C<$object> is an 642instance of C<$class>, and false otherwise. The C<$object> argument need 643not be a reference, nor need it be blessed, though in these cases the 644return is false. 645 646=head2 __legal_options 647 648 my $lgl = $self->__legal_options( $code, $opt ); 649 650This method takes as its arguments a code reference and an optional hash 651reference. It returns a reference to an array of 652L<Getopt::Long|Getopt::Long> option specifications derived from the 653code's C<Verb()> attribute. If the attributes are computed and the 654C<$opt> hash reference is supplied, it may be modified by the 655computation. 656 657=head2 load_package 658 659 load_package( $module ); 660 load_package( $module, 'Astro::App::Satpass2' ); 661 load_package( { lib => '.lib' }, $module ); 662 $object->load_package( { complaint => 'wail' }. $module ); 663 664This exportable subroutine loads a Perl module. The first argument is 665the name of the module itself. Subsequent arguments are prefixes to try, 666B<without> any trailing colons. 667 668This subroutine can also be called as a method. If this is done errors 669will be reported with a call to the invocant's C<weep()> method if that 670exists. Otherwise C<Carp> will be loaded and errors will be reported by 671C<Carp::confess()>. 672 673An optional first argument is a reference to a hash of option values. 674The supported values are: 675 676=over 677 678=item complaint 679 680This specifies how to report invalid module names if C<load_package()> 681is called as a method. Valid values are C<'whinge'>, C<'wail'>, and 682C<'weep'>. An invalid value is equivalent to C<'weep'>, which is the 683default. If not called as a method, this option is ignored and a call to 684C<Carp::confess()> is done. 685 686=item fatal 687 688If C<load_package()> is called as a method, this argument specifies how 689to report a failure to load the requested module. Valid values are 690C<'whinge'>, C<'wail'> and C<'weep'>. An invalid value is equivalent to 691C<'wail'>, which is the default. If C<load_package()> is not called as a 692method, any true value will cause C<Carp::croak()> to be called, and the 693failure B<not> to be recorded, so that the load can be retried with a 694different path. 695 696Either way, a false value causes C<load_package()> to simply return if 697the requested module can not be loaded. 698 699=item lib 700 701This specifies a directory to add to C<@INC> before attempting the load. 702If it is not specified, F<lib/> in the configuration directory is used. 703If it is specified as C<undef>, nothing is added to C<@INC>. No 704expansion is done on the directory name. 705 706=back 707 708In the examples, if C<$module> contains C<'Foo'>, the first example will 709try to C<require 'Foo'>, and the second will try to 710C<require 'Astro::App::Satpass2::Foo'> and C<require 'Foo'>, in that 711order. The first attempt that succeeds returns the name of the module 712actually loaded. If no attempt succeeds, C<undef> is returned. 713 714Arguments are cached, and subsequent attempts to load a module simply 715return the contents of the cache. 716 717=head2 merge_hashes 718 719 my $hash_ref = merge_hashes( \%hash1, \%hash2, ... ); 720 721This subroutine returns a reference to a hash that contains keys merged 722from all the hash references passed as arguments. Arguments which are 723not hash references are removed before processing. If there are no 724arguments, an empty hash is returned. If there is exactly one argument, 725it is returned. If there is more than one argument, a new hash is 726constructed from all keys of all hashes, and that hash is returned. If 727the same key appears in more than one argument, the value from the 728right-most argument is the one returned. 729 730=head2 my_dist_config 731 732 my $cfg_dir = my_dist_config( { 'create-directory' => 1 } ); 733 734This subroutine returns a path to the user's configuration directory. If 735environment variable C<ASTRO_APP_SATPASS2_CONFIG_DIR> is defined, that 736is expanded to an absolute path and returned regardless of any 737arguments. Otherwise it simply wraps 738 739 File::HomeDir->my_dist_config( 'Astro-App-Satpass2' ); 740 741You can pass an optional reference to an options hash (sic!). The only 742supported option is {'create-directory'}, which is passed verbatim to 743the C<File::HomeDir> C<'create'> option. 744 745If the configuration directory is found or successfully created, the 746path to it is returned. Otherwise C<undef> is returned. 747 748=head3 my_dist_config under macOS 749 750Under macOS 10.15 Catalina it has proven difficult/impossible to grant a 751launchd job access to the F<Documents/> directory, which is where 752L<File::HomeDir|File::HomeDir> puts the configuration data. 753 754To give the user a way to work around this, the C<darwin> implementation 755checks C<< File::HomeDir->my_dist_data( 'Astro-App-Satpass2' ) >> after 756the environment variable, but before the L<File::HomeDir|File::HomeDir> 757C<my_dist_config()> directory. 758 759The C<my_dist_data()> directory is 760F<~/Library/Application Support/Perl/dist/Astro-App-Satpass2/>, which is 761accessible from C<launchd> jobs, at least as of macOS 10.15 Catalina. 762This directory will B<not> be created if it does not exist, even if a 763true value was specified for the C<'create-directory'> option. 764 765=head2 __parse_class_and_args 766 767 my ( $cls, @arg ) = $self->__parse_class_and_args( $val ); 768 769This mixin parses the C<$val> as a list of comma-delimited C<name=value> 770pairs. The first element, though, is expected not to contain an equals 771sign, and in fact to be a valid class name. The invocant is only used 772for error messages, and must conform to the 773L<Astro::App::Satpass2::Warner|Astro::App::Satpass2::Warner> interface. 774 775=head2 quoter 776 777 say scalar quoter( @vals ); 778 say quoter( @vals ); 779 780This exportable subroutine quotes and escapes its arguments as necessary 781for the parser. Specifically, if an argument is: 782 783* undef, C<'undef'> is returned; 784 785* a number, C<$string> is returned unmodified; 786 787* an empty string, C<''> is returned; 788 789* a string containing white space, quotes, or dollar signs, the value is 790escaped and enclosed in double quotes (C<"">). 791 792* anything else is returned unmodified. 793 794If called in scalar context, the results are concatenated with 795C<< join ' ', ... >>. Otherwise they are simply returned. 796 797=head2 __arguments 798 799 my ( $self, $opt, @args ) = __arguments( @_ ); 800 801This subroutine is intended to be used to unpack the arguments of an 802C<Astro::App::Satpass2> interactive method or a code macro. 803 804Specifically, this subroutine expects to be called from a subroutine or 805method that has the C<Verb()> attribute, and expects the contents of the 806parentheses in the C<Verb()> attribute to be a set of 807white-space-delimited L<Getopt::Long|Getopt::Long> option 808specifications. Further, if the subroutine has a C<Configure()> 809attribute, it will be used to configure the L<Getopt::Long|Getopt::Long> 810object. 811 812The first argument is expected to be the invocant, and is always 813returned intact. 814 815Subsequent arguments are preprocessed by calling their C<dereference()> 816method if it exists. This is a severe wart on the code, but was needed 817(I thought) to get certain arguments through C<Template-Toolkit>. 818Arguments that do not have a C<dereference()> method are left 819unmodified, as are any unblessed arguments. 820 821If the first remaining argument after preprocessing is a hash reference, 822it is assumed that the options have already been processed, and we 823simply return the invocant and the remaining arguments as they now 824stand. 825 826If the first remaining argument after preprocessing is B<not> a hash 827reference, we run all the remaining arguments through 828L<Getopt::Long|Getopt::Long>, and return the invocant, the options hash 829populated by L<Getopt::Long>, and all remaining arguments. If 830L<Getopt::Long|Getopt::Long> encounters an error an exception is thrown. 831This is done using the invocant's C<wail()> method if it has one, 832otherwise C<Carp> is loaded and C<Carp::croak()> is called. 833 834=head1 CONSTANTS 835 836This module supports the following exportable constants. You can export 837them all using tag C<':ref'>. 838 839=head2 ARRAY_REF 840 841This constant is simply C<ref []>. 842 843=head2 CODE_REF 844 845This constant is simply C<ref sub {}>. 846 847=head2 HASH_REF 848 849This constant is simply C<ref {}>. 850 851=head2 REGEXP_REF 852 853This constant is simply C<ref qr{}>. 854 855=head2 SCALAR_REF 856 857This constant is simply C<ref \1>. 858 859=head1 GLOBALS 860 861This module exports the following globals: 862 863=head2 @CARP_NOT 864 865This global contains all modules in this package. 866 867=head1 SUPPORT 868 869Support is by the author. Please file bug reports at 870L<https://rt.cpan.org/Public/Dist/Display.html?Name=Astro-App-Satpass2>, 871L<https://github.com/trwyant/perl-Astro-App-Satpass2/issues>, or in 872electronic mail to the author. 873 874=head1 AUTHOR 875 876Thomas R. Wyant, III F<wyant at cpan dot org> 877 878=head1 COPYRIGHT AND LICENSE 879 880Copyright (C) 2011-2021 by Thomas R. Wyant, III 881 882This program is free software; you can redistribute it and/or modify it 883under the same terms as Perl 5.10.0. For more details, see the full text 884of the licenses in the directory LICENSES. 885 886This program is distributed in the hope that it will be useful, but 887without any warranty; without even the implied warranty of 888merchantability or fitness for a particular purpose. 889 890=cut 891 892# ex: set textwidth=72 : 893