*** /dev/null Sat Nov 23 01:31:49 2024
--- - Sat Nov 23 01:31:53 2024
***************
*** 0 ****
--- 1,635 ----
+ ##
+ ## OSSP cfg - Configuration Parsing
+ ## Copyright (c) 2002-2004 Ralf S. Engelschall <rse@engelschall.com>
+ ## Copyright (c) 2002-2004 The OSSP Project <http://www.ossp.org/>
+ ## Copyright (c) 2002-2004 Cable & Wireless <http://www.cw.com/>
+ ##
+ ## 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.7' =~ 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;
+
|
