##
##  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;