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