local-lib5/lib/perl5/AppConfig/File.pm

   1 #============================================================================
   2 #
   3 # AppConfig::File.pm
   4 #
   5 # Perl5 module to read configuration files and use the contents therein
   6 # to update variable values in an AppConfig::State object.
   7 #
   8 # Written by Andy Wardley <abw@wardley.org>
   9 #
  10 # Copyright (C) 1997-2007 Andy Wardley.  All Rights Reserved.
  11 # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
  12 #
  13 #============================================================================
  14
  15 package AppConfig::File;
  16 use strict;
  17 use warnings;
  18 use AppConfig;
  19 use AppConfig::State;
  20 our $VERSION = '1.65';
  21
  22
  23 #------------------------------------------------------------------------
  24 # new($state, $file, [$file, ...])
  25 #
  26 # Module constructor.  The first, mandatory parameter should be a
  27 # reference to an AppConfig::State object to which all actions should
  28 # be applied.  The remaining parameters are assumed to be file names or
  29 # file handles for reading and are passed to parse().
  30 #
  31 # Returns a reference to a newly created AppConfig::File object.
  32 #------------------------------------------------------------------------
  33
  34 sub new {
  35     my $class = shift;
  36     my $state = shift;
  37     my $self  = {
  38         STATE    => $state,                # AppConfig::State ref
  39         DEBUG    => $state->_debug(),      # store local copy of debug
  40         PEDANTIC => $state->_pedantic,     # and pedantic flags
  41     };
  42
  43     bless $self, $class;
  44
  45     # call parse(@_) to parse any files specified as further params
  46     $self->parse(@_) if @_;
  47
  48     return $self;
  49 }
  50
  51
  52 #------------------------------------------------------------------------
  53 # parse($file, [file, ...])
  54 #
  55 # Reads and parses a config file, updating the contents of the
  56 # AppConfig::State referenced by $self->{ STATE } according to the
  57 # contents of the file.  Multiple files may be specified and are
  58 # examined in turn.  The method reports any error condition via
  59 # $self->{ STATE }->_error() and immediately returns undef if it
  60 # encounters a system error (i.e. cannot open one of the files.
  61 # Parsing errors such as unknown variables or unvalidated values will
  62 # also cause warnings to be raised vi the same _error(), but parsing
  63 # continues to the end of the current file and through any subsequent
  64 # files.  If the PEDANTIC option is set in the $self->{ STATE } object,
  65 # the behaviour is overridden and the method returns 0 immediately on
  66 # any system or parsing error.
  67 #
  68 # The EXPAND option for each variable determines how the variable
  69 # value should be expanded.
  70 #
  71 # Returns undef on system error, 0 if all files were parsed but generated
  72 # one or more warnings, 1 if all files parsed without warnings.
  73 #------------------------------------------------------------------------
  74
  75 sub parse {
  76     my $self     = shift;
  77     my $warnings = 0;
  78     my $prefix;           # [block] defines $prefix
  79     my $file;
  80     my $flag;
  81
  82     # take a local copy of the state to avoid much hash dereferencing
  83     my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) };
  84
  85     # we want to install a custom error handler into the AppConfig::State
  86     # which appends filename and line info to error messages and then
  87     # calls the previous handler;  we start by taking a copy of the
  88     # current handler..
  89     my $errhandler = $state->_ehandler();
  90
  91     # ...and if it doesn't exist, we craft a default handler
  92     $errhandler = sub { warn(sprintf(shift, @_), "\n") }
  93         unless defined $errhandler;
  94
  95     # install a closure as a new error handler
  96     $state->_ehandler(
  97         sub {
  98             # modify the error message
  99             my $format  = shift;
 100                $format .= ref $file
 101                           ? " at line $."
 102                           : " at $file line $.";
 103
 104             # chain call to prevous handler
 105             &$errhandler($format, @_);
 106         }
 107     );
 108
 109     # trawl through all files passed as params
 110     FILE: while ($file = shift) {
 111
 112         # local/lexical vars ensure opened files get closed
 113         my $handle;
 114         local *FH;
 115
 116         # if the file is a reference, we assume it's a file handle, if
 117         # not, we assume it's a filename and attempt to open it
 118         $handle = $file;
 119         if (ref($file)) {
 120             $handle = $file;
 121
 122             # DEBUG
 123             print STDERR "reading from file handle: $file\n" if $debug;
 124         }
 125         else {
 126             # open and read config file
 127             open(FH, $file) or do {
 128                 # restore original error handler and report error
 129                 $state->_ehandler($errhandler);
 130                 $state->_error("$file: $!");
 131
 132                 return undef;
 133             };
 134             $handle = \*FH;
 135
 136             # DEBUG
 137             print STDERR "reading file: $file\n" if $debug;
 138         }
 139
 140         # initialise $prefix to nothing (no [block])
 141         $prefix = '';
 142
 143         while (<$handle>) {
 144             chomp;
 145
 146             # Throw away everything from an unescaped # to EOL
 147             s/(^|\s+)#.*/$1/;
 148
 149             # add next line if there is one and this is a continuation
 150             if (s/\\$// && !eof($handle)) {
 151                 $_ .= <$handle>;
 152                 redo;
 153             }
 154
 155             # Convert \# -> #
 156             s/\\#/#/g;
 157
 158             # ignore blank lines
 159             next if /^\s*$/;
 160
 161             # strip leading and trailing whitespace
 162             s/^\s+//;
 163             s/\s+$//;
 164
 165             # look for a [block] to set $prefix
 166             if (/^\[([^\]]+)\]$/) {
 167                 $prefix = $1;
 168                 print STDERR "Entering [$prefix] block\n" if $debug;
 169                 next;
 170             }
 171
 172             # split line up by whitespace (\s+) or "equals" (\s*=\s*)
 173             if (/^([^\s=]+)(?:(?:(?:\s*=\s*)|\s+)(.*))?/) {
 174                 my ($variable, $value) = ($1, $2);
 175
 176                 if (defined $value) {
 177                     # here document
 178                     if ($value =~ /^([^\s=]+\s*=)?\s*<<(['"]?)(\S+)\2$/) { # '<<XX' or 'hashkey =<<XX'
 179                         my $boundary = "$3\n";
 180                         $value = defined($1) ? $1 : '';
 181                         while (<$handle>) {
 182                             last if $_ eq $boundary;
 183                             $value .= $_;
 184                         };
 185                         $value =~ s/[\r\n]$//;
 186                     } else {
 187                         # strip any quoting from the variable value
 188                         $value =~ s/^(['"])(.*)\1$/$2/;
 189                     };
 190                 };
 191
 192                 # strip any leading '+/-' from the variable
 193                 $variable =~ s/^([\-+]?)//;
 194                 $flag = $1;
 195
 196                 # $variable gets any $prefix
 197                 $variable = $prefix . '_' . $variable
 198                     if length $prefix;
 199
 200                 # if the variable doesn't exist, we call set() to give
 201                 # AppConfig::State a chance to auto-create it
 202                 unless ($state->_exists($variable)
 203                             || $state->set($variable, 1)) {
 204                     $warnings++;
 205                     last FILE if $pedantic;
 206                     next;
 207                 }
 208
 209                 my $nargs = $state->_argcount($variable);
 210
 211                 # variables prefixed '-' are reset to their default values
 212                 if ($flag eq '-') {
 213                     $state->_default($variable);
 214                     next;
 215                 }
 216                 # those prefixed '+' get set to 1
 217                 elsif ($flag eq '+') {
 218                     $value = 1 unless defined $value;
 219                 }
 220
 221                 # determine if any extra arguments were expected
 222                 if ($nargs) {
 223                     if (defined $value && length $value) {
 224                         # expand any embedded variables, ~uids or
 225                         # environment variables, testing the return value
 226                         # for errors;  we pass in any variable-specific
 227                         # EXPAND value
 228                         unless ($self->_expand(\$value,
 229                                 $state->_expand($variable), $prefix)) {
 230                             print STDERR "expansion of [$value] failed\n"
 231                                 if $debug;
 232                             $warnings++;
 233                             last FILE if $pedantic;
 234                         }
 235                     }
 236                     else {
 237                         $state->_error("$variable expects an argument");
 238                         $warnings++;
 239                         last FILE if $pedantic;
 240                         next;
 241                     }
 242                 }
 243                 # $nargs = 0
 244                 else {
 245                     # default value to 1 unless it is explicitly defined
 246                     # as '0' or "off"
 247                     if (defined $value) {
 248                         # "off" => 0
 249                         $value = 0 if $value =~ /off/i;
 250                         # any value => 1
 251                         $value = 1 if $value;
 252                     }
 253                     else {
 254                         # assume 1 unless explicitly defined off/0
 255                         $value = 1;
 256                     }
 257                     print STDERR "$variable => $value (no expansion)\n"
 258                         if $debug;
 259                 }
 260
 261                 # set the variable, noting any failure from set()
 262                 unless ($state->set($variable, $value)) {
 263                     $warnings++;
 264                     last FILE if $pedantic;
 265                 }
 266             }
 267             else {
 268                 $state->_error("parse error");
 269                 $warnings++;
 270             }
 271         }
 272     }
 273
 274     # restore original error handler
 275     $state->_ehandler($errhandler);
 276
 277     # return $warnings => 0, $success => 1
 278     return $warnings ? 0 : 1;
 279 }
 280
 281
 282
 283 #========================================================================
 284 #                      -----  PRIVATE METHODS -----
 285 #========================================================================
 286
 287 #------------------------------------------------------------------------
 288 # _expand(\$value, $expand, $prefix)
 289 #
 290 # The variable value string, referenced by $value, is examined and any
 291 # embedded variables, environment variables or tilde globs (home
 292 # directories) are replaced with their respective values, depending on
 293 # the value of the second parameter, $expand.  The third paramter may
 294 # specify the name of the current [block] in which the parser is
 295 # parsing.  This prefix is prepended to any embedded variable name that
 296 # can't otherwise be resolved.  This allows the following to work:
 297 #
 298 #   [define]
 299 #   home = /home/abw
 300 #   html = $define_home/public_html
 301 #   html = $home/public_html     # same as above, 'define' is prefix
 302 #
 303 # Modifications are made directly into the variable referenced by $value.
 304 # The method returns 1 on success or 0 if any warnings (undefined
 305 # variables) were encountered.
 306 #------------------------------------------------------------------------
 307
 308 sub _expand {
 309     my ($self, $value, $expand, $prefix) = @_;
 310     my $warnings = 0;
 311     my ($sys, $var, $val);
 312
 313
 314     # ensure prefix contains something (nothing!) valid for length()
 315     $prefix = "" unless defined $prefix;
 316
 317     # take a local copy of the state to avoid much hash dereferencing
 318     my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) };
 319
 320     # bail out if there's nothing to do
 321     return 1 unless $expand && defined($$value);
 322
 323     # create an AppConfig::Sys instance, or re-use a previous one,
 324     # to handle platform dependant functions: getpwnam(), getpwuid()
 325     unless ($sys = $self->{ SYS }) {
 326         require AppConfig::Sys;
 327         $sys = $self->{ SYS } = AppConfig::Sys->new();
 328     }
 329
 330     print STDERR "Expansion of [$$value] " if $debug;
 331
 332     EXPAND: {
 333
 334         #
 335         # EXPAND_VAR
 336         # expand $(var) and $var as AppConfig::State variables
 337         #
 338         if ($expand & AppConfig::EXPAND_VAR) {
 339
 340             $$value =~ s{
 341                 (?<!\\)\$ (?: \((\w+)\) | (\w+) ) # $2 => $(var) | $3 => $var
 342
 343             } {
 344                 # embedded variable name will be one of $2 or $3
 345                 $var = defined $1 ? $1 : $2;
 346
 347                 # expand the variable if defined
 348                 if ($state->_exists($var)) {
 349                     $val = $state->get($var);
 350                 }
 351                 elsif (length $prefix
 352                         && $state->_exists($prefix . '_' . $var)) {
 353                     print STDERR "(\$$var => \$${prefix}_$var) "
 354                         if $debug;
 355                     $var = $prefix . '_' . $var;
 356                     $val = $state->get($var);
 357                 }
 358                 else {
 359                     # raise a warning if EXPAND_WARN set
 360                     if ($expand & AppConfig::EXPAND_WARN) {
 361                         $state->_error("$var: no such variable");
 362                         $warnings++;
 363                     }
 364
 365                     # replace variable with nothing
 366                     $val = '';
 367                 }
 368
 369                 # $val gets substituted back into the $value string
 370                 $val;
 371             }gex;
 372
 373             $$value =~ s/\\\$/\$/g;
 374
 375             # bail out now if we need to
 376             last EXPAND if $warnings && $pedantic;
 377         }
 378
 379
 380         #
 381         # EXPAND_UID
 382         # expand ~uid as home directory (for $< if uid not specified)
 383         #
 384         if ($expand & AppConfig::EXPAND_UID) {
 385             $$value =~ s{
 386                 ~(\w+)?                    # $1 => username (optional)
 387             } {
 388                 $val = undef;
 389
 390                 # embedded user name may be in $1
 391                 if (defined ($var = $1)) {
 392                     # try and get user's home directory
 393                     if ($sys->can_getpwnam()) {
 394                         $val = ($sys->getpwnam($var))[7];
 395                     }
 396                 } else {
 397                     # determine home directory
 398                     $val = $ENV{ HOME };
 399                 }
 400
 401                 # catch-all for undefined $dir
 402                 unless (defined $val) {
 403                     # raise a warning if EXPAND_WARN set
 404                     if ($expand & AppConfig::EXPAND_WARN) {
 405                         $state->_error("cannot determine home directory%s",
 406                             defined $var ? " for $var" : "");
 407                         $warnings++;
 408                     }
 409
 410                     # replace variable with nothing
 411                     $val = '';
 412                 }
 413
 414                 # $val gets substituted back into the $value string
 415                 $val;
 416             }gex;
 417
 418             # bail out now if we need to
 419             last EXPAND if $warnings && $pedantic;
 420         }
 421
 422
 423         #
 424         # EXPAND_ENV
 425         # expand ${VAR} as environment variables
 426         #
 427         if ($expand & AppConfig::EXPAND_ENV) {
 428
 429             $$value =~ s{
 430                 ( \$ \{ (\w+) \} )
 431             } {
 432                 $var = $2;
 433
 434                 # expand the variable if defined
 435                 if (exists $ENV{ $var }) {
 436                     $val = $ENV{ $var };
 437                 } elsif ( $var eq 'HOME' ) {
 438                     # In the special case of HOME, if not set
 439                     # use the internal version
 440                     $val = $self->{ HOME };
 441                 } else {
 442                     # raise a warning if EXPAND_WARN set
 443                     if ($expand & AppConfig::EXPAND_WARN) {
 444                         $state->_error("$var: no such environment variable");
 445                         $warnings++;
 446                     }
 447
 448                     # replace variable with nothing
 449                     $val = '';
 450                 }
 451                 # $val gets substituted back into the $value string
 452                 $val;
 453             }gex;
 454
 455             # bail out now if we need to
 456             last EXPAND if $warnings && $pedantic;
 457         }
 458     }
 459
 460     print STDERR "=> [$$value] (EXPAND = $expand)\n" if $debug;
 461
 462     # return status
 463     return $warnings ? 0 : 1;
 464 }
 465
 466
 467
 468 #------------------------------------------------------------------------
 469 # _dump()
 470 #
 471 # Dumps the contents of the Config object.
 472 #------------------------------------------------------------------------
 473
 474 sub _dump {
 475     my $self = shift;
 476
 477     foreach my $key (keys %$self) {
 478         printf("%-10s => %s\n", $key,
 479                 defined($self->{ $key }) ? $self->{ $key } : "<undef>");
 480     }
 481 }
 482
 483
 484
 485 1;
 486
 487 __END__
 488
 489 =head1 NAME
 490
 491 AppConfig::File - Perl5 module for reading configuration files.
 492
 493 =head1 SYNOPSIS
 494
 495     use AppConfig::File;
 496
 497     my $state   = AppConfig::State->new(\%cfg1);
 498     my $cfgfile = AppConfig::File->new($state, $file);
 499
 500     $cfgfile->parse($file);            # read config file
 501
 502 =head1 OVERVIEW
 503
 504 AppConfig::File is a Perl5 module which reads configuration files and use
 505 the contents therein to update variable values in an AppConfig::State
 506 object.
 507
 508 AppConfig::File is distributed as part of the AppConfig bundle.
 509
 510 =head1 DESCRIPTION
 511
 512 =head2 USING THE AppConfig::File MODULE
 513
 514 To import and use the AppConfig::File module the following line should appear
 515 in your Perl script:
 516
 517     use AppConfig::File;
 518
 519 AppConfig::File is used automatically if you use the AppConfig module
 520 and create an AppConfig::File object through the file() method.
 521
 522 AppConfig::File is implemented using object-oriented methods.  A new
 523 AppConfig::File object is created and initialised using the
 524 AppConfig::File->new() method.  This returns a reference to a new
 525 AppConfig::File object.  A reference to an AppConfig::State object
 526 should be passed in as the first parameter:
 527
 528     my $state   = AppConfig::State->new();
 529     my $cfgfile = AppConfig::File->new($state);
 530
 531 This will create and return a reference to a new AppConfig::File object.
 532
 533 =head2 READING CONFIGURATION FILES
 534
 535 The C<parse()> method is used to read a configuration file and have the
 536 contents update the STATE accordingly.
 537
 538     $cfgfile->parse($file);
 539
 540 Multiple files maye be specified and will be read in turn.
 541
 542     $cfgfile->parse($file1, $file2, $file3);
 543
 544 The method will return an undef value if it encounters any errors opening
 545 the files.  It will return immediately without processing any further files.
 546 By default, the PEDANTIC option in the AppConfig::State object,
 547 $self->{ STATE }, is turned off and any parsing errors (invalid variables,
 548 unvalidated values, etc) will generated warnings, but not cause the method
 549 to return.  Having processed all files, the method will return 1 if all
 550 files were processed without warning or 0 if one or more warnings were
 551 raised.  When the PEDANTIC option is turned on, the method generates a
 552 warning and immediately returns a value of 0 as soon as it encounters any
 553 parsing error.
 554
 555 Variables values in the configuration files may be expanded depending on
 556 the value of their EXPAND option, as determined from the App::State object.
 557 See L<AppConfig::State> for more information on variable expansion.
 558
 559 =head2 CONFIGURATION FILE FORMAT
 560
 561 A configuration file may contain blank lines and comments which are
 562 ignored.  Comments begin with a '#' as the first character on a line
 563 or following one or more whitespace tokens, and continue to the end of
 564 the line.
 565
 566     # this is a comment
 567     foo = bar               # so is this
 568     url = index.html#hello  # this too, but not the '#welcome'
 569
 570 Notice how the '#welcome' part of the URL is not treated as a comment
 571 because a whitespace character doesn't precede it.
 572
 573 Long lines can be continued onto the next line by ending the first
 574 line with a '\'.
 575
 576     callsign = alpha bravo camel delta echo foxtrot golf hipowls \
 577                india juliet kilo llama mike november oscar papa  \
 578                quebec romeo sierra tango umbrella victor whiskey \
 579                x-ray yankee zebra
 580
 581 Variables that are simple flags and do not expect an argument (ARGCOUNT =
 582 ARGCOUNT_NONE) can be specified without any value.  They will be set with
 583 the value 1, with any value explicitly specified (except "0" and "off")
 584 being ignored.  The variable may also be specified with a "no" prefix to
 585 implicitly set the variable to 0.
 586
 587     verbose                              # on  (1)
 588     verbose = 1                          # on  (1)
 589     verbose = 0                          # off (0)
 590     verbose off                          # off (0)
 591     verbose on                           # on  (1)
 592     verbose mumble                       # on  (1)
 593     noverbose                            # off (0)
 594
 595 Variables that expect an argument (ARGCOUNT = ARGCOUNT_ONE) will be set to
 596 whatever follows the variable name, up to the end of the current line.  An
 597 equals sign may be inserted between the variable and value for clarity.
 598
 599     room = /home/kitchen
 600     room   /home/bedroom
 601
 602 Each subsequent re-definition of the variable value overwrites the previous
 603 value.
 604
 605     print $config->room();               # prints "/home/bedroom"
 606
 607 Variables may be defined to accept multiple values (ARGCOUNT = ARGCOUNT_LIST).
 608 Each subsequent definition of the variable adds the value to the list of
 609 previously set values for the variable.
 610
 611     drink = coffee
 612     drink = tea
 613
 614 A reference to a list of values is returned when the variable is requested.
 615
 616     my $beverages = $config->drinks();
 617     print join(", ", @$beverages);      # prints "coffee, tea"
 618
 619 Variables may also be defined as hash lists (ARGCOUNT = ARGCOUNT_HASH).
 620 Each subsequent definition creates a new key and value in the hash array.
 621
 622     alias l="ls -CF"
 623     alias h="history"
 624
 625 A reference to the hash is returned when the variable is requested.
 626
 627     my $aliases = $config->alias();
 628     foreach my $k (keys %$aliases) {
 629         print "$k => $aliases->{ $k }\n";
 630     }
 631
 632 A large chunk of text can be defined using Perl's "heredoc" quoting
 633 style.
 634
 635    scalar = <<BOUNDARY_STRING
 636    line 1
 637    line 2: Space/linebreaks within a HERE document are kept.
 638    line 3: The last linebreak (\n) is stripped.
 639    BOUNDARY_STRING
 640
 641    hash   key1 = <<'FOO'
 642      * Quotes (['"]) around the boundary string are simply ignored.
 643      * Whether the variables in HERE document are expanded depends on
 644        the EXPAND option of the variable or global setting.
 645    FOO
 646
 647    hash = key2 = <<"_bar_"
 648    Text within HERE document are kept as is.
 649    # comments are treated as a normal text.
 650    The same applies to line continuation. \
 651    _bar_
 652
 653 Note that you cannot use HERE document as a key in a hash or a name
 654 of a variable.
 655
 656 The '-' prefix can be used to reset a variable to its default value and
 657 the '+' prefix can be used to set it to 1
 658
 659     -verbose
 660     +debug
 661
 662 Variable, environment variable and tilde (home directory) expansions
 663 Variable values may contain references to other AppConfig variables,
 664 environment variables and/or users' home directories.  These will be
 665 expanded depending on the EXPAND value for each variable or the GLOBAL
 666 EXPAND value.
 667
 668 Three different expansion types may be applied:
 669
 670     bin = ~/bin          # expand '~' to home dir if EXPAND_UID
 671     tmp = ~abw/tmp       # as above, but home dir for user 'abw'
 672
 673     perl = $bin/perl     # expand value of 'bin' variable if EXPAND_VAR
 674     ripl = $(bin)/ripl   # as above with explicit parens
 675
 676     home = ${HOME}       # expand HOME environment var if EXPAND_ENV
 677
 678 See L<AppConfig::State> for more information on expanding variable values.
 679
 680 The configuration files may have variables arranged in blocks.  A block
 681 header, consisting of the block name in square brackets, introduces a
 682 configuration block.  The block name and an underscore are then prefixed
 683 to the names of all variables subsequently referenced in that block.  The
 684 block continues until the next block definition or to the end of the current
 685 file.
 686
 687     [block1]
 688     foo = 10             # block1_foo = 10
 689
 690     [block2]
 691     foo = 20             # block2_foo = 20
 692
 693 =head1 AUTHOR
 694
 695 Andy Wardley, E<lt>abw@wardley.orgE<gt>
 696
 697 =head1 COPYRIGHT
 698
 699 Copyright (C) 1997-2007 Andy Wardley.  All Rights Reserved.
 700
 701 This module is free software; you can redistribute it and/or modify it
 702 under the same terms as Perl itself.
 703
 704 =head1 SEE ALSO
 705
 706 AppConfig, AppConfig::State
 707
 708 =cut