File Coverage

blib/lib/App/Framework/Feature/Options.pm
Criterion Covered Total %
statement 223 230 96.9
branch 57 66 86.3
condition 9 14 64.2
subroutine 20 21 95.2
pod 14 14 100.0
total 323 345 93.6


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
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__