AnonymousFox

//usr/local/share/perl5/AppConfig/File.pm

#============================================================================
#
# AppConfig::File.pm
#
# Perl5 module to read configuration files and use the contents therein 
# to update variable values in an AppConfig::State object.
#
# Written by Andy Wardley <abw@wardley.org>
#
# Copyright (C) 1997-2007 Andy Wardley.  All Rights Reserved.
# Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
#
#============================================================================

package AppConfig::File;
use 5.006;
use strict;
use warnings;
use AppConfig;
use AppConfig::State;
our $VERSION = '1.71';

#------------------------------------------------------------------------
# new($state, $file, [$file, ...])
#
# Module constructor.  The first, mandatory parameter should be a 
# reference to an AppConfig::State object to which all actions should 
# be applied.  The remaining parameters are assumed to be file names or
# file handles for reading and are passed to parse().
#
# Returns a reference to a newly created AppConfig::File object.
#------------------------------------------------------------------------

sub new {
    my $class = shift;
    my $state = shift;
    my $self  = {
        STATE    => $state,                # AppConfig::State ref
        DEBUG    => $state->_debug(),      # store local copy of debug 
        PEDANTIC => $state->_pedantic,     # and pedantic flags
    };

bless $self, $class;

# call parse(@_) to parse any files specified as further params
    $self->parse(@_) if @_;

return $self;
}

#------------------------------------------------------------------------
# parse($file, [file, ...])
#
# Reads and parses a config file, updating the contents of the 
# AppConfig::State referenced by $self->{ STATE } according to the 
# contents of the file.  Multiple files may be specified and are 
# examined in turn.  The method reports any error condition via 
# $self->{ STATE }->_error() and immediately returns undef if it 
# encounters a system error (i.e. cannot open one of the files.  
# Parsing errors such as unknown variables or unvalidated values will 
# also cause warnings to be raised vi the same _error(), but parsing
# continues to the end of the current file and through any subsequent
# files.  If the PEDANTIC option is set in the $self->{ STATE } object, 
# the behaviour is overridden and the method returns 0 immediately on 
# any system or parsing error.
#
# The EXPAND option for each variable determines how the variable
# value should be expanded.
#
# Returns undef on system error, 0 if all files were parsed but generated
# one or more warnings, 1 if all files parsed without warnings.
#------------------------------------------------------------------------

sub parse {
    my $self     = shift;
    my $warnings = 0;
    my $prefix;           # [block] defines $prefix
    my $file;
    my $flag;

# take a local copy of the state to avoid much hash dereferencing
    my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) };

# we want to install a custom error handler into the AppConfig::State 
    # which appends filename and line info to error messages and then 
    # calls the previous handler;  we start by taking a copy of the 
    # current handler..
    my $errhandler = $state->_ehandler();

# ...and if it doesn't exist, we craft a default handler
    $errhandler = sub { warn(sprintf(shift, @_), "\n") }
        unless defined $errhandler;

# install a closure as a new error handler
    $state->_ehandler(
        sub {
            # modify the error message 
            my $format  = shift;
               $format .= ref $file 
                          ? " at line $."
                          : " at $file line $.";

# chain call to prevous handler
            &$errhandler($format, @_);
        }
    );

# trawl through all files passed as params
    FILE: while ($file = shift) {

# local/lexical vars ensure opened files get closed
        my $handle;
        local *FH;

# if the file is a reference, we assume it's a file handle, if
        # not, we assume it's a filename and attempt to open it
        $handle = $file;
        if (ref($file)) {
            $handle = $file;

# DEBUG
            print STDERR "reading from file handle: $file\n" if $debug;
        }
        else {
            # open and read config file
            open(FH, $file) or do {
                # restore original error handler and report error
                $state->_ehandler($errhandler);
                $state->_error("$file: $!");

return undef;
            };
            $handle = \*FH;

# DEBUG
            print STDERR "reading file: $file\n" if $debug;
        }

# initialise $prefix to nothing (no [block])
        $prefix = '';

local $_;
        while (<$handle>) {
            chomp;

# Throw away everything from an unescaped # to EOL
            s/(^|\s+)#.*/$1/;

# add next line if there is one and this is a continuation
            if (s/\\$// && !eof($handle)) {
                $_ .= <$handle>;
                redo;
            }

# Convert \# -> #
            s/\\#/#/g;

# ignore blank lines
            next if /^\s*$/;

# strip leading and trailing whitespace
            s/^\s+//;
            s/\s+$//;

# look for a [block] to set $prefix
            if (/^\[([^\]]+)\]$/) {
                $prefix = $1;
                print STDERR "Entering [$prefix] block\n" if $debug;
                next;
            }

# split line up by whitespace (\s+) or "equals" (\s*=\s*)
            if (/^([^\s=]+)(?:(?:(?:\s*=\s*)|\s+)(.*))?/) {
                my ($variable, $value) = ($1, $2);

if (defined $value) {
                    # here document
                    if ($value =~ /^([^\s=]+\s*=)?\s*<<(['"]?)(\S+)\2$/) { # '<<XX' or 'hashkey =<<XX'
                        my $boundary = "$3\n";
                        $value = defined($1) ? $1 : '';
                        while (<$handle>) {
                            last if $_ eq $boundary;
                            $value .= $_;
                        };
                        $value =~ s/[\r\n]$//;
                    } else {
                        # strip any quoting from the variable value
                        $value =~ s/^(['"])(.*)\1$/$2/;
                    };
                };

# strip any leading '+/-' from the variable
                $variable =~ s/^([\-+]?)//;
                $flag = $1;

# $variable gets any $prefix 
                $variable = $prefix . '_' . $variable
                    if length $prefix;

# if the variable doesn't exist, we call set() to give 
                # AppConfig::State a chance to auto-create it
                unless ($state->_exists($variable) 
                            || $state->set($variable, 1)) {
                    $warnings++;
                    last FILE if $pedantic;
                    next;
                }

my $nargs = $state->_argcount($variable);

# variables prefixed '-' are reset to their default values
                if ($flag eq '-') {
                    $state->_default($variable);
                    next;
                }
                # those prefixed '+' get set to 1
                elsif ($flag eq '+') {
                    $value = 1 unless defined $value;
                }

# determine if any extra arguments were expected
                if ($nargs) {
                    if (defined $value && length $value) {
                        # expand any embedded variables, ~uids or
                        # environment variables, testing the return value
                        # for errors;  we pass in any variable-specific
                        # EXPAND value 
                        unless ($self->_expand(\$value, 
                                $state->_expand($variable), $prefix)) {
                            print STDERR "expansion of [$value] failed\n" 
                                if $debug;
                            $warnings++;
                            last FILE if $pedantic;
                        }
                    }
                    else {
                        $state->_error("$variable expects an argument");
                        $warnings++;
                        last FILE if $pedantic;
                        next;
                    }
                }
                # $nargs = 0
                else {
                    # default value to 1 unless it is explicitly defined
                    # as '0' or "off"
                    if (defined $value) {
                        # "off" => 0
                        $value = 0 if $value =~ /off/i;
                        # any value => 1
                        $value = 1 if $value;
                    }
                    else {
                        # assume 1 unless explicitly defined off/0
                        $value = 1;
                    }
                    print STDERR "$variable => $value (no expansion)\n"
                        if $debug;
                }

# set the variable, noting any failure from set()
                unless ($state->set($variable, $value)) {
                    $warnings++;
                    last FILE if $pedantic;
                }
            }
            else {
                $state->_error("parse error");
                $warnings++;
            }
        }
    }

# restore original error handler
    $state->_ehandler($errhandler);

# return $warnings => 0, $success => 1
    return $warnings ? 0 : 1;
}

#========================================================================
#                      -----  PRIVATE METHODS -----
#========================================================================

#------------------------------------------------------------------------
# _expand(\$value, $expand, $prefix)
#
# The variable value string, referenced by $value, is examined and any 
# embedded variables, environment variables or tilde globs (home 
# directories) are replaced with their respective values, depending on 
# the value of the second parameter, $expand.  The third paramter may
# specify the name of the current [block] in which the parser is 
# parsing.  This prefix is prepended to any embedded variable name that
# can't otherwise be resolved.  This allows the following to work:
#
#   [define]
#   home = /home/abw
#   html = $define_home/public_html
#   html = $home/public_html     # same as above, 'define' is prefix
#
# Modifications are made directly into the variable referenced by $value.
# The method returns 1 on success or 0 if any warnings (undefined 
# variables) were encountered.
#------------------------------------------------------------------------

sub _expand {
    my ($self, $value, $expand, $prefix) = @_;
    my $warnings = 0;
    my ($sys, $var, $val);

# ensure prefix contains something (nothing!) valid for length()
    $prefix = "" unless defined $prefix;

# take a local copy of the state to avoid much hash dereferencing
    my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) };

# bail out if there's nothing to do
    return 1 unless $expand && defined($$value);

# create an AppConfig::Sys instance, or re-use a previous one, 
    # to handle platform dependant functions: getpwnam(), getpwuid()
    unless ($sys = $self->{ SYS }) {
        require AppConfig::Sys;
        $sys = $self->{ SYS } = AppConfig::Sys->new();
    }

print STDERR "Expansion of [$$value] " if $debug;

EXPAND: {

# 
        # EXPAND_VAR
        # expand $(var) and $var as AppConfig::State variables
        #
        if ($expand & AppConfig::EXPAND_VAR) {

$$value =~ s{
                (?<!\\)\$ (?: $(\w+)$ | (\w+) ) # $2 => $(var) | $3 => $var

} {
                # embedded variable name will be one of $2 or $3
                $var = defined $1 ? $1 : $2;

# expand the variable if defined
                if ($state->_exists($var)) {
                    $val = $state->get($var);
                }
                elsif (length $prefix 
                        && $state->_exists($prefix . '_' . $var)) {
                    print STDERR "(\$$var => \$${prefix}_$var) "
                        if $debug;
                    $var = $prefix . '_' . $var;
                    $val = $state->get($var);
                }
                else {
                    # raise a warning if EXPAND_WARN set
                    if ($expand & AppConfig::EXPAND_WARN) {
                        $state->_error("$var: no such variable");
                        $warnings++;
                    }

# replace variable with nothing
                    $val = '';
                }

# $val gets substituted back into the $value string
                $val;
            }gex;

$$value =~ s/\\\$/\$/g;

# bail out now if we need to
            last EXPAND if $warnings && $pedantic;
        }

#
        # EXPAND_UID
        # expand ~uid as home directory (for $< if uid not specified)
        #
        if ($expand & AppConfig::EXPAND_UID) {
            $$value =~ s{
                ~(\w+)?                    # $1 => username (optional)
            } {
                $val = undef;

# embedded user name may be in $1
                if (defined ($var = $1)) {
                    # try and get user's home directory
                    if ($sys->can_getpwnam()) {
                        $val = ($sys->getpwnam($var))[7];
                    }
                } else {
                    # determine home directory 
                    $val = $ENV{ HOME };
                }

# catch-all for undefined $dir
                unless (defined $val) {
                    # raise a warning if EXPAND_WARN set
                    if ($expand & AppConfig::EXPAND_WARN) {
                        $state->_error("cannot determine home directory%s",
                            defined $var ? " for $var" : "");
                        $warnings++;
                    }

# replace variable with nothing
                    $val = '';
                }

# $val gets substituted back into the $value string
                $val;
            }gex;

# bail out now if we need to
            last EXPAND if $warnings && $pedantic;
        }

#
        # EXPAND_ENV
        # expand ${VAR} as environment variables
        #
        if ($expand & AppConfig::EXPAND_ENV) {

$$value =~ s{ 
                ( \$ \{ (\w+) \} )
            } {
                $var = $2;

# expand the variable if defined
                if (exists $ENV{ $var }) {
                    $val = $ENV{ $var };
                } elsif ( $var eq 'HOME' ) {
                    # In the special case of HOME, if not set
                    # use the internal version
                    $val = $self->{ HOME };
                } else {
                    # raise a warning if EXPAND_WARN set
                    if ($expand & AppConfig::EXPAND_WARN) {
                        $state->_error("$var: no such environment variable");
                        $warnings++;
                    }

# replace variable with nothing
                    $val = '';
                }
                # $val gets substituted back into the $value string
                $val;
            }gex;

# bail out now if we need to
            last EXPAND if $warnings && $pedantic;
        }
    }

print STDERR "=> [$$value] (EXPAND = $expand)\n" if $debug;

# return status 
    return $warnings ? 0 : 1;
}

#------------------------------------------------------------------------
# _dump()
#
# Dumps the contents of the Config object.
#------------------------------------------------------------------------

sub _dump {
    my $self = shift;

foreach my $key (keys %$self) {
        printf("%-10s => %s\n", $key, 
                defined($self->{ $key }) ? $self->{ $key } : "<undef>");
    }       
}

__END__

=head1 NAME

AppConfig::File - Perl5 module for reading configuration files.

=head1 SYNOPSIS

use AppConfig::File;

my $state   = AppConfig::State->new(\%cfg1);
    my $cfgfile = AppConfig::File->new($state, $file);

$cfgfile->parse($file);            # read config file

=head1 OVERVIEW

AppConfig::File is a Perl5 module which reads configuration files and use 
the contents therein to update variable values in an AppConfig::State 
object.

AppConfig::File is distributed as part of the AppConfig bundle.

=head1 DESCRIPTION

=head2 USING THE AppConfig::File MODULE

To import and use the AppConfig::File module the following line should appear
in your Perl script:

use AppConfig::File;

AppConfig::File is used automatically if you use the AppConfig module 
and create an AppConfig::File object through the file() method.

AppConfig::File is implemented using object-oriented methods.  A new 
AppConfig::File object is created and initialised using the 
AppConfig::File->new() method.  This returns a reference to a new 
AppConfig::File object.  A reference to an AppConfig::State object 
should be passed in as the first parameter:

my $state   = AppConfig::State->new();
    my $cfgfile = AppConfig::File->new($state);

This will create and return a reference to a new AppConfig::File object.

=head2 READING CONFIGURATION FILES

The C<parse()> method is used to read a configuration file and have the 
contents update the STATE accordingly.

$cfgfile->parse($file);

Multiple files maye be specified and will be read in turn.

$cfgfile->parse($file1, $file2, $file3);

The method will return an undef value if it encounters any errors opening
the files.  It will return immediately without processing any further files.
By default, the PEDANTIC option in the AppConfig::State object, 
$self->{ STATE }, is turned off and any parsing errors (invalid variables,
unvalidated values, etc) will generated warnings, but not cause the method
to return.  Having processed all files, the method will return 1 if all
files were processed without warning or 0 if one or more warnings were
raised.  When the PEDANTIC option is turned on, the method generates a
warning and immediately returns a value of 0 as soon as it encounters any
parsing error.

Variables values in the configuration files may be expanded depending on 
the value of their EXPAND option, as determined from the App::State object.
See L<AppConfig::State> for more information on variable expansion.

=head2 CONFIGURATION FILE FORMAT

A configuration file may contain blank lines and comments which are
ignored.  Comments begin with a '#' as the first character on a line
or following one or more whitespace tokens, and continue to the end of
the line.

# this is a comment
    foo = bar               # so is this
    url = index.html#hello  # this too, but not the '#welcome'

Notice how the '#welcome' part of the URL is not treated as a comment
because a whitespace character doesn't precede it.

Long lines can be continued onto the next line by ending the first 
line with a '\'.

callsign = alpha bravo camel delta echo foxtrot golf hipowls \
               india juliet kilo llama mike november oscar papa  \
               quebec romeo sierra tango umbrella victor whiskey \
               x-ray yankee zebra

Variables that are simple flags and do not expect an argument (ARGCOUNT = 
ARGCOUNT_NONE) can be specified without any value.  They will be set with 
the value 1, with any value explicitly specified (except "0" and "off")
being ignored.  The variable may also be specified with a "no" prefix to 
implicitly set the variable to 0.

verbose                              # on  (1)
    verbose = 1                          # on  (1)
    verbose = 0                          # off (0)
    verbose off                          # off (0)
    verbose on                           # on  (1)
    verbose mumble                       # on  (1)
    noverbose                            # off (0)

Variables that expect an argument (ARGCOUNT = ARGCOUNT_ONE) will be set to 
whatever follows the variable name, up to the end of the current line.  An
equals sign may be inserted between the variable and value for clarity.

room = /home/kitchen     
    room   /home/bedroom

Each subsequent re-definition of the variable value overwrites the previous
value.

print $config->room();               # prints "/home/bedroom"

Variables may be defined to accept multiple values (ARGCOUNT = ARGCOUNT_LIST).
Each subsequent definition of the variable adds the value to the list of
previously set values for the variable.

drink = coffee
    drink = tea

A reference to a list of values is returned when the variable is requested.

my $beverages = $config->drinks();
    print join(", ", @$beverages);      # prints "coffee, tea"

Variables may also be defined as hash lists (ARGCOUNT = ARGCOUNT_HASH).
Each subsequent definition creates a new key and value in the hash array.

alias l="ls -CF"
    alias h="history"

A reference to the hash is returned when the variable is requested.

my $aliases = $config->alias();
    foreach my $k (keys %$aliases) {
        print "$k => $aliases->{ $k }\n";
    }

A large chunk of text can be defined using Perl's "heredoc" quoting
style.

scalar = <<BOUNDARY_STRING
   line 1
   line 2: Space/linebreaks within a HERE document are kept.
   line 3: The last linebreak (\n) is stripped.
   BOUNDARY_STRING

hash   key1 = <<'FOO'
     * Quotes (['"]) around the boundary string are simply ignored.
     * Whether the variables in HERE document are expanded depends on
       the EXPAND option of the variable or global setting.
   FOO

hash = key2 = <<"_bar_"
   Text within HERE document are kept as is.
   # comments are treated as a normal text.
   The same applies to line continuation. \
   _bar_

Note that you cannot use HERE document as a key in a hash or a name 
of a variable.

The '-' prefix can be used to reset a variable to its default value and
the '+' prefix can be used to set it to 1

-verbose
    +debug

Variable, environment variable and tilde (home directory) expansions
Variable values may contain references to other AppConfig variables, 
environment variables and/or users' home directories.  These will be 
expanded depending on the EXPAND value for each variable or the GLOBAL
EXPAND value.

Three different expansion types may be applied:

bin = ~/bin          # expand '~' to home dir if EXPAND_UID
    tmp = ~abw/tmp       # as above, but home dir for user 'abw'

perl = $bin/perl     # expand value of 'bin' variable if EXPAND_VAR
    ripl = $(bin)/ripl   # as above with explicit parens

home = ${HOME}       # expand HOME environment var if EXPAND_ENV

See L<AppConfig::State> for more information on expanding variable values.

The configuration files may have variables arranged in blocks.  A block 
header, consisting of the block name in square brackets, introduces a 
configuration block.  The block name and an underscore are then prefixed 
to the names of all variables subsequently referenced in that block.  The 
block continues until the next block definition or to the end of the current 
file.

[block1]
    foo = 10             # block1_foo = 10

[block2]
    foo = 20             # block2_foo = 20

=head1 AUTHOR

Andy Wardley, E<lt>abw@wardley.orgE<gt>

=head1 COPYRIGHT

This module is free software; you can redistribute it and/or modify it 
under the same terms as Perl itself.

=head1 SEE ALSO

AppConfig, AppConfig::State

=cut