ossp-pkg/cfg/perl/cfg.pm
##
## OSSP cfg - Configuration Parsing
## Copyright (c) 2002-2006 Ralf S. Engelschall <rse@engelschall.com>
## Copyright (c) 2002-2006 The OSSP Project <http://www.ossp.org/>
##
## This file is part of OSSP cfg, a configuration parsing library which
## can be found at http://www.ossp.org/pkg/lib/cfg/.
##
## Permission to use, copy, modify, and distribute this software for
## any purpose with or without fee is hereby granted, provided that
## the above copyright notice and this permission notice appear in all
## copies.
##
## THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
## SUCH DAMAGE.
##
## cfg.pm: Perl Binding (Perl part)
##
package OSSP::cfg;
use 5.008;
use strict;
use warnings;
use Carp;
use XSLoader;
use Exporter;
##
## API Definition
##
# API version
our $VERSION = do { my @v = ('0.9.11' =~ m/\d+/g); sprintf("%d.".("%02d"x$#v), @v); };
# API inheritance
our @ISA = qw(Exporter);
# API symbols
my $symbols = {
'const' => [qw(
CFG_OK
CFG_ERR_ARG
CFG_ERR_USE
CFG_ERR_MEM
CFG_ERR_SYS
CFG_ERR_FMT
CFG_ERR_INT
CFG_ERR_SYN
CFG_ERR_NDE
CFG_FMT_CFG
CFG_FMT_XML
CFG_NODE_TYPE_SEQ
CFG_NODE_TYPE_DIR
CFG_NODE_TYPE_OPT
CFG_NODE_TYPE_ARG
CFG_NODE_ATTR_PARENT
CFG_NODE_ATTR_LBROTH
CFG_NODE_ATTR_RBROTH
CFG_NODE_ATTR_CHILD1
CFG_NODE_ATTR_CHILDL
CFG_NODE_ATTR_CHILDS
CFG_NODE_ATTR_NODES
CFG_NODE_ATTR_DEPTH
CFG_NODE_ATTR_SRCNAME
CFG_NODE_ATTR_SRCPOS
CFG_NODE_ATTR_TYPE
CFG_NODE_ATTR_TOKEN
CFG_NODE_ATTR_DATA
CFG_DATA_TYPE_PTR
CFG_DATA_TYPE_STR
CFG_DATA_TYPE_INT
CFG_DATA_TYPE_FLT
CFG_DATA_CTRL_CLONE
CFG_DATA_CTRL_DESTROY
CFG_DATA_ATTR_TYPE
CFG_DATA_ATTR_VALUE
CFG_DATA_ATTR_CTRL
)],
'func' => [qw(
cfg_create
cfg_destroy
cfg_error
cfg_version
cfg_import
cfg_export
cfg_node_create
cfg_node_destroy
cfg_node_clone
cfg_node_set
cfg_node_get
cfg_node_root
cfg_node_select
cfg_node_find
cfg_node_apply
cfg_node_cmp
cfg_node_link
cfg_node_unlink
cfg_data_set
cfg_data_get
cfg_data_ctrl
)]
};
# API symbol exportation
our %EXPORT_TAGS = (
'all' => [ @{$symbols->{'const'}}, @{$symbols->{'func'}} ],
'const' => [ @{$symbols->{'const'}} ],
'func' => [ @{$symbols->{'func'}} ]
);
our @EXPORT_OK = @{$EXPORT_TAGS{'all'}};
our @EXPORT = ();
##
## High-Level Perl Module OO-style API
## (just an OO wrapper around the C-style API)
##
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
bless ($self, $class);
$self->{-cfg} = undef;
$self->{-rc} = $self->CFG_OK;
my $rc = cfg_create($self->{-cfg});
if ($rc != $self->CFG_OK) {
croak(sprintf("OSSP::cfg::new: cfg_create: %s (%d)", $self->error($rc), $rc));
}
return $self;
}
sub DESTROY ($) {
my ($self) = @_;
$self->{-rc} = cfg_destroy($self->{-cfg}) if (defined($self->{-cfg}));
if ($self->{-rc} != $self->CFG_OK) {
carp(sprintf("OSSP::cfg::DESTROY: cfg_destroy: %s (%d)", $self->error($self->{-rc}), $self->{-rc}));
return;
}
$self->{-cfg} = undef;
$self->{-rc} = undef;
return;
}
sub import { # ($$$$)
# ATTENTION: The OSSP cfg API function "import" conflicts with
# the standardized "import" method the Perl world expects from
# their modules. In order to keep the Perl binding consist
# with the C API, we solve the conflict under run-time by
# distinguishing between the two types of "import" calls.
if (defined($_[0]) and ref($_[0]) =~ m/^OSSP::cfg/) {
# the regular OSSP::cfg "import" method
my ($self, $node, $fmt, $in) = @_;
$self->{-rc} = cfg_import($self->{-cfg}, $node, $fmt, $in, length($in));
return ($self->{-rc} == $self->CFG_OK);
}
else {
# the special Perl "import" method
# (usually inherited from the Exporter)
no strict "refs";
return OSSP::cfg->export_to_level(1, @_);
}
}
sub export { # ($$$)
# ATTENTION: The OSSP cfg API function "export" conflicts with
# the standardized "export" method the Perl world expects from
# their modules. In order to keep the Perl binding consist
# with the C API, we solve the conflict under run-time by
# distinguishing between the two types of "export" calls.
if (defined($_[0]) and ref($_[0]) =~ m/^OSSP::cfg/) {
# the regular OSSP::cfg "export" method
my ($self, $node, $fmt) = @_;
my $out;
$self->{-rc} = cfg_export($self->{-cfg}, $node, $fmt, $out, 0);
return ($self->{-rc} == $self->CFG_OK ? $out : undef);
}
else {
# the special Perl "export" method
# (usually inherited from the Exporter)
return Exporter::export(@_);
}
}
sub error ($;$) {
my ($self, $rc) = @_;
$rc = $self->{-rc} if (not defined($rc));
my $error;
if (cfg_error($self->{-cfg}, $rc, $error) != $self->CFG_OK) {
croak("OSSP::cfg::error: cfg_error: INTERNAL ERROR");
}
return wantarray ? ($error, $rc) : $error;
}
sub version () {
my ($self) = @_;
return cfg_version();
}
sub node_create ($) {
my ($self) = @_;
my $node;
$self->{-rc} = cfg_node_create($self->{-cfg}, $node);
return ($self->{-rc} == $self->CFG_OK ? $node : undef);
}
sub node_destroy ($$) {
my ($self, $node) = @_;
$self->{-rc} = cfg_node_destroy($self->{-cfg}, $node);
return ($self->{-rc} == $self->CFG_OK);
}
sub node_clone ($$) {
my ($self, $node) = @_;
my $node2;
$self->{-rc} = cfg_node_clone($self->{-cfg}, $node, $node2);
return ($self->{-rc} == $self->CFG_OK ? $node2 : undef);
}
sub node_set ($$$$) {
my ($self, $node, $attr, $arg) = @_;
$self->{-rc} = cfg_node_set($self->{-cfg}, $node, $attr, $arg);
return ($self->{-rc} == $self->CFG_OK);
}
sub node_get ($$$) {
my ($self, $node, $attr) = @_;
my $arg;
$self->{-rc} = cfg_node_get($self->{-cfg}, $node, $attr, $arg);
return ($self->{-rc} == $self->CFG_OK ? $arg : undef);
}
sub node_root ($;$) {
my ($self, $node_new) = @_;
$node_new ||= \0;
my $node_old;
$self->{-rc} = cfg_node_root($self->{-cfg}, $node_new, $node_old);
return ($self->{-rc} == $self->CFG_OK ? $node_old : undef);
}
sub node_select ($$$) {
my ($self, $node, $spec) = @_;
my $result;
$self->{-rc} = cfg_node_select($self->{-cfg}, $node, $result, $spec);
return ($self->{-rc} == $self->CFG_OK ? $result : undef);
}
sub node_find ($$$$) {
my ($self, $node, $cb_fct_cmp, $cb_ctx_cmp) = @_;
my $cont;
$self->{-rc} = cfg_node_find($self->{-cfg}, $node, $cb_fct_cmp, $cb_ctx_cmp, $cont);
return ($self->{-rc} == $self->CFG_OK ? $cont : undef);
}
sub node_apply ($$$$) {
my ($self, $node, $cb_fct_cmp, $cb_ctx_cmp, $cb_fct_cb, $cb_ctx_cb) = @_;
$self->{-rc} = cfg_node_apply($self->{-cfg}, $node, $cb_fct_cmp, $cb_ctx_cmp, $cb_fct_cb, $cb_ctx_cb);
return ($self->{-rc} == $self->CFG_OK);
}
sub node_cmp ($$$) {
my ($self, $node, $token) = @_;
$self->{-rc} = cfg_node_cmp($self->{-cfg}, $node, $token);
return ($self->{-rc} == $self->CFG_OK);
}
sub node_link ($$$$) {
my ($self, $node, $id, $node2) = @_;
$self->{-rc} = cfg_node_link($self->{-cfg}, $node, $id, $node2);
return ($self->{-rc} == $self->CFG_OK);
}
sub node_unlink ($$) {
my ($self, $node) = @_;
$self->{-rc} = cfg_node_unlink($self->{-cfg}, $node);
return ($self->{-rc} == $self->CFG_OK);
}
sub data_set ($$$$) {
my ($self, $data, $attr, $value) = @_;
$self->{-rc} = cfg_data_set($data, $attr, $value);
return ($self->{-rc} == $self->CFG_OK);
}
sub data_get ($$$) {
my ($self, $data, $attr) = @_;
my $value;
$self->{-rc} = cfg_data_get($data, $attr, $value);
return ($self->{-rc} == $self->CFG_OK ? $value : undef);
}
sub data_ctrl ($$$;$) {
my ($self, $data, $ctrl, $value) = @_;
$self->{-rc} = cfg_data_ctrl($data, $ctrl, $value);
return ($self->{-rc} == $self->CFG_OK);
}
##
## Low-Level Perl XS C-style API
## (actually just the activation of the XS part)
##
# auto-loading constants
sub AUTOLOAD {
my $constname;
our $AUTOLOAD;
($constname = $AUTOLOAD) =~ s/.*:://;
croak "&OSSP::cfg::constant not defined" if ($constname eq 'constant');
my ($error, $val) = constant($constname);
croak $error if ($error);
{ no strict 'refs'; *$AUTOLOAD = sub { $val }; }
goto &$AUTOLOAD;
}
# static-loading functions
XSLoader::load('OSSP::cfg', $VERSION);
##
## Highest-Level Perl Convenience API
## (based on OSSP::cfg Perl API above)
##
package OSSP::cfg::simple;
use 5.008;
use strict;
use warnings;
use Carp;
use IO::File;
# object constructor
sub new ($;$) {
my ($proto, $input) = @_;
my $class = ref($proto) || $proto;
my $self = {};
bless ($self, $class);
$self->{-cfg} = new OSSP::cfg
or croak "failed to create OSSP::cfg object";
$self->parse($input) if (defined($input));
return $self;
}
# object destructor
sub DESTROY ($) {
my ($self) = @_;
undef $self->{-cfg};
return;
}
# parse textual syntax into node tree
sub parse ($$) {
my ($self, $input) = @_;
my $cfg = $self->{-cfg};
if (length($input) < 1024 and $input !~ m|[{}&\n\s]|s) {
if (-f $input) {
my $io = new IO::File "<" . $input
or croak "unable to read from configuration file \"".$input."\"";
{ local $/; $input = <$io>; }
$io->close();
}
}
$cfg->import(\0, $cfg->CFG_FMT_CFG, $input)
or die "failed to parse configuration: " . $cfg->error();
return $self;
}
# format textual syntax from node tree
sub format ($$) {
my ($self) = @_;
my $cfg = $self->{-cfg};
my $root = $cfg->node_root();
my $str = $cfg->export($root, $cfg->CFG_FMT_CFG)
or die "failed to format configuration: " . $cfg->error();
return $str;
}
# pack Perl complex data structure into node tree
sub pack ($$) {
my ($self, $tree) = @_;
# destroy old and create new OSSP::cfg object
undef $self->{-cfg};
my $cfg = new OSSP::cfg
or croak "failed to create OSSP::cfg object";
$self->{-cfg} = $cfg;
# start parsing with a sequence
my $node = &parse_seq($cfg, $tree);
# parse a sequence (reference) scalar
sub parse_seq {
my ($cfg, $seq) = @_;
my $node = undef;
if (ref($seq) eq 'ARRAY') {
$node = $cfg->node_create();
$cfg->node_set($node, $cfg->CFG_NODE_ATTR_TYPE, $cfg->CFG_NODE_TYPE_SEQ);
if (@{$seq} > 0) {
my $child = &parse_dir($cfg, $seq->[0]);
$cfg->node_set($node, $cfg->CFG_NODE_ATTR_CHILD1, $child);
my $sibling = $child;
foreach my $dir (@{$seq}[1..$#{$seq}]) {
$child = &parse_dir($cfg, $dir);
$cfg->node_set($sibling, $cfg->CFG_NODE_ATTR_RBROTH, $child);
$sibling = $child;
}
}
}
return $node;
}
# parse a directive (reference) scalar
sub parse_dir {
my ($cfg, $dir) = @_;
my $node = undef;
if (ref($dir) eq 'ARRAY') {
$node = $cfg->node_create();
$cfg->node_set($node, $cfg->CFG_NODE_ATTR_TYPE, $cfg->CFG_NODE_TYPE_DIR);
if (@{$dir} > 0) {
my $child = &parse_tok($cfg, $dir->[0]);
$cfg->node_set($node, $cfg->CFG_NODE_ATTR_CHILD1, $child);
my $sibling = $child;
foreach my $tok (@{$dir}[1..$#{$dir}]) {
$child = &parse_tok($cfg, $tok);
$cfg->node_set($sibling, $cfg->CFG_NODE_ATTR_RBROTH, $child);
$sibling = $child;
}
}
}
return $node;
}
# parse a token scalar
sub parse_tok {
my ($cfg, $tok) = @_;
my $node;
if (ref($tok) eq 'ARRAY') {
# token is actually a sub-sequence
$node = &parse_seq($cfg, $tok); # recursion
}
else {
# token is a plain one
$node = $cfg->node_create();
$cfg->node_set($node, $cfg->CFG_NODE_ATTR_TYPE, $cfg->CFG_NODE_TYPE_ARG);
$cfg->node_set($node, $cfg->CFG_NODE_ATTR_TOKEN, $tok);
}
return $node;
}
# set generated node tree into OSSP::cfg object
$cfg->node_root($node);
return $self;
}
# unpack Perl complex data structure from node tree
sub unpack ($;%) {
my ($self, %arg) = @_;
my $cfg = $self->{-cfg};
# start traversing the node tree from the root node
my $root = $cfg->node_root();
my $tree = &traverse($cfg, \%arg, $root);
# node processing function
sub traverse {
my ($cfg, $arg, $node) = @_;
return if (not(ref($node) and $$node != 0));
my $type = $cfg->node_get($node, $cfg->CFG_NODE_ATTR_TYPE);
if ($type == $cfg->CFG_NODE_TYPE_SEQ) {
# node is a sequence
my $seq = [];
$node = $cfg->node_get($node, $cfg->CFG_NODE_ATTR_CHILD1);
while (ref($node) and $$node != 0) {
my $tree = &traverse($cfg, $arg, $node); # recursion
push(@{$seq}, $tree) if (defined($tree));
$node = $cfg->node_get($node, $cfg->CFG_NODE_ATTR_RBROTH);
}
# optional post-processing of data structure
$seq = &unpack_postproc_merge ($seq, $arg->{-merge}) if (defined($arg->{-merge}));
$seq = &unpack_postproc_index ($seq, $arg->{-index}) if (defined($arg->{-index}));
$seq = &unpack_postproc_strip ($seq, $arg->{-strip}) if (defined($arg->{-strip}));
$seq = &unpack_postproc_flatten ($seq, $arg->{-flatten}) if (defined($arg->{-flatten}));
return $seq;
}
elsif ($type == $cfg->CFG_NODE_TYPE_DIR) {
# node is a directive
my $dir = [];
$node = $cfg->node_get($node, $cfg->CFG_NODE_ATTR_CHILD1);
while (ref($node) and $$node != 0) {
my $tree = &traverse($cfg, $arg, $node); # recursion
push(@{$dir}, $tree) if (defined($tree));
$node = $cfg->node_get($node, $cfg->CFG_NODE_ATTR_RBROTH);
}
return $dir;
}
else {
# node is a token
my $token = $cfg->node_get($node, $cfg->CFG_NODE_ATTR_TOKEN);
return $token;
}
}
return $tree;
}
# unpack helper function:
# optionally merge arguments of DIRectives starting with same TOKen.
# complexity: O(n) (actually 3*n)
sub unpack_postproc_merge {
my ($seq, $re) = @_;
# pass 1: determine directive names and their
# occurences in sequence. complexity: O(n)
my $dir = {};
for (my $i = 0; $i < @{$seq}; $i++) {
if ( ref($seq->[$i]) eq 'ARRAY'
and not ref($seq->[$i]->[0])
and $seq->[$i]->[0] =~ m/^$re$/s) {
my $name = $seq->[$i]->[0];
$dir->{$name} = [] if (not defined($dir->{$name}));
push(@{$dir->{$name}}, $i);
}
}
# pass 2: append arguments of second and following sequences
# to arguments of first directive. complexity: O(n)
foreach my $name (keys(%{$dir})) {
if (@{$dir->{$name}} > 1) {
my $f = $dir->{$name}->[0];
foreach my $n (@{$dir->{$name}}[1..$#{$dir->{$name}}]) {
foreach my $tok (@{$seq->[$n]}[1..$#{$seq->[$n]}]) {
push(@{$seq->[$f]}, $tok);
}
$seq->[$n] = undef;
}
}
}
# pass 3: shrink sequence by eliminating removing entries
# complexity: O(n)
for (my $i = 0; $i < @{$seq}; $i++) {
if (not defined($seq->[$i])) {
splice(@{$seq}, $i, 1);
$i--; # compensate for splice operation
}
}
return $seq;
}
# unpack helper function:
# optionally annotate SEQuence nodes with a DIRective name indexing hash
# complexity: O(n)
sub unpack_postproc_index {
my ($seq, $re) = @_;
# create an index hash
my $idx = {};
for (my $i = 0; $i < @{$seq}; $i++) {
if (ref($seq->[$i]) eq 'ARRAY') {
# determine name of directive, i.e.,
# first non-sub-sequence element
my $name = {};
for (my $j = 0; $j < @{$seq->[$j]}; $j++) {
$name = $seq->[$i]->[$j];
last if (not ref($name));
}
if ( not ref($name)
and $name =~ m/^$re$/s
and not defined($idx->{$name})) {
# remember position of directive's
# first occurrence in sequence
$idx->{$name} = ($i + 1);
}
}
}
# insert index at first position of sequence array following
# perlref(1)'s "Pseudo-hashes: Using an array as a hash" approach.
unshift(@{$seq}, $idx);
return $seq;
}
# unpack helper function:
# strip directive command/start token
# complexity: O(n)
sub unpack_postproc_strip {
my ($seq, $re) = @_;
foreach my $dir (@{$seq}) {
if ( ref($dir) eq 'ARRAY'
and $dir->[0] =~ m/^$re$/s) {
# remove first token of directive array
shift(@{$dir});
}
}
return $seq;
}
# unpack helper function:
# flatten empty and single token directives
sub unpack_postproc_flatten {
my ($seq, $empty) = @_;
for (my $i = 0; $i < @{$seq}; $i++) {
if (ref($seq->[$i]) eq 'ARRAY') {
if (@{$seq->[$i]} == 0) {
# replace empty directive array
# (can exist after "dirstrip" processing!)
$seq->[$i] = $empty;
}
elsif (@{$seq->[$i]} == 1) {
# simplify single token directive array
$seq->[$i] = $seq->[$i]->[0];
}
}
}
return $seq;
}
1;
