File Coverage

blib/lib/App/Framework/Feature/Args.pm
Criterion Covered Total %
statement 319 342 93.2
branch 106 132 80.3
condition 49 61 80.3
subroutine 21 21 100.0
pod 13 13 100.0
total 508 569 89.2


line stmt bran cond sub pod time code
1             package App::Framework::Feature::Args ;
2              
3             =head1 NAME
4              
5             App::Framework::Feature::Args - Handle application command line arguments
6              
7             =head1 SYNOPSIS
8              
9             # Args are loaded by default as if the script contained:
10             use App::Framework '+Args' ;
11            
12             # Alternatives...
13            
14             # Open no file handles
15             use App::Framework '+Args(open=none)' ;
16            
17             # Open only input file handles
18             use App::Framework '+Args(open=in)' ;
19            
20             # Open only output file handles
21             use App::Framework '+Args(open=out)' ;
22            
23             # Open all file handles (the default)
24             use App::Framework '+Args(open=all)' ;
25              
26              
27             =head1 DESCRIPTION
28              
29             Args feature that provides command line arguments handling.
30              
31             Arguments are defined once in a text format and this text format generates
32             both the command line arguments data, but also the man pages, help text etc.
33              
34             =head2 Argument Definition
35              
36             Arguments are specified in the application __DATA__ section in the format:
37              
38             * =
39            
40            
41              
42             The parts of the specification are defined below.
43              
44             =head3 name
45              
46             The name defines the name of the key to use to access the argument value in the arguments hash. The application framework
47             passes a reference to the argument hash as the third parameter to the application subroutine B (see L)
48              
49             =head3 specification
50              
51             The specification is in the format:
52              
53             [ ] [ ] [ ]
54              
55             The optional I is only valid for file or directory types. For a file or directory types, if no direction is specified then
56             it is assumed to be input. Direction can be one of:
57              
58             =over 4
59              
60             =item <
61              
62             An input file or directory
63              
64             =item >
65              
66             An output file or directory
67              
68             =item >>
69              
70             An output appended file
71              
72             =back
73              
74             An optional 'b' after the direction specifies that the file is binary mode (only used when the type is file).
75              
76             The B must be specified and may be one of:
77              
78             =over 4
79              
80             =item f
81              
82             A file
83              
84             =item d
85              
86             A directory
87              
88             =item s
89              
90             Any string
91              
92             =back
93              
94             Additionally, an optional multiple can be specified. If used, this can only be specified on the last argument. When it is used, this tells the
95             application framework to use the last argument as an ARRAY, pushing all subsequent specified arguments onto this. Accessing the argument
96             in the script returns the ARRAY ref containing all of the command line argument values.
97              
98             Multiple can be:
99              
100             =over 4
101              
102             =item '@'
103              
104             One or more items
105              
106             =item '*'
107              
108             Zero or more items. There is also a special case (the real reason for *) where the argument specification is of the form '
109             specify any arguments on the command line for this argument then the framework opens STDIN and provides it as a file handle.
110              
111             =back
112              
113              
114             =head3 summary
115              
116             The summary is a simple line of text used to summarise the argument. It is used in the man pages in 'usage' mode.
117              
118             =head3 default
119              
120             Defaults values are optional. If they are defined, they are in the format:
121              
122             [default=]
123              
124             When a default is defined, if the user does not specify a value for an argument then that argument takes on the defualt value.
125              
126             Also, all subsequent arguments must also be defined as optional.
127              
128             =head3 description
129              
130             The summary is multiple lines of text used to fully describe the option. It is used in the man pages in 'man' mode.
131              
132             =head2 Feature Options
133              
134             The Args feature allows control over how it opens files. By default, any input or output file definitions also create equivalent file handles
135             (the files being opened for read/write automatically). These file handles are made available only in the arguments HASH. The key name for the handle
136             being the name of the argument with the suffix '_fh'.
137              
138             For example, the following definition:
139              
140             [ARGS]
141            
142             * file=f Input file
143            
144             A simple input directory name (directory must exist)
145            
146             * out=>f Output file (file will be created)
147            
148             An output filename
149              
150             And the command line arguments:
151              
152             infile.txt outfile.txt
153              
154             Results in the arguments HASH:
155              
156             'file' => 'infile.txt'
157             'out' => 'outfile.txt'
158             'file_fh' =>
159             'out_fh' =>
160              
161             If this behaviour is not required, then you can get the framework to open just input files, output files, or none by using the 'open' option.
162              
163             Specify this in the App::Framework 'use' line as an argument to the Args feature:
164              
165             # Open no file handles
166             use App::Framework '+Args(open=none)' ;
167            
168             # Open only input file handles
169             use App::Framework '+Args(open=in)' ;
170            
171             # Open only output file handles
172             use App::Framework '+Args(open=out)' ;
173            
174             # Open all file handles (the default)
175             use App::Framework '+Args(open=all)' ;
176              
177             =head2 Variable Expansion
178              
179             Argument values can contain variables, defined using the standard Perl format:
180              
181             $
182             ${}
183              
184             When the argument is used, the variable is expanded and replaced with a suitable value. The value will be looked up from a variety of possible sources:
185             object fields (where the variable name matches the field name) or environment variables.
186              
187             The variable name is looked up in the following order, the first value found with a matching name is used:
188              
189             =over 4
190              
191             =item *
192              
193             Argument names - the values of any other arguments may be used as variables in arguments
194              
195             =item *
196              
197             Option names - the values of any command line options may be used as variables in arguments
198              
199             =item *
200              
201             Application fields - any fields of the $app object may be used as variables
202              
203             =item *
204              
205             Environment variables - if no application fields match the variable name, then the environment variables are used
206              
207             =back
208              
209              
210              
211             =head2 Script Usage
212              
213             The application framework passes a reference to the argument HASH as the third parameter to the application subroutine B. Alternatively,
214             the script can call the app object's alias to the args accessor, i.e. the B method which returns the arguments value list. Yet another
215             alternative is to call the args accessor method directly. These alternatives are shown below:
216              
217              
218             sub app
219             {
220             my ($app, $opts_href, $args_href) = @_ ;
221            
222             # use parameter
223             my $infile = $args_href->{infile}
224            
225             # access alias
226             my @args = $app->args() ;
227             $infile = $args[0] ;
228            
229             # access alias
230             @args = $app->Args() ;
231             $infile = $args[0] ;
232              
233             ($infile) = $app->args('infile') ;
234            
235             # feature object
236             @args = $app->feature('Args')->args() ;
237             $infile = $args[0] ;
238             }
239              
240              
241              
242             =head2 Examples
243              
244             With the following script definition:
245              
246             [ARGS]
247            
248             * file=f Input file
249            
250             A simple input file name (file must exist)
251            
252             * dir=d Input directory
253            
254             A simple input directory name (directory must exist)
255            
256             * out=>f Output file (file will be created)
257            
258             An output filename
259            
260             * outdir=>d Output directory
261            
262             An output directory name (path will be created)
263            
264             * append=>>f Output file append
265            
266             An output filename (an existing file will be appended; otherwise file will be created)
267            
268             * array=
269            
270             Any other command line arguments will be pushced on to this array.
271              
272             The following command line arguments:
273              
274             infile.txt indir outfile.txt odir append.txt file1.txt file2.txt file3.txt
275              
276             Give the arguments HASH values:
277              
278             'file' => 'infile.txt'
279             'file_fh' =>
280             'dir' => 'indir'
281             'out' => 'outfile.txt'
282             'out_fh' =>
283             'outdir' => 'odir'
284             'append' => 'append.txt'
285             'append_fh'=>
286             'array' => [
287             'file1.txt'
288             'file2.txt'
289             'file3.txt'
290             ]
291             'array_fh' => [
292            
293            
294            
295             ]
296              
297              
298             An example script that uses the I arguments, along with the default 'open' behaviour is:
299              
300             sub app
301             {
302             my ($app, $opts_href, $args_href) = @_ ;
303            
304             foreach my $fh (@{$args_href->{array_fh}})
305             {
306             while (my $data = <$fh>)
307             {
308             # do something ...
309             }
310             }
311             }
312            
313             __DATA__
314             [ARGS]
315             * array=f@ Input file
316            
317              
318             This script can then be called with one or more filenames and each file will be processed. Or it can be called with no
319             filenames and STDIN will then be used.
320              
321              
322              
323             =cut
324              
325 26     26   16471 use strict ;
  26         3252  
  26         1653  
326 26     26   1019 use Carp ;
  26         562  
  26         4489  
327              
328             our $VERSION = "1.007" ;
329              
330             #============================================================================================
331             # USES
332             #============================================================================================
333 26     26   160 use App::Framework::Feature ;
  26         61  
  26         134789  
334              
335             #============================================================================================
336             # OBJECT HIERARCHY
337             #============================================================================================
338             our @ISA = qw(App::Framework::Feature) ;
339              
340             #============================================================================================
341             # GLOBALS
342             #============================================================================================
343              
344              
345             =head2 FIELDS
346              
347             The following fields should be defined either in the call to 'new()', as part of a 'set()' call, or called by their accessor method
348             (which is the same name as the field):
349              
350              
351             =over 4
352              
353             =item B - list of argument definitions
354              
355             Created by the object. Once all of the arguments have been created, this field contains an ARRAY ref to the list
356             of all of the specified option specifications (see method L).
357              
358             =item B - list of argument names
359              
360             Created by the object. Once all of the arguments have been created, this field contains an ARRAY ref to the list
361             of all of the argument names.
362              
363             =item B - list of command line arguments
364              
365             Reference to @ARGV array.
366              
367             =back
368              
369             =cut
370              
371             my %FIELDS = (
372             ## User specified
373             'user_args' => [], # User-specified args
374             'argv' => [], # ref to @ARGV
375             'arg_names' => [], # List of arg names
376              
377             ## Created
378             '_arg_list' => [], # Final ARRAY ref of args - EXCLUDING any opened files
379             '_args' => {}, # Final args HASH - key = arg name; value = arg value
380             '_arg_names_hash' => {}, # List of HASHes, each hash contains details of an arg
381             '_fh_list' => [], # List of any opened file handles
382             ) ;
383              
384             #============================================================================================
385              
386             =head2 CONSTRUCTOR
387              
388             =over 4
389              
390             =cut
391              
392             #============================================================================================
393              
394              
395             =item B< new([%args]) >
396              
397             Create a new Args.
398              
399             The %args are specified as they would be in the B method (see L).
400              
401             =cut
402              
403             sub new
404             {
405 30     30 1 1103 my ($obj, %args) = @_ ;
406              
407 30   33     1283 my $class = ref($obj) || $obj ;
408              
409             # Create object
410 30         1388 my $this = $class->SUPER::new(%args,
411             ) ;
412              
413              
414 30         1953 my $args = $this->feature_args() ;
415 30         527 $this->_dbg_prt(["NEW: feature args=", $args]) ;
416 30         261 $this->_dbg_prt(["OBJ=", $this]) ;
417            
418 30         200 return($this) ;
419             }
420              
421              
422              
423             #============================================================================================
424              
425             =back
426              
427             =head2 CLASS METHODS
428              
429             =over 4
430              
431             =cut
432              
433             #============================================================================================
434              
435              
436             #-----------------------------------------------------------------------------
437              
438             =item B< init_class([%args]) >
439              
440             Initialises the Args object class variables.
441              
442             =cut
443              
444             sub init_class
445             {
446 30     30 1 255 my $class = shift ;
447 30         354 my (%args) = @_ ;
448              
449             # Add extra fields
450 30         1152 $class->add_fields(\%FIELDS, \%args) ;
451              
452             # init class
453 30         760 $class->SUPER::init_class(%args) ;
454              
455             }
456              
457             #============================================================================================
458              
459             =back
460              
461             =head2 OBJECT METHODS
462              
463             =over 4
464              
465             =cut
466              
467             #============================================================================================
468              
469             #----------------------------------------------------------------------------
470              
471             =item B< args([$name]) >
472              
473             When called with no arguments, returns the full arguments list (same as call to method L).
474              
475             When a name (or list of names) is specified: if the named arguments hash is available, returns the
476             argument values as a list; otherwise just returns the complete args list.
477              
478             =cut
479              
480             sub args
481             {
482 5     5 1 10 my $this = shift ;
483 5         10 my (@names) = @_ ;
484            
485 5         130 my $args_href = $this->_args() ;
486 5         17 my @args = $this->arg_list ;
487              
488 5 50       23 if (keys %$args_href)
489             {
490             # do named args
491 5 50       28 if (@names)
492             {
493 0         0 @args = () ;
494 0         0 foreach my $name (@names)
495             {
496 0 0       0 push @args, $args_href->{$name} if exists($args_href->{$name}) ;
497             }
498             }
499             }
500            
501 5         27 return @args ;
502             }
503              
504             #----------------------------------------------------------------------------
505              
506             =item B< Args([$name]) >
507              
508             Alias to L
509              
510             =cut
511              
512             *Args = \&args ;
513              
514              
515             #----------------------------------------------------------------------------
516              
517             =item B< arg_list() >
518              
519             Returns the full arguments list. This is the list of arguments, as specified
520             at the command line by the user.
521              
522             =cut
523              
524             sub arg_list
525             {
526 44     44 1 83 my $this = shift ;
527              
528 44         1138 my $args_aref = $this->_arg_list() ;
529              
530 44         218 return @$args_aref ;
531             }
532              
533             #----------------------------------------------------------------------------
534              
535             =item B< arg_hash() >
536              
537             Returns the full arguments hash.
538              
539             =cut
540              
541             sub arg_hash
542             {
543 103     103 1 311 my $this = shift ;
544              
545 103         3044 my $args_href = $this->_args() ;
546 103         534 return %$args_href ;
547             }
548              
549              
550             #----------------------------------------------------------------------------
551              
552             =item B
553              
554             Append the options listed in the ARRAY ref I<$args_aref> to the current args list
555              
556             =cut
557              
558             sub append_args
559             {
560 12     12 1 34 my $this = shift ;
561 12         35 my ($args_aref) = @_ ;
562              
563 12         102 $this->_dbg_prt(["Args: append_args()\n"]) ;
564              
565 12         41 my @combined_args = (@{$this->user_args}, @$args_aref) ;
  12         479  
566 12         357 $this->user_args(\@combined_args) ;
567              
568 12         104 $this->_dbg_prt(["Options: append_args() new=", $args_aref], 2) ;
569 12         80 $this->_dbg_prt(["combined=", \@combined_args], 2) ;
570              
571             ## Build new set of args
572 12         197 $this->update() ;
573            
574 12         66 return @combined_args ;
575             }
576              
577             #----------------------------------------------------------------------------
578              
579             =item B< update() >
580              
581             Take the list of args (created by calls to L) and process the list into the
582             final args list.
583              
584             Each entry in the ARRAY is an ARRAY ref containing:
585              
586             [ , , , ]
587              
588             Returns the hash of args/values
589              
590             =cut
591              
592             sub update
593             {
594 12     12 1 33 my $this = shift ;
595              
596 12         196 $this->_dbg_prt(["Args: update()\n"]) ;
597              
598             ## get user settings
599 12         401 my $args_aref = $this->user_args ;
600              
601             ## set up internals
602            
603             # rebuild these
604 12         47 my $args_href = {} ;
605              
606             # keep full details
607 12         49 my $args_names_href = {} ;
608              
609             ## fill args_href, get_args_aref
610 12         36 my $args_list = [] ;
611            
612             # Cycle through
613 12         24 my $optional = 0 ;
614 12         24 my $last_dest_type ;
615 12         62 foreach my $arg_entry_aref (@$args_aref)
616             {
617 31         153 $this->_dbg_prt(["Arg entry=", $arg_entry_aref], 2) ;
618              
619 31         95 my ($arg_spec, $summary, $description, $default_val) = @$arg_entry_aref ;
620            
621             ## Process the arg spec
622 31         45 my ($name, $pod_spec, $dest_type, $arg_type, $arg_direction, $arg_optional, $arg_append, $arg_mode) ;
623 31         149 ($name, $arg_spec, $pod_spec, $dest_type, $arg_type, $arg_direction, $arg_optional, $arg_append, $arg_mode) =
624             $this->_process_arg_spec($arg_spec) ;
625              
626 31 50       120 if ($last_dest_type)
627             {
628 0         0 $this->throw_fatal("Application definition error: arg $name defined after $last_dest_type defined as array") ;
629             }
630 31 100       98 $last_dest_type = $name if $dest_type ;
631            
632             # Set default if required
633 31 100       96 $args_href->{$name} = $default_val if (defined($default_val)) ;
634              
635             # See if optional
636 31 100       98 $arg_optional++ if defined($default_val) ;
637 31 50 66     126 if ($optional && !$arg_optional)
638             {
639 0         0 $this->throw_fatal("Application definition error: arg $name should be optional since previous arg is") ;
640             }
641 31   100     192 $optional ||= $arg_optional ;
642              
643 31         158 $this->_dbg_prt(["Args: update() - arg_optional=$arg_optional optional=$optional\n"]) ;
644            
645             # Create full entry
646 31         127 my $href = $this->_new_arg_entry($name, $arg_spec, $summary, $description, $default_val, $pod_spec, $arg_type, $arg_direction, $dest_type, $optional, $arg_append, $arg_mode) ;
647 31         169 $args_names_href->{$name} = $href ;
648              
649 31         180 $this->_dbg_prt(["Arg $name HASH=", $href], 2) ;
650              
651             # save arg in specified order
652 31         116 push @$args_list, $name ;
653             }
654              
655 12         74 $this->_dbg_prt(["update() - END\n"], 2) ;
656              
657             ## Save
658 12         404 $this->arg_names($args_list) ;
659 12         437 $this->_args($args_href) ;
660 12         340 $this->_arg_names_hash($args_names_href) ;
661              
662 12         37 return %$args_href ;
663             }
664              
665              
666              
667             #-----------------------------------------------------------------------------
668              
669             =item B< check_args() >
670              
671             At start of application, check the arguments for valid files etc.
672              
673             =cut
674              
675             sub check_args
676             {
677 34     34 1 77 my $this = shift ;
678              
679             # specified args
680 34         933 my $argv_aref = $this->argv ;
681             # values
682 34         874 my $args_href = $this->_args() ;
683             # details
684 34         831 my $arg_names_href = $this->_arg_names_hash() ;
685              
686             # File handles
687 34         965 my $fh_aref = $this->_fh_list() ;
688              
689 34         890 $this->_dbg_prt(["check_args() Names=", $arg_names_href, "Values=", $args_href, "Name list=", $this->arg_names()], 2) ;
690            
691            
692             ## Check feature settings
693 34         99 my ($open_out, $open_in) = (1, 1) ;
694 34         1333 my $feature_args = $this->feature_args ;
695 34 100       211 if ($feature_args =~ m/open\s*=\s*(out|in|no)/i)
696             {
697 9 50       50 if ($1 =~ /out/i)
    50          
698             {
699 0         0 ++$open_out ;
700             }
701             elsif ($1 =~ /in/i)
702             {
703 0         0 ++$open_in ;
704             }
705             else
706             {
707             # none
708 9         19 $open_in = 0;
709 9         14 $open_out = 0;
710             }
711             }
712             # elsif ($feature_args =~ m/open/i)
713             # {
714             # ## open both
715             # ++$open_out ;
716             # ++$open_in ;
717             # }
718            
719             ## Process each arg checking that it's been specified (where required)
720 34         99 my $idx = -1 ;
721 34         998 my $arg_list = $this->arg_names() ;
722 34         171 foreach my $name (@$arg_list)
723             {
724             # # skip if optional
725             # next if $arg_names_href->{$name}{'optional'} ;
726              
727             # create file handle name
728 45         109 my $fh_name = "${name}_fh";
729              
730 45         76 my $type = "" ;
731 45 100       171 if ($arg_names_href->{$name}{'type'} eq 'f')
732             {
733 31         52 $type = "file " ;
734             }
735 45 100       126 if ($arg_names_href->{$name}{'type'} eq 'd')
736             {
737 9         17 $type = "directory " ;
738             }
739              
740 45         86 my $value = $args_href->{$name} ;
741 45         77 my @values = ($value) ;
742              
743             ## Special handling for @* spec
744 45 100       143 if ($arg_names_href->{$name}{'dest_type'})
745             {
746 12         70 $this->_dbg_prt([" + + special dest type\n"], 2) ;
747 12 50       39 if (defined($value))
748             {
749 12         35 @values = @$value ;
750             }
751            
752 12 100       35 push @values, '' unless @values ;
753              
754 12 100 66     65 if ($open_in && ($arg_names_href->{$name}{'type'} eq 'f'))
755             {
756 7         19 $args_href->{$fh_name} = [] ;
757             }
758             }
759              
760 45         309 $this->_dbg_prt([" + values (@values) [".scalar(@values)."]\n"], 2) ;
761              
762             ## Very special case of * spec with no args - set fh to STDIN if required
763 45 100       211 if ($arg_names_href->{$name}{'dest_type'} eq '*')
764             {
765 8 100 66     61 if (!defined($value) || scalar(@$value)==0)
766             {
767 2 100 66     21 if ($open_in && ($arg_names_href->{$name}{'type'} eq 'f'))
768             {
769             # Create new entry
770 1         4 my $href = $this->_new_arg_entry($fh_name) ;
771 1         3 $arg_names_href->{$fh_name} = $href ;
772            
773             # set value
774 1         10 $args_href->{$fh_name} = [\*STDIN] ;
775              
776 1   50     4 $args_href->{$name} ||= [] ;
777 1         2 push @{$args_href->{$name}}, 'STDIN' ;
  1         3  
778            
779 1         6 next ;
780             }
781             }
782             }
783            
784            
785             ## Check all of the values
786 44         88 foreach my $val (@values)
787             {
788            
789 54         71 ++$idx ;
790 54         108 my $arg_optional = $arg_names_href->{$name}{'optional'} ;
791            
792 54         307 $this->_dbg_prt([" + checking $name value=$val, type=$type, optional=$arg_optional ..\n"], 2) ;
793            
794             # First check that an arg has been specified
795 54 100       152 if ($idx >= scalar(@$argv_aref))
796             {
797             # Ignore if * type -OR- optional
798 13 100 100     92 if ( ($arg_names_href->{$name}{'dest_type'} ne '*') && (! $arg_optional) )
799             {
800 2         12 $this->_complain_usage_exit("Must specify input $type\"$name\"") ;
801             }
802             }
803            
804 52 100       124 next unless $val ;
805            
806             ## Input
807 51 100       187 if ($arg_names_href->{$name}{'direction'} eq 'i')
808             {
809 42         187 $this->_dbg_prt([" + Check $val for existence\n"], 2) ;
810            
811             ## skip checks if optional and no value specified (i.e. do the check if a default is specified)
812 42 100 66     208 if (!$arg_optional && $val)
813             {
814             # File check
815 34 100 100     963 if ( ($arg_names_href->{$name}{'type'} eq 'f') && (! -f $val) )
816             {
817 3         16 $this->_complain_usage_exit("Must specify a valid input filename for \"$name\"") ;
818             }
819             # Directory check
820 31 100 100     204 if ( ($arg_names_href->{$name}{'type'} eq 'd') && (! -d $val) )
821             {
822 1         6 $this->_complain_usage_exit("Must specify a valid input directory for \"$name\"") ;
823             }
824             }
825             else
826             {
827 8         56 $this->_dbg_prt([" + Skipped checks opt=$arg_optional val=$val bool=".."...\n"], 2) ;
828            
829             }
830            
831            
832             ## File open
833 38 100 100     182 if ($open_in && ($arg_names_href->{$name}{'type'} eq 'f'))
834             {
835 10         591 open my $fh, "<$val" ;
836 10 50       33 if ($fh)
837             {
838 10         21 push @$fh_aref, $fh ;
839            
840 10 50       59 if ($arg_names_href->{$name}{'mode'} eq 'b')
841             {
842 0         0 binmode $fh ;
843             }
844            
845             # Create new entry
846 10         38 my $href = $this->_new_arg_entry($fh_name) ;
847 10         26 $arg_names_href->{$fh_name} = $href ;
848            
849             # set value
850 10 100       50 if ($arg_names_href->{$name}{'dest_type'})
851             {
852 6   50     21 $args_href->{$fh_name} ||= [] ;
853 6         7 push @{$args_href->{$fh_name}}, $fh ;
  6         17  
854             }
855             else
856             {
857 4         12 $args_href->{$fh_name} = $fh ;
858             }
859             }
860             else
861             {
862 0         0 $this->_complain_usage_exit("Unable to read file \"$val\" : $!") ;
863             }
864             }
865             }
866            
867             ## Output
868 47 100       145 if ($open_out)
869             {
870 23 100 100     230 if (($arg_names_href->{$name}{'direction'} eq 'o') && ($arg_names_href->{$name}{'type'} eq 'f'))
871             {
872 4         9 my $mode = '>' ;
873 4 100       16 if ($arg_names_href->{$name}{'append'})
874             {
875 2         5 $mode .= '>' ;
876             }
877            
878 4         318 open my $fh, "$mode$val" ;
879 4 50       25 if ($fh)
880             {
881 4         8 push @$fh_aref, $fh ;
882            
883 4 50       13 if ($arg_names_href->{$name}{'mode'} eq 'b')
884             {
885 0         0 binmode $fh ;
886             }
887            
888             # Create new entry
889 4         11 my $href = $this->_new_arg_entry($fh_name) ;
890 4         19 $arg_names_href->{$fh_name} = $href ;
891            
892             # set value
893 4         20 $args_href->{$fh_name} = $fh ;
894             }
895             else
896             {
897 0 0       0 my $md = $arg_names_href->{$name}{'append'} ? 'append' : 'write' ;
898            
899 0         0 $this->_complain_usage_exit("Unable to $md file \"$val\" : $!") ;
900             }
901             }
902             }
903             }
904             }
905            
906             }
907              
908             #-----------------------------------------------------------------------------
909              
910             =item B< close_args() >
911              
912             If any arguements cause files/devices to be opened, this shuts them down
913              
914             =cut
915              
916             sub close_args
917             {
918 28     28 1 93 my $this = shift ;
919              
920             # File handles
921 28         992 my $fh_aref = $this->_fh_list() ;
922            
923 28         173 foreach my $fh (@$fh_aref)
924             {
925 29         349 close $fh ;
926             }
927              
928             }
929              
930              
931              
932             #----------------------------------------------------------------------------
933              
934             =item B
935              
936             Finish any args processing and return the arguments list
937              
938             =cut
939              
940             sub get_args
941             {
942 36     36 1 80 my $this = shift ;
943              
944             # save @ARGV
945 36         1283 $this->argv(\@ARGV) ;
946 36         263 my @args = @ARGV ;
947              
948             # Copy values over
949 36         371 $this->_process_argv() ;
950              
951 36         60 my %args ;
952            
953 36         318 %args = $this->arg_hash() ;
954 36         295 $this->_dbg_prt(["Args before expand : hash=", \%args]) ;
955              
956             # Expand the args variables
957 36         206 $this->_expand_args() ;
958              
959             # Set arg list
960 36         122 my @arg_array ;
961 36         157 %args = $this->arg_hash() ;
962 36         983 my $arg_list = $this->arg_names() ;
963 36         195 foreach my $name (@$arg_list)
964             {
965 65         134 push @arg_array, $args{$name} ;
966             }
967 36         1092 $this->_arg_list(\@arg_array) ;
968              
969              
970             # return arglist
971 36         184 return $this->arg_list ;
972             }
973              
974             #----------------------------------------------------------------------------
975              
976             =item B
977              
978             Returns the HASH ref of arg if name is found; undef otherwise
979              
980             =cut
981              
982             sub arg_entry
983             {
984 104     104 1 186 my $this = shift ;
985 104         143 my ($arg_name) = @_ ;
986              
987 104         2378 my $arg_names_href = $this->_arg_names_hash() ;
988 104         131 my $arg_href ;
989 104 50       337 if (exists($arg_names_href->{$arg_name}))
990             {
991 104         142 $arg_href = $arg_names_href->{$arg_name} ;
992             }
993 104         198 return $arg_href ;
994             }
995              
996              
997             #----------------------------------------------------------------------------
998              
999             =item B
1000              
1001             Returns the args values HASH reference.
1002              
1003             =cut
1004              
1005             sub args_values_hash
1006             {
1007 72     72 1 127 my $this = shift ;
1008              
1009 72         1975 my $args_href = $this->_args() ;
1010 72         1850 my $args_names_href = $this->_arg_names_hash() ;
1011              
1012             # get args
1013 72         127 my %values ;
1014 72         283 foreach my $arg (keys %$args_names_href)
1015             {
1016 140 100       457 $values{$arg} = $args_href->{$arg} if defined($args_href->{$arg}) ;
1017             }
1018              
1019 72         274 return \%values ;
1020             }
1021              
1022             #----------------------------------------------------------------------------
1023              
1024             =item B
1025              
1026             Sets the args values based on the values in the HASH reference B<$values_href>.
1027              
1028             =cut
1029              
1030             sub args_values_set
1031             {
1032 36     36 1 81 my $this = shift ;
1033 36         66 my ($values_href) = @_ ;
1034              
1035 36         1099 my $args_href = $this->_args() ;
1036 36         945 my $args_names_href = $this->_arg_names_hash() ;
1037              
1038             ## Update
1039             # foreach my $arg (keys %$args_names_href)
1040             # {
1041             # $args_href->{$arg} = $values_href->{$arg} if defined($args_href->{$arg}) ;
1042             # }
1043              
1044             # Cycle through
1045 36         936 my $names_aref = $this->arg_names() ;
1046 36         188 foreach my $arg (@$names_aref)
1047             {
1048 65 100       188 if ( defined($args_href->{$arg}) )
1049             {
1050 63         174 my $arg_entry_href = $this->arg_entry($arg) ;
1051            
1052 63         114 $args_href->{$arg} = $values_href->{$arg} ;
1053 63         202 $arg_entry_href->{'default'} = $values_href->{$arg} ;
1054             }
1055             }
1056             }
1057              
1058             # ============================================================================================
1059             # PRIVATE METHODS
1060             # ============================================================================================
1061              
1062             #----------------------------------------------------------------------------
1063             #
1064             #=item B<_expand_args()>
1065             #
1066             #Expand any variables in the args
1067             #
1068             #=cut
1069             #
1070             sub _expand_args
1071             {
1072 36     36   87 my $this = shift ;
1073              
1074 36         1204 my $args_href = $this->_args() ;
1075 36         1061 my $args_names_href = $this->_arg_names_hash() ;
1076              
1077             # get args
1078 36         84 my %values ;
1079 36         191 foreach my $arg (keys %$args_names_href)
1080             {
1081 70 100       256 $values{$arg} = $args_href->{$arg} if defined($args_href->{$arg}) ;
1082             }
1083              
1084             # get replacement vars
1085 36         112 my @vars ;
1086 36         1142 my $app = $this->app ;
1087 36 50       186 if ($app)
1088             {
1089 36         185 my %app_vars = $app->vars ;
1090 36         330 push @vars, \%app_vars ;
1091 36         481 my %opt_vars = $app->options() ;
1092 36         164 push @vars, \%opt_vars ;
1093             }
1094 36         99 push @vars, \%ENV ;
1095            
1096             # ## expand
1097             # $this->expand_keys(\%values, \@vars) ;
1098            
1099             ## Update
1100 36         245 foreach my $arg (keys %$args_names_href)
1101             {
1102 70 100       380 $args_href->{$arg} = $values{$arg} if defined($args_href->{$arg}) ;
1103             }
1104            
1105             }
1106              
1107             #----------------------------------------------------------------------------
1108             #
1109             #=item B<_process_argv()>
1110             #
1111             #Processes the @ARGV array
1112             #
1113             #=cut
1114             #
1115             sub _process_argv
1116             {
1117 36     36   91 my $this = shift ;
1118              
1119 36         978 my $argv_aref = $this->argv() ;
1120 36         110 my @args = @$argv_aref ;
1121 36         233 $argv_aref = [] ; # clear our args, rebuild the list as we process them
1122 36         84 my $idx = 0 ;
1123              
1124 36         277 $this->_dbg_prt(["_process_argv() : args=", \@args]) ;
1125            
1126             # values
1127 36         1133 my $args_href = $this->_args() ;
1128             # details
1129 36         1019 my $args_names_href = $this->_arg_names_hash() ;
1130            
1131 36         82 my $dest_type ;
1132 36         1000 my $arg_list = $this->arg_names() ;
1133 36         154 foreach my $name (@$arg_list)
1134             {
1135 65 100       243 if ($args_names_href->{$name}{'dest_type'})
1136             {
1137             # set value
1138 16         65 $args_href->{$name} = [] ;
1139             }
1140             }
1141            
1142 36         95 foreach my $name (@$arg_list)
1143             {
1144 58 100       158 last unless @args ;
1145 50         66 my $arg = shift @args ;
1146            
1147             # set value
1148 50         77 $args_href->{$name} = $arg ;
1149 50         77 push @$argv_aref, $arg ;
1150            
1151             # get this dest type
1152 50 100       113 $dest_type = $name if $args_names_href->{$name}{'dest_type'} ;
1153              
1154 50         80 ++$idx ;
1155             }
1156              
1157             # If last arg specified as ARRAY, then convert value to ARRAY ref
1158 36 100       133 if ($dest_type)
1159             {
1160 13         22 my $arg = $args_href->{$dest_type} ;
1161 13         26 $args_href->{$dest_type} = [] ;
1162 13         22 pop @$argv_aref ;
1163              
1164             ## Handle wildcards (mainly to cope with Windoze)
1165 13 100       51 if ($arg =~ m/[\*\?]/)
1166             {
1167 1         150072 my @files = glob("$arg") ;
1168 1 50       27 if (@files)
1169             {
1170 1         5 push @{$args_href->{$dest_type}}, @files ;
  1         13  
1171 1         7 push @$argv_aref, @files ;
1172 1         16 $arg = undef ;
1173             }
1174             }
1175              
1176 13 100       43 if ($arg)
1177             {
1178 12         17 push @{$args_href->{$dest_type}}, $arg ;
  12         32  
1179 12         27 push @$argv_aref, $arg ;
1180             }
1181            
1182             }
1183              
1184 36         425 $this->_dbg_prt(["_process_argv() : args hash (so far)=", $args_href, "args now=", \@args]) ;
1185            
1186             # If there are any args left over, handle them
1187 36         135 foreach my $arg (@args)
1188             {
1189             # If last arg specified as ARRAY, then just add all ARGS
1190 20 50       40 if ($dest_type)
1191             {
1192             ## Handle wildcards (mainly to cope with Windoze)
1193 20 100       60 if ($arg =~ m/[\*\?]/)
1194             {
1195 1         151 my @files = glob("$arg") ;
1196 1 50       8 if (@files)
1197             {
1198 1         3 push @{$args_href->{$dest_type}}, @files ;
  1         6  
1199 1         6 push @$argv_aref, @files ;
1200 1         4 $arg = undef ;
1201             }
1202             }
1203            
1204 20 100       44 if ($arg)
1205             {
1206 19         20 push @{$args_href->{$dest_type}}, $arg ;
  19         37  
1207 19         39 push @$argv_aref, $arg ;
1208             }
1209             }
1210             else
1211             {
1212 0         0 push @$argv_aref, $arg ;
1213              
1214             # create name
1215 0         0 my $name = sprintf "arg%d", $idx++ ;
1216            
1217             # Create new entry
1218 0         0 my $href = $this->_new_arg_entry($name) ;
1219 0         0 $args_names_href->{$name} = $href ;
1220            
1221             # save arg in specified order
1222 0         0 push @$arg_list, $name ;
1223            
1224             # set value
1225 0         0 $args_href->{$name} = $arg ;
1226            
1227             }
1228              
1229             }
1230              
1231 36         1229 $this->argv($argv_aref) ;
1232             }
1233              
1234             #----------------------------------------------------------------------------
1235             #
1236             #=item B<_process_arg_spec($arg_spec)>
1237             #
1238             #Processes the arg specification string, returning:
1239             #
1240             # ($name, $arg_spec, $spec, $dest_type, $arg_type, $arg_direction, $arg_optional, $arg_append, $arg_mode)
1241             #
1242             #=cut
1243             #
1244             sub _process_arg_spec
1245             {
1246 31     31   56 my $this = shift ;
1247 31         60 my ($arg_spec) = @_ ;
1248              
1249 31         149 $this->_dbg_prt(["arg: _process_arg_spec($arg_spec)"], 2) ;
1250              
1251 31         55 my $developer_only = 0 ;
1252              
1253             # If arg starts with start char then remove it
1254 31         100 $arg_spec =~ s/^[\-\+\*]// ;
1255            
1256             # Get arg name
1257 31         61 my $name = $arg_spec ;
1258 31 50       135 if ($arg_spec =~ /[\'\"](\w+)[\'\"]/)
1259             {
1260 0         0 $name = $1 ;
1261 0         0 $arg_spec =~ s/[\'\"]//g ;
1262             }
1263 31         171 $name =~ s/\=.*$// ;
1264              
1265 31         64 my $spec = $arg_spec ;
1266 31         60 my $arg = "";
1267 31 50       208 if ($spec =~ s/\=(.*)$//)
1268             {
1269 31         76 $arg = $1 ;
1270             }
1271 31         194 $this->_dbg_prt(["_process_arg_spec() set: pod spec=$spec arg=$arg\n"], 2) ;
1272            
1273 31         78 my $dest_type = "" ;
1274 31 100       115 if ($arg =~ /([\@\*])/i)
1275             {
1276 6         16 $dest_type = $1 ;
1277             }
1278            
1279 31         68 my $arg_type = "" ;
1280 31 50       251 if ($arg =~ /([sfd])/i)
1281             {
1282 31         58 $arg_type = $1 ;
1283 31 100       130 if ($arg_type eq 's')
    100          
    50          
1284             {
1285 5         10 $spec .= " " ;
1286             }
1287             elsif ($arg_type eq 'f')
1288             {
1289 20         37 $spec .= " " ;
1290             }
1291             elsif ($arg_type eq 'd')
1292             {
1293 6         11 $spec .= " " ;
1294             }
1295             }
1296              
1297 31         59 my $arg_direction = "i" ;
1298 31         47 my $arg_append = "" ;
1299 31 100       278 if ($arg =~ /(i|<)/i)
    100          
    100          
1300             {
1301 8         16 $arg_direction = 'i' ;
1302 8         16 $spec .= " " ;
1303             }
1304             elsif ($arg =~ /a|>>/i)
1305             {
1306 3         7 $arg_direction = 'o' ;
1307 3         6 $arg_append = "a" ;
1308 3         6 $spec .= " " ;
1309             }
1310             elsif ($arg =~ /(o|>)/i)
1311             {
1312 6         10 $arg_direction = 'o' ;
1313 6         12 $spec .= " " ;
1314             }
1315            
1316 31         53 my $arg_optional = 0 ;
1317 31 50       110 if ($arg =~ /\?/i)
1318             {
1319 0         0 $this->_dbg_prt(["_process_arg_spec() set: optional\n"], 2) ;
1320 0         0 $arg_optional = 1 ;
1321             }
1322              
1323 31         51 my $arg_mode = "" ;
1324 31 50       114 if ($arg =~ /b/i)
1325             {
1326 0         0 $arg_mode = 'b' ;
1327             }
1328            
1329 31         174 $this->_dbg_prt(["_process_arg_spec() set: final pod spec=$spec arg=$arg\n"], 2) ;
1330            
1331 31         273 return ($name, $arg_spec, $spec, $dest_type, $arg_type, $arg_direction, $arg_optional, $arg_append, $arg_mode) ;
1332             }
1333              
1334              
1335             #----------------------------------------------------------------------------
1336             #
1337             #=item B<_new_arg_entry($name, $arg_spec, $summary, $description, $default_val, $pod_spec, $arg_type, $arg_direction, $dest_type, $optional, $arg_append, $arg_mode)>
1338             #
1339             #Create a new HASH with the specified values. Sets the values to defaults if not specified
1340             #
1341             #=cut
1342             #
1343             sub _new_arg_entry
1344             {
1345 46     46   76 my $this = shift ;
1346 46         126 my ($name, $arg_spec, $summary, $description, $default_val, $pod_spec, $arg_type, $arg_direction, $dest_type, $optional, $arg_append, $arg_mode) = @_ ;
1347            
1348 46   100     132 $summary ||= "Arg" ;
1349 46   100     203 $description ||= "" ;
1350 46   100     140 $arg_type ||= "s" ;
1351 46   100     144 $arg_direction ||= "i" ;
1352 46   100     199 $dest_type ||= "" ;
1353 46   100     187 $optional ||= 0 ;
1354 46   66     141 $arg_spec ||= "$arg_type" ;
1355 46   100     220 $arg_append ||= "" ;
1356 46   50     190 $arg_mode ||= "" ;
1357 46         700 my $entry_href =
1358             {
1359             'name'=>$name,
1360             'spec'=>$arg_spec,
1361             'summary'=>$summary,
1362             'description'=>$description,
1363             'default'=>$default_val,
1364             'pod_spec'=>$pod_spec,
1365             'type' => $arg_type,
1366             'direction' => $arg_direction,
1367             'dest_type' => $dest_type,
1368             'optional' => $optional,
1369             'append' => $arg_append,
1370             'mode' => $arg_mode,
1371             } ;
1372              
1373 46         131 return $entry_href ;
1374             }
1375              
1376             #----------------------------------------------------------------------------
1377             # Output message, usage info, then exit
1378             sub _complain_usage_exit
1379             {
1380 6     6   18 my $this = shift ;
1381 6         9 my ($complain, $exit_code) = @_ ;
1382              
1383 6         42 print "Error: $complain\n" ;
1384 6         162 $this->app->usage() ;
1385 6   50     164 $this->app->exit( $exit_code || 1 ) ;
1386             }
1387              
1388              
1389             # ============================================================================================
1390             # END OF PACKAGE
1391              
1392             =back
1393              
1394             =head1 DIAGNOSTICS
1395              
1396             Setting the debug flag to level 1 prints out (to STDOUT) some debug messages, setting it to level 2 prints out more verbose messages.
1397              
1398             =head1 AUTHOR
1399              
1400             Steve Price C<< >>
1401              
1402             =head1 BUGS
1403              
1404             None that I know of!
1405              
1406             =cut
1407              
1408             1;
1409              
1410             __END__