| blib/lib/AppConfig/File.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::File; | ||||||
| 2 | |||||||
| 3 | #============================================================================ | ||||||
| 4 | # | ||||||
| 5 | # AppConfig::File.pm | ||||||
| 6 | # | ||||||
| 7 | # Perl5 module to read configuration files and use the contents therein | ||||||
| 8 | # to update variable values in an AppConfig::State object. | ||||||
| 9 | # | ||||||
| 10 | # Written by Andy Wardley <abw@wardley.org> | ||||||
| 11 | # | ||||||
| 12 | # Copyright (C) 1997-2003 Andy Wardley. All Rights Reserved. | ||||||
| 13 | # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. | ||||||
| 14 | # | ||||||
| 15 | # $Id: File.pm,v 1.62 2004/02/04 10:28:28 abw Exp $ | ||||||
| 16 | # | ||||||
| 17 | #============================================================================ | ||||||
| 18 | |||||||
| 19 | use strict; | ||||||
| 20 | |||||||
| 21 | require 5.005; | ||||||
| 22 | |||||||
| 23 | use AppConfig; | ||||||
| 24 | use AppConfig::State; | ||||||
| 25 | use File::HomeDir; | ||||||
| 26 | |||||||
| 27 | use vars qw( $VERSION ); | ||||||
| 28 | BEGIN { | ||||||
| 29 | $VERSION = '1.64'; | ||||||
| 30 | } | ||||||
| 31 | |||||||
| 32 | |||||||
| 33 | |||||||
| 34 | |||||||
| 35 | |||||||
| 36 | #------------------------------------------------------------------------ | ||||||
| 37 | # new($state, $file, [$file, ...]) | ||||||
| 38 | # | ||||||
| 39 | # Module constructor. The first, mandatory parameter should be a | ||||||
| 40 | # reference to an AppConfig::State object to which all actions should | ||||||
| 41 | # be applied. The remaining parameters are assumed to be file names or | ||||||
| 42 | # file handles for reading and are passed to parse(). | ||||||
| 43 | # | ||||||
| 44 | # Returns a reference to a newly created AppConfig::File object. | ||||||
| 45 | #------------------------------------------------------------------------ | ||||||
| 46 | |||||||
| 47 | sub new { | ||||||
| 48 | my $class = shift; | ||||||
| 49 | my $state = shift; | ||||||
| 50 | |||||||
| 51 | my $self = { | ||||||
| 52 | STATE => $state, # AppConfig::State ref | ||||||
| 53 | DEBUG => $state->_debug(), # store local copy of debug | ||||||
| 54 | PEDANTIC => $state->_pedantic, # and pedantic flags | ||||||
| 55 | }; | ||||||
| 56 | |||||||
| 57 | bless $self, $class; | ||||||
| 58 | |||||||
| 59 | # Find the home directory | ||||||
| 60 | $self->{HOME} = File::HomeDir->my_home; | ||||||
| 61 | |||||||
| 62 | # call parse(@_) to parse any files specified as further params | ||||||
| 63 | $self->parse(@_) if @_; | ||||||
| 64 | |||||||
| 65 | return $self; | ||||||
| 66 | } | ||||||
| 67 | |||||||
| 68 | |||||||
| 69 | #------------------------------------------------------------------------ | ||||||
| 70 | # parse($file, [file, ...]) | ||||||
| 71 | # | ||||||
| 72 | # Reads and parses a config file, updating the contents of the | ||||||
| 73 | # AppConfig::State referenced by $self->{ STATE } according to the | ||||||
| 74 | # contents of the file. Multiple files may be specified and are | ||||||
| 75 | # examined in turn. The method reports any error condition via | ||||||
| 76 | # $self->{ STATE }->_error() and immediately returns undef if it | ||||||
| 77 | # encounters a system error (i.e. cannot open one of the files. | ||||||
| 78 | # Parsing errors such as unknown variables or unvalidated values will | ||||||
| 79 | # also cause warnings to be raised vi the same _error(), but parsing | ||||||
| 80 | # continues to the end of the current file and through any subsequent | ||||||
| 81 | # files. If the PEDANTIC option is set in the $self->{ STATE } object, | ||||||
| 82 | # the behaviour is overridden and the method returns 0 immediately on | ||||||
| 83 | # any system or parsing error. | ||||||
| 84 | # | ||||||
| 85 | # The EXPAND option for each variable determines how the variable | ||||||
| 86 | # value should be expanded. | ||||||
| 87 | # | ||||||
| 88 | # Returns undef on system error, 0 if all files were parsed but generated | ||||||
| 89 | # one or more warnings, 1 if all files parsed without warnings. | ||||||
| 90 | #------------------------------------------------------------------------ | ||||||
| 91 | |||||||
| 92 | sub parse { | ||||||
| 93 | my $self = shift; | ||||||
| 94 | my $warnings = 0; | ||||||
| 95 | my $prefix; # [block] defines $prefix | ||||||
| 96 | my $file; | ||||||
| 97 | my $flag; | ||||||
| 98 | |||||||
| 99 | # take a local copy of the state to avoid much hash dereferencing | ||||||
| 100 | my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) }; | ||||||
| 101 | |||||||
| 102 | # we want to install a custom error handler into the AppConfig::State | ||||||
| 103 | # which appends filename and line info to error messages and then | ||||||
| 104 | # calls the previous handler; we start by taking a copy of the | ||||||
| 105 | # current handler.. | ||||||
| 106 | my $errhandler = $state->_ehandler(); | ||||||
| 107 | |||||||
| 108 | # ...and if it doesn't exist, we craft a default handler | ||||||
| 109 | $errhandler = sub { warn(sprintf(shift, @_), "\n") } | ||||||
| 110 | unless defined $errhandler; | ||||||
| 111 | |||||||
| 112 | # install a closure as a new error handler | ||||||
| 113 | $state->_ehandler( | ||||||
| 114 | sub { | ||||||
| 115 | # modify the error message | ||||||
| 116 | my $format = shift; | ||||||
| 117 | $format .= ref $file | ||||||
| 118 | ? " at line $." | ||||||
| 119 | : " at $file line $."; | ||||||
| 120 | |||||||
| 121 | # chain call to prevous handler | ||||||
| 122 | &$errhandler($format, @_); | ||||||
| 123 | } | ||||||
| 124 | ); | ||||||
| 125 | |||||||
| 126 | # trawl through all files passed as params | ||||||
| 127 | FILE: while ($file = shift) { | ||||||
| 128 | |||||||
| 129 | # local/lexical vars ensure opened files get closed | ||||||
| 130 | my $handle; | ||||||
| 131 | local *FH; | ||||||
| 132 | |||||||
| 133 | # if the file is a reference, we assume it's a file handle, if | ||||||
| 134 | # not, we assume it's a filename and attempt to open it | ||||||
| 135 | $handle = $file; | ||||||
| 136 | if (ref($file)) { | ||||||
| 137 | $handle = $file; | ||||||
| 138 | |||||||
| 139 | # DEBUG | ||||||
| 140 | print STDERR "reading from file handle: $file\n" if $debug; | ||||||
| 141 | } | ||||||
| 142 | else { | ||||||
| 143 | # open and read config file | ||||||
| 144 | open(FH, $file) or do { | ||||||
| 145 | # restore original error handler and report error | ||||||
| 146 | $state->_ehandler($errhandler); | ||||||
| 147 | $state->_error("$file: $!"); | ||||||
| 148 | |||||||
| 149 | return undef; | ||||||
| 150 | }; | ||||||
| 151 | $handle = \*FH; | ||||||
| 152 | |||||||
| 153 | # DEBUG | ||||||
| 154 | print STDERR "reading file: $file\n" if $debug; | ||||||
| 155 | } | ||||||
| 156 | |||||||
| 157 | # initialise $prefix to nothing (no [block]) | ||||||
| 158 | $prefix = ''; | ||||||
| 159 | |||||||
| 160 | while (<$handle>) { | ||||||
| 161 | chomp; | ||||||
| 162 | |||||||
| 163 | # Throw away everything from an unescaped # to EOL | ||||||
| 164 | s/(^|\s+)#.*/$1/; | ||||||
| 165 | |||||||
| 166 | # add next line if there is one and this is a continuation | ||||||
| 167 | if (s/\\$// && !eof($handle)) { | ||||||
| 168 | $_ .= <$handle>; | ||||||
| 169 | redo; | ||||||
| 170 | } | ||||||
| 171 | |||||||
| 172 | # Convert \# -> # | ||||||
| 173 | s/\\#/#/g; | ||||||
| 174 | |||||||
| 175 | # ignore blank lines | ||||||
| 176 | next if /^\s*$/; | ||||||
| 177 | |||||||
| 178 | # strip leading and trailing whitespace | ||||||
| 179 | s/^\s+//; | ||||||
| 180 | s/\s+$//; | ||||||
| 181 | |||||||
| 182 | # look for a [block] to set $prefix | ||||||
| 183 | if (/^\[([^\]]+)\]$/) { | ||||||
| 184 | $prefix = $1; | ||||||
| 185 | print STDERR "Entering [$prefix] block\n" if $debug; | ||||||
| 186 | next; | ||||||
| 187 | } | ||||||
| 188 | |||||||
| 189 | # split line up by whitespace (\s+) or "equals" (\s*=\s*) | ||||||
| 190 | if (/^([^\s=]+)(?:(?:(?:\s*=\s*)|\s+)(.*))?/) { | ||||||
| 191 | my ($variable, $value) = ($1, $2); | ||||||
| 192 | |||||||
| 193 | if (defined $value) { | ||||||
| 194 | # here document | ||||||
| 195 | if ($value =~ /^([^\s=]+\s*=)?\s*<<(['"]?)(\S+)\2$/) { # '<<XX' or 'hashkey =<<XX' | ||||||
| 196 | my $boundary = "$3\n"; | ||||||
| 197 | $value = defined($1) ? $1 : ''; | ||||||
| 198 | while (<$handle>) { | ||||||
| 199 | last if $_ eq $boundary; | ||||||
| 200 | $value .= $_; | ||||||
| 201 | }; | ||||||
| 202 | $value =~ s/[\r\n]$//; | ||||||
| 203 | } else { | ||||||
| 204 | # strip any quoting from the variable value | ||||||
| 205 | $value =~ s/^(['"])(.*)\1$/$2/; | ||||||
| 206 | }; | ||||||
| 207 | }; | ||||||
| 208 | |||||||
| 209 | # strip any leading '+/-' from the variable | ||||||
| 210 | $variable =~ s/^([\-+]?)//; | ||||||
| 211 | $flag = $1; | ||||||
| 212 | |||||||
| 213 | # $variable gets any $prefix | ||||||
| 214 | $variable = $prefix . '_' . $variable | ||||||
| 215 | if length $prefix; | ||||||
| 216 | |||||||
| 217 | # if the variable doesn't exist, we call set() to give | ||||||
| 218 | # AppConfig::State a chance to auto-create it | ||||||
| 219 | unless ($state->_exists($variable) | ||||||
| 220 | || $state->set($variable, 1)) { | ||||||
| 221 | $warnings++; | ||||||
| 222 | last FILE if $pedantic; | ||||||
| 223 | next; | ||||||
| 224 | } | ||||||
| 225 | |||||||
| 226 | my $nargs = $state->_argcount($variable); | ||||||
| 227 | |||||||
| 228 | # variables prefixed '-' are reset to their default values | ||||||
| 229 | if ($flag eq '-') { | ||||||
| 230 | $state->_default($variable); | ||||||
| 231 | next; | ||||||
| 232 | } | ||||||
| 233 | # those prefixed '+' get set to 1 | ||||||
| 234 | elsif ($flag eq '+') { | ||||||
| 235 | $value = 1 unless defined $value; | ||||||
| 236 | } | ||||||
| 237 | |||||||
| 238 | # determine if any extra arguments were expected | ||||||
| 239 | if ($nargs) { | ||||||
| 240 | if (defined $value && length $value) { | ||||||
| 241 | # expand any embedded variables, ~uids or | ||||||
| 242 | # environment variables, testing the return value | ||||||
| 243 | # for errors; we pass in any variable-specific | ||||||
| 244 | # EXPAND value | ||||||
| 245 | unless ($self->_expand(\$value, | ||||||
| 246 | $state->_expand($variable), $prefix)) { | ||||||
| 247 | print STDERR "expansion of [$value] failed\n" | ||||||
| 248 | if $debug; | ||||||
| 249 | $warnings++; | ||||||
| 250 | last FILE if $pedantic; | ||||||
| 251 | } | ||||||
| 252 | } | ||||||
| 253 | else { | ||||||
| 254 | $state->_error("$variable expects an argument"); | ||||||
| 255 | $warnings++; | ||||||
| 256 | last FILE if $pedantic; | ||||||
| 257 | next; | ||||||
| 258 | } | ||||||
| 259 | } | ||||||
| 260 | # $nargs = 0 | ||||||
| 261 | else { | ||||||
| 262 | # default value to 1 unless it is explicitly defined | ||||||
| 263 | # as '0' or "off" | ||||||
| 264 | if (defined $value) { | ||||||
| 265 | # "off" => 0 | ||||||
| 266 | $value = 0 if $value =~ /off/i; | ||||||
| 267 | # any value => 1 | ||||||
| 268 | $value = 1 if $value; | ||||||
| 269 | } | ||||||
| 270 | else { | ||||||
| 271 | # assume 1 unless explicitly defined off/0 | ||||||
| 272 | $value = 1; | ||||||
| 273 | } | ||||||
| 274 | print STDERR "$variable => $value (no expansion)\n" | ||||||
| 275 | if $debug; | ||||||
| 276 | } | ||||||
| 277 | |||||||
| 278 | # set the variable, noting any failure from set() | ||||||
| 279 | unless ($state->set($variable, $value)) { | ||||||
| 280 | $warnings++; | ||||||
| 281 | last FILE if $pedantic; | ||||||
| 282 | } | ||||||
| 283 | } | ||||||
| 284 | else { | ||||||
| 285 | $state->_error("parse error"); | ||||||
| 286 | $warnings++; | ||||||
| 287 | } | ||||||
| 288 | } | ||||||
| 289 | } | ||||||
| 290 | |||||||
| 291 | # restore original error handler | ||||||
| 292 | $state->_ehandler($errhandler); | ||||||
| 293 | |||||||
| 294 | # return $warnings => 0, $success => 1 | ||||||
| 295 | return $warnings ? 0 : 1; | ||||||
| 296 | } | ||||||
| 297 | |||||||
| 298 | |||||||
| 299 | |||||||
| 300 | #======================================================================== | ||||||
| 301 | # ----- PRIVATE METHODS ----- | ||||||
| 302 | #======================================================================== | ||||||
| 303 | |||||||
| 304 | #------------------------------------------------------------------------ | ||||||
| 305 | # _expand(\$value, $expand, $prefix) | ||||||
| 306 | # | ||||||
| 307 | # The variable value string, referenced by $value, is examined and any | ||||||
| 308 | # embedded variables, environment variables or tilde globs (home | ||||||
| 309 | # directories) are replaced with their respective values, depending on | ||||||
| 310 | # the value of the second parameter, $expand. The third paramter may | ||||||
| 311 | # specify the name of the current [block] in which the parser is | ||||||
| 312 | # parsing. This prefix is prepended to any embedded variable name that | ||||||
| 313 | # can't otherwise be resolved. This allows the following to work: | ||||||
| 314 | # | ||||||
| 315 | # [define] | ||||||
| 316 | # home = /home/abw | ||||||
| 317 | # html = $define_home/public_html | ||||||
| 318 | # html = $home/public_html # same as above, 'define' is prefix | ||||||
| 319 | # | ||||||
| 320 | # Modifications are made directly into the variable referenced by $value. | ||||||
| 321 | # The method returns 1 on success or 0 if any warnings (undefined | ||||||
| 322 | # variables) were encountered. | ||||||
| 323 | #------------------------------------------------------------------------ | ||||||
| 324 | |||||||
| 325 | sub _expand { | ||||||
| 326 | my ($self, $value, $expand, $prefix) = @_; | ||||||
| 327 | my $warnings = 0; | ||||||
| 328 | my ($sys, $var, $val); | ||||||
| 329 | |||||||
| 330 | |||||||
| 331 | # ensure prefix contains something (nothing!) valid for length() | ||||||
| 332 | $prefix = "" unless defined $prefix; | ||||||
| 333 | |||||||
| 334 | # take a local copy of the state to avoid much hash dereferencing | ||||||
| 335 | my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) }; | ||||||
| 336 | |||||||
| 337 | # bail out if there's nothing to do | ||||||
| 338 | return 1 unless $expand && defined($$value); | ||||||
| 339 | |||||||
| 340 | # create an AppConfig::Sys instance, or re-use a previous one, | ||||||
| 341 | # to handle platform dependant functions: getpwnam(), getpwuid() | ||||||
| 342 | unless ($sys = $self->{ SYS }) { | ||||||
| 343 | require AppConfig::Sys; | ||||||
| 344 | $sys = $self->{ SYS } = AppConfig::Sys->new(); | ||||||
| 345 | } | ||||||
| 346 | |||||||
| 347 | print STDERR "Expansion of [$$value] " if $debug; | ||||||
| 348 | |||||||
| 349 | EXPAND: { | ||||||
| 350 | |||||||
| 351 | # | ||||||
| 352 | # EXPAND_VAR | ||||||
| 353 | # expand $(var) and $var as AppConfig::State variables | ||||||
| 354 | # | ||||||
| 355 | if ($expand & AppConfig::EXPAND_VAR) { | ||||||
| 356 | |||||||
| 357 | $$value =~ s{ | ||||||
| 358 | (?<!\\)\$ (?: \((\w+)\) | (\w+) ) # $2 => $(var) | $3 => $var | ||||||
| 359 | |||||||
| 360 | } { | ||||||
| 361 | # embedded variable name will be one of $2 or $3 | ||||||
| 362 | $var = defined $1 ? $1 : $2; | ||||||
| 363 | |||||||
| 364 | # expand the variable if defined | ||||||
| 365 | if ($state->_exists($var)) { | ||||||
| 366 | $val = $state->get($var); | ||||||
| 367 | } | ||||||
| 368 | elsif (length $prefix | ||||||
| 369 | && $state->_exists($prefix . '_' . $var)) { | ||||||
| 370 | print STDERR "(\$$var => \$${prefix}_$var) " | ||||||
| 371 | if $debug; | ||||||
| 372 | $var = $prefix . '_' . $var; | ||||||
| 373 | $val = $state->get($var); | ||||||
| 374 | } | ||||||
| 375 | else { | ||||||
| 376 | # raise a warning if EXPAND_WARN set | ||||||
| 377 | if ($expand & AppConfig::EXPAND_WARN) { | ||||||
| 378 | $state->_error("$var: no such variable"); | ||||||
| 379 | $warnings++; | ||||||
| 380 | } | ||||||
| 381 | |||||||
| 382 | # replace variable with nothing | ||||||
| 383 | $val = ''; | ||||||
| 384 | } | ||||||
| 385 | |||||||
| 386 | # $val gets substituted back into the $value string | ||||||
| 387 | $val; | ||||||
| 388 | }gex; | ||||||
| 389 | |||||||
| 390 | $$value =~ s/\\\$/\$/g; | ||||||
| 391 | |||||||
| 392 | # bail out now if we need to | ||||||
| 393 | last EXPAND if $warnings && $pedantic; | ||||||
| 394 | } | ||||||
| 395 | |||||||
| 396 | |||||||
| 397 | # | ||||||
| 398 | # EXPAND_UID | ||||||
| 399 | # expand ~uid as home directory (for $< if uid not specified) | ||||||
| 400 | # | ||||||
| 401 | if ($expand & AppConfig::EXPAND_UID) { | ||||||
| 402 | |||||||
| 403 | $$value =~ s{ | ||||||
| 404 | ~(\w+)? # $1 => username (optional) | ||||||
| 405 | } { | ||||||
| 406 | $val = undef; | ||||||
| 407 | |||||||
| 408 | # embedded user name may be in $1 | ||||||
| 409 | if (defined ($var = $1)) { | ||||||
| 410 | # try and get user's home directory | ||||||
| 411 | if ($sys->can_getpwnam()) { | ||||||
| 412 | $val = ($sys->getpwnam($var))[7]; | ||||||
| 413 | } | ||||||
| 414 | } else { | ||||||
| 415 | # determine home directory | ||||||
| 416 |