File Coverage

blib/lib/XML/Conf.pm

Criterion	Covered	Total	%
statement	106	125	84.8
branch	16	26	61.5
condition	3	8	37.5
subroutine	27	32	84.3
pod	0	6	0.0
total	152	197	77.1

package XML::Conf;

use XML::Simple;
use strict;
use warnings;
use vars qw($VERSION @ISA);
use Tie::DeepTied;
use Tie::Hash;
use Carp;

$VERSION = 0.07;

sub new {
    my ($class, $filename, %opts) = @_;
    my $xml;
    my $fn;

    if (ref($filename) eq 'SCALAR') { #Internal use (TIEHASH)
        $xml = $$filename;
    } elsif ($filename =~ m/^\s*\<.*\>\s*$/s) { #internal use (TIEHASH)
        $xml = $filename;
    } else { #internal use (ReadConfig)
        $filename = "./$filename" if ($filename !~ /^[\/\.]/ && -e "./$filename");
        open(I, $filename) || croak "Could not open $filename: $!";
        $xml = join("", );
        close(I);
        $fn = $filename;
    }
    my $hash = XML::Simple::XMLin($xml) || return undef;
    my $case = $opts{'case'}?$opts{'case'}:'_dummysub';
    #my $case = $opts{'case'};
    $hash = &_trans($hash, eval "sub { $case(\$_);} ") if ($case);
    #$hash = &_trans($hash, $case) if ($case);
    my $self = {'data' => $hash, 'case' => $case, 'fn' => $fn};
    my $sig = $opts{'sig'};
    if ($sig) {
        $SIG{$sig} = sub { $self->ReadConfig; };
    }
    bless $self, $class;
}

sub _dummysub {
	my $val = shift;
}

sub _trans {
    my ($tree, $case) = @_;
    return $tree unless (UNIVERSAL::isa($tree, 'HASH'));
    my %hash;
    no strict 'refs';
    foreach (keys %$tree) {
        $hash{ &$case($_) } = &_trans($tree->{$_}, $case);
    }
    use strict 'refs';
    \%hash;
}

sub _val {
    my $self = shift;
    my $data = $self->{'data'};

    foreach (@_) {
        $data = $data->{$_};
    }
    wantarray ? split("\n", $data) : $data;
}

sub _setval {
    my $self = shift;
    my $data = \$self->{'data'};
    while (@_ > 1) {
        $data = \($$data->{shift()});
    }
    $$data = shift;
}

sub _newval {
    my $self = shift;
    $self->_setval(@_);
}

sub _delval {
    my $self = shift;
    my $data = $self->{'data'};
    while (@_ > 1) {
        $data = $data->{shift()};
    }
    delete $data->{shift()};
}

sub ReadConfig {
    my $self = shift;
    my $fn = $self->{'fn'};
    return undef unless ($fn);
    my $new = &new(__PACKAGE__, $fn, 'case' => $self->{'case'});
    %$self = %$new;
    1;
}

sub Sections {
    my $self = shift;
    $self->Parameters(@_);
}

sub Parameters {
    my $self = shift;
    my $val = $self->_val(@_);
    my $case = $self->{'case'};
    no strict 'refs';
    map { &$case($_); } keys %$val;
    use strict 'refs';
}

sub RewriteConfig {
    my $self = shift;
    my $fn = $self->{'fn'};
    croak "No filename" unless ($fn);
    $self->WriteConfig($fn);
}

sub WriteConfig {
    my ($self, $name) = @_;
    my $xml = XMLout($self->{'data'}, xmldecl => 1);
    open(O, ">$name") || croak "Can't rewrite $name: $!";
    print O $xml;
    close(O);
}

sub TIEHASH {
    my $class = shift;
    $class->new(@_);
}

sub FETCH {
    my ($self, $key) = @_;
    my $val = $self->_val($key);
    if (UNIVERSAL::isa($val, 'HASH') && !tied(%$val)) {
        my %h = %$val;
        tie %$val, 'Tie::StdHash', $self, $key;
        %$val = %h;
        tie %$val, 'Tie::DeepTied', $self, $key;
    }
    $val;
}

sub STORE {
    my ($self, $key, $val) = @_;
    $self->_setval($key, $val);
}

sub DELETE {
    my ($self, $key) = @_;
    $self->_delval($key);
}

sub CLEAR {
    my $self = shift;
    $self->{'data'} = {};
}

sub EXISTS {
    my ($self, $key) = @_;
    exists $self->{'data'}->{$key};
}

sub FIRSTKEY {
    my $self = shift;
    keys %{$self->{'data'}};
    each %{$self->{'data'}};
}

sub NEXTKEY {
    my $self = shift;
    each %{$self->{'data'}};
}

1;

__END__