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__