Config-Grammar
view release on metacpan or search on metacpan
lib/Config/Grammar.pm view on Meta::CPAN
package Config::Grammar;
use strict;
$Config::Grammar::VERSION = '1.13';
sub new($$)
{
my $proto = shift;
my $grammar = shift;
my $class = ref($proto) || $proto;
my $self = {grammar => $grammar};
bless($self, $class);
return $self;
}
sub err($)
{
my $self = shift;
return $self->{'err'};
}
sub _make_error($$)
{
my $self = shift;
my $text = shift;
$self->{'err'} = "$self->{file}, line $self->{line}: $text";
}
sub _peek($)
{
my $a = shift;
return $a->[$#$a];
}
sub _quotesplit($)
{
my $line = shift;
my @items;
while ($line ne "") {
if ($line =~ s/^"((?:\\.|[^"])*)"\s*//) {
my $frag = $1;
$frag =~ s/\\(.)/$1/g;
push @items, $frag;
} elsif ($line =~ s/^'((?:\\.|[^'])*)'\s*//) {
my $frag = $1;
lib/Config/Grammar.pm view on Meta::CPAN
$frag =~ s/\\(.)/$1/g;
push @items, $frag;
}
else {
die "Internal parser error for '$line'";
}
}
return @items;
}
sub _check_mandatory($$$$)
{
my $self = shift;
my $g = shift;
my $c = shift;
my $section = shift;
# check _mandatory sections, variables and tables
if (defined $g->{_mandatory}) {
for (@{$g->{_mandatory}}) {
if (not defined $g->{$_}) {
lib/Config/Grammar.pm view on Meta::CPAN
delete $c->{$_}{_grammar};
delete $c->{$_}{_order_count} if exists $c->{$_}{_order_count};
}
return 1;
}
######### SECTIONS #########
# search grammar definition of a section
sub _search_section($$)
{
my $self = shift;
my $name = shift;
if (not defined $self->{grammar}{_sections}) {
$self->_make_error("no sections are allowed");
return undef;
}
# search exact match
lib/Config/Grammar.pm view on Meta::CPAN
next if exists $c->{$var};
my $value = $g->{$var}{_default}
if exists $g->{$var}{_default};
next unless defined $value;
$c->{$var} = $value;
}
}
}
sub _next_level($$$)
{
my $self = shift;
my $name = shift;
# section name
if (defined $self->{section}) {
$self->{section} .= "/$name";
}
else {
$self->{section} = $name;
lib/Config/Grammar.pm view on Meta::CPAN
$self->{cfg}{_is_section} = 1;
$self->{cfg}{_grammar} = $s;
$self->{cfg}{_order} = $order if defined $order;
# increase level
$self->{level}++;
return 1;
}
sub _prev_level($)
{
my $self = shift;
# fill in the values from _default keywords when going up
$self->_fill_defaults;
# section name
if (defined $self->{section}) {
if ($self->{section} =~ /\//) {
$self->{section} =~ s/\/.*?$//;
lib/Config/Grammar.pm view on Meta::CPAN
# config context
$self->{cfg} = pop @{$self->{cfg_stack}};
# grammar context
$self->{grammar} = pop @{$self->{grammar_stack}};
# decrease level
$self->{level}--;
}
sub _goto_level($$$)
{
my $self = shift;
my $level = shift;
my $name = shift;
# _text is multi-line. Check when changing level
$self->_check_text($self->{section}) or return 0;
if ($level > $self->{level}) {
if ($level > $self->{level} + 1) {
lib/Config/Grammar.pm view on Meta::CPAN
$self->_next_level($name) or return 0;
}
}
return 1;
}
######### VARIABLES #########
# search grammar definition of a variable
sub _search_variable($$)
{
my $self = shift;
my $name = shift;
if (not defined $self->{grammar}{_vars}) {
$self->_make_error("no variables are allowed");
return undef;
}
# search exact match
lib/Config/Grammar.pm view on Meta::CPAN
return $_;
}
}
}
# no match
$self->_make_error("unknown variable '$name'");
return undef;
}
sub _set_variable($$$)
{
my $self = shift;
my $key = shift;
my $value = shift;
my $gn = $self->_search_variable($key);
defined $gn or return 0;
my $varlistref;
if (defined $self->{grammar}{_varlist}) {
lib/Config/Grammar.pm view on Meta::CPAN
}
}
$self->{cfg}{$key} = $value;
push @{$varlistref}, $key if ref $varlistref;
return 1;
}
######### PARSER #########
sub _parse_table($$)
{
my $self = shift;
local $_ = shift;
my $g = $self->{grammar}{_table};
defined $g or do {
$self->_make_error("table syntax error");
return 0;
};
lib/Config/Grammar.pm view on Meta::CPAN
}
# list (unkeyed table)
else {
push @{$self->{cfg}{_table}}, \@l;
}
return 1;
}
sub _parse_text($$)
{
my ($self, $line) = @_;
$self->{cfg}{_text} .= $line;
return 1;
}
sub _check_text($$)
{
my ($self, $name) = @_;
my $g = $self->{grammar}{_text};
defined $g or return 1;
# chop empty lines at beginning and end
if(defined $self->{cfg}{_text}) {
$self->{cfg}{_text} =~ s/\A([ \t]*[\n\r]+)*//m;
$self->{cfg}{_text} =~ s/^([ \t]*[\n\r]+)*\Z//m;
lib/Config/Grammar.pm view on Meta::CPAN
if (defined $g->{_sub}){
my $error = &{$g->{_sub}}($self->{cfg}{_text});
if (defined $error) {
$self->_make_error($error);
return 0;
}
}
return 1;
}
sub _parse_file($$);
sub _parse_line($$$)
{
my $self = shift;
local $_ = shift;
my $source = shift;
/^\@include\s+["']?(.*)["']?$/ and do {
my $inc = $1;
if ( ( $^O eq 'win32' and $inc !~ m|^(?:[a-z]:)?[/\\]|i and $self->{file} =~ m|^(.+)[\\/][^/]+$| ) or
( $inc !~ m|^/| and $self->{file} =~ m|^(.+)/[^/]+$| ) ){
$inc = "$1/$inc";
lib/Config/Grammar.pm view on Meta::CPAN
}
$self->_set_variable($1, $2) or return 0;
return 1;
};
$self->_parse_table($_) or return 0;
return 1;
}
sub _check_section_sub($$) {
my $self = shift;
my $name = shift;
my $g = $self->{grammar};
if (defined $g->{_sub}){
my $error = &{$g->{_sub}}($name);
if (defined $error){
$self->_make_error($error);
return 0;
}
}
return 1;
}
sub _parse_file($$)
{
my $self = shift;
my $file = shift;
unless ($file) { $self->{'err'} = "no filename given" ;
return undef;};
my $fh;
my $mode = "<";
$mode .= ":encoding($self->{encoding})" if $self->{encoding};
lib/Config/Grammar.pm view on Meta::CPAN
}
$self->{line} = $.;
$self->_parse_line($_, $source) or do{ close $fh; return 0; };
$source = '';
}
close $fh;
return 1;
}
sub makepod($) {
my $pod = eval {
require Config::Grammar::Document;
return Config::Grammar::Document::makepod(@_);
};
defined $pod or die "ERROR: install Config::Grammar::Document in order to use makepod(): $@\n";
return $pod;
}
sub maketmpl ($@) {
my $pod = eval {
lib/Config/Grammar.pm view on Meta::CPAN
sub makemintmpl ($@) {
my $pod = eval {
require Config::Grammar::Document;
return Config::Grammar::Document::makemintmpl(@_);
};
defined $pod or die "ERROR: install Config::Grammar::Document in order to use makemintmpl()\n";
return $pod;
}
sub parse($$$)
{
my $self = shift;
my $file = shift;
my $args = shift;
$self->{encoding} = $args->{encoding} if ref $args eq 'HASH';
$self->{cfg} = {};
$self->{level} = 0;
$self->{cfg_stack} = [];
lib/Config/Grammar.pm~ view on Meta::CPAN
package Config::Grammar;
use strict;
$Config::Grammar::VERSION = '1.11';
sub new($$)
{
my $proto = shift;
my $grammar = shift;
my $class = ref($proto) || $proto;
my $self = {grammar => $grammar};
bless($self, $class);
return $self;
}
sub err($)
{
my $self = shift;
return $self->{'err'};
}
sub _make_error($$)
{
my $self = shift;
my $text = shift;
$self->{'err'} = "$self->{file}, line $self->{line}: $text";
}
sub _peek($)
{
my $a = shift;
return $a->[$#$a];
}
sub _quotesplit($)
{
my $line = shift;
my @items;
while ($line ne "") {
if ($line =~ s/^"((?:\\.|[^"])*)"\s*//) {
my $frag = $1;
$frag =~ s/\\(.)/$1/g;
push @items, $frag;
} elsif ($line =~ s/^'((?:\\.|[^'])*)'\s*//) {
my $frag = $1;
lib/Config/Grammar.pm~ view on Meta::CPAN
$frag =~ s/\\(.)/$1/g;
push @items, $frag;
}
else {
die "Internal parser error for '$line'";
}
}
return @items;
}
sub _check_mandatory($$$$)
{
my $self = shift;
my $g = shift;
my $c = shift;
my $section = shift;
# check _mandatory sections, variables and tables
if (defined $g->{_mandatory}) {
for (@{$g->{_mandatory}}) {
if (not defined $g->{$_}) {
lib/Config/Grammar.pm~ view on Meta::CPAN
delete $c->{$_}{_grammar};
delete $c->{$_}{_order_count} if exists $c->{$_}{_order_count};
}
return 1;
}
######### SECTIONS #########
# search grammar definition of a section
sub _search_section($$)
{
my $self = shift;
my $name = shift;
if (not defined $self->{grammar}{_sections}) {
$self->_make_error("no sections are allowed");
return undef;
}
# search exact match
lib/Config/Grammar.pm~ view on Meta::CPAN
next if exists $c->{$var};
my $value = $g->{$var}{_default}
if exists $g->{$var}{_default};
next unless defined $value;
$c->{$var} = $value;
}
}
}
sub _next_level($$$)
{
my $self = shift;
my $name = shift;
# section name
if (defined $self->{section}) {
$self->{section} .= "/$name";
}
else {
$self->{section} = $name;
lib/Config/Grammar.pm~ view on Meta::CPAN
$self->{cfg}{_is_section} = 1;
$self->{cfg}{_grammar} = $s;
$self->{cfg}{_order} = $order if defined $order;
# increase level
$self->{level}++;
return 1;
}
sub _prev_level($)
{
my $self = shift;
# fill in the values from _default keywords when going up
$self->_fill_defaults;
# section name
if (defined $self->{section}) {
if ($self->{section} =~ /\//) {
$self->{section} =~ s/\/.*?$//;
lib/Config/Grammar.pm~ view on Meta::CPAN
# config context
$self->{cfg} = pop @{$self->{cfg_stack}};
# grammar context
$self->{grammar} = pop @{$self->{grammar_stack}};
# decrease level
$self->{level}--;
}
sub _goto_level($$$)
{
my $self = shift;
my $level = shift;
my $name = shift;
# _text is multi-line. Check when changing level
$self->_check_text($self->{section}) or return 0;
if ($level > $self->{level}) {
if ($level > $self->{level} + 1) {
lib/Config/Grammar.pm~ view on Meta::CPAN
$self->_next_level($name) or return 0;
}
}
return 1;
}
######### VARIABLES #########
# search grammar definition of a variable
sub _search_variable($$)
{
my $self = shift;
my $name = shift;
if (not defined $self->{grammar}{_vars}) {
$self->_make_error("no variables are allowed");
return undef;
}
# search exact match
lib/Config/Grammar.pm~ view on Meta::CPAN
return $_;
}
}
}
# no match
$self->_make_error("unknown variable '$name'");
return undef;
}
sub _set_variable($$$)
{
my $self = shift;
my $key = shift;
my $value = shift;
my $gn = $self->_search_variable($key);
defined $gn or return 0;
my $varlistref;
if (defined $self->{grammar}{_varlist}) {
lib/Config/Grammar.pm~ view on Meta::CPAN
}
}
$self->{cfg}{$key} = $value;
push @{$varlistref}, $key if ref $varlistref;
return 1;
}
######### PARSER #########
sub _parse_table($$)
{
my $self = shift;
local $_ = shift;
my $g = $self->{grammar}{_table};
defined $g or do {
$self->_make_error("table syntax error");
return 0;
};
lib/Config/Grammar.pm~ view on Meta::CPAN
}
# list (unkeyed table)
else {
push @{$self->{cfg}{_table}}, \@l;
}
return 1;
}
sub _parse_text($$)
{
my ($self, $line) = @_;
$self->{cfg}{_text} .= $line;
return 1;
}
sub _check_text($$)
{
my ($self, $name) = @_;
my $g = $self->{grammar}{_text};
defined $g or return 1;
# chop empty lines at beginning and end
if(defined $self->{cfg}{_text}) {
$self->{cfg}{_text} =~ s/\A([ \t]*[\n\r]+)*//m;
$self->{cfg}{_text} =~ s/^([ \t]*[\n\r]+)*\Z//m;
lib/Config/Grammar.pm~ view on Meta::CPAN
if (defined $g->{_sub}){
my $error = &{$g->{_sub}}($self->{cfg}{_text});
if (defined $error) {
$self->_make_error($error);
return 0;
}
}
return 1;
}
sub _parse_file($$);
sub _parse_line($$$)
{
my $self = shift;
local $_ = shift;
my $source = shift;
/^\@include\s+["']?(.*)["']?$/ and do {
my $inc = $1;
if ( ( $^O eq 'win32' and $inc !~ m|^(?:[a-z]:)?[/\\]|i and $self->{file} =~ m|^(.+)[\\/][^/]+$| ) or
( $inc !~ m|^/| and $self->{file} =~ m|^(.+)/[^/]+$| ) ){
$inc = "$1/$inc";
lib/Config/Grammar.pm~ view on Meta::CPAN
}
$self->_set_variable($1, $2) or return 0;
return 1;
};
$self->_parse_table($_) or return 0;
return 1;
}
sub _check_section_sub($$) {
my $self = shift;
my $name = shift;
my $g = $self->{grammar};
if (defined $g->{_sub}){
my $error = &{$g->{_sub}}($name);
if (defined $error){
$self->_make_error($error);
return 0;
}
}
return 1;
}
sub _parse_file($$)
{
my $self = shift;
my $file = shift;
unless ($file) { $self->{'err'} = "no filename given" ;
return undef;};
my $fh;
my $mode = "<";
$mode .= ":encoding($self->{encoding})" if $self->{encoding};
lib/Config/Grammar.pm~ view on Meta::CPAN
}
$self->{line} = $.;
$self->_parse_line($_, $source) or do{ close $fh; return 0; };
$source = '';
}
close $fh;
return 1;
}
sub makepod($) {
my $pod = eval {
require Config::Grammar::Document;
return Config::Grammar::Document::makepod(@_);
};
defined $pod or die "ERROR: install Config::Grammar::Document in order to use makepod(): $@\n";
return $pod;
}
sub maketmpl ($@) {
my $pod = eval {
lib/Config/Grammar.pm~ view on Meta::CPAN
sub makemintmpl ($@) {
my $pod = eval {
require Config::Grammar::Document;
return Config::Grammar::Document::makemintmpl(@_);
};
defined $pod or die "ERROR: install Config::Grammar::Document in order to use makemintmpl()\n";
return $pod;
}
sub parse($$$)
{
my $self = shift;
my $file = shift;
my $args = shift;
$self->{encoding} = $args->{encoding};
$self->{cfg} = {};
$self->{level} = 0;
$self->{cfg_stack} = [];
lib/Config/Grammar/Document.pm view on Meta::CPAN
grep {$_ eq $var} @{$tree->{_inherited}});
push @doc, "This variable I<inherits> its value from the parent section if nothing is specified here."
if $inherited;
push @doc, "Default value: $var = $tree->{$var}{_default}"
if ($tree->{$var}{_default});
push @doc, "Example: $var = $tree->{$var}{_example}"
if ($tree->{$var}{_example});
return @doc;
}
sub _genpod($$$);
sub _genpod($$$)
{
my ($tree, $level, $doc) = @_;
if ($tree->{_vars}){
push @{$doc}, "The following variables can be set in this section:";
push @{$doc}, "=over";
foreach my $var (@{$tree->{_vars}}){
push @{$doc}, _describevar($tree, $var);
}
push @{$doc}, "=back";
}
lib/Config/Grammar/Document.pm view on Meta::CPAN
next;
}
push @{$doc}, ($tree->{$section}{_doc})
if $tree->{$section}{_doc};
_genpod($tree->{$section},$level+1,$doc);
}
push @{$doc}, "=back" if $level > 0
}
};
sub makepod($) {
my $self = shift;
my $tree = $self->{grammar};
my @doc;
_genpod($tree,0,\@doc);
return join("\n\n", @doc)."\n";
}
sub _gentmpl($$$@);
sub _gentmpl($$$@){
my $tree = shift;
my $complete = shift;
my $level = shift;
my $doc = shift;
my @start = @_;
if (scalar @start ) {
my $section = shift @start;
my $secex ='';
my $prefix = '';
$prefix = "# " unless $tree->{_mandatory} and
lib/Config/Grammar/Dynamic.pm view on Meta::CPAN
for (ref $what) {
/^ARRAY$/ and return [ map { $_ eq $what ? $_ : _deepcopy($_) } @$what ];
/^HASH$/ and return { map { $_ => $what->{$_} eq $what ?
$what->{$_} : _deepcopy($what->{$_}) } keys %$what };
/^CODE$/ and return $what; # we don't need to copy the subs
/^Regexp$/ and return $what; # neither Regexp objects
}
die "Cannot _deepcopy reference type @{[ref $what]}";
}
sub _next_level($$$)
{
my $self = shift;
my $name = shift;
# section name
if (defined $self->{section}) {
$self->{section} .= "/$name";
}
else {
$self->{section} = $name;
lib/Config/Grammar/Dynamic.pm view on Meta::CPAN
}
return 1;
}
# find variables in old grammar list 'listname'
# that aren't in the corresponding list in the new grammar
# and list them as a POD document, possibly with a callback
# function 'docfunc'
sub _findmissing($$$;$) {
my $old = shift;
my $new = shift;
my $listname = shift;
my $docfunc = shift;
my @doc;
if ($old->{$listname}) {
my %newlist;
if ($new->{$listname}) {
@newlist{@{$new->{$listname}}} = undef;
lib/Config/Grammar/Dynamic.pm view on Meta::CPAN
}
}
return @doc;
}
# find variables in new grammar list 'listname'
# that aren't in the corresponding list in the new grammar
#
# this is just _findmissing with the arguments swapped
sub _findnew($$$;$) {
my $old = shift;
my $new = shift;
my $listname = shift;
my $docfunc = shift;
return _findmissing($new, $old, $listname, $docfunc);
}
# compare two lists for element equality
sub _listseq($$);
sub _listseq($$) {
my ($k, $l) = @_;
my $length = @$k;
return 0 unless @$l == $length;
for (my $i=0; $i<$length; $i++) {
return 0 unless $k->[$i] eq $l->[$i];
}
return 1;
}
# diff two grammar trees, documenting the differences
sub _diffgrammars($$);
sub _diffgrammars($$) {
my $old = shift;
my $new = shift;
my @doc;
my @vdoc;
@vdoc = _findmissing($old, $new, '_vars');
push @doc, "The following variables are not valid anymore:", "=over" , @vdoc, "=back"
if @vdoc;
@vdoc = _findnew($old, $new, '_vars', \&_describevar);
push @doc, "The following new variables are valid:", "=over" , @vdoc, "=back"
lib/Config/Grammar/Dynamic.pm view on Meta::CPAN
if $inherited;
push @doc, "This variable I<dynamically> modifies the grammar based on its value."
if $tree->{$var}{_dyn};
push @doc, "Default value: $var = $tree->{$var}{_default}"
if ($tree->{$var}{_default});
push @doc, "Example: $var = $tree->{$var}{_example}"
if ($tree->{$var}{_example});
return @doc;
}
sub _genpod($$$);
sub _genpod($$$)
{
my ($tree, $level, $doc) = @_;
my %dyndoc;
if ($tree->{_vars}){
push @{$doc}, "The following variables can be set in this section:";
push @{$doc}, "=over";
foreach my $var (@{$tree->{_vars}}){
push @{$doc}, _describevar($tree, $var);
}
push @{$doc}, "=back";
lib/Config/Grammar/Dynamic.pm view on Meta::CPAN
push @{$doc}, "No changes that can be automatically described.";
}
push @{$doc}, "(End of dynamical grammar changes for variable C<$var> example value C<$val>.)";
}
push @{$doc}, "=back";
push @{$doc}, "(End of dynamical grammar changes for example values of variable C<$var>.)";
}
}
};
sub makepod($) {
my $self = shift;
my $tree = $self->{grammar};
my @doc;
_genpod($tree,0,\@doc);
return join("\n\n", @doc)."\n";
}
sub _set_variable($$$)
{
my $self = shift;
my $key = shift;
my $value = shift;
my $gn = $self->_search_variable($key);
defined $gn or return 0;
my $varlistref;
if (defined $self->{grammar}{_varlist}) {
lib/Config/Grammar/Dynamic.pm view on Meta::CPAN
&{$g->{_dyn}}($key, $value, $self->{grammar});
}
}
$self->{cfg}{$key} = $value;
push @{$varlistref}, $key if ref $varlistref;
return 1;
}
sub parse($$)
{
my $self = shift;
my $file = shift;
my $args = shift;
$self->{encoding} = $args->{encoding} if ref $args eq 'HASH';
$self->{cfg} = {};
$self->{level} = 0;
$self->{cfg_stack} = [];
t/DebugDump.pm view on Meta::CPAN
package DebugDump;
use vars qw($VERSION);
$VERSION=1.1;
sub debug_dump($;$);
sub debug_dump($;$)
{
my $ref = shift;
my $indent = shift || '';
my $out = '';
my $type = ref $ref;
if(not $type) {
if(defined $ref) {
$out .= $indent."'$ref'\n";
}
else {
( run in 1.089 second using v1.01-cache-2.11-cpan-65fba6d93b7 )