File Coverage

blib/lib/Parse/PerlConfig.pm

Criterion	Covered	Total	%
statement	144	195	73.8
branch	53	88	60.2
condition	1	3	33.3
subroutine	16	20	80.0
pod	0	1	0.0
total	214	307	69.7

# Parse::PerlConfig - parse a configuration file written in Perl

# Copyright (C) 1999 Michael Fowler, all rights reserved

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


package Parse::PerlConfig;

require Exporter;
use Fcntl qw(O_RDONLY);
use strict;
use vars (
    qw($VERSION @ISA @EXPORT_OK),
    qw($saved_dollar_slash),        # used in _do_file()
);


@ISA = qw(Exporter);

@EXPORT_OK = qw(parse);

$VERSION = '0.05';


my %thing_str2key = (
    '$'     =>      'SCALAR',
    '@'     =>      'ARRAY',
    '%'     =>      'HASH',
    '&'     =>      'CODE',
    '*'     =>      'GLOB',
    'i'     =>      'IO',
);


my %thing_key2str;

@thing_key2str{values %thing_str2key} = keys(%thing_str2key);



sub parse {
    local *FILE;
    my $subname = (caller(0))[3];

    my %args = (
        Namespace_Base          =>      __PACKAGE__ . '::ConfigFile',

        Thing_Order             =>       '$@%&i*',
        Taint_Clean             =>              0,

        Warn_default            =>         'noop',
        Warn_preparse           =>      'default',
        Warn_eval               =>      'default',

        Error_default           =>         'warn',
        Error_argument          =>      'default',
        Error_file_is_dir       =>      'default',
        Error_failed_open       =>      'default',
        Error_eval              =>      'default',
        Error_unknown_thing     =>      'default',
        Error_unknown_handler   =>      'default',
        Error_invalid_lexical   =>      'default',
        Error_invalid_namespace =>      'default',
    );


    if (ref($_[0]) eq 'HASH') {             # first argument is a hash..
        %args = (%args, %{+ shift }, @_);   # ..dereference it

    } elsif (ref($_[0]) eq 'ARRAY') {       # first argument is an array..
        %args = (%args, @{+ shift }, @_);   # ..dereference it

    } elsif (@_) {
        %args = (%args, @_);
    }


    my $def_errsub  = _errsub($args{'Error_default'});
    my $def_warnsub = _errsub($args{ 'Warn_default'});

    my(%errsubs, %warnsubs);
    foreach my $handler (qw(
        argument
        file_is_dir
        failed_open
        eval
        unknown_thing
        unknown_handler
        invalid_namespace
    )) {
        $errsubs{$handler} = _errsub($args{"Error_$handler"}, $def_errsub);
    }


    foreach my $handler (qw(preparse eval)) {
        $warnsubs{$handler} = _errsub($args{"Warn_$handler"}, $def_warnsub);
    }


    # This allows us to pass around %args, rather than each hash necessary.
    $args{'_errsubs'}  = \%errsubs;
    $args{'_warnsubs'} = \%warnsubs;



    my @files;
    push(@files, $args{File}) if defined($args{File});

    if (ref($args{Files}) eq 'ARRAY') {
        push(@files, @{ $args{Files} });

    } elsif (defined $args{Files}) {
        push(@files, $args{Files});
    }

    unless (@files) {
        $errsubs{'argument'}->(
            "Files or File argument required in call to $subname."
        );
        return;
    }


    my @handlers;
    push(@handlers, $args{Handler}) if defined($args{Handler});

    if (ref($args{Handlers}) eq 'ARRAY') {
        push(@handlers, @{ $args{Handlers} });

    } elsif (defined $args{Handlers}) {
        push(@handlers, $args{Handlers});
    }


    my %lexicals;
    if (ref $args{Lexicals} eq 'HASH') {
        %lexicals = %{ $args{Lexicals} };

    } elsif (defined $args{Lexicals}) {
        $errsubs{'argument'}->(
            "Lexicals argument must be a hashref in call to $subname."
        );
    }


    my @def_thing_order = _thingstr_to_array(\%args, $args{'Thing_Order'});

    my %custom_symbols;
    if (ref($args{Symbols}) eq 'HASH') {
        while (my($sym, $order) = each(%{$args{Symbols}})) {
            $custom_symbols{$sym} = [ _thingstr_to_array(\%args, $order) ];
        }
    }


    my $lexicals_string = _construct_lexicals_string(\%args, \%lexicals);



    # Having checked all of our arguments, we run through our files.
    my %parsed_symbols;
    FILE: foreach my $file (@files) {

        $errsubs{'file_is_dir'}->("Config file \"$file\" is a directory.")
            if -d $file;

        $warnsubs{'preparse'}->("Preparing to parse config file \"$file\".");




        unless (sysopen FILE, $file, O_RDONLY) {
            $errsubs{'failed_open'}->(
                "Unable to open config file \"$file\": \l$!."
            );
            return;
        }


        if ($args{'Taint_Clean'}) {
            require IO::Handle;
            FILE->untaint;
        }


        my $namespace = _construct_namespace(\%args, $file);

        unless (_valid_namespace($namespace)) {
            $errsubs{'invalid_namespace'}->(
                "Namespace \"$namespace\" is invalid."
            );
            return;
        }


        {
            my %parse_perl_config = (
                Parse_Args      =>      \%args,
                Filename        =>      $file,
                Namespace       =>      $namespace,
                Error           =>      undef,
            );

            my $eval_warn = $warnsubs{'eval'};

            local $SIG{__WARN__} = sub { $eval_warn->(join "", @_) };
            _do_file(\*FILE, $namespace, \%parse_perl_config, $lexicals_string);


            my $error;
            if (defined($error = $parse_perl_config{Error})) {
                $errsubs{'eval'}->(
                    "Configuration file raised an error: $error."
                );
                next FILE;

            } elsif ($@) {
                $error = $@;
                1 while chomp($error);

                $errsubs{'eval'}->("Error in configuration eval: $error.");
                next FILE;
            }
        }


        _parse_symbols(
            Namespace       =>  $namespace,
            Thing_Order     =>  \@def_thing_order,
            Symbols         =>  \%custom_symbols,
            Hash            =>  \%parsed_symbols,
        );
    }


    _dispatch_handlers(\%args, \@handlers, \%parsed_symbols);


    return \%parsed_symbols;
}




# _parse_symbols
#       Namespace       - namespace to parse symbols from
#       Symbols         - hashref of symbols with specific thing ordering
#       Thing_Order     - default thing order, arrayref
#       Hash            - a hashref into which parsed symbols are placed
#
# This an internal function used by parse() to do the actual parsing of
# symbols from a namespace.  This function has the potential to be a public
# one, if sanity checking on arguments is added.

sub _parse_symbols {
    my %args = @_;

    my $namespace           =   $args{'Namespace'};
    my %custom_symbols      =   %{ $args{'Symbols'} };
    my @def_thing_order     =   @{ $args{'Thing_Order'} };
    my $parsed_symbols      =   $args{'Hash'};


    no strict 'refs';
    while (my($symbol, $glob) = each(%{"$namespace\::"})) {
        my @thing_order;

        if (exists $custom_symbols{$symbol}) {
            @thing_order = @{ $custom_symbols{$symbol} };
        } else {
            @thing_order = @def_thing_order;
        }


        my $value;
        foreach my $thing (@thing_order) {
            if ($thing eq 'SCALAR') {
                # Special case for scalars; we always get a scalar
                # reference, even if the underlying scalar is undefined.
                if (defined ${ *$glob{SCALAR} }) {
                    $value = ${ *$glob{SCALAR} };
                    last;
                }

            } elsif (defined *$glob{$thing}) {
                $value = *$glob{$thing};
                last;
            }
        }


        $$parsed_symbols{$symbol} = $value if defined($value);


        # In order to prevent various warnings, and the symbols from still
        # being there (even though the symbol table isn't), we undef each
        # glob as we go.
        undef(*{"$namespace\::$symbol"});
    }


    return;
}




sub _dispatch_handlers {
    my($args, $handlers, $parsed_symbols) = (shift, shift, shift);

    foreach my $handler (@$handlers) {
        if (ref $handler eq 'CODE') {
            $handler->($parsed_symbols);

        } elsif (ref $handler eq 'HASH') {
            @$handler{keys %$parsed_symbols} = values %$parsed_symbols

        } else {
            $$args{'_errsubs'}{'unknown_handler'}->(
                'Unknown handler type "' . ref($handler) . '"'
            );
        }
    }
}




# _do_file
#
#
#   Reads the given filename using sysopen and eval, in the specified
#   namespace.  The hash %parse_perl_config is set with the specified
#   hashref.
#
#   The reason this subroutine exists is to keep the lexical space as clean
#   as possible, while still allowing some lexicals through.  Were this
#   functionality inlined with the rest of parse(), a configuration file
#   would have access to parse()'s lexicals.  To keep things even cleaner
#   local() is used rather than my().  Obviously the latter is preferable,
#   but in this case, would cause problems

sub _do_file {
    # Arguments are accessed through @_ indexing, rather than shifting, to
    # keep the lexical space as clean as possible.

    local *FILE              =     $_[0]  ;
    my    %parse_perl_config = %{+ $_[2] };


    # We go to some lengths to be able to slurp the file, while
    # still keeping $/ intact.

    local $saved_dollar_slash = $/;
    local $/;

    no strict;
    eval    '$/ = $saved_dollar_slash;'     .
            "package $_[1];"                .
            $_[3]                           . # lexical definitions

    ;
}




sub _construct_lexicals_string {
    my($args, $lexicals) = (shift, shift);

    return '' unless %$lexicals;

    require Data::Dumper;

    my $inv_lex_errsub = $$args{'_errsubs'}{'invalid_lexical'};

    my $lexicals_string = '';
    LEXICAL: while (my($key, $value) = each(%$lexicals)) {

        if ($key !~ /^([^_\W][\w\d]*|\w[\w\d]+)$/) {
            $inv_lex_errsub->(
                "Lexical name \"$key\" is invalid, must be a valid " .
                "identifier."
            );

            next LEXICAL;

        } elsif (ref($value) eq 'CODE') {
            $inv_lex_errsub->(
                "Lexical \"$key\" value is invalid, code references " .
                "are not allowed."
            );

            next LEXICAL;

        } elsif ($key eq 'parse_perl_config' && ref($value) eq 'HASH') {
            $inv_lex_errsub->(
                "Cannot have a hash lexical named \"parse_perl_config\"."
            );

            next LEXICAL;
        }

        $lexicals_string .= 'my ' . Data::Dumper->Dump([$value], ["*$key"]);
    }


    $lexicals_string;
}





sub _construct_namespace {
    my($args, $file) = (shift, shift);

    my $namespace;
    if (defined $$args{'Namespace'}) {
        $namespace = $$args{'Namespace'};

    } else {
        $namespace = "$$args{'Namespace_Base'}::" . _encode_namespace($file);
    }


    if ($$args{'Taint_Clean'}) {
        # We've already filtered the namespace, but perl doesn't know
        # that; fake it.
        ($namespace) = ($namespace =~ /(.*)/);
    }


    return $namespace;
}



sub _valid_namespace {
    my $namespace = shift;

    foreach my $ns_ele (split /::/, $namespace) {
        return 0 unless $ns_ele =~ /^[_A-Za-z][_A-Za-z0-9]*/;
    }

    return 1;
}



sub _encode_namespace {
    my $namespace = shift;

    my @namespace;
    foreach my $ns_ele (split /::/, $namespace) {
        # ^A-Za-z0-9 (as opposed to [\W\D]) is spelled out explicitly
        # because package names are not (yet?) locale-friendly.
        $ns_ele =~
            s{
                (
                    (?:^[^A-Za-z])      # first character must not be a number
                        |
                    [^A-Za-z0-9]        # any further characters can be
                )
            }{
                sprintf("_%2x", ord $1)
            }egx
        ;


        push(@namespace, $ns_ele);
    }


    return join("::", @namespace);
}





# _thingstr_to_array
#
#   Translates a thing string ($%@*i&) into the associated glob keys:
#       $       SCALAR
#       @       ARRAY
#       %       HASH
#       *       GLOB
#       i       IO
#       &       CODE
#
#
#   Returns the keys as a list, in the same order.  The specified coderef is
#   an error function used to report when an unknown character is
#   encountered.
#
#   If the string is actually an array reference, the array is dereferenced,
#   checked for invalid keys, and returned.

sub _thingstr_to_array {
    my($args, $string) = (shift, shift);

    my $errsub = $$args{'_errsubs'}{'unknown_thing'};

    if (ref($string) eq 'ARRAY') {
        my @filtered;

        foreach my $thing (@$string) {
            $thing = uc($thing);
            if (!exists $thing_key2str{$thing}) {
                $errsub->("Unknown thing key \"$thing\".");
                next;
            }

            push(@filtered, $thing);
        }

        return @filtered;
    }


    my @keys;
    foreach my $c (split //, $string) {
        unless (defined $thing_str2key{$c}) {
            $errsub->("Undefined thing string \"$c\".");
            next;
        }

        push(@keys, $thing_str2key{$c});
    }

    return @keys;
}




sub _fwarn {  CORE::warn(shift() . "\n")          }
sub _warn  {  CORE::warn(shift() . "\n") if $^W   }
sub _die   {  CORE::die (shift() . "\n")          }
sub _noop  {                                      }

# _errsub  []
#       Responsible for parsing the "default", "noop", "warn", "fwarn", and
#       "die" strings, and returning an appropriate code reference.

sub _errsub {
    my($spec, $default) = (shift, shift);
    $spec = lc($spec) unless ref($spec);

    (ref $spec eq 'CODE' )          &&      return $spec;
    (    $spec eq 'warn' )          &&      return \&_warn;
    (    $spec eq 'fwarn')          &&      return \&_fwarn;
    (    $spec eq 'die'  )          &&      return \&_die;
    (    $spec eq 'noop' )          &&      return \&_noop;

    # catch anything that falls through
    return (ref $default eq 'CODE') ? $default : \&_warn;
}




1;


__END__