# Copyright (c) 2004-2012 by Karl Gaissmaier, Ulm University, Germany
#
# This library is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# for documentation see Config::Scoped.pod
package Config::Scoped;
use strict;
use warnings;
use Storable qw(dclone lock_nstore lock_retrieve);
use Carp;
use Safe;
use Digest::MD5 qw(md5_base64);
use File::Basename qw(fileparse);
use File::Spec;
use Config::Scoped::Error;
use base 'Parse::RecDescent';
our $VERSION = '0.22';
my $grammar;
{
local $/;
$grammar = <DATA>;
close DATA;
}
my @state_hashes = qw(config params macros warnings includes);
sub new {
my $class = shift;
Config::Scoped::Error->throw(
-text => Carp::shortmess("odd number of arguments,") )
if @_ % 2;
my %args = @_;
##############################################
# Delayed compilation of grammar in method parse()
#
my $empty_grammar = '';
$args{compiled} = undef;
##############################################
# create the parser object, delayed grammar
#
my $thisparser = $class->SUPER::new($empty_grammar)
or Config::Scoped::Error->throw(
-text => "Can't create a '$class' parser," );
##############################################
# store the args in the P::RD object below 'local'
# don't use deep copy since we use always one and
# only one global config hash
#
$thisparser->{local} = {%args};
# frequent typos, be polite
$thisparser->{local}{warnings} ||= $thisparser->{local}{warning};
$thisparser->{local}{lc} ||= $thisparser->{local}{lowercase};
$thisparser->{local}{safe} ||= $thisparser->{local}{Safe};
$thisparser->{local}{file} ||= $thisparser->{local}{File};
##############################################
# validate and munge the 'file' param
#
# a cfg_file isn't necessary, the parse method can be feeded
# with a plain text string
if ( my $cfg_file = $thisparser->{local}{file} ) {
Config::Scoped::Error->throw(
-text => Carp::shortmess("can't use filehandle as cfg file") )
if ref $cfg_file;
# retrieve the dir part, later on needed for relative include files
my ( undef, $cfg_dir ) = fileparse($cfg_file)
or Config::Scoped::Error->throw(
-text => "error in fileparse",
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
);
$cfg_file = File::Spec->rel2abs($cfg_file)
or Config::Scoped::Error->throw(
-text => "error in rel2abs",
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
);
$thisparser->{local}{cfg_file} = $cfg_file;
$thisparser->{local}{cfg_dir} = $cfg_dir;
}
else {
# no cfg_file defined, use _STRING and cwd
$thisparser->{local}{cfg_file} = '_STRING';
$thisparser->{local}{cfg_dir} =
File::Spec->rel2abs( File::Spec->curdir );
}
##############################################
# check for warnings
#
# set the default to all on
$thisparser->{local}{warnings} = { all => 'on' }
unless $thisparser->{local}{warnings};
# allow the simple form: 'warnings' => 'on/off'
if ( ref $thisparser->{local}{warnings} ne 'HASH' ) {
$thisparser->{local}{warnings} = { all => 'on' }
if $thisparser->{local}{warnings} =~ m/on/i;
$thisparser->{local}{warnings} = { all => 'off' }
if $thisparser->{local}{warnings} =~ m/off/i;
}
# store the warnings in a normalized form
foreach my $name ( keys %{ $thisparser->{local}{warnings} } ) {
my $switch = delete $thisparser->{local}{warnings}{$name};
$thisparser->_set_warnings(
name => $name,
switch => $switch,
);
}
##############################################
# preset the state hashes
#
# use empty state_hashes if not defined
foreach my $hash_name (@state_hashes) {
$thisparser->{local}{$hash_name} ||= {};
# be defensive
Config::Scoped::Error->throw(
-text => Carp::shortmess("$hash_name is no hash ref") )
unless ref $thisparser->{local}{$hash_name} eq 'HASH';
}
# install/create Safe compartment for perl_code
my $compartment = $thisparser->{local}{safe};
if ( $thisparser->{local}{safe} ) {
Config::Scoped::Error->throw(
-text => Carp::shortmess("can't find method 'reval' on compartment")
)
unless UNIVERSAL::can( $thisparser->{local}{safe}, 'reval' );
}
else {
$thisparser->{local}{safe} = Safe->new
or Config::Scoped::Error->throw(
-text => "can't create a Safe compartment!" );
}
return $thisparser;
}
sub parse {
my $thisparser = shift;
Config::Scoped::Error->throw(
-text => Carp::shortmess("odd number of arguments,") )
if @_ % 2;
unless (defined $thisparser->{local}{compiled} ){
$thisparser->Replace($grammar);
$thisparser->{local}{compiled} = 1;
}
my %args = @_;
my $cfg_text = $args{text};
unless ( defined $cfg_text ) {
my $cfg_file = $thisparser->{local}{cfg_file}
or Config::Scoped::Error->throw(
-text => Carp::shortmess("no cfg_file defined"),
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
);
Config::Scoped::Error->throw( -text => "no text to parse defined" )
if $cfg_file eq '_STRING';
# slurp the cfg file
$cfg_text = $thisparser->_get_cfg_text( %args, file => $cfg_file );
Config::Scoped::Error->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "'$cfg_file' is empty"
)
unless $cfg_text;
# calculate the message digest and remember this cfg text in includes
my $digest = md5_base64($cfg_text);
Config::Scoped::Error->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "include loop for '$cfg_file' encountered",
)
if $thisparser->{local}{includes}{$digest};
$thisparser->{local}{includes}{$digest} = $cfg_file;
}
# call the P::RD with the startrule of the grammar
$thisparser->config($cfg_text);
##############################################
# no declarations but parameters in scope?
#
# copy them to an automatically generated _GLOBAL hash
# first use some shortcuts
my $params = $thisparser->{local}{params};
my $config = $thisparser->{local}{config};
# all $config keys other than _GLOBAL are real declarations
my @declarations = grep !/^_GLOBAL$/, keys %$config;
# no declarations but parameters in global scope
if ( !@declarations && %$params ) {
# the overall parent scope overrides scopes from include files
$config->{_GLOBAL} = dclone $params;
}
else {
# perhaps a prior parse for an include file filled this slot
delete $config->{_GLOBAL};
}
return $thisparser->{local}{config};
}
sub warnings_on {
my $thisparser = shift;
Config::Scoped::Error->throw(
-text => Carp::shortmess("odd number of arguments,") )
if @_ % 2;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameters") )
unless defined $args{name};
my $name = $args{name};
my $warnings = $thisparser->{local}{warnings};
$name = $thisparser->_trim_warnings($name);
return undef if exists $warnings->{$name} && $warnings->{$name} eq 'off';
return 1 if exists $warnings->{$name} && $warnings->{$name} eq 'on';
# use 'all'
return undef if exists $warnings->{all} && $warnings->{all} eq 'off';
return 1 if exists $warnings->{all} && $warnings->{all} eq 'on';
# hmm, name and all not defined, defaults to on
return 1;
}
sub set_warnings {
my $thisparser = shift;
Config::Scoped::Error->throw(
-text => Carp::shortmess("odd number of arguments,") )
if @_ % 2;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("no warnings switch (on/off) defined") )
unless defined $args{switch};
my $warnings = $thisparser->{local}{warnings};
my $name = $args{name} || 'all';
my $switch = $args{switch};
$name = $thisparser->_trim_warnings($name);
# trim the switch, convert to lowercase
$switch = lc($switch);
if ( $name eq 'all' ) {
# reset the hash
%{$warnings} = ();
$warnings->{all} = $args{switch};
}
else {
# override the key, key is 'macro', 'declaration', 'parameter', ...
$warnings->{$name} = $args{switch};
}
return 1;
}
# just a wrapper for the same method without leading _
# this method is called in the grammar file whereas the set_warnings
# may be overriden by the application
sub _set_warnings {
my $thisparser = shift;
$thisparser->set_warnings(@_);
}
# shortcuts allowed, less spelling errors
sub _trim_warnings {
my ( $thisparser, $name ) = @_;
# trim the names
return 'declaration' if $name =~ /^decl/i;
return 'parameter' if $name =~ /^param/i;
return 'macro' if $name =~ /^mac/i;
return 'permissions' if $name =~ /^perm/i;
return 'digests' if $name =~ /^dig/i;
return $name;
}
sub store_cache {
my $thisparser = shift;
Config::Scoped::Error->throw(
-text => Carp::shortmess("odd number of arguments,") )
if @_ % 2;
my %args = @_;
my $cache_file = $args{cache};
unless ($cache_file) {
my $cfg_file = $thisparser->{local}{cfg_file}
or Config::Scoped::Error->throw(
-text => Carp::shortmess("no cache_file and no cfg_file defined") );
Config::Scoped::Error->throw( -text =>
Carp::shortmess("parameter 'cache' needed for parsed strings") )
if $cfg_file eq '_STRING';
$cache_file = $cfg_file . '.dump';
}
my $cfg_hash = {
includes => $thisparser->{local}{includes},
config => $thisparser->{local}{config},
};
my $result = eval { lock_nstore( $cfg_hash, $cache_file ); };
Config::Scoped::Error->throw( -text => Carp::shortmess($@) ) if $@;
Config::Scoped::Error->throw(
-text => Carp::shortmess("can't store the cfg hash to '$cache_file'") )
unless $result;
}
sub retrieve_cache {
my $thisparser = shift;
Config::Scoped::Error->throw(
-text => Carp::shortmess("odd number of arguments,") )
if @_ % 2;
my %args = @_;
my $cache_file = $args{cache};
$args{parent_file} = $cache_file; # for better error messages
unless ($cache_file) {
my $cfg_file = $thisparser->{local}{cfg_file}
or Config::Scoped::Error->throw(
-text => Carp::shortmess("no cache_file and no cfg_file defined") );
Config::Scoped::Error->throw(
-text => Carp::shortmess("cache not supported for strings") )
if $cfg_file eq '_STRING';
$cache_file = $cfg_file . '.dump';
}
Config::Scoped::Error::IO->throw(
-text => Carp::shortmess("Can't read the cfg_cache '$cache_file'") )
unless -r $cache_file;
# check the permission and ownership, I know, it's no handle and of
# restricted usage
Config::Scoped::Error::Validate::Permissions->throw(
-text => Carp::shortmess(
"permissions_validate returned false for cache_file '$cache_file'")
)
unless $thisparser->permissions_validate( %args, file => $cache_file );
my $cfg_cache = eval { lock_retrieve($cache_file); };
Config::Scoped::Error->throw( -text => Carp::shortmess($@) ) if $@;
Config::Scoped::Error->throw(
-text => Carp::shortmess( "cfg cache is empty", ) )
unless $cfg_cache;
# warnings for digests enabled?
return $cfg_cache->{config}
unless $thisparser->warnings_on( %args, name => 'digests', );
# check the include digests for modification
while ( my ( $digest, $file ) = each %{ $cfg_cache->{includes} } ) {
my $text = $thisparser->_get_cfg_text( %args, file => $file, );
if ( $digest ne md5_base64($text) ) {
Config::Scoped::Error->throw(
-text => Carp::shortmess(
"'$file' modified, can't use the cache '$cache_file',")
);
}
}
return $cfg_cache->{config};
}
# _include
#
# this method is called as an action in the INCLUDE grammar rule
# the current localized $thisparser->{local}... parameters are used and adjusted
# and a new P::RD parser with the same grammar is created and started
# for the include file.
# After that the parse in the parent cfg file is continued.
# We don't change the $text and don't resync the linecounter in P::RD, since
# this would result in awfully wrong line numbers in error messages and
# we would still have no hint in which include file the error happened.
#
# The current scope, macro and warnings hash is used during include file parsing
# so the include file can use (or overwrite) the current parse state.
#
# The changed state during the include file parse is propagated to the
# parent parser state (except warnings). If this import isn't intended
# put the include # in a own block: { %include filename; }
#
sub _include {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => Carp::shortmess("missing parameters"),
)
unless defined $args{file};
my $include_file = $args{file};
my $parent_cfg_file = $thisparser->{local}{cfg_file};
my $parent_cfg_dir = $thisparser->{local}{cfg_dir};
# absolute path? else concat with parent cfg dir
unless ( File::Spec->file_name_is_absolute($include_file) ) {
$include_file = File::Spec->catfile( $parent_cfg_dir, $include_file )
or Config::Scoped::Error->throw(
-file => $parent_cfg_file,
-line => $thisparser->_get_line(%args),
-text => "error in catfile for '$include_file'"
);
}
# Create a new parser for this include file parsing.
# Use the current parser states (perhaps already localized
# in a grammar { action }), and change some args for the new
# include parser creation.
#
my $clone_parser =
( ref $thisparser )
->new( %{ $thisparser->{local} }, file => $include_file )
or Config::Scoped::Error->throw(
-file => $parent_cfg_file,
-line => $thisparser->_get_line(%args),
-text => "Internal error: Can't create a clone parser"
);
# parse the include file (recursively) and return to the parent
# cfg parse. Loop includes are detected (via md5) and throws an exception.
return $clone_parser->parse(
parent_file => $parent_cfg_file, # for better error reporting
);
}
# this method is called as an action in the MACRO rule in order
# to store the macro in the macros hash
sub _store_macro {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameters") )
unless ( defined $args{name} && defined $args{value} );
# macro validation, may be overwritten by the application
my $valid_macro = $thisparser->macro_validate(%args);
return $thisparser->{local}{macros}{ $args{name} } = $valid_macro;
}
sub macro_validate {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameters") )
unless ( defined $args{name} && defined $args{value} );
my $name = $args{name};
my $value = $args{value};
# warnings for macros enabled?
if ( $thisparser->warnings_on( name => 'macro', ) ) {
Config::Scoped::Error::Validate::Macro->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "macro redefinition for '$name"
)
if exists $thisparser->{local}{macros}{$name};
}
# return unchanged, subclass methods may do it different
return $value;
}
# macro expansion
sub _expand_macro {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameters") )
unless defined $args{value};
my $value = $args{value};
while ( my ( $macro, $defn ) = each %{ $thisparser->{local}{macros} } ) {
$value =~ s/\Q$macro\E/$defn/g;
}
# a P::RD rule can't return undef, then the rule will fail
return defined $value ? $value : '';
}
# parameter storage, called as action from within the grammar
sub _store_parameter {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameters") )
unless ( defined $args{value} && defined $args{name} );
$args{name} = lc( $args{name} ) if $thisparser->{local}{lc};
# parameter validation, may be overwritten by the application
my $valid_value = $thisparser->parameter_validate(%args);
# store the return value in the params hash
return $thisparser->{local}{params}{ $args{name} } = $valid_value;
}
sub parameter_validate {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameters") )
unless ( defined $args{value} && defined $args{name} );
# warnings for parameters enabled?
if ( $thisparser->warnings_on( name => 'parameter', ) ) {
Config::Scoped::Error::Validate::Parameter->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "parameter redefinition for '$args{name}'"
)
if exists $thisparser->{local}{params}{ $args{name} };
}
# return unchanged, subclass methods may do it different
return $args{value};
}
# declaration storage, called as action from within the grammar
sub _store_declaration {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameters") )
unless ( defined $args{name} && defined $args{value} );
{
local $_;
map { $_ = lc($_) } @{ $args{name} }
if $thisparser->{local}{lc};
}
# convert declaration: foo bar ... baz { parameters }
# to the data structure
# $config->{foo}{bar}...{baz} = { parameters };
my $tail = $thisparser->{local}{config};
# walking down the street ...
foreach my $name ( @{ $args{name} } ) {
$tail->{$name} = {} unless exists $tail->{$name};
$tail = $tail->{$name};
}
# now we have baz = {}
# application validation
my $valid_value = $thisparser->declaration_validate( %args, tail => $tail );
# store the current scope in the last $config->{foo}...{baz} = $params
# use deep copy to break dependencies when config parameters
# get's changed in the application in different declarations
return %$tail = %{ dclone( $args{value} ) };
}
sub declaration_validate {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameters") )
unless ( defined $args{name} && defined $args{value} );
# warnings for declarations enabled and 'tail' already set?
if ( $thisparser->warnings_on( name => 'declaration', ) ) {
Config::Scoped::Error::Validate::Declaration->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "declaration redefinition for '@{$args{name}}'"
)
if %{ $args{tail} };
}
# return unchanged, subclass methods may do it different
return $args{value};
}
sub permissions_validate {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameters") )
unless ( defined $args{handle} || defined $args{file} );
my $warnings = $thisparser->{local}{warnings};
# warnings for files enabled?
return 1
unless $thisparser->warnings_on(
name => 'permissions',
warnings => $warnings,
);
my $fh = $args{handle} || $args{file};
# mysteriously vaporized
Config::Scoped::Error::IO->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "'$args{file}' can't stat cfg file/handle: $!"
)
unless stat $fh;
my ( $dev, $ino, $mode, $nlink, $uid, $gid ) = stat(_);
# owner is not root and not real uid
Config::Scoped::Error::Validate::Permissions->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "'$args{file}' is unsafe: owner is not root and not real uid",
)
if $uid != 0 && $uid != $<;
Config::Scoped::Error::Validate::Permissions->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "'$args{file}' is unsafe: writeable by group or others",
)
if $mode & 022;
return 1;
}
# handle quoted strings, expand macro's and interpolate backslash
# patterns like \t, \n, etc. Called as action from within the grammar.
sub _quotelike {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("missing parameter") )
unless defined $args{value};
my $value = $args{value};
# accepts only '', "", <<foo, <<'foo', <<"foo" quotes and
# not q, qq, qx, qw, ..., s///, tr/// etc.
my %accept = ( single => 1, double => 1, '<<' => 1 );
# see Text::Balanced::extract_quotelike() to understand this
# and of course Parse::RecDescent <perl_quotelike> directive
my $quote_name = $value->[0];
my $quote_delim = substr( $value->[1], 0, 1 );
my $quote_text = $value->[2];
# the quote_name isn't set with plain quotes, set it now
unless ($quote_name) {
$quote_name = 'double' if $quote_delim eq '"';
$quote_name = 'single' if $quote_delim eq "'";
}
# let the rule fail if not an accepted quote name
return undef unless $accept{$quote_name};
# backslash substitution in double quoted strings is
# done by reval() in the Safe compartment since
# it's possible to smuggle a subroutine call
# in a double quoted string.
#
$quote_text = $thisparser->_perl_code( expr => "\"$quote_text\"" )
unless $quote_name eq 'single' || $quote_delim eq "'";
# macro expansion for double quoted constructs
$quote_text = $thisparser->_expand_macro( %args, value => $quote_text )
unless $quote_name eq 'single' || $quote_delim eq "'";
# a P::RD rule can't return undef, then the rule would fail
return defined $quote_text ? $quote_text : '';
}
# slurp in the cfg files
sub _get_cfg_text {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("no cfg_file defined") )
unless defined $args{file};
my $cfg_file = $args{file};
local *CFG;
# open the cfg file
Config::Scoped::Error::IO->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "Can't open cfg_file '$cfg_file': $!"
)
unless open( CFG, $cfg_file );
# check the permission and ownership
Config::Scoped::Error::Validate::Permissions->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "permissions_validate returned false for cfg_file '$cfg_file'"
)
unless $thisparser->permissions_validate( %args, handle => \*CFG );
# slurp the cfg_file, close the handle and return the text
my $cfg_text = join '', <CFG>;
Config::Scoped::Error::IO->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => "Can't close cfg_file '$cfg_file' : $!"
)
unless close CFG;
return $cfg_text;
}
# eval perlcode in Safe compartment, called as action from within the grammar.
sub _perl_code {
my $thisparser = shift;
my %args = @_;
Config::Scoped::Error->throw(
-text => Carp::shortmess("no expression to eval defined") )
unless defined $args{expr};
my $expr = $args{expr};
# macro expansion before code evaluation
$expr = $thisparser->_expand_macro( %args, value => $expr );
my $compartment = $thisparser->{local}{safe};
# eval in Safe compartment
my $result = $compartment->reval($expr);
# adjust error message and rethrow
if ( !defined $result && $@ ) {
chomp $@;
$@ .= "\n... (re)blessed and propagated via perl_code{}";
Config::Scoped::Error::Parse->throw(
-file => $thisparser->_get_file(%args),
-line => $thisparser->_get_line(%args),
-text => $@,
);
}
# a P::RD rule can't return undef, then the rule would fail
return defined $result ? $result : '';
}
# used for well spotted error messages
sub _get_file {
my $thisparser = shift;
my %args = @_;
return $args{parent_file}
|| $args{file}
|| $thisparser->{local}{cfg_file}
|| '?';
}
# used for well spotted error messages
sub _get_line {
my $thisparser = shift;
my %args = @_;
return $args{line} || $thisparser->{local}{line} || 0;
}
1;
__DATA__
#######################################################################
# Grammar for Config::Scoped
#######################################################################
#
# Do you to understand this grammar?
# Be warned, dragons ahead, recursive brain damage possible!
#
# First, read the Config::Scoped manual to understand what's going on here!
#
# Second, read the Parse::RecDescent manual and learn it by heart to
# understand what's going on here!
#
# INHERITANCE!
# The real action is done via $thisparser->_method() calls
# to methods in the Config::Scoped package in order to keep the actions in
# this grammar file simple and maintainable.
#
# The logic is heavily based on localization via <rulevar's> in order to
# handle scopes properly.
#
# Call by value are always deep copies via Storable::dclone.
#
# Blocks, declarations and hashes start new scopes for parameters, macros
# and warnings.
#
# Include files are handled by a cloned Config::Scoped parser.
# Include files import parameters and macros to the current scope
# but not the warnings. Warnings are scoped within the include files and don't
# leak to the parent file. If you don't wish the leakage of parameters and
# macros to the parent file, put the %inlcude pragma inside a block {}.
#
# Declarations collect the parameters and store them
# in the unscoped $config hashref. The declaration name(s) are the
# keys in the $config hashref. Declarations are never scoped,
# they always add to the global config. Declarations are just (named)
# collectors of the parameters.
#
# The principle is easy, isn't it?
#
#########################################################################
#
# START of GRAMMAR for Config::Scoped
#
#########################################################################
#
# STARTRULE
#
config : config_item(s) eofile
| {
# Error handling:
# fetch only the first error, this is the most important one
my $parse_error = shift @{ $thisparser->{errors} };
# keep P::RD silent, see the P::RD FAQ
$thisparser->{errors} = undef;
# throw an exception
Config::Scoped::Error::Parse->throw(
-text => $parse_error->[0],
-line => $parse_error->[1],
-file => $thisparser->{local}{cfg_file}
);
} <reject>
# hack, could be done without this intermediate rule, but
# the error messages are more readable with this hack.
#
# commit hack: with a <commit> we get better error messages
config_item : <commit> statement
| <error?> <reject>
#########################################################################
# STATEMENT'S
#########################################################################
#
# use $break to shortcut the alternate productions after a rejected commit
# in a subrule.
#
# This is a hack since P::RD is missing a <committed?: action> directive.
# I do this programmatically with a localized <rulevar> and { ++$break }
#
statement : <rulevar: local $break>
statement : <reject: $break> parameter
| <reject: $break> block
| <reject: $break> declaration
| <reject: $break> pragma
| <reject: $break> comment
#########################################################################
# BLOCK'S: { statement(s) }
#########################################################################
#
# Open a new scope, inherit (deep copy) the scoped hashes.
#
block : <rulevar: local $thisparser->{local}{params} =
Storable::dclone $thisparser->{local}{params}>
block : <rulevar: local $thisparser->{local}{macros} =
Storable::dclone $thisparser->{local}{macros}>
block : <rulevar: local $thisparser->{local}{warnings} =
Storable::dclone $thisparser->{local}{warnings}>
block : '{' <commit> { ++$break } statement(s) '}' stop_pattern
| <error?> <reject>
#########################################################################
# DECLARATIONS
#########################################################################
#
# Open a new scope, inherit (deep copy) the scoped hashes.
#
declaration : <rulevar: local $thisparser->{local}{params} =
Storable::dclone $thisparser->{local}{params}>
declaration : <rulevar: local $thisparser->{local}{macros} =
Storable::dclone $thisparser->{local}{macros}>
declaration : <rulevar: local $thisparser->{local}{warnings} =
Storable::dclone $thisparser->{local}{warnings}>
declaration : key(s) '{' <commit> { ++$break } decl_item(s?) '}' stop_pattern
{
$thisparser->{local}{line} = $thisline;
$thisparser->_store_declaration(
name => $item{'key(s)'},
value => $thisparser->{local}{params},
);
# rule success, errors in the method don't raise syntax errors
1;
}
| <error?> <reject>
decl_item : ...!'}' <commit> parameter_or_macro_or_comment_or_warning
| <error?> <reject>
#########################################################################
# HASH
#########################################################################
#
# Open a new scope, inherit (deep copy) the localized hashes
# for macros and warnings.
# Reset the params hash!
#
hash : <rulevar: local $thisparser->{local}{params} = {}>
hash : <rulevar: local $thisparser->{local}{macros} =
Storable::dclone $thisparser->{local}{macros}>
hash : <rulevar: local $thisparser->{local}{warnings} =
Storable::dclone $thisparser->{local}{warnings}>
hash : '{' <commit> { ++$break } hash_item(s?) '}'
{
# returns just the filled parameter hash as value
$return = $thisparser->{local}{params};
}
| <error?> <reject>
hash_item : ...!'}' <commit> parameter_or_macro_or_comment_or_warning m/,?/
| <error?> <reject>
#########################################################################
# LIST
#########################################################################
#
# lists start no scope, they are just a special kind of parameters
#
list : <rulevar: local @list>
list : '[' <commit> { ++$break } list_item(s?) ']'
{
# returns just the filled list as value
$return = \@list;
}
| <error?> <reject>
list_item : ...!']' <commit> hash_or_list_or_value_or_comment m/,?/
| <error?> <reject>
#########################################################################
# PARAMETER'S
#########################################################################
#
parameter : key /=>?/ <commit> { ++$break } hash_or_list_or_value stop_pattern
{
$thisparser->{local}{line} = $thisline;
# store the parameter in the local scope
$thisparser->_store_parameter(
name => $item{key},
value => $item{hash_or_list_or_value},
);
# rule success, errors in the method don't raise syntax errors
1;
}
| <error?> <reject>
#########################################################################
# intermediate compounds
#########################################################################
#
# use $break to shortcut the alternations after a rejected commit
parameter_or_macro_or_comment_or_warning : <rulevar: local $break>
parameter_or_macro_or_comment_or_warning : <reject: $break> parameter
| <reject: $break> macro
| <reject: $break> warning
| <reject: $break> comment
# use $break to shortcut the alternations after a rejected commit
hash_or_list_or_value_or_comment : <rulevar: local $break>
hash_or_list_or_value_or_comment : <reject: $break> hash_or_list_or_value
{
# fill the list, but not with comments!
push @list, $item{hash_or_list_or_value}
}
| <reject: $break> comment
# use $break to shortcut the alternations after a rejected commit
hash_or_list_or_value : <rulevar: local $break>
hash_or_list_or_value : <reject: $break> hash
| <reject: $break> list
| <reject: $break> value
#########################################################################
# PRAGMA's
#########################################################################
#
pragma : macro | include | warning
macro : '%macro' <commit> { ++$break } key value stop_pattern
{
$thisparser->{local}{line} = $thisline;
$thisparser->_store_macro(
name => $item{key},
value => $item{value},
);
# rule success, errors in the method don't raise syntax errors
1;
}
| <error?> <reject>
# call recursively a new P::RD parser for this include file
# call by value for the current $warnings
include : <rulevar: local $thisparser->{local}{warnings} =
Storable::dclone $thisparser->{local}{warnings}>
include : '%include' <commit> { ++$break } value stop_pattern
{
$thisparser->{local}{line} = $thisline;
$thisparser->_include( file => $item{value}, );
# rule success, errors in the method don't raise syntax errors
1;
}
| <error?> <reject>
warning : warning_short | warning_long
warning_short : /%warnings?/i on_off <commit> { ++$break } stop_pattern
{
$thisparser->{local}{line} = $thisline;
$thisparser->_set_warnings( switch => $item{on_off} );
# rule success, errors in the method don't raise syntax errors
1;
}
| <error?> <reject>
warning_long :
/%warnings?/i ...!on_off key <commit> { ++$break } on_off stop_pattern
{
$thisparser->{local}{line} = $thisline;
$thisparser->_set_warnings(
name => $item{key},
switch => $item{on_off},
);
# rule success, errors in the method don't raise syntax errors
1;
}
| <error?> <reject>
on_off : /on|off/i
#########################################################################
# KEY and VALUE'S
#########################################################################
#
key : perl_code | token | perl_quote
value : perl_code | token | perl_quote
# everything unless separator characters, better than \w in unicode times
token : /[^ \s >< }{ )( [\] ; , ' " = # % ]+/x
perl_quote : .../"|'|<</ <perl_quotelike>
{
$thisparser->{local}{line} = $thisline;
$return = $thisparser->_quotelike( value => $item{__DIRECTIVE1__} );
}
perl_code : /perl_code|eval/i <perl_codeblock>
{
$thisparser->{local}{line} = $thisline;
$return = $thisparser->_perl_code( expr => $item{__DIRECTIVE1__}, );
}
#########################################################################
# helpers
#########################################################################
#
# The skip reset is necessary, since the default eats the newlines.
# stop_pattern is:
# a newline, a semicolon, a comma or a look-ahead for '}', ']', '\s'
#
stop_pattern : <skip: qr//> m/\s* (\n | ; | , | \z | (?=[ \} \] \s ]) )/x
eofile : /\z/
comment : m/#.*\n/
#########################################################################
#
# END of GRAMMAR, without headache?
#
#########################################################################