xemacsweb / cgi-bin /

Full commit
package AppCfg;

# Application Configuration -- parses a user specified file of value
# assignments to variables. Values can be accessed either through object
# methods or by importing the variables into a Perl package namespace.
# Pod document at the end of this file.

# Copyright 1996, 1998 by David Wolfe <>.
# May be freely used, modified, and redistributed under the same terms
# as Perl. Absolutely no warranty of any kind. Author is not responsible
# for any damage or loss caused by use of this program.

use strict;
use subs qw/ _substitute /;
use vars qw/ $NAMES $VARS $VERSION /;

*VERSION = \('$Revision$' =~ /\D*([\d.]+)/);

use Carp;

# Method called to create an AppCfg object. Parses files specified in
# the argument list to populate the object, a two-element. The first
# element is a reference to a hash keyed by the upper-case configuration
# variables whose values are references to arrays of the configuration
# variable values. The second element is an array of the original
# configuration variable names. Since this method may call warn and/or
# die, some applications may need to eval the call to it to trap these
# conditions.

*VARS  = \0;
*NAMES = \1;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = [];
    my $cfg   = $self->[$VARS] = {}; $self->[$NAMES] = [];
    my @argv  = @_;
    my $argv;
    local $_;

    # Process each configuration file, ignoring blank and comment lines.
    foreach $argv (@argv) {
	open(ARGFD, $argv) || croak "open $argv failed: $!";
	my ($append, $op, $val, $var, $vname);
	while (<ARGFD>) {
	    s/(^#|\s+#).*//;	# Remove comments
	    next if /^\s*$/;	# Skip blank lines

	    # Extract variable assignments
	    if (($var, $append, $op, $val) =
		    /^\s*([a-z_]\w*)\s*(\+)?(=|<<)\s*(.*?)\s*$/i) {
		$vname = uc $var;
		carp "'$var' redefined at line $. in config file $argv\n"
		    if !defined $append && defined $cfg->{$vname};

		# Save the unaltered name
		push(@{$self->[$NAMES]}, $var) unless defined $cfg->{$vname};

		# Single value assignments
		if ($op eq '=') {
		    if (defined $append && defined $cfg->{$vname}) {
			push @{$cfg->{$vname}}, _substitute($cfg, $val);
		    else {
			$cfg->{$vname} = [ _substitute($cfg, $val) ];

		# Multi-value assignments. Process lines like main loop
		# until value delimiter is found.
		else {
		    my $atend = 0;
		    $cfg->{$vname} = []
		    	if !defined $append && defined $cfg->{$vname};
		    while (!($atend = eof(ARGFD)) && defined($_ = <ARGFD>)) {
			s/(^#|\s+#).*//;	# Remove comments
			next unless /\S/;	# Skip blank lines
			s/^\s+|\s+$//g;		# Trim leading/trailing space
			last if $_ eq $val;	# Done if delimiter string
			push(@{$cfg->{$vname}}, _substitute($cfg, $_));
		    croak "Delimiter '$val' for list '$var' not found in " .
			"config file $argv\n" if $atend;

	    # Line didn't have a recognizable assignment
	    else {
		carp "Line $. of config file $argv is invalid:\n$_";
    bless $self, $class;	# Return the object reference

# Method to retrieve a multi-valued variable.

sub get_list {
    my ($self, $var) = @_;
    @{$self->[$VARS]->{uc $var}};

# Method to retrieve a single-valued variable.

sub get_scalar {
    my ($self, $var) = @_;
    $self->[$VARS]->{uc $var}->[0];

# Method to import variables into a namespace. First argument is the
# namespace name ("CFG" if null or undefined) and the second is one of
# "lower" (the default), "upper", or "exact" (also "asis"), denoting how
# the variable names are to be defined in the namespace: in upper-case,
# lower-case, or as written in the configuration file, respectively.

my %casemap = (
    'asis'  => sub { $_[0] },
    'exact' => sub { $_[0] },
    'lower' => sub { lc $_[0] },
    'upper' => sub { uc $_[0] },

sub import_variables {
    my ($self, $namespace, $case) = @_;

    if (! defined $namespace || $namespace eq '') {
	$namespace = 'CFG';
    else {
	croak "Invalid namespace '$namespace'\n"
	    unless $namespace =~ /^[a-z_]\w*$/i;
	croak "Can't import variables into 'main'\n"
	    if $namespace eq 'main';

    $case = (defined $case && defined $casemap{lc $case})
	    ? $casemap{lc $case}
	    : $casemap{'lower'};

    my $name;
    foreach $name (@{$self->[$NAMES]}) {
	my $var = &$case($name);
	no strict 'refs';
	${"${namespace}::$var"} = $self->[$VARS]->{uc $name}->[0];
	@{"${namespace}::$var"} = @{$self->[$VARS]->{uc $name}};

# Private data and functions

# Meta-characters that map to control characters when escaped.

my %meta = (
    'a' => "\a",
    'b' => "\b",
    'e' => "\e",
    'f' => "\f",
    'n' => "\n",
    'r' => "\r",
    't' => "\t"

# Function to substitute meta-characters and variable values into
# strings.

sub _substitute {
    my $vars = shift;
    local $_ = shift;

    # Identify all numeric control character escapes and replace them
    # with marker characters.
    my @escapes = /\\(x[A-Fa-f\d]{1,2}|0[0-7]{0,3}|c.|.|$)/g;

    # Substitute variable references. Note that the global $" Perl
    # variable is inserted between multi-value elements.
    s/ \$ (?:
		([a-z_]\w+)	#  $variable
	   | \( ([a-z_]\w+) \)	# $(variable)
	   | \{ ([a-z_]\w+) \}	# ${variable}
    / defined $vars->{uc $1 || uc $2 || uc $3}
	? join($", @{$vars->{uc $1 || uc $2 || uc $3}})
	: ""

    # Replace markers with the corresponding control character.
    my $ch;
    foreach $ch (@escapes) {
	if ($ch =~ /^x(.+)/) {
	    $ch = chr hex $1;
	elsif ($ch =~ /^(0.*)/) {
	    $ch = chr oct $1;
	elsif ($ch =~ /^c(.)/) {
	    $ch = chr(ord($1) & ~0x60);
	elsif ($meta{$ch}) {
	    $ch = $meta{$ch};



=head1 NAME

AppCfg - class for application configuration files


    require AppCfg;

    $my_config = new AppCfg @config_files;
    @value = $my_config->get_list($variable);
    $value = $my_config->get_scalar($variable);
    $my_config->import_variables($namespace, $case);


The C<new> method parses the specified configuration files to initialize
the AppCfg object. Configuration variables take one of two forms:

=over 4

=item A scalar assignment:

    SomeVariable = its value

=item A list assignment:

    ListVariable << DELIMITER
    First value
    second value
    3rd value


A B<+> may be used as a modifier prefix to the B<=> and B<<<> assignment
operators to indicate that the value(s) are to be appended to the
current value(s) of the variable instead of replacing it.

Variable names may contain only alphanumeric characters and underscore
and the first character is restricted to alphabetic and the underscore
characters. Variables that differ only in alphabetic case are considered
to be the same variable. Whitespace surrounding variable names and
value strings is discarded, as are empty lines. The B<#> character,
when preceded by whitespace or at the beginning of a line, introduces a
comment which is stripped from the input before parsing.

Previously defined variables may be substituted into values by denoting
them with a leading B<$> or surrounding the variable name by parentheses
and prepending the B<$> character when not otherwise delimited by
non-alphanumeric, non-underscore characters. Only one level of
substitution is supported and is subject to the case spelling in effect.
For example:

=over 4

    DocumentRoot = /usr/local/docs
    DocDirectories << EOD
    DocDirectories += $DocumentRoot/ps

    RoffInput = $(BaseName)1.1

    Where = "Documents are in $DocDirectories"


The characters inserted between values of multi-valued variable
substitutions are determined by the Perl B<$"> variable, normally a

In value strings, a B<\> escapes the next character (except at the end
of the line), so B<$> and B<#> may be inserted without interpolation
by pairing them with B<\>, e.g. B<\$>, B<\#>, and B<\\>. A B<\> at the
end of a line does I<not> escape the newline, nor does it join lines,
but it may be used to force trailing whitespace on a value, just as a
leading B<\> can be used to force leading whitespace on a value. The
following characters, when escaped by B<\>, are interpolated to insert
the corresponding control codes:

= over 4

    \b    Backspace
    \f    Form feed
    \n    Newline
    \r    Carriage return
    \t    Tab
    \cx   Character 'x' as a control character
    \xdd  Digits 'dd' as a hex number
    \0ddd Digits 'ddd' as an octal number


Any other escaped character is substituted for itself.

The C<get_scalar> method returns a scalar configuration variable or the
first element of a list configuration variable. This is a change from
earlier versions which returned C<undef> for list variables.

The C<get_list> method returns the list of values assigned to a
configuration variable or a one-element list of the single value of a
scalar variable. Again, this is a change from earlier versions which
returned an empty list for scalar variables.

The variable name specified to C<get_scalar> and C<get_list>
is caseless, that is, case is irrelevant. C<list_variable>,
C<List_Variable>, and C<LIST_VARIABLE> all refer to the same variable.

The C<import_variables> method assigns the object's configuration
variables to Perl variables in the specified namespace. Both scalar and
array variables are defined for each configuration variable: the array
variable is defined with the full list of values and the scalar variable
is defined with only the first value. Variables may not be imported
to package C<main>. A null or undefined namespace string defaults to

The case of the Perl variables is specified by the second argument to
C<import_variables>: one of "lower", "upper", or "exact" (or its synonym
"asis") is specified to define the variables names in lower-case,
upper-case, or exactly as they appeared in the configuration file,
respectively. If this argument is null or undefined, it defaults to
lower-case. Note that since variables that differ only in alphabetic
case are considered to be the same variable, importing exact variable
names will define only the first spelling of such variables.

While imported variables can be modified, undefined, and new variables
defined in the import namespace, no changes are reflected in the
corresponding configuration file.

=head1 AUTHOR

Dave Wolfe <>