line
stmt
bran
cond
sub
pod
time
code
1
package App::Framework::Feature::Options ;
2
3
=head1 NAME
4
5
App::Framework::Feature::Options - Handle application options
6
7
=head1 SYNOPSIS
8
9
# Options are loaded by default as if the script contained:
10
use App::Framework '+Options' ;
11
12
13
=head1 DESCRIPTION
14
15
Options feature that provides command line options handling.
16
17
Options are defined once in a text format and this text format generates
18
both the command line options data, but also the man pages, help text etc.
19
20
=head2 Option Definition
21
22
Options are specified in the application __DATA__ section in the format:
23
24
-
25
26
27
28
These user-specified options are added to the application framework options (defined dependent on whatever core/features/extensions are installed).
29
Also, the user may over ride default settings and descriptions on any application framework options by re-defining them in the script.
30
31
The parts of the specification are defined below.
32
33
=head3 name
34
35
The name defines the option name to be used at the command line, along with any command line option aliases (e.g. -log or -l, -logfile etc). Using the
36
option in the script is via a HASH where the key is the 'main' option name.
37
38
Where an option has one or more aliases, this list of names is separated by '|'. By default, the first name defined is the 'main' option name used
39
as the option HASH key. This may be overridden by quoting the name that is required to be the main name.
40
41
For example, the following name definitions:
42
43
-log|logfile|l
44
-l|'log'|logfile
45
-log
46
47
Are all access by the key 'log'
48
49
=head3 specification
50
51
(Note: This is a subset of the specification supported by L).
52
53
The specification is optional. If not defined, then the option is a boolean value - is the user specifies the option on the command line
54
then the option value is set to 1; otherwise the option value is set to 0.
55
56
When the specification is defined, it is in the format:
57
58
[ ] [ ]
59
60
The option requires an argument of the given type. Supported types
61
are:
62
63
=over 4
64
65
=item s
66
67
String. An arbitrary sequence of characters. It is valid for the
68
argument to start with C<-> or C<-->.
69
70
=item i
71
72
Integer. An optional leading plus or minus sign, followed by a
73
sequence of digits.
74
75
=item o
76
77
Extended integer, Perl style. This can be either an optional leading
78
plus or minus sign, followed by a sequence of digits, or an octal
79
string (a zero, optionally followed by '0', '1', .. '7'), or a
80
hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
81
insensitive), or a binary string (C<0b> followed by a series of '0'
82
and '1').
83
84
=item f
85
86
Real number. For example C<3.14>, C<-6.23E24> and so on.
87
88
=back
89
90
The I can be C<@> or C<%> to specify that the option is
91
list or a hash valued. This is only needed when the destination for
92
the option value is not otherwise specified. It should be omitted when
93
not needed.
94
95
The I, if used, can be C to specify that the option is meant for application developer
96
use only. In this case, the option will not be shown in the normal help and man pages, but will
97
only be shown when the -man-dev option is used.
98
99
=head3 summary
100
101
The summary is a simple line of text used to summarise the option. It is used in the man pages in 'usage' mode.
102
103
=head3 default
104
105
Defaults values are optional. If they are defined, they are in the format:
106
107
[default=]
108
109
When a default is defined, if the user does not specify a value for an option then that option takes on the defualt value.
110
111
=head3 description
112
113
The summary is multiple lines of text used to fully describe the option. It is used in the man pages in 'man' mode.
114
115
=head2 Variable Expansion
116
117
Option values and default values can contain variables, defined using the standard Perl format:
118
119
$
120
${}
121
122
When the option is used, the variable is expanded and replaced with a suitable value. The value will be looked up from a variety of possible sources:
123
object fields (where the variable name matches the field name) or environment variables.
124
125
The variable name is looked up in the following order, the first value found with a matching name is used:
126
127
=over 4
128
129
=item *
130
131
Option names - the values of any other options may be used as variables in options
132
133
=item *
134
135
Application fields - any fields of the $app object may be used as variables
136
137
=item *
138
139
Environment variables - if no application fields match the variable name, then the environment variables are used
140
141
=back
142
143
=head2 Script Usage
144
145
The application framework passes a reference to the options HASH as the second parameter to the application subroutine B. Alternatively,
146
the script can call the app object's alias to the options accessor, i.e. the B method which returns the options hash. Yet another
147
alternative is to call the options accessor method directly. These alternatives are shown below:
148
149
150
sub app
151
{
152
my ($app, $opts_href, $args_href) = @_ ;
153
154
# use parameter
155
my $log = $opts_href->{log}
156
157
# access alias
158
my %options = $app->options() ;
159
$log = $options{log} ;
160
161
# access alias
162
%options = $app->Options() ;
163
$log = $options{log} ;
164
165
# feature object
166
%options = $app->feature('Options')->options() ;
167
$log = $options{log} ;
168
}
169
170
171
172
=head2 Examples
173
174
With the following script definition:
175
176
[OPTIONS]
177
178
-n|'name'=s Test name [default=a name]
179
180
String option, accessed as $opts_href->{name}.
181
182
-nomacro Do not create test macro calls
183
184
Boolean option, accessed as $opts_href->{nomacro}
185
186
-log=s Override default [default=another default]
187
188
Over rides the default log option (specified by the framework)
189
190
-int=i An integer
191
192
Example of integer option
193
194
-float=f An float
195
196
Example of float option
197
198
-array=s@ An array
199
200
Example of an array option
201
202
-hash=s% A hash
203
204
Example of a hash option
205
206
The following command line options are valid:
207
208
-int 1234 -float 1.23 -array a -array b -array c -hash key1=val1 -hash key2=val2 -nomacro
209
210
Giving the options HASH values:
211
212
'name' => 'a name'
213
'nomacro' => 1
214
'log' => 'another default'
215
'int' => 1234
216
'float' => 1.23
217
'array' => [ 'a', 'b', 'c' ]
218
'hash' => {
219
'key1' => 'val1',
220
'key2' => 'val2',
221
}
222
223
=cut
224
225
26
26
23308
use strict ;
26
63
26
1524
226
26
26
180
use Carp ;
26
64
26
4583
227
228
our $VERSION = "1.005" ;
229
230
231
#============================================================================================
232
# USES
233
#============================================================================================
234
26
26
7814
use Getopt::Long qw(:config no_ignore_case) ;
26
31108
26
677
235
236
26
26
10635
use App::Framework::Feature ;
26
82
26
676
237
26
26
156
use App::Framework::Base ;
26
66
26
86547
238
239
#============================================================================================
240
# OBJECT HIERARCHY
241
#============================================================================================
242
our @ISA = qw(App::Framework::Feature) ;
243
244
#============================================================================================
245
# GLOBALS
246
#============================================================================================
247
248
=head2 FIELDS
249
250
The following fields should be defined either in the call to 'new()', as part of a 'set()' call, or called by their accessor method
251
(which is the same name as the field):
252
253
254
=over 4
255
256
=item B - list of options
257
258
Created by the object. Once all of the options have been created, this field contains an ARRAY ref to the list
259
of all of the specified option specifications (see method L).
260
261
=item B - list of options names
262
263
Created by the object. Once all of the options have been created, this field contains an ARRAY ref to the list
264
of all of the option field names.
265
266
=back
267
268
=cut
269
270
my %FIELDS = (
271
'user_options' => [], # User-specified options
272
'option_names' => [], # List of option names
273
274
'_options' => {}, # Final options HASH - key = option name; value = option value
275
'_option_fields_hash' => {}, # List of HASHes, each hash contains details of an option
276
'_get_options' => [], # Options converted into list for GetOpts
277
'_options_list' => [], # Processed list of options (with duplicates removed)
278
) ;
279
280
281
#============================================================================================
282
283
=head2 CONSTRUCTOR
284
285
=over 4
286
287
=cut
288
289
#============================================================================================
290
291
292
=item B< new([%args]) >
293
294
Create a new Options.
295
296
The %args are specified as they would be in the B method to set field values (see L).
297
298
=cut
299
300
sub new
301
{
302
26
26
1
848
my ($obj, %args) = @_ ;
303
304
26
33
915
my $class = ref($obj) || $obj ;
305
306
# Create object
307
26
1156
my $this = $class->SUPER::new(%args,
308
'priority' => $App::Framework::Base::PRIORITY_SYSTEM + 10, # needs to be before data
309
# 'registered' => [qw/getopts_entry/],
310
) ;
311
312
313
26
213
return($this) ;
314
}
315
316
317
318
#============================================================================================
319
320
=back
321
322
=head2 CLASS METHODS
323
324
=over 4
325
326
=cut
327
328
#============================================================================================
329
330
331
#-----------------------------------------------------------------------------
332
333
=item B< init_class([%args]) >
334
335
Initialises the Options object class variables.
336
337
=cut
338
339
sub init_class
340
{
341
26
26
1
310
my $class = shift ;
342
26
240
my (%args) = @_ ;
343
344
# Add extra fields
345
26
861
$class->add_fields(\%FIELDS, \%args) ;
346
347
# init class
348
26
817
$class->SUPER::init_class(%args) ;
349
350
}
351
352
#============================================================================================
353
354
=back
355
356
=head2 OBJECT METHODS
357
358
=over 4
359
360
=cut
361
362
#============================================================================================
363
364
365
#----------------------------------------------------------------------------
366
367
=item B< options() >
368
369
Feature accessor method (aliases on the app object as B)
370
371
Returns the hash of options/values
372
373
=cut
374
375
sub options
376
{
377
486
486
1
621
my $this = shift ;
378
379
486
1682
$this->_dbg_prt( ["Options()\n"] ) ;
380
381
486
13272
my $options_href = $this->_options() ;
382
486
6053
return %$options_href ;
383
}
384
385
#----------------------------------------------------------------------------
386
387
=item B< Options([%args]) >
388
389
Alias to L
390
391
=cut
392
393
*Options = \&options ;
394
395
#----------------------------------------------------------------------------
396
397
=item B
398
399
Returns the value of the named option
400
401
=cut
402
403
sub option
404
{
405
61
61
1
77
my $this = shift ;
406
61
69
my ($option_name) = @_ ;
407
408
61
1369
my $options_href = $this->_options() ;
409
61
50
252
return exists($options_href->{$option_name}) ? $options_href->{$option_name} : undef ;
410
}
411
412
#----------------------------------------------------------------------------
413
414
=item B< update() >
415
416
(Called by App::Framework::Core)
417
418
Take the list of options (created by calls to L) and process the list into the
419
final options list.
420
421
Returns the hash of options/values
422
423
=cut
424
425
sub update
426
{
427
206
206
1
373
my $this = shift ;
428
429
206
1231
$this->_dbg_prt( ["update()\n"] ) ;
430
431
206
100
744
if ( $this->debug()>=2 )
432
{
433
12
81
$this->dump_callstack() ;
434
}
435
436
## get user settings
437
206
6100
my $options_aref = $this->user_options ;
438
439
## set up internals
440
441
# rebuild these
442
206
429
my $options_href = {} ;
443
206
378
my $get_options_aref = [] ;
444
206
379
my $option_names_aref = [] ;
445
446
# keep full details
447
# my $options_fields_href = $this->_option_fields_hash($options_fields_href) ;
448
206
414
my $options_fields_href = {} ;
449
450
451
## process to see if any options are to be over-ridden
452
206
326
my %options ;
453
my @processed_options ;
454
206
507
foreach my $option_aref (@$options_aref)
455
{
456
2370
4994
my ($spec, $summary, $default_val, $description) = @$option_aref ;
457
458
# split spec into the field names
459
2370
5222
my ($field, $option_spec, $pod_spec, $dest_type, $developer_only, $fields_aref, $arg_type) =
460
$this->_process_option_spec($spec) ;
461
462
# see if any fields have been seen before
463
2370
4020
my $in_list = 0 ;
464
2370
3582
foreach my $fnm (@$fields_aref)
465
{
466
2962
13943
$this->_dbg_prt( ["opt: Checking '$fnm' ($option_aref)..\n"], 2 ) ;
467
468
2962
100
8702
if (exists($options{$fnm}))
469
{
470
720
2255
$this->_dbg_prt( ["opt: '$fnm' seen before\n"], 2 ) ;
471
# seen before - overwrite settings
472
720
1241
my $aref = $options{$fnm} ;
473
720
707
$in_list = 1;
474
475
# [$spec, $summary, $description, $default_val]
476
720
1700
for (my $i=1; $i < scalar(@$option_aref); $i++)
477
{
478
2880
9658
$this->_dbg_prt( ["opt: checking $i\n"], 2 ) ;
479
# if newer entry is set to something then use it
480
2880
100
7522
if ($option_aref->[$i])
481
{
482
2174
50
3926
my $old = $aref->[$i] || '' ;
483
2174
8106
$this->_dbg_prt( ["opt: overwrite $i : '$old' with '$option_aref->[$i]'\n"], 2 ) ;
484
2174
7707
$aref->[$i] = $option_aref->[$i] ;
485
}
486
}
487
}
488
else
489
{
490
2242
10133
$this->_dbg_prt( ["opt: '$fnm' new $option_aref\n"], 2 ) ;
491
# save for later checking
492
2242
9170
$options{$fnm} = $option_aref ;
493
}
494
}
495
2370
12624
$this->_dbg_prt( ["opt: In list $in_list ($option_aref)\n"], 2 ) ;
496
497
2370
100
9813
push @processed_options, $option_aref unless $in_list ;
498
}
499
206
480
$options_aref = \@processed_options ;
500
501
502
## fill options_href, get_options_aref
503
504
# Cycle through
505
206
435
foreach my $option_entry_aref (@$options_aref)
506
{
507
1744
3680
my ($option_spec, $summary, $description, $default_val, $owner_pkg) = @$option_entry_aref ;
508
509
## Process the option spec
510
1744
1962
my ($field, $spec, $dest_type, $developer_only, $fields_aref, $arg_type) ;
511
1744
3504
($field, $option_spec, $spec, $dest_type, $developer_only, $fields_aref, $arg_type) =
512
$this->_process_option_spec($option_spec) ;
513
514
# Set default if required
515
1744
100
5445
$options_href->{$field} = $default_val if (defined($default_val)) ;
516
517
# Add to Getopt list
518
1744
4863
push @$get_options_aref, $option_spec => \$options_href->{$field} ;
519
520
# Create full entry
521
1744
997399
$options_fields_href->{$field} = {
522
'field'=>$field,
523
'spec'=>$option_spec,
524
'summary'=>$summary,
525
'description'=>$description,
526
'default'=>$default_val,
527
'pod_spec'=>$spec,
528
'type' => $arg_type,
529
'dest_type' => $dest_type,
530
'developer' => $developer_only,
531
'entry' => $option_entry_aref,
532
'owner' => $owner_pkg,
533
} ;
534
535
# add to list of names
536
1744
5575
push @$option_names_aref, $field ;
537
}
538
206
1073
$this->_dbg_prt( ["update() set: Getopts spec=", $get_options_aref] , 2) ;
539
206
1040
$this->_dbg_prt( ["update() - END\n"], 2 ) ;
540
541
## Save
542
206
240330
$this->_options_list($options_aref) ;
543
206
6530
$this->_options($options_href) ;
544
206
6934
$this->_get_options($get_options_aref) ;
545
206
6128
$this->_option_fields_hash($options_fields_href) ;
546
547
206
8292
$this->option_names($option_names_aref) ;
548
549
206
1139
return %$options_href ;
550
}
551
552
#----------------------------------------------------------------------------
553
554
=item B
555
556
Append the options listed in the ARRAY ref I<$options_aref> to the current options list
557
558
Each entry in the ARRAY ref is an ARRAY ref containing:
559
560
[ , , , ]
561
562
Where the is in the format (see L and L above). The summary and description
563
are as describe in L. The optional default value is just the value (rather than the string '[default=...]').
564
565
Can optionally specify the caller package name (otherwise works out the caller and stores that package name)
566
567
=cut
568
569
sub append_options
570
{
571
169
169
1
314
my $this = shift ;
572
169
453
my ($options_aref, $caller_pkg) = @_ ;
573
574
169
1435
$this->_dbg_prt( ["Options: append_options()\n"] ) ;
575
576
# get caller
577
169
100
799
unless ($caller_pkg)
578
{
579
57
757
$caller_pkg = (caller(0))[0] ;
580
}
581
582
169
287
my @combined_options = (@{$this->user_options}) ;
169
7021
583
169
936
foreach my $opt_aref (@$options_aref)
584
{
585
385
2284
my @opt = ($opt_aref->[0], $opt_aref->[1], $opt_aref->[2], $opt_aref->[3], $caller_pkg) ;
586
385
1102
push @combined_options, \@opt ;
587
}
588
169
5450
$this->user_options(\@combined_options) ;
589
590
169
1085
$this->_dbg_prt( ["Options: append_options() new=", $options_aref] , 2) ;
591
169
1023
$this->_dbg_prt( ["combined=", \@combined_options] , 2) ;
592
593
## Build new set of options
594
169
981
$this->update() ;
595
596
169
796
return @combined_options ;
597
}
598
599
#----------------------------------------------------------------------------
600
601
=item B
602
603
Clears the current options list.
604
605
=cut
606
607
sub clear_options
608
{
609
0
0
1
0
my $this = shift ;
610
611
0
0
$this->_dbg_prt( ["Options: clear_options()\n"] ) ;
612
613
0
0
$this->user_options([]) ;
614
615
}
616
617
#----------------------------------------------------------------------------
618
619
=item B
620
621
Use Getopt::Long to process the command line options. Returns 1 on success; 0 otherwise
622
623
=cut
624
625
sub get_options
626
{
627
37
37
1
91
my $this = shift ;
628
629
# Do final processing of the options
630
37
150
$this->update() ;
631
632
# get the list suitable for GetOpts
633
37
987
my $get_options_aref = $this->_get_options() ;
634
635
37
339
$this->_dbg_prt( ["get_options() : ARGV=", \@ARGV, " Options=", $get_options_aref], 2 ) ;
636
637
# Parse options using GetOpts
638
37
565
my $ok = GetOptions(@$get_options_aref) ;
639
640
# Expand the options variables
641
37
33434
$this->_expand_options() ;
642
643
37
275
$this->_dbg_prt( ["get_options() : ok=$ok Options now=", $get_options_aref], 2 ) ;
644
645
37
201
return $ok ;
646
}
647
648
#----------------------------------------------------------------------------
649
650
=item B
651
652
Returns the HASH ref of option if name is found; undef otherwise.
653
654
The HASH ref contains:
655
656
'field' => option 'main' name
657
'spec' => specification string
658
'summary' => summary text
659
'description' => description text
660
'default' => default value (if specified)
661
'pod_spec' => specification string suitable for pod output
662
'type' => option type (e.g. s, f etc)
663
'dest_type' => destination type (e.g. @, %)
664
'developer' => developer only option (flag set if option is to be used for developer use only)
665
'entry' => reference to the ARRAY that defined the option (as per L)
666
667
=cut
668
669
sub option_entry
670
{
671
217
217
1
472
my $this = shift ;
672
217
305
my ($option_name) = @_ ;
673
674
217
6499
my $option_fields_href = $this->_option_fields_hash() ;
675
217
255
my $opt_href ;
676
217
100
541
if (exists($option_fields_href->{$option_name}))
677
{
678
209
288
$opt_href = $option_fields_href->{$option_name} ;
679
}
680
217
534
return $opt_href ;
681
}
682
683
684
685
#----------------------------------------------------------------------------
686
687
=item B
688
689
Changes the default setting of the named option. Returns the option value if sucessful; undef otherwise
690
691
=cut
692
693
sub modify_default
694
{
695
16
16
1
17
my $this = shift ;
696
16
22
my ($option_name, $default) = @_ ;
697
698
16
100
33
$default = '' unless defined $default ;
699
16
64
$this->_dbg_prt( ["Options: modify_default($option_name, $default)\n"] ) ;
700
701
16
41
my $opt_href = $this->option_entry($option_name);
702
16
100
32
if ($opt_href)
703
{
704
## Update the source
705
8
17
$opt_href->{'entry'}[3] = $default ;
706
707
## keep derived info up to date (?)
708
709
# Set default if required
710
8
175
my $options_href = $this->_options() ;
711
8
15
$options_href->{$option_name} = $default ;
712
713
# Add to Getopt list
714
8
15
$opt_href->{'default'} = $default ;
715
716
}
717
16
52
$this->_dbg_prt( ["Options: after modify = ", $opt_href] , 2) ;
718
16
40
return $opt_href ;
719
}
720
721
#----------------------------------------------------------------------------
722
723
=item B
724
725
Scans through the options looking for any matching variable stored in $obj
726
(accessed via $obj->$variable). Where there is an variable, modifies the option
727
default to be equal to the current variable setting.
728
729
Optionally, you can specify an ARRAY ref of option names so that only those named are examined
730
731
This is a utility routine that can be called by extensions (or features) that want to
732
set the option defaults equal to their object variable settings.
733
734
=cut
735
736
sub defaults_from_obj
737
{
738
3
3
1
7
my $this = shift ;
739
3
7
my ($obj, $names_aref) = @_ ;
740
741
3
90
my $option_fields_href = $this->_option_fields_hash() ;
742
743
3
27
$this->_dbg_prt(["## defaults_from_obj() names=", $names_aref]) ;
744
745
# get object vars
746
3
53
my %vars = $obj->vars ;
747
748
3
16
my @names ;
749
3
50
11
if ($names_aref)
750
{
751
# do just those specified
752
3
15
@names = @$names_aref ;
753
}
754
else
755
{
756
# do them all
757
0
0
@names = keys %$option_fields_href ;
758
}
759
760
# scan options
761
3
19
foreach my $option_name (@names)
762
{
763
25
100
66
158
if (exists($vars{$option_name}) && defined($vars{$option_name}) && exists($option_fields_href->{$option_name}))
100
764
{
765
5
10
$this->modify_default($option_name, $vars{$option_name}) ;
766
5
20
$this->_dbg_prt([ " + modify default: $option_name = $vars{$option_name}\n"]) ;
767
}
768
}
769
3
24
$this->_dbg_prt(["Options=", $option_fields_href]) ;
770
}
771
772
#----------------------------------------------------------------------------
773
774
=item B
775
776
Scans through the options looking for any matching variable stored in $obj
777
(accessed via $obj->$variable). Where there is an variable, modifies the object variable value
778
to be equal to the current option setting.
779
780
Optionally, you can specify an ARRAY ref of option names so that only those named are examined
781
782
This is effectively the reversal of L
783
784
=cut
785
786
sub obj_vars
787
{
788
6
6
1
12
my $this = shift ;
789
6
17
my ($obj, $names_aref) = @_ ;
790
791
6
149
my $option_fields_href = $this->_option_fields_hash() ;
792
793
# get object vars
794
6
20
my %vars = $obj->vars ;
795
796
6
53
$this->_dbg_prt(["## obj_vars() names=", $names_aref, "Options=", $option_fields_href]) ;
797
798
6
16
my @names ;
799
6
50
14
if ($names_aref)
800
{
801
# do just those specified
802
6
21
@names = @$names_aref ;
803
}
804
else
805
{
806
# do them all
807
0
0
@names = keys %$option_fields_href ;
808
}
809
810
# scan names
811
6
10
my %set ;
812
6
11
foreach my $option_name (@names)
813
{
814
66
100
66
259
if (exists($vars{$option_name}) && exists($option_fields_href->{$option_name}))
815
{
816
42
72
$set{$option_name} = $this->option($option_name) ;
817
}
818
}
819
820
6
35
$this->_dbg_prt([" + setting=", \%set]) ;
821
822
# set the variables on the object (if necessary)
823
6
50
48
$obj->set(%set) if keys %set ;
824
}
825
826
#----------------------------------------------------------------------------
827
828
=item B
829
830
Returns the options values and defaults HASH references in an array, values HASH ref
831
as the first element.
832
833
=cut
834
835
sub option_values_hash
836
{
837
36
36
1
111
my $this = shift ;
838
839
36
1234
my $options_href = $this->_options() ;
840
36
979
my $options_fields_href = $this->_option_fields_hash() ;
841
842
# get defaults & options
843
36
71
my (%values, %defaults) ;
844
36
344
foreach my $opt (keys %$options_fields_href)
845
{
846
438
829
$defaults{$opt} = $options_fields_href->{$opt}{'default'} ;
847
438
100
1036
$values{$opt} = $options_href->{$opt} if defined($options_href->{$opt}) ;
848
}
849
850
36
206
return (\%values, \%defaults) ;
851
}
852
853
854
#----------------------------------------------------------------------------
855
856
=item B
857
858
Sets the options values and defaults based on the HASH references passed in.
859
860
=cut
861
862
sub option_values_set
863
{
864
36
36
1
82
my $this = shift ;
865
36
79
my ($values_href, $defaults_href) = @_ ;
866
867
36
1068
my $options_href = $this->_options() ;
868
36
969
my $options_fields_href = $this->_option_fields_hash() ;
869
870
## Update
871
36
262
foreach my $opt (keys %$options_fields_href)
872
{
873
# update defaults to reflect any user specified options
874
438
559
$defaults_href->{$opt} = $values_href->{$opt} ;
875
438
657
$options_fields_href->{$opt}{'default'} = $defaults_href->{$opt} ;
876
877
# update values
878
438
100
1149
$options_href->{$opt} = $values_href->{$opt} if defined($options_href->{$opt}) ;
879
}
880
}
881
882
883
# ============================================================================================
884
# PRIVATE METHODS
885
# ============================================================================================
886
887
888
#----------------------------------------------------------------------------
889
#
890
#=item B<_process_option_spec($option_spec)>
891
#
892
#Processes the option specification string, returning:
893
#
894
# ($field, $option_spec, $spec, $dest_type, $developer_only, $fields_aref, $arg_type)
895
#
896
#=cut
897
#
898
sub _process_option_spec
899
{
900
4114
4114
4841
my $this = shift ;
901
4114
5381
my ($option_spec) = @_ ;
902
903
4114
15105
$this->_dbg_prt( ["option: _process_option_spec($option_spec)"] , 2) ;
904
905
4114
7135
my $developer_only = 0 ;
906
907
# (subset of that supported by Getopt::Long):
908
# [ ]
909
# :
910
# s = String. An arbitrary sequence of characters. It is valid for the argument to start with - or -- .
911
# i = Integer. An optional leading plus or minus sign, followed by a sequence of digits.
912
# o = Extended integer, Perl style. This can be either an optional leading plus or minus sign, followed by a sequence of digits, or an octal string (a zero, optionally followed by '0', '1', .. '7'), or a hexadecimal string (0x followed by '0' .. '9', 'a' .. 'f', case insensitive), or a binary string (0b followed by a series of '0' and '1').
913
# f = Real number. For example 3.14 , -6.23E24 and so on.
914
#
915
# :
916
# @ = store options in ARRAY ref
917
# % = store options in HASH ref
918
919
# If option starts with start char then remove it
920
4114
8506
$option_spec =~ s/^[\-\+\*]// ;
921
922
# if starts with dev: then remove and flag
923
4114
100
10826
if ($option_spec =~ s/^dev://i)
924
{
925
1146
1458
$developer_only = 1 ;
926
}
927
928
# Get field name
929
4114
5282
my $field = $option_spec ;
930
4114
100
10331
if ($option_spec =~ /[\'\"](\w+)[\'\"]/)
931
{
932
1082
2305
$field = $1 ;
933
1082
3976
$option_spec =~ s/[\'\"]//g ;
934
}
935
4114
6418
$field =~ s/\|.*$// ;
936
4114
7789
$field =~ s/\=.*$// ;
937
938
# re-create spec with field name highlighted
939
4114
5016
my $spec = $option_spec ;
940
4114
4356
my $arg = "";
941
4114
100
9749
if ($spec =~ s/\=(.*)$//)
942
{
943
972
2094
$arg = $1 ;
944
}
945
4114
16718
$this->_dbg_prt( ["_process_option_spec() set: pod spec=$spec arg=$arg\n"], 2 ) ;
946
947
4114
12301
my @fields = split /\|/, $spec ;
948
4114
100
8727
if (@fields > 1)
949
{
950
# put field name first
951
1082
1328
$spec = "$field" ;
952
1082
1665
foreach my $fld (@fields)
953
{
954
2172
100
5425
next if $fld eq $field ;
955
956
1090
599529
$this->_dbg_prt( [" + $fld\n"], 2 ) ;
957
1090
50
2757
$spec .= '|' if $spec;
958
1090
1663
$spec .= $fld ;
959
}
960
}
961
962
4114
5508
my $dest_type = "" ;
963
4114
100
8140
if ($arg =~ /([\@\%])/i)
964
{
965
16
33
$dest_type = $1 ;
966
}
967
968
4114
4851
my $arg_type = "" ;
969
4114
100
9053
if ($arg =~ /([siof])/i)
970
{
971
972
1510
$arg_type = $1 ;
972
972
100
2362
if ($arg_type eq 's')
100
50
0
973
{
974
544
100
886
if ($dest_type eq '%')
975
{
976
8
17
$spec .= " " ;
977
}
978
else
979
{
980
536
1171
$spec .= " " ;
981
}
982
}
983
elsif ($arg_type eq 'i')
984
{
985
420
757
$spec .= " " ;
986
}
987
elsif ($arg_type eq 'f')
988
{
989
8
16
$spec .= " " ;
990
}
991
elsif ($arg_type eq 'o')
992
{
993
0
0
$spec .= " " ;
994
}
995
else
996
{
997
0
0
$spec .= " "
998
}
999
}
1000
1001
4114
15879
$this->_dbg_prt( ["_process_option_spec() set: final pod spec=$spec arg=$arg\n"], 2 ) ;
1002
1003
4114
25361
return ($field, $option_spec, $spec, $dest_type, $developer_only, \@fields, $arg_type) ;
1004
1005
}
1006
1007
1008
#----------------------------------------------------------------------------
1009
#
1010
#=item B<_expand_options()>
1011
#
1012
#Expand any variables in the options
1013
#
1014
#=cut
1015
#
1016
sub _expand_options
1017
{
1018
37
37
103
my $this = shift ;
1019
1020
37
237
$this->_dbg_prt(["_expand_options()\n"]) ;
1021
1022
37
1224
my $options_href = $this->_options() ;
1023
37
1008
my $options_fields_href = $this->_option_fields_hash() ;
1024
1025
# get defaults & options
1026
37
108
my (%defaults, %values) ;
1027
37
254
foreach my $opt (keys %$options_fields_href)
1028
{
1029
451
794
$defaults{$opt} = $options_fields_href->{$opt}{'default'} ;
1030
451
100
1030
$values{$opt} = $options_href->{$opt} if defined($options_href->{$opt}) ;
1031
}
1032
37
300
$this->_dbg_prt(["_expand_options: defaults=",\%defaults," values=",\%values,"\n"]) ;
1033
1034
# get replacement vars
1035
37
112
my @vars ;
1036
37
1280
my $app = $this->app ;
1037
37
50
174
if ($app)
1038
{
1039
37
648
my %app_vars = $app->vars ;
1040
37
263
push @vars, \%app_vars ;
1041
}
1042
37
119
push @vars, \%ENV ;
1043
1044
# ## expand
1045
# $this->expand_keys(\%values, \@vars) ;
1046
# push @vars, \%values ; # allow defaults to use user-specified values
1047
# $this->expand_keys(\%defaults, \@vars) ;
1048
1049
37
279
$this->_dbg_prt(["_expand_options - end: defaults=",\%defaults," values=",\%values,"\n"]) ;
1050
1051
## Update
1052
37
215
foreach my $opt (keys %$options_fields_href)
1053
{
1054
# update defaults to reflect any user specified options
1055
451
563
$defaults{$opt} = $values{$opt} ;
1056
451
633
$options_fields_href->{$opt}{'default'} = $defaults{$opt} ;
1057
1058
# update values
1059
451
100
1407
$options_href->{$opt} = $values{$opt} if defined($options_href->{$opt}) ;
1060
}
1061
}
1062
1063
1064
# ============================================================================================
1065
# END OF PACKAGE
1066
1067
=back
1068
1069
=head1 DIAGNOSTICS
1070
1071
Setting the debug flag to level 1 prints out (to STDOUT) some debug messages, setting it to level 2 prints out more verbose messages.
1072
1073
=head1 AUTHOR
1074
1075
Steve Price C<< >>
1076
1077
=head1 BUGS
1078
1079
None that I know of!
1080
1081
=cut
1082
1083
1084
1;
1085
1086
__END__