libconfigreader-perl 0.5-5 / usr / share / perl5 / ConfigReader / Spec.pm

# ConfigReader/Spec.pm: specifies a set of configuration directives
#
# Copyright 1996 by Andrew Wilcox <awilcox@world.std.com>.
# All rights reserved.
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public
# License along with this library; if not, write to the Free
# Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

package ConfigReader::Spec;
$VERSION = "0.5";

my $This_file = __FILE__;       # used to get our filename out of error msgs

require 5.001;
use Carp;
use strict;

=head1 NAME

ConfigReader::Spec - stores specifications of configuration directives

=head1 DESCRIPTION

The ConfigReader::Spec class stores a specification about
configuration directives: their names, whether they are required or if
they have default values, and what parsing function or method to use.

=cut

## Public methods

sub new {
    my ($class) = @_;
    my $self = {directives => {},          # directive name => 1
                alias_to_directive => {},  # map alias to name
                default => {},             # name => default value
                whence_default => {},      # name => source location of default 
                parser => {},              # name => value parser
                name => {},                # name => 1, ignore this directive
                required => {}             # name => 1, required directive
            };
    return bless $self, $class;
}

sub directives {
    my ($self) = @_;
    return keys %{$self->{'directives'}};
}

sub value {
    my ($self, $directive, $values, $whence) = @_;
    $directive = $self->canonical_name($directive);

    my $name = $self->{'alias_to_directive'}{$directive};
    $self->_error("Undefined directive '$directive'", $whence)
        unless defined $name;

    $self->_error("The directive '$directive' has not been assigned a value",
                  $whence)
        unless exists($values->{$name});

    return $values->{$name};
}


sub alias {
    my ($self, $directive, @aliases) = @_;
    $directive = $self->canonical_name($directive);
    my $alias;
    foreach $alias (@aliases) {
        $self->{'alias_to_directive'}{$self->canonical_name($alias)} =
            $directive;
    }
}

sub define_directive {
    my ($self, $directive, $parser, $whence) = @_;

    my ($name, @aliases);

    my $ref = ref($directive);
    if (defined $ref and $ref eq 'ARRAY') {
        $name = shift @$directive;
        @aliases = @$directive;
    }
    else {
        $name = $directive;
        @aliases = ($directive);
    }
    $name = $self->canonical_name($name);

    $self->{'directives'}{$name} = 1;
    $self->alias($name, @aliases);

    if (defined $parser) {
        $self->{'parser'}{$name} =
            $self->_resolve_code($parser,
                                 'specified as parser',
                                 $whence);
    }
    else {
        delete $self->{'parser'};
    }

    return $name;
}

sub required {
    my ($self, $directive, $parser, $whence) = @_;

    my $name = $self->define_directive($directive,
                                       $parser,
                                       $whence);
    $self->{'required'}{$name} = 1;
}


sub directive {
    my ($self, $directive, $parser, $default, $whence) = @_;

    my $name = $self->define_directive($directive,
                                       $parser,
                                       $whence);
    $self->{'default'}{$name} = $default;
    $self->{'whence_default'}{$name} = $whence;
    return $name;
}

sub ignore {
    my ($self, $directive, $whence) = @_;

    my $name = $self->define_directive($directive, undef, undef, $whence);
    $self->{'ignore'}{$name} = 1;
}

sub assign {
    my ($self, $directive, $value_string, $values, $whence) = @_;
    $directive = $self->canonical_name($directive);

    my $name = $self->{'alias_to_directive'}{$directive};
    $self->undefined_directive($directive, $value_string, $whence)
        unless defined $name;

    return undef if $self->{'ignore'}{$name};

    $self->duplicate_directive($directive, $value_string, $whence)
        if defined $values and exists $values->{$name};

    if (not defined $value_string) {
        $values->{$name} = undef if defined $values;
        return undef;
    }

    my $parser = $self->{parser}{$name};
    my $value;

    if (defined $parser) {
        my @warnings = ();
        local $SIG{'__WARN__'} = sub { push @warnings, $_[0] };
        my $saved_eval_error = $@;
        eval { $value = &$parser($value_string) };
        my $error = $@;
        $@ = $saved_eval_error;

        my $warning;
        foreach $warning (@warnings) {
            $warning =~ s/ at $This_file line \d+$//o;  # uncarp
            if (defined $whence) {
                warn
"While parsing '$value_string' as the value for the
'$directive' directive as specified
$whence,
I got this warning:
$warning";
            }
            else {
                $warning =~ s/\n?$/\n/;
                carp $warning .
" while parsing '$value_string' as the value for the '$directive' directive";
            }
        }

        if ($error) {
            $error =~ s/ at $This_file line \d+$//o;  # uncroak
            if (defined $whence) {
                $whence =~ s,\n$,,;
                die
"I tried to parse '$value_string' as the value for the '$directive' directive as specified $whence
but the following error occurred:

$error";
            }
            else {
                $error =~ s/\n?$/\n/;
                croak $error."while parsing '$value_string' as the value for the '$directive' directive";
            }
        }
    }
    else {
        $value = $value_string;
    }

    $values->{$name} = $value if defined $values;
    return $value;
}

sub assign_defaults {
    my ($self, $values, $whence) = @_;

    my $name;
    foreach $name ($self->directives()) {
        $self->assign_default($name, $values, $whence);
    }
}

sub assign_default {
    my ($self, $directive, $values, $whence) = @_;
    $directive = $self->canonical_name($directive);

    my $name = $self->{'alias_to_directive'}{$directive};
    $self->_error("Undefined directive '$directive'", $whence)
        unless defined $name;

    return $values->{$name} if defined $values and exists $values->{$name};

    if ($self->{'required'}{$name}) {
        $self->_error("Please specify the '$name' directive", $whence);
    }
    elsif ($self->{'ignore'}{$name}) {
        return undef;
    }

    my $default = $self->{'default'}{$name};
    # "as the default value "
    my $whence_default = $self->{'whence_default'}{$name};
    my $value;

    if (not defined $default) {
        return $self->assign($name, undef, $values, $whence_default);
    }
    elsif (not ref $default) {
        return $self->assign($name, $default, $values, $whence_default);
    }
    elsif (ref($default) eq 'CODE') {
        local $SIG{'__DIE__'} = sub {
            $self->_error("$_[0]\nwhile assigning the default value for the '$name' directive", $whence_default);
        };
        $value = &$default();
        $values->{$name} = $value if defined $values;
        return $value;
    }
    else {
        $value = $default;
        $values->{$name} = $value if defined $values;
        return $value;
    }
}

## subclass hooks

sub canonical_name {
    my ($self, $directive) = @_;
    return $directive;
}

sub undefined_directive {
    my ($self, $directive, $value_string, $whence) = @_;

    $self->_error("Unknown directive '$directive' specified", $whence);
}

sub duplicate_directive {
    my ($self, $directive, $value_string, $whence) = @_;

    $self->_error("Duplicate directive '$directive' specified", $whence);
}


## Internal methods

# Allows the user to specify code to run in several different ways.
# Returns a code ref that will run the desired code.
#    'new URI::URL'       calls static method 'new' in class 'URI::URL'
#    $coderef             calls the code ref
#    [new => 'URI::URL']  calls new URI::URL
#    [parse => $obj]      calls $obj->parse()

sub _resolve_code {
    my ($self, $sub, $purpose, $whence) = @_;
    my ($r, $class, $static_method, $function);

    $r = ref($sub);
    if (not $r) {
        if (($static_method, $class) = ($sub =~ m/^(\w+) \s+ ([\w:]+)$/x)) {
            return sub {
                $class->$static_method(@_);
            };
        }
        else {
            $self->_error("Syntax error in function name '$sub' $purpose",
                          $whence);
        }
    }
    elsif ($r eq 'CODE') {
        return $sub;
    }
    elsif ($r eq 'ARRAY') {
        my ($method, $class_or_obj) = @$sub;
        $self->_error("Empty array used to $purpose", $whence)
            unless defined $method;
        $self->_error("Class or object not specified in array used to $purpose",
                      $whence)
            unless defined $class_or_obj;
        return sub {
            $class_or_obj->$method(@_);
        };
    }
    else {
        $self->_error("Unknown object $purpose", $whence);
    }
}

sub _error {
    my ($self, $msg, $whence) = @_;

    if (defined $whence) {
        $whence =~ s,\n?$,\n,;
        die "$msg $whence";
    }
    else {
        croak $msg;
    }
}

1;