File Coverage

blib/lib/AppConfig/State.pm
Criterion Covered Total %
statement n/a
branch n/a
condition n/a
subroutine n/a
pod n/a
total n/a


line stmt bran cond sub pod time code
1             package AppConfig::State;
2              
3             #============================================================================
4             #
5             # AppConfig::State.pm
6             #
7             # Perl5 module in which configuration information for an application can
8             # be stored and manipulated. AppConfig::State objects maintain knowledge
9             # about variables; their identities, options, aliases, targets, callbacks
10             # and so on. This module is used by a number of other AppConfig::* modules.
11             #
12             # Written by Andy Wardley <abw@wardley.org>
13             #
14             # Copyright (C) 1997-2003 Andy Wardley. All Rights Reserved.
15             # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
16             #
17             # $Id: State.pm,v 1.61 2004/02/04 10:11:23 abw Exp $
18             #
19             #----------------------------------------------------------------------------
20             #
21             # TODO
22             #
23             # * Change varlist() to varhash() and provide another varlist() method
24             # which returns a list. Multiple parameters passed implies a hash
25             # slice/list grep, a single parameter should indicate a regex.
26             #
27             # * Perhaps allow a callback to be installed which is called *instead* of
28             # the get() and set() methods (or rather, is called by them).
29             #
30             # * Maybe CMDARG should be in there to specify extra command-line only
31             # options that get added to the AppConfig::GetOpt alias construction,
32             # but not applied in config files, general usage, etc. The GLOBAL
33             # CMDARG might be specified as a format, e.g. "-%c" where %s = name,
34             # %c = first character, %u - first unique sequence(?). Will
35             # GetOpt::Long handle --long to -l application automagically?
36             #
37             # * ..and an added thought is that CASE sensitivity may be required for the
38             # command line (-v vs -V, -r vs -R, for example), but not for parsing
39             # config files where you may wish to treat "Name", "NAME" and "name" alike.
40             #
41             #============================================================================
42              
43             require 5.004;
44              
45             use strict;
46              
47             use vars qw( $VERSION $DEBUG $AUTOLOAD );
48             BEGIN {
49             $VERSION = '1.64';
50             $DEBUG   = 0;
51             }
52              
53             # need access to AppConfig::ARGCOUNT_*
54             use AppConfig qw(:argcount);
55              
56             # internal per-variable hashes that AUTOLOAD should provide access to
57             my %METHVARS;
58                @METHVARS{ qw( EXPAND ARGS ARGCOUNT ) } = ();
59              
60             # internal values that AUTOLOAD should provide access to
61             my %METHFLAGS;
62                @METHFLAGS{ qw( PEDANTIC ) } = ();
63              
64             # variable attributes that may be specified in GLOBAL;
65             my @GLOBAL_OK = qw( DEFAULT EXPAND VALIDATE ACTION ARGS ARGCOUNT );
66              
67              
68             #------------------------------------------------------------------------
69             # new(\%config, @vars)
70             #
71             # Module constructor. A reference to a hash array containing
72             # configuration options may be passed as the first parameter. This is
73             # passed off to _configure() for processing. See _configure() for
74             # information about configurarion options. The remaining parameters
75             # may be variable definitions and are passed en masse to define() for
76             # processing.
77             #
78             # Returns a reference to a newly created AppConfig::State object.
79             #------------------------------------------------------------------------
80              
81             sub new {
82                 my $class = shift;
83                 
84                 my $self = {
85             # internal hash arrays to store variable specification information
86                     VARIABLE => { }, # variable values
87                     DEFAULT => { }, # default values
88                     ALIAS => { }, # known aliases ALIAS => VARIABLE
89                     ALIASES => { }, # reverse alias lookup VARIABLE => ALIASES
90                     ARGCOUNT => { }, # arguments expected
91                     ARGS => { }, # specific argument pattern (AppConfig::Getopt)
92                     EXPAND => { }, # variable expansion (AppConfig::File)
93                     VALIDATE => { }, # validation regexen or functions
94                     ACTION => { }, # callback functions for when variable is set
95                     GLOBAL => { }, # default global settings for new variables
96                     
97             # other internal data
98                     CREATE => 0, # auto-create variables when set
99                     CASE => 0, # case sensitivity flag (1 = sensitive)
100                     PEDANTIC => 0, # return immediately on parse warnings
101                     EHANDLER => undef, # error handler (let's hope we don't need it!)
102                     ERROR => '', # error message
103                 };
104              
105                 bless $self, $class;
106            
107             # configure if first param is a config hash ref
108                 $self->_configure(shift)
109                     if ref($_[0]) eq 'HASH';
110              
111             # call define(@_) to handle any variables definitions
112                 $self->define(@_)
113                     if @_;
114              
115                 return $self;
116             }
117              
118              
119             #------------------------------------------------------------------------
120             # define($variable, \%cfg, [$variable, \%cfg, ...])
121             #
122             # Defines one or more variables. The first parameter specifies the
123             # variable name. The following parameter may reference a hash of
124             # configuration options for the variable. Further variables and
125             # configuration hashes may follow and are processed in turn. If the
126             # parameter immediately following a variable name isn't a hash reference
127             # then it is ignored and the variable is defined without a specific
128             # configuration, although any default parameters as specified in the
129             # GLOBAL option will apply.
130             #
131             # The $variable value may contain an alias/args definition in compact
132             # format, such as "Foo|Bar=1".
133             #
134             # A warning is issued (via _error()) if an invalid option is specified.
135             #------------------------------------------------------------------------
136              
137             sub define {
138                 my $self = shift;
139                 my ($var, $args, $count, $opt, $val, $cfg, @names);
140              
141                 while (@_) {
142                     $var = shift;
143                     $cfg = ref($_[0]) eq 'HASH' ? shift : { };
144              
145             # variable may be specified in compact format, 'foo|bar=i@'
146                     if ($var =~ s/(.+?)([!+=:].*)/$1/) {
147              
148             # anything coming after the name|alias list is the ARGS
149                         $cfg->{ ARGS } = $2
150                             if length $2;
151                     }
152              
153             # examine any ARGS option
154                     if (defined ($args = $cfg->{ ARGS })) {
155                       ARGGCOUNT: {
156                           $count = ARGCOUNT_NONE, last if $args =~ /^!/;
157                           $count = ARGCOUNT_LIST, last if $args =~ /@/;
158                           $count = ARGCOUNT_HASH, last if $args =~ /%/;
159                           $count = ARGCOUNT_ONE;
160                       }
161                         $cfg->{ ARGCOUNT } = $count;
162                     }
163              
164             # split aliases out
165                     @names = split(/\|/, $var);
166                     $var = shift @names;
167                     $cfg->{ ALIAS } = [ @names ] if @names;
168              
169             # variable name gets folded to lower unless CASE sensitive
170                     $var = lc $var unless $self->{ CASE };
171              
172             # activate $variable (so it does 'exist()')
173                     $self->{ VARIABLE }->{ $var } = undef;
174              
175             # merge GLOBAL and variable-specific configurations
176                     $cfg = { %{ $self->{ GLOBAL } }, %$cfg };
177              
178             # examine each variable configuration parameter
179                     while (($opt, $val) = each %$cfg) {
180                         $opt = uc $opt;
181                         
182             # DEFAULT, VALIDATE, EXPAND, ARGS and ARGCOUNT are stored as
183             # they are;
184                         $opt =~ /^DEFAULT|VALIDATE|EXPAND|ARGS|ARGCOUNT$/ && do {
185                             $self->{ $opt }->{ $var } = $val;
186                             next;
187                         };
188                         
189             # CMDARG has been deprecated
190                         $opt eq 'CMDARG' && do {
191                             $self->_error("CMDARG has been deprecated. "
192                                           . "Please use an ALIAS if required.");
193                             next;
194                         };
195                         
196             # ACTION should be a code ref
197                         $opt eq 'ACTION' && do {
198                             unless (ref($val) eq 'CODE') {
199                                 $self->_error("'$opt' value is not a code reference");
200                                 next;
201                             };
202                             
203             # store code ref, forcing keyword to upper case
204                             $self->{ ACTION }->{ $var } = $val;
205                             
206                             next;
207                         };
208                         
209             # ALIAS creates alias links to the variable name
210                         $opt eq 'ALIAS' && do {
211                             
212             # coerce $val to an array if not already so
213                             $val = [ split(/\|/, $val) ]
214                                 unless ref($val) eq 'ARRAY';
215                             
216             # fold to lower case unless CASE sensitivity set
217                             unless ($self->{ CASE }) {
218                                 @$val = map { lc } @$val;
219                             }
220                             
221             # store list of aliases...
222                             $self->{ ALIASES }->{ $var } = $val;
223                             
224             # ...and create ALIAS => VARIABLE lookup hash entries
225                             foreach my $a (@$val) {
226                                 $self->{ ALIAS }->{ $a } = $var;
227                             }
228                             
229                             next;
230                         };
231                         
232             # default
233                         $self->_error("$opt is not a valid configuration item");
234                     }
235                     
236             # set variable to default value
237                     $self->_default($var);
238                     
239             # DEBUG: dump new variable definition
240                     if ($DEBUG) {
241                         print STDERR "Variable defined:\n";
242                  $self->_dump_var($var);
243                     }
244                 }
245             }
246              
247              
248             #------------------------------------------------------------------------
249             # get($variable)
250             #
251             # Returns the value of the variable specified, $variable. Returns undef
252             # if the variable does not exists or is undefined and send a warning
253             # message to the _error() function.
254             #------------------------------------------------------------------------
255              
256             sub get {
257                 my $self = shift;
258                 my $variable = shift;
259                 my $negate = 0;
260                 my $value;
261              
262             # _varname returns variable name after aliasing and case conversion
263             # $negate indicates if the name got converted from "no<var>" to "<var>"
264                 $variable = $self->_varname($variable, \$negate);
265              
266             # check the variable has been defined
267                 unless (exists($self->{ VARIABLE }->{ $variable })) {
268                     $self->_error("$variable: no such variable");
269                     return undef;
270                 }
271              
272             # DEBUG
273                 print STDERR "$self->get($variable) => ",
274             defined $self->{ VARIABLE }->{ $variable }
275             ? $self->{ VARIABLE }->{ $variable }
276             : "<undef>",
277             "\n"
278                       if $DEBUG;
279              
280             # return variable value, possibly negated if the name was "no<var>"
281                 $value = $self->{ VARIABLE }->{ $variable };
282              
283                 return $negate ? !$value : $value;
284             }
285              
286              
287             #------------------------------------------------------------------------
288             # set($variable, $value)
289             #
290             # Assigns the value, $value, to the variable specified.
291             #
292             # Returns 1 if the variable is successfully updated or 0 if the variable
293             # does not exist. If an ACTION sub-routine exists for the variable, it
294             # will be executed and its return value passed back.
295             #------------------------------------------------------------------------
296              
297             sub set {
298                 my $self = shift;
299                 my $variable = shift;
300                 my $value = shift;
301                 my $negate = 0;
302                 my $create;
303              
304             # _varname returns variable name after aliasing and case conversion
305             # $negate indicates if the name got converted from "no<var>" to "<var>"
306                 $variable = $self->_varname($variable, \$negate);
307              
308             # check the variable exists
309                 if (exists($self->{ VARIABLE }->{ $variable })) {
310             # variable found, so apply any value negation
311                     $value = $value ? 0 : 1 if $negate;
312                 }
313                 else {
314             # auto-create variable if CREATE is 1 or a pattern matching
315             # the variable name (real name, not an alias)
316                     $create = $self->{ CREATE };
317                     if (defined $create
318                         && ($create eq '1' || $variable =~ /$create/)) {
319                         $self->define($variable);
320                         
321                         print STDERR "Auto-created $variable\n" if $DEBUG;
322                     }
323                     else {
324                         $self->_error("$variable: no such variable");
325                         return 0;
326                     }
327                 }
328                 
329             # call the validate($variable, $value) method to perform any validation
330                 unless ($self->_validate($variable, $value)) {
331                     $self->_error("$variable: invalid value: $value");
332                     return 0;
333                 }
334                 
335             # DEBUG
336                 print STDERR "$self->set($variable, ",
337                 defined $value
338                     ? $value
339                     : "<undef>",
340                     ")\n"
341                     if $DEBUG;
342                 
343              
344             # set the variable value depending on its ARGCOUNT
345                 my $argcount = $self->{ ARGCOUNT }->{ $variable };
346                 $argcount = AppConfig::ARGCOUNT_ONE unless defined $argcount;
347              
348                 if ($argcount eq AppConfig::ARGCOUNT_LIST) {
349             # push value onto the end of the list
350                     push(@{ $self->{ VARIABLE }->{ $variable } }, $value);
351                 }
352                 elsif ($argcount eq AppConfig::ARGCOUNT_HASH) {
353             # insert "<key>=<value>" data into hash
354                     my ($k, $v) = split(/\s*=\s*/, $value, 2);
355             # strip quoting
356                     $v =~ s/^(['"])(.*)\1$/$2/ if defined $v;
357                     $self->{ VARIABLE }->{ $variable }->{ $k } = $v;
358                 }
359                 else {
360             # set simple variable
361                     $self->{ VARIABLE }->{ $variable } = $value;
362                 }
363              
364              
365             # call any ACTION function bound to this variable
366                 return &{ $self->{ ACTION }->{ $variable } }($self, $variable, $value)
367                  if (exists($self->{ ACTION }->{ $variable }));
368              
369             # ...or just return 1 (ok)
370                 return 1;
371             }
372              
373              
374             #------------------------------------------------------------------------
375             # varlist($criteria, $filter)
376             #
377             # Returns a hash array of all variables and values whose real names
378             # match the $criteria regex pattern passed as the first parameter.
379             # If $filter is set to any true value, the keys of the hash array
380             # (variable names) will have the $criteria part removed. This allows
381             # the caller to specify the variables from one particular [block] and
382             # have the "block_" prefix removed, for example.
383             #
384             # TODO: This should be changed to varhash(). varlist() should return a
385             # list. Also need to consider specification by list rather than regex.
386             #
387             #------------------------------------------------------------------------
388              
389             sub varlist {
390                 my $self = shift;
391                 my $criteria = shift;
392                 my $strip = shift;
393              
394                 $criteria = "" unless defined $criteria;
395              
396             # extract relevant keys and slice out corresponding values
397                 my @keys = grep(/$criteria/, keys %{ $self->{ VARIABLE } });
398                 my @vals = @{ $self->{ VARIABLE } }{ @keys };
399                 my %set;
400              
401             # clean off the $criteria part if $strip is set
402                 @keys = map { s/$criteria//; $_ } @keys if $strip;
403              
404             # slice values into the target hash
405                 @set{ @keys } = @vals;
406                 return %set;
407             }
408              
409                 
410             #------------------------------------------------------------------------
411             # AUTOLOAD
412             #
413             # Autoload function called whenever an unresolved object method is
414             # called. If the method name relates to a defined VARIABLE, we patch
415             # in $self->get() and $self->set() to magically update the varaiable
416             # (if a parameter is supplied) and return the previous value.
417             #
418             # Thus the function can be used in the folowing ways:
419             # $state->variable(123); # set a new value
420             # $foo = $state->variable(); # get the current value
421             #
422             # Returns the current value of the variable, taken before any new value
423             # is set. Prints a warning if the variable isn't defined (i.e. doesn't
424             # exist rather than exists with an undef value) and returns undef.
425             #------------------------------------------------------------------------
426              
427             sub AUTOLOAD {
428                 my $self = shift;
429                 my ($variable, $attrib);
430              
431              
432             # splat the leading package name
433                 ($variable = $AUTOLOAD) =~ s/.*:://;
434              
435             # ignore destructor
436                 $variable eq 'DESTROY' && return;
437              
438              
439             # per-variable attributes and internal flags listed as keys in
440             # %METHFLAGS and %METHVARS respectively can be accessed by a
441             # method matching the attribute or flag name in lower case with
442             # a leading underscore_
443                 if (($attrib = $variable) =~ s/_//g) {
444                     $attrib = uc $attrib;
445            
446                     if (exists $METHFLAGS{ $attrib }) {
447                         return $self->{ $attrib };
448                     }
449              
450                     if (exists $METHVARS{ $attrib }) {
451             # next parameter should be variable name
452                         $variable = shift;
453                         $variable = $self->_varname($variable);
454                         
455             # check we've got a valid variable
456             # $self->_error("$variable: no such variable or method"),
457             # return undef
458             # unless exists($self->{ VARIABLE }->{ $variable });
459                         
460             # return attribute
461                         return $self->{ $attrib }->{ $variable };
462                     }
463                 }
464                 
465             # set a new value if a parameter was supplied or return the old one
466                 return defined($_[0])
467                        ? $self->set($variable, shift)
468                        : $self->get($variable);
469             }
470              
471              
472              
473             #========================================================================
474             # ----- PRIVATE METHODS -----
475             #========================================================================
476              
477             #------------------------------------------------------------------------
478             # _configure(\%cfg)
479             #
480             # Sets the various configuration options using the values passed in the
481             # hash array referenced by $cfg.
482             #------------------------------------------------------------------------
483              
484             sub _configure {
485                 my $self = shift;
486                 my $cfg = shift || return;
487              
488             # construct a regex to match values which are ok to be found in GLOBAL
489                 my $global_ok = join('|', @GLOBAL_OK);
490              
491                 foreach my $opt (keys %$cfg) {
492              
493             # GLOBAL must be a hash ref
494                     $opt =~ /^GLOBALS?$/i && do {
495                         unless (ref($cfg->{ $opt }) eq 'HASH') {
496                             $self->_error("\U$opt\E parameter is not a hash ref");
497                             next;
498                         }
499              
500             # we check each option is ok to be in GLOBAL, but we don't do
501             # any error checking on the values they contain (but should?).
502                         foreach my $global ( keys %{ $cfg->{ $opt } } ) {
503              
504             # continue if the attribute is ok to be GLOBAL
505                             next if ($global =~ /(^$global_ok$)/io);
506                                      
507                             $self->_error( "\U$global\E parameter cannot be GLOBAL");
508                         }
509                         $self->{ GLOBAL } = $cfg->{ $opt };
510                         next;
511                     };
512                         
513            
514             # CASE, CREATE and PEDANTIC are stored as they are
515                     $opt =~ /^CASE|CREATE|PEDANTIC$/i && do {
516                         $self->{ uc $opt } = $cfg->{ $opt };
517                         next;
518                     };
519              
520             # ERROR triggers $self->_ehandler()
521                     $opt =~ /^ERROR$/i && do {
522                         $self->_ehandler($cfg->{ $opt });
523                         next;
524                     };
525              
526             # DEBUG triggers $self->_debug()
527                     $opt =~ /^DEBUG$/i && do {
528                         $self->_debug($cfg->{ $opt });
529                         next;
530                     };
531                         
532             # warn about invalid options
533                     $self->_error("\U$opt\E is not a valid configuration option");
534                 }
535             }
536              
537              
538             #------------------------------------------------------------------------
539             # _varname($variable, \$negated)
540             #
541             # Variable names are treated case-sensitively or insensitively, depending
542             # on the value of $self->{ CASE }. When case-insensitive ($self->{ CASE }
543             # != 0), all variable names are converted to lower case. Variable values
544             # are not converted. This function simply converts the parameter
545             # (variable) to lower case if $self->{ CASE } isn't set. _varname() also
546             # expands a variable alias to the name of the target variable.
547             #
548             # Variables with an ARGCOUNT of ARGCOUNT_ZERO may be specified as
549             # "no<var>" in which case, the intended value should be negated. The
550             # leading "no" part is stripped from the variable name. A reference to
551             # a scalar value can be passed as the second parameter and if the
552             # _varname() method identified such a variable, it will negate the value.
553             # This allows the intended value or a simple negate flag to be passed by
554             # reference and be updated to indicate any negation activity taking place.
555             #
556             # The (possibly modified) variable name is returned.
557             #------------------------------------------------------------------------
558              
559             sub _varname {
560                 my $self = shift;
561                 my $variable = shift;
562                 my $negated = shift;
563              
564             # convert to lower case if case insensitive
565                 $variable = $self->{ CASE } ? $variable : lc $variable;
566              
567             # get the actual name if this is an alias
568                 $variable = $self->{ ALIAS }->{ $variable }
569             if (exists($self->{ ALIAS }->{ $variable }));
570              
571             # if the variable doesn't exist, we can try to chop off a leading
572             # "no" and see if the remainder matches an ARGCOUNT_ZERO variable
573                 unless (exists($self->{ VARIABLE }->{ $variable })) {
574             # see if the variable is specified as "no<var>"
575                     if ($variable =~ /^no(.*)/) {
576             # see if the real variable (minus "no") exists and it
577             # has an ARGOUNT of ARGCOUNT_NONE (or no ARGCOUNT at all)
578                         my $novar = $self->_varname($1);
579                         if (exists($self->{ VARIABLE }->{ $novar })
580                             && ! $self->{ ARGCOUNT }->{ $novar }) {
581             # set variable name and negate value
582                             $variable = $novar;
583                             $$negated = ! $$negated if defined $negated;
584                         }
585                     }
586                 }
587                 
588             # return the variable name
589                 $variable;
590             }
591              
592              
593             #------------------------------------------------------------------------
594             # _default($variable)
595             #
596             # Sets the variable specified to the default value or undef if it doesn't
597             # have a default. The default value is returned.
598             #------------------------------------------------------------------------
599              
600             sub _default {
601                 my $self = shift;
602                 my $variable = shift;
603              
604             # _varname returns variable name after aliasing and case conversion
605                 $variable = $self->_varname($variable);
606              
607             # check the variable exists
608                 if (exists($self->{ VARIABLE }->{ $variable })) {
609             # set variable value to the default scalar, an empty list or empty
610             # hash array, depending on its ARGCOUNT value
611                     my $argcount = $self->{ ARGCOUNT }->{ $variable };
612                     $argcount = AppConfig::ARGCOUNT_ONE unless defined $argcount;
613                     
614                     if ($argcount == AppConfig::ARGCOUNT_NONE) {
615                         return $self->{ VARIABLE }->{ $variable }
616             = $self->{ DEFAULT }->{ $variable } || 0;
617                     }
618                     elsif ($argcount == AppConfig::ARGCOUNT_LIST) {
619                         my $deflist = $self->{ DEFAULT }->{ $variable };
620                         return $self->{ VARIABLE }->{ $variable } =
621                             [ ref $deflist eq 'ARRAY' ? @$deflist : ( ) ];
622                         
623                     }
624                     elsif ($argcount == AppConfig::ARGCOUNT_HASH) {
625                         my $defhash = $self->{ DEFAULT }->{ $variable };
626                         return $self->{ VARIABLE }->{ $variable } =
627                         { ref $defhash eq 'HASH' ? %$defhash : () };
628                     }
629                     else {
630                         return $self->{ VARIABLE }->{ $variable }
631             = $self->{ DEFAULT }->{ $variable };
632                     }
633                 }
634                 else {
635                     $self->_error("$variable: no such variable");
636                     return 0;
637                 }
638             }
639              
640              
641             #------------------------------------------------------------------------
642             # _exists($variable)
643             #
644             # Returns 1 if the variable specified exists or 0 if not.
645             #------------------------------------------------------------------------
646              
647             sub _exists {
648                 my $self = shift;
649                 my $variable = shift;
650              
651              
652             # _varname returns variable name after aliasing and case conversion
653                 $variable = $self->_varname($variable);
654              
655             # check the variable has been defined
656                 return exists($self->{ VARIABLE }->{ $variable });
657             }
658              
659              
660             #------------------------------------------------------------------------
661             # _validate($variable, $value)
662             #
663             # Uses any validation rules or code defined for the variable to test if
664             # the specified value is acceptable.
665             #
666             # Returns 1 if the value passed validation checks, 0 if not.
667             #------------------------------------------------------------------------
668              
669             sub _validate {
670                 my $self = shift;
671                 my $variable = shift;
672                 my $value = shift;
673                 my $validator;
674              
675              
676             # _varname returns variable name after aliasing and case conversion
677                 $variable = $self->_varname($variable);
678              
679             # return OK unless there is a validation function
680                 return 1 unless defined($validator = $self->{ VALIDATE }->{ $variable });
681              
682             #
683             # the validation performed is based on the validator type;
684             #
685             # CODE ref: code executed, returning 1 (ok) or 0 (failed)
686             # SCALAR : a regex which should match the value
687             #
688              
689             # CODE ref
690                 ref($validator) eq 'CODE' && do {
691             # run the validation function and return the result
692                     return &$validator($variable, $value);
693                 };
694              
695             # non-ref (i.e. scalar)
696                 ref($validator) || do {
697             # not a ref - assume it's a regex
698                     return $value =~ /$validator/;
699                 };
700                 
701             # validation failed
702                 return 0;
703             }
704              
705              
706             #------------------------------------------------------------------------
707             # _error($format, @params)
708             #
709             # Checks for the existence of a user defined error handling routine and
710             # if defined, passes all variable straight through to that. The routine
711             # is expected to handle a string format and optional parameters as per
712             # printf(3C). If no error handler is defined, the message is formatted
713             # and passed to warn() which prints it to STDERR.
714             #------------------------------------------------------------------------
715              
716             sub _error {
717                 my $self = shift;
718                 my $format = shift;
719              
720             # user defined error handler?
721                 if (ref($self->{ EHANDLER }) eq 'CODE') {
722                     &{ $self->{ EHANDLER } }($format, @_);
723                 }
724                 else {
725                     warn(sprintf("$format\n", @_));
726                 }
727             }
728              
729              
730             #------------------------------------------------------------------------
731             # _ehandler($handler)
732             #
733             # Allows a new error handler to be installed. The current value of
734             # the error handler is returned.
735             #
736             # This is something of a kludge to allow other AppConfig::* modules to
737             # install their own error handlers to format error messages appropriately.
738             # For example, AppConfig::File appends a message of the form
739             # "at $file line $line" to each error message generated while parsing
740             # configuration files. The previous handler is returned (and presumably
741             # stored by the caller) to allow new error handlers to chain control back
742             # to any user-defined handler, and also restore the original handler when
743             # done.
744             #------------------------------------------------------------------------
745              
746             sub _ehandler {
747                 my $self = shift;
748                 my $handler = shift;
749              
750             # save previous value
751                 my $previous = $self->{ EHANDLER };
752              
753             # update internal reference if a new handler vas provide
754                 if (defined $handler) {
755             # check this is a code reference
756                     if (ref($handler) eq 'CODE') {
757                         $self->{ EHANDLER } = $handler;
758                         
759             # DEBUG
760                         print STDERR "installed new ERROR handler: $handler\n" if $DEBUG;
761                     }
762                     else {
763                         $self->_error("ERROR handler parameter is not a code ref");
764                     }
765                 }
766                
767                 return $previous;
768             }
769              
770              
771             #------------------------------------------------------------------------
772             # _debug($debug)
773             #
774             # Sets the package debugging variable, $AppConfig::State::DEBUG depending
775             # on the value of the $debug parameter. 1 turns debugging on, 0 turns
776             # debugging off.
777             #
778             # May be called as an object method, $state->_debug(1), or as a package
779             # function, AppConfig::State::_debug(1). Returns the previous value of
780             # $DEBUG, before any new value was applied.
781             #------------------------------------------------------------------------
782              
783             sub _debug {
784             # object reference may not be present if called as a package function
785                 my $self = shift if ref($_[0]);
786                 my $newval = shift;
787              
788             # save previous value
789                 my $oldval = $DEBUG;
790              
791             # update $DEBUG if a new value was provided
792                 $DEBUG = $newval if defined $newval;
793              
794             # return previous value
795                 $oldval;
796             }
797              
798              
799             #------------------------------------------------------------------------
800             # _dump_var($var)
801             #
802             # Displays the content of the specified variable, $var.
803             #------------------------------------------------------------------------
804              
805             sub _dump_var {
806                 my $self = shift;
807                 my $var = shift;
808              
809                 return unless defined $var;
810              
811             # $var may be an alias, so we resolve the real variable name
812                 my $real = $self->_varname($var);
813                 if ($var eq $real) {
814                  print STDERR "$var\n";
815                 }
816                 else {
817                  print STDERR "$real ('$var' is an alias)\n";
818                     $var = $real;
819                 }
820              
821             # for some bizarre reason, the variable VALUE is stored in VARIABLE
822             # (it made sense at some point in time)
823                 printf STDERR " VALUE => %s\n",
824             defined($self->{ VARIABLE }->{ $var })
825             ? $self->{ VARIABLE }->{ $var }
826             : "<undef>";
827              
828             # the rest of the values can be read straight out of their hashes
829                 foreach my $param (qw( DEFAULT ARGCOUNT VALIDATE ACTION EXPAND )) {
830             printf STDERR " %-12s => %s\n", $param,
831             defined($self->{ $param }->{ $var })
832             ? $self->{ $param }->{ $var }
833             : "<undef>";
834                 }
835              
836             # summarise all known aliases for this variable
837                 print STDERR " ALIASES => ",
838             join(", ", @{ $self->{ ALIASES }->{ $var } }), "\n"
839                         if defined $self->{ ALIASES }->{ $var };
840             } 
841              
842              
843             #------------------------------------------------------------------------
844             # _dump()
845             #
846             # Dumps the contents of the Config object and all stored variables.
847             #------------------------------------------------------------------------
848              
849             sub _dump {
850                 my $self = shift;
851                 my $var;
852              
853                 print STDERR "=" x 71, "\n";
854                 print STDERR
855             "Status of AppConfig::State (version $VERSION) object:\n\t$self\n";
856              
857                 
858                 print STDERR "- " x 36, "\nINTERNAL STATE:\n";
859                 foreach (qw( CREATE CASE PEDANTIC EHANDLER ERROR )) {
860                     printf STDERR " %-12s => %s\n", $_,
861             defined($self->{ $_ }) ? $self->{ $_ } : "<undef>";
862                 }
863              
864                 print STDERR "- " x 36, "\nVARIABLES:\n";
865                 foreach $var (keys %{ $self->{ VARIABLE } }) {
866                     $self->_dump_var($var);
867                 }
868              
869                 print STDERR "- " x 36, "\n", "ALIASES:\n";
870                 foreach $var (keys %{ $self->{ ALIAS } }) {
871                     printf(" %-12s => %s\n", $var, $self->{ ALIAS }->{ $var });
872                 }
873                 print STDERR "=" x 72, "\n";
874             } 
875              
876              
877              
878             1;
879              
880             __END__
881            
882             =head1 NAME
883            
884             AppConfig::State - application configuration state
885            
886             =head1 SYNOPSIS
887            
888             use AppConfig::State;
889            
890             my $state = AppConfig::State->new(\%cfg);
891            
892             $state->define("foo"); # very simple variable definition
893             $state->define("bar", \%varcfg); # variable specific configuration
894             $state->define("foo|bar=i@"); # compact format
895            
896             $state->set("foo", 123); # trivial set/get examples
897             $state->get("foo");
898            
899             $state->foo(); # shortcut variable access
900             $state->foo(456); # shortcut variable update
901            
902             =head1 OVERVIEW
903            
904             AppConfig::State is a Perl5 module to handle global configuration variables
905             for perl programs. It maintains the state of any number of variables,
906             handling default values, aliasing, validation, update callbacks and
907             option arguments for use by other AppConfig::* modules.
908            
909             AppConfig::State is distributed as part of the AppConfig bundle.
910            
911             =head1 DESCRIPTION
912            
913             =head2 USING THE AppConfig::State MODULE
914            
915             To import and use the AppConfig::State module the following line should
916             appear in your Perl script:
917            
918             use AppConfig::State;
919            
920             The AppConfig::State module is loaded automatically by the new()
921             constructor of the AppConfig module.
922            
923             AppConfig::State is implemented using object-oriented methods. A
924             new AppConfig::State object is created and initialised using the
925             new() method. This returns a reference to a new AppConfig::State
926             object.
927            
928             my $state = AppConfig::State->new();
929            
930             This will create a reference to a new AppConfig::State with all
931             configuration options set to their default values. You can initialise
932             the object by passing a reference to a hash array containing
933             configuration options:
934            
935             $state = AppConfig::State->new( {
936             CASE => 1,
937             ERROR => \&my_error,
938             } );
939            
940             The new() constructor of the AppConfig module automatically passes all
941             parameters to the AppConfig::State new() constructor. Thus, any global
942             configuration values and variable definitions for AppConfig::State are
943             also applicable to AppConfig.
944            
945             The following configuration options may be specified.
946            
947             =over 4
948            
949             =item CASE
950            
951             Determines if the variable names are treated case sensitively. Any non-zero
952             value makes case significant when naming variables. By default, CASE is set
953             to 0 and thus "Variable", "VARIABLE" and "VaRiAbLe" are all treated as
954             "variable".
955            
956             =item CREATE
957            
958             By default, CREATE is turned off meaning that all variables accessed via
959             set() (which includes access via shortcut such as
960             C<$state-E<gt>variable($value)> which delegates to set()) must previously
961             have been defined via define(). When CREATE is set to 1, calling
962             set($variable, $value) on a variable that doesn't exist will cause it
963             to be created automatically.
964            
965             When CREATE is set to any other non-zero value, it is assumed to be a
966             regular expression pattern. If the variable name matches the regex, the
967             variable is created. This can be used to specify configuration file
968             blocks in which variables should be created, for example:
969            
970             $state = AppConfig::State->new( {
971             CREATE => '^define_',
972             } );
973            
974             In a config file:
975            
976             [define]
977             name = fred # define_name gets created automatically
978            
979             [other]
980             name = john # other_name doesn't - warning raised
981            
982             Note that a regex pattern specified in CREATE is applied to the real
983             variable name rather than any alias by which the variables may be
984             accessed.
985            
986             =item PEDANTIC
987            
988             The PEDANTIC option determines what action the configuration file
989             (AppConfig::File) or argument parser (AppConfig::Args) should take
990             on encountering a warning condition (typically caused when trying to set an
991             undeclared variable). If PEDANTIC is set to any true value, the parsing
992             methods will immediately return a value of 0 on encountering such a
993             condition. If PEDANTIC is not set, the method will continue to parse the
994             remainder of the current file(s) or arguments, returning 0 when complete.
995            
996             If no warnings or errors are encountered, the method returns 1.
997            
998             In the case of a system error (e.g. unable to open a file), the method
999             returns undef immediately, regardless of the PEDANTIC option.
1000            
1001             =item ERROR
1002            
1003             Specifies a user-defined error handling routine. When the handler is
1004             called, a format string is passed as the first parameter, followed by
1005             any additional values, as per printf(3C).
1006            
1007             =item DEBUG
1008            
1009             Turns debugging on or off when set to 1 or 0 accordingly. Debugging may
1010             also be activated by calling _debug() as an object method
1011             (C<$state-E<gt>_debug(1)>) or as a package function
1012             (C<AppConfig::State::_debug(1)>), passing in a true/false value to
1013             set the debugging state accordingly. The package variable
1014             $AppConfig::State::DEBUG can also be set directly.
1015            
1016             The _debug() method returns the current debug value. If a new value
1017             is passed in, the internal value is updated, but the previous value is
1018             returned.
1019            
1020             Note that any AppConfig::File or App::Config::Args objects that are
1021             instantiated with a reference to an App::State will inherit the
1022             DEBUG (and also PEDANTIC) values of the state at that time. Subsequent
1023             changes to the AppConfig::State debug value will not affect them.
1024            
1025             =item GLOBAL
1026            
1027             The GLOBAL option allows default values to be set for the DEFAULT, ARGCOUNT,
1028             EXPAND, VALIDATE and ACTION options for any subsequently defined variables.
1029            
1030             $state = AppConfig::State->new({
1031             GLOBAL => {
1032             DEFAULT => '<undef>', # default value for new vars
1033             ARGCOUNT => 1, # vars expect an argument
1034             ACTION => \&my_set_var, # callback when vars get set
1035             }
1036             });
1037            
1038             Any attributes specified explicitly when a variable is defined will
1039             override any GLOBAL values.
1040            
1041             See L<DEFINING VARIABLES> below which describes these options in detail.
1042            
1043             =back
1044            
1045             =head2 DEFINING VARIABLES
1046            
1047             The C<define()> function is used to pre-declare a variable and specify
1048             its configuration.
1049            
1050             $state->define("foo");
1051            
1052             In the simple example above, a new variable called "foo" is defined. A
1053             reference to a hash array may also be passed to specify configuration
1054             information for the variable:
1055            
1056             $state->define("foo", {
1057             DEFAULT => 99,
1058             ALIAS => 'metavar1',
1059             });
1060            
1061             Any variable-wide GLOBAL values passed to the new() constructor in the
1062             configuration hash will also be applied. Values explicitly specified
1063             in a variable's define() configuration will override the respective GLOBAL
1064             values.
1065            
1066             The following configuration options may be specified
1067            
1068             =over 4
1069            
1070             =item DEFAULT
1071            
1072             The DEFAULT value is used to initialise the variable.
1073            
1074             $state->define("drink", {
1075             DEFAULT => 'coffee',
1076             });
1077            
1078             print $state->drink(); # prints "coffee"
1079            
1080             =item ALIAS
1081            
1082             The ALIAS option allows a number of alternative names to be specified for
1083             this variable. A single alias should be specified as a string. Multiple
1084             aliases can be specified as a reference to an array of alternatives or as
1085             a string of names separated by vertical bars, '|'. e.g.:
1086            
1087             $state->define("name", {
1088             ALIAS => 'person',
1089             });
1090             or
1091             $state->define("name", {
1092             ALIAS => [ 'person', 'user', 'uid' ],
1093             });
1094             or
1095             $state->define("name", {
1096             ALIAS => 'person|user|uid',
1097             });
1098            
1099             $state->user('abw'); # equivalent to $state->name('abw');
1100            
1101             =item ARGCOUNT
1102            
1103             The ARGCOUNT option specifies the number of arguments that should be
1104             supplied for this variable. By default, no additional arguments are
1105             expected for variables (ARGCOUNT_NONE).
1106            
1107             The ARGCOUNT_* constants can be imported from the AppConfig module:
1108            
1109             use AppConfig ':argcount';
1110            
1111             $state->define('foo', { ARGCOUNT => ARGCOUNT_ONE });
1112            
1113             or can be accessed directly from the AppConfig package:
1114            
1115             use AppConfig;
1116            
1117             $state->define('foo', { ARGCOUNT => AppConfig::ARGCOUNT_ONE });
1118            
1119             The following values for ARGCOUNT may be specified.
1120            
1121             =over 4
1122            
1123             =item ARGCOUNT_NONE (0)
1124            
1125             Indicates that no additional arguments are expected. If the variable is
1126             identified in a confirguration file or in the command line arguments, it
1127             is set to a value of 1 regardless of whatever arguments follow it.
1128            
1129             =item ARGCOUNT_ONE (1)
1130            
1131             Indicates that the variable expects a single argument to be provided.
1132             The variable value will be overwritten with a new value each time it
1133             is encountered.
1134            
1135             =item ARGCOUNT_LIST (2)
1136            
1137             Indicates that the variable expects multiple arguments. The variable
1138             value will be appended to the list of previous values each time it is
1139             encountered.
1140            
1141             =item ARGCOUNT_HASH (3)
1142            
1143             Indicates that the variable expects multiple arguments and that each
1144             argument is of the form "key=value". The argument will be split into
1145             a key/value pair and inserted into the hash of values each time it
1146             is encountered.
1147            
1148             =back
1149            
1150             =item ARGS
1151            
1152             The ARGS option can also be used to specify advanced command line options
1153             for use with AppConfig::Getopt, which itself delegates to Getopt::Long.
1154             See those two modules for more information on the format and meaning of
1155             these options.
1156            
1157             $state->define("name", {
1158             ARGS => "=i@",
1159             });
1160            
1161             =item EXPAND
1162            
1163             The EXPAND option specifies how the AppConfig::File processor should
1164             expand embedded variables in the configuration file values it reads.
1165             By default, EXPAND is turned off (EXPAND_NONE) and no expansion is made.
1166            
1167             The EXPAND_* constants can be imported from the AppConfig module:
1168            
1169             use AppConfig ':expand';
1170            
1171             $state->define('foo', { EXPAND => EXPAND_VAR });
1172            
1173             or can be accessed directly from the AppConfig package:
1174            
1175             use AppConfig;
1176            
1177             $state->define('foo', { EXPAND => AppConfig::EXPAND_VAR });
1178            
1179             The following values for EXPAND may be specified. Multiple values should
1180             be combined with vertical bars , '|', e.g. C<EXPAND_UID | EXPAND_VAR>).
1181            
1182             =over 4
1183            
1184             =item EXPAND_NONE
1185            
1186             Indicates that no variable expansion should be attempted.
1187            
1188             =item EXPAND_VAR
1189            
1190             Indicates that variables embedded as $var or $(var) should be expanded
1191             to the values of the relevant AppConfig::State variables.
1192            
1193             =item EXPAND_UID
1194            
1195             Indicates that '~' or '~uid' patterns in the string should be
1196             expanded to the current users ($<), or specified user's home directory.
1197            
1198             =item EXPAND_ENV
1199            
1200             Inidicates that variables embedded as ${var} should be expanded to the
1201             value of the relevant environment variable.
1202            
1203             =item EXPAND_ALL
1204            
1205             Equivalent to C<EXPAND_VARS | EXPAND_UIDS | EXPAND_ENVS>).
1206            
1207             =item EXPAND_WARN
1208            
1209             Indicates that embedded variables that are not defined should raise a
1210             warning. If PEDANTIC is set, this will cause the read() method to return 0
1211             immediately.
1212            
1213             =back
1214            
1215             =item VALIDATE
1216            
1217             Each variable may have a sub-routine or regular expression defined which
1218             is used to validate the intended value for a variable before it is set.
1219            
1220             If VALIDATE is defined as a regular expression, it is applied to the
1221             value and deemed valid if the pattern matches. In this case, the
1222             variable is then set to the new value. A warning message is generated
1223             if the pattern match fails.
1224            
1225             VALIDATE may also be defined as a reference to a sub-routine which takes
1226             as its arguments the name of the variable and its intended value. The
1227             sub-routine should return 1 or 0 to indicate that the value is valid
1228             or invalid, respectively. An invalid value will cause a warning error
1229             message to be generated.
1230            
1231             If the GLOBAL VALIDATE variable is set (see GLOBAL in L<DESCRIPTION>
1232             above) then this value will be used as the default VALIDATE for each
1233             variable unless otherwise specified.
1234            
1235             $state->define("age", {
1236             VALIDATE => '\d+',
1237             });
1238            
1239             $state->define("pin", {
1240             VALIDATE => \&check_pin,
1241             });
1242            
1243             =item ACTION
1244            
1245             The ACTION option allows a sub-routine to be bound to a variable as a
1246             callback that is executed whenever the variable is set. The ACTION is
1247             passed a reference to the AppConfig::State object, the name of the
1248             variable and the value of the variable.
1249            
1250             The ACTION routine may be used, for example, to post-process variable
1251             data, update the value of some other dependant variable, generate a
1252             warning message, etc.
1253            
1254             Example:
1255            
1256             $state->define("foo", { ACTION => \&my_notify });
1257            
1258             sub my_notify {
1259             my $state = shift;
1260             my $var = shift;
1261             my $val = shift;
1262            
1263             print "$variable set to $value";
1264             }
1265            
1266             $state->foo(42); # prints "foo set to 42"
1267            
1268             Be aware that calling C<$state-E<gt>set()> to update the same variable
1269             from within the ACTION function will cause a recursive loop as the
1270             ACTION function is repeatedly called.
1271            
1272             =item
1273            
1274             =back
1275            
1276             =head2 DEFINING VARIABLES USING THE COMPACT FORMAT
1277            
1278             Variables may be defined in a compact format which allows any ALIAS and
1279             ARGS values to be specified as part of the variable name. This is designed
1280             to mimic the behaviour of Johan Vromans' Getopt::Long module.
1281            
1282             Aliases for a variable should be specified after the variable name,
1283             separated by vertical bars, '|'. Any ARGS parameter should be appended
1284             after the variable name(s) and/or aliases.
1285            
1286             The following examples are equivalent:
1287            
1288             $state->define("foo", {
1289             ALIAS => [ 'bar', 'baz' ],
1290             ARGS => '=i',
1291             });
1292            
1293             $state->define("foo|bar|baz=i");
1294            
1295             =head2 READING AND MODIFYING VARIABLE VALUES
1296            
1297             AppConfig::State defines two methods to manipulate variable values:
1298            
1299             set($variable, $value);
1300             get($variable);
1301            
1302             Both functions take the variable name as the first parameter and
1303             C<set()> takes an additional parameter which is the new value for the
1304             variable. C<set()> returns 1 or 0 to indicate successful or
1305             unsuccessful update of the variable value. If there is an ACTION
1306             routine associated with the named variable, the value returned will be
1307             passed back from C<set()>. The C<get()> function returns the current
1308             value of the variable.
1309            
1310             Once defined, variables may be accessed directly as object methods where
1311             the method name is the same as the variable name. i.e.
1312            
1313             $state->set("verbose", 1);
1314            
1315             is equivalent to
1316            
1317             $state->verbose(1);
1318            
1319             Without parameters, the current value of the variable is returned. If
1320             a parameter is specified, the variable is set to that value and the
1321             result of the set() operation is returned.
1322            
1323             $state->age(29); # sets 'age' to 29, returns 1 (ok)
1324            
1325             =head2 INTERNAL METHODS
1326            
1327             The interal (private) methods of the AppConfig::State class are listed
1328             below.
1329            
1330             They aren't intended for regular use and potential users should consider
1331             the fact that nothing about the internal implementation is guaranteed to
1332             remain the same. Having said that, the AppConfig::State class is
1333             intended to co-exist and work with a number of other modules and these
1334             are considered "friend" classes. These methods are provided, in part,
1335             as services to them. With this acknowledged co-operation in mind, it is
1336             safe to assume some stability in this core interface.
1337            
1338             The _varname() method can be used to determine the real name of a variable
1339             from an alias:
1340            
1341             $varname->_varname($alias);
1342            
1343             Note that all methods that take a variable name, including those listed
1344             below, can accept an alias and automatically resolve it to the correct
1345             variable name. There is no need to call _varname() explicitly to do
1346             alias expansion. The _varname() method will fold all variables names
1347             to lower case unless CASE sensititvity is set.
1348            
1349             The _exists() method can be used to check if a variable has been
1350             defined:
1351            
1352             $state->_exists($varname);
1353            
1354             The _default() method can be used to reset a variable to its default value:
1355            
1356             $state->_default($varname);
1357            
1358             The _expand() method can be used to determine the EXPAND value for a
1359             variable:
1360            
1361             print "$varname EXPAND: ", $state->_expand($varname), "\n";
1362            
1363             The _argcount() method returns the value of the ARGCOUNT attribute for a
1364             variable:
1365            
1366             print "$varname ARGCOUNT: ", $state->_argcount($varname), "\n";
1367            
1368             The _validate() method can be used to determine if a new value for a variable
1369             meets any validation criteria specified for it. The variable name and
1370             intended value should be passed in. The methods returns a true/false value
1371             depending on whether or not the validation succeeded:
1372            
1373             print "OK\n" if $state->_validate($varname, $value);
1374            
1375             The _pedantic() method can be called to determine the current value of the
1376             PEDANTIC option.
1377            
1378             print "pedantic mode is ", $state->_pedantic() ? "on" ; "off", "\n";
1379            
1380             The _debug() method can be used to turn debugging on or off (pass 1 or 0
1381             as a parameter). It can also be used to check the debug state,
1382             returning the current internal value of $AppConfig::State::DEBUG. If a
1383             new debug value is provided, the debug state is updated and the previous
1384             state is returned.
1385            
1386             $state->_debug(1); # debug on, returns previous value
1387            
1388             The _dump_var($varname) and _dump() methods may also be called for
1389             debugging purposes.
1390            
1391             $state->_dump_var($varname); # show variable state
1392             $state->_dump(); # show internal state and all vars
1393            
1394             =head1 AUTHOR
1395            
1396             Andy Wardley, E<lt>abw@wardley.orgE<gt>
1397            
1398             =head1 REVISION
1399            
1400             $Revision: 1.61 $
1401            
1402             =head1 COPYRIGHT
1403            
1404             Copyright (C) 1997-2003 Andy Wardley. All Rights Reserved.
1405            
1406             Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
1407            
1408             This module is free software; you can redistribute it and/or modify it
1409             under the same terms as Perl itself.
1410            
1411             =head1 SEE ALSO
1412            
1413             AppConfig, AppConfig::File, AppConfig::Args, AppConfig::Getopt
1414            
1415             =cut
1416