File Coverage

blib/lib/Config/General/Hierarchical.pm

Criterion	Covered	Total	%
statement	290	294	98.6
branch	187	188	99.4
condition	54	56	96.4
subroutine	28	29	96.5
pod	6	15	40.0
total	565	582	97.0

#
# Config::General::Hierarchical.pm - Hierarchical Generic Config Module
#
# Purpose: Permits to organize configuration values
#          in a hierarchical structure of files
#
# Copyright (c) 2007-2009 Daniele Ricci .
# All Rights Reserved. Std. disclaimer applies.
# Artificial License, same as perl itself.

package Config::General::Hierarchical;

$Config::General::Hierarchical::VERSION = 0.07;

use strict;
use warnings;

use Carp;
use Clone::PP qw( clone );
use Config::General;
use Config::General::Hierarchical::ExcludeWeaken;
use Cwd qw( abs_path );
use Scalar::Util qw( weaken );

use base 'Class::Accessor::Fast';

my @properties = qw( constraint name opt value );
my %properties = map( ( $_ => 1 ), @properties );

__PACKAGE__->mk_accessors( @properties, qw( cache ) );

my %Config_General_Proxy = (
    '-AutoLaunder'    => 1,
    '-CComments'      => 1,
    '-LowerCaseNames' => 1,
    '-SplitDelimiter' => 1,
    '-SplitPolicy'    => 1,
);

sub new {
    my ( $ref, %args ) = @_;

    my $file;
    my %general;
    my %props;
    my %options;

    foreach my $key ( keys %args ) {
        if ( $key eq 'file' ) {
            $file = $args{$key};
        }
        elsif ( $properties{$key} ) {
            $props{$key} = $args{$key};
        }
        elsif ( $Config::General::Hierarchical::Options::options{$key} ) {
            $options{$key} = $args{$key};
        }
        elsif ( $Config_General_Proxy{$key} ) {
            $general{$key} = $args{$key};
        }
    }

    my $class = ref $ref || $ref or croak __PACKAGE__ . ": wrong new call";
    my $self = $class->SUPER::new(
        {
            cache => {},
            %props
        }
    );

    unless (%props) {
        $self->opt(
            Config::General::Hierarchical::Options->new(
                {
                    files     => [],
                    general   => \%general,
                    inherits  => 'inherits',
                    root      => $self,
                    struct    => { '0' => {} },
                    undefined => 'undefined',
                    wild      => '*',
                    %options
                }
            )
        );

        weaken( $self->opt->{root} )
          unless $Config::General::Hierarchical::ExcludeWeaken::exclude;

        $self->read($file) if $file;

        $self->check if $args{check};
    }

    return $self;
}

sub check {
    my ($self) = @_;

    foreach my $key ( keys %{ $self->value } ) {
        my $v = $self->get($key);

        $v->check if eval { $v->isa(__PACKAGE__); };
    }

    return $self;
}

sub import {
    my ( $class, @pars ) = @_;
    my $syntax = $class->syntax;

    die "$class: syntax method musts return an HASH reference\n"
      if ref $syntax ne 'HASH';

    $class->check_syntax( $syntax, [] );
}

sub check_syntax {
    my ( $class, $syntax, $parents ) = @_;

    foreach my $key ( keys %$syntax ) {
        my $ref = ref $syntax->{$key};
        my $syn = $syntax->{$key};

        push @$parents, $key;

        if ($ref) {
            die "$class: wrong use of $ref reference as syntax for variable '"
              . join( '->', @$parents ) . "'\n"
              if $ref ne 'HASH';

            $class->check_syntax( $syn, $parents );
        }
        else {
            die "$class: wrong '$syn' syntax for variable '"
              . join( '->', @$parents ) . "'\n"
              if defined $syn && $syn !~ /^[amuABDEINST]*$/;

            die
"$class: wrong use of 'm' flag for not string nor array variable '"
              . join( '->', @$parents ) . "'\n"
              if defined $syn
                  && $syn =~ /m/
                  && syntax_check_get_type($syn) ne 'S'
                  && $syn !~ /a/;
        }

        pop @$parents;
    }
}

sub get {
    my ( $self, $name, @names ) = @_;

    my $vname = $self->name ? $self->name . '->' . $name : $name;

    if ( exists $self->cache->{$name} ) {
        my $value = $self->cache->{$name};

        return $value unless scalar @names;
        return $value->get(@names) if eval { $value->isa(__PACKAGE__) };

        croak __PACKAGE__
          . ": can't get subkey '$names[0]' value for not node variable '$vname'";
    }

    my $syntax =
      exists $self->constraint->{$name}
      ? $self->constraint->{$name}
      : $self->constraint->{ $self->wild };
    my $value = $self->value->{$name} || $self->value->{ $self->wild };

    if ( !defined $value || ref $value->value ne 'HASH' ) {
        croak __PACKAGE__
          . ": can't get subkey '$names[0]' value for not node variable '$vname'"
          if scalar @names;

        return $self->cache->{$name} =
          $self->syntax_check( $vname, $value, $syntax );
    }

    $self->cache->{$name} = $value = $self->syntax_check(
        $vname,
        $self->new(
            constraint => $syntax || {},
            name       => $vname,
            opt        => $self->opt,
            value      => $value->value
        ),
        $syntax
    );

    return $value unless scalar @names;

    return $value->get(@names);
}

our $AUTOLOAD;

sub AUTOLOAD {
    my ( $self, @args ) = @_;
    my $name = $AUTOLOAD;

    $name =~ s/\w+:://g;

    return $self->get( $1, @args ) if $name =~ /^_(\w+)$/;

    return $self->opt->$name
      if $Config::General::Hierarchical::Options::options{$name};

    my $ref = ref $self;

    croak "Can't locate object method \"$name\" via package \"$ref\"";
}

# simply avoid AUTOLOAD is called when an object is destroied
sub DESTROY { }

sub getk {
    my ($self) = @_;

    croak __PACKAGE__ . ": can't get keys before reading any file"
      unless $self->value;

    return keys %{ $self->value };
}

sub read {
    my ( $self, $name ) = @_;

    $self->constraint( $self->syntax );
    $self->value( $self->read_( $name, [] ) );
    $self->expand_wild_keys( $self->value );
    $self->name('');

    return $self;
}

sub read_ {
    my ( $self, $name, $children ) = @_;

    my $tmp = eval { abs_path($name); };
    my $error = $@ || !$tmp;
    $name = $tmp if $tmp;
    my $files = $self->opt->files;
    my $in_file =
        $name
      . join( '', reverse( map( "\ninherited by: $files->[$_]", @$children ) ) )
      . "\n ";
    my $nfile = scalar @$files;

    croak __PACKAGE__ . ": no such directory: $in_file" if $error;
    croak __PACKAGE__ . ": no such file: $in_file" unless -e $name;
    croak __PACKAGE__ . ": recursive hierarchy\nin file: $in_file"
      if grep /^$name$/, map $files->[$_], @$children;
    push @$files, $name;

    my $cfg;
    eval {
        $cfg = Config::General->new(
            '-AllowMultiOptions'     => 1,
            '-AutoTrue'              => 0,
            '-CComments'             => 0,
            '-ConfigFile'            => $name,
            '-ExtendedAccess'        => 0,
            '-InterPolateEnv'        => 0,
            '-InterPolateVars'       => 0,
            '-MergeDuplicateBlocks'  => 1,
            '-MergeDuplicateOptions' => 0,
            '-SlashIsDirectory'      => 0,
            '-UseApacheInclude'      => 0,
            ( %{ $self->opt->general } )
        );
    };

    if ($@) {
        my @list = split /\n/, $@;
        pop @list;
        my $msg = join "\n", @list;

        croak __PACKAGE__ . ": $msg\nin file: $in_file";
    }

    if ( scalar @$children ) {
        my $str = $self->opt->struct;

        foreach (@$children) {
            $str = $str->{$_};
        }

        $str->{$nfile} = {};
    }

    my $hash     = { $cfg->getall };
    my $syntax   = $self->inherits;
    my $inherits = $hash->{$syntax};

    delete $hash->{$syntax};
    my ( $undefined, $value ) = $self->convert_hash( $hash, $nfile, $in_file );

    if ($inherits) {
        my $parents;

        if ( !ref $inherits ) {
            $parents = [$inherits];
        }
        elsif ( ref $inherits eq 'ARRAY' ) {
            $parents = $inherits;
        }
        else {
            croak __PACKAGE__
              . ": wrong use of inherits ('$syntax') directive\nin file: $in_file";
        }

        push @$children, @$files - 1;
        foreach my $parent ( reverse @$parents ) {
            if ( $parent =~ /^\// ) {
                $name = $parent;
            }
            else {
                my @list = split /\//, $name;
                pop @list;
                $name = join( '/', @list ) . '/' . $parent;
            }

            $hash = $self->read_( $name, $children );

            $self->merge_values( $value, $hash, $self->constraint );
        }
        pop @$children;
    }

    $self->undefine( $value, $undefined, $nfile );

    return $value;
}

sub convert_hash {
    my ( $self, $hash, $file, $in_file ) = @_;

    my $syntax = $self->inherits;
    my %undefined;

    croak __PACKAGE__
      . ": inherits ('$syntax') directive cannot be used as node name\nin file: $in_file"
      if exists $hash->{$syntax};

    $syntax = $self->undefined;
    my $undefined = $hash->{$syntax};
    delete $hash->{$syntax};

    foreach my $key ( keys %$hash ) {
        if ( ref $hash->{$key} eq 'HASH' ) {
            ( $undefined{$key}, my $tmp ) =
              $self->convert_hash( $hash->{$key}, $file, $in_file );
        }
        $hash->{$key} = '' unless defined $hash->{$key};
        $hash->{$key} = Config::General::Hierarchical::Value->new(
            { value => $hash->{$key}, file => $file } );
    }

    if ($undefined) {
        if ( !ref $undefined ) {
            $undefined{$undefined} = undef;
        }
        elsif ( ref $undefined eq 'ARRAY' ) {
            $undefined{$_} = undef foreach @$undefined;
        }
        else {
            croak __PACKAGE__
              . ": wrong use of undefined ('$syntax') directive\nin file: $in_file";
        }
    }

    return ( \%undefined, $hash );
}

sub merge_values {
    my ( $self, $value, $hash, $constraint ) = @_;
    my ( $key, $val );

    foreach $key ( keys %$value ) {
        $val = $value->{$key};

        if ( ref $val eq 'Config::General::Hierarchical::Value' ) {
            my $other = exists $hash->{$key} ? $hash->{$key}->value : undef;
            my $syn = (
                exists $constraint->{$key}
                ? $constraint->{$key}
                : $constraint->{ $self->wild }
              )
              || {};

            if ( ref $val->value eq 'HASH' ) {
                if ( ref $other eq 'HASH' ) {
                    $self->merge_values( $val->value, $other, $syn );
                }
            }
            elsif ( !ref $syn && $syn =~ /m/ && defined $other ) {
                if ( $syn =~ /a/ ) {
                    $other = [$other] unless ref $other;

                    if ( ref $val->value ) {
                        unshift @{ $val->value }, @$other;
                    }
                    else {
                        $val->value( [ @$other, $val->value ] );
                    }
                }
                else {
                    $val->value( $other . $val->value );
                }
            }
        }
        elsif ( ref $val eq 'HASH' ) {
            if ( exists $hash->{$key} && ref $hash->{$key} eq 'HASH' ) {
                $self->merge_values( $val, $hash->{$key} );
            }
        }
    }

    foreach $key ( keys %$hash ) {
        $value->{$key} = $hash->{$key} unless exists $value->{$key};
    }

    return $value;
}

sub expand_wild_keys {
    my ( $self, $value ) = @_;

    my $wild = $self->wild;
    my $wv   = $value->{$wild};

    if ( $wv && ref $wv->value eq 'HASH' ) {
        $wv = $wv->value;

        foreach my $key ( keys %$value ) {
            my $v = $value->{$key}->value;

            next if $key eq $wild;
            next if ref $v ne 'HASH';

            foreach my $wk ( keys %$wv ) {
                $v->{$wk} = clone( $wv->{$wk} ) unless exists $v->{$wk};
            }
        }
    }

    foreach my $key ( keys %$value ) {
        my $v = $value->{$key}->value;

        next if $key eq $wild;
        next if ref $v ne 'HASH';

        $self->expand_wild_keys($v);
    }
}

sub undefine {
    my ( $self, $value, $undefined, $file ) = @_;

    foreach my $key ( keys %$value ) {
        next unless exists $undefined->{$key};

        if ( defined $undefined->{$key} ) {
            $self->undefine( $value->{$key}->value, $undefined->{$key}, $file );
        }
        else {
            $value->{$key} = Config::General::Hierarchical::Value->new(
                { value => undef, file => $file } );
        }
    }
}

sub syntax {
    return {};
}

my %types = (
    A => { d => 'datetime',       e => '^\d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d$' },
    B => { d => 'boolean value',  e => '^(0|1|on|off|yes|no|true|false)$' },
    D => { d => 'date',           e => '^\d\d\d\d-\d\d-\d\d$' },
    E => { d => 'e-mail address', e => '^[\w\d\-_\.]+@[\w\d\-_\.]+\.\w+$' },
    I => { d => 'integer value',  e => '^-?\d+$' },
    N => { d => 'number',         e => '^-?\d*\.?\d+$' },
    S => { d => 'string' },
    T => { d => 'time',           e => '^\d\d:\d\d:\d\d$' },
);

sub syntax_check {
    my ( $self, $vname, $value, $syntax ) = @_;
    my $can_be_undefined;
    my $file = 0;

    if ( defined $value
        && ref $value eq 'Config::General::Hierarchical::Value' )
    {
        $file  = $value->file;
        $value = $value->value;
    }
    $file = "\nin file: " . $self->opt->files->[$file];

    if ( defined $syntax ) {
        $can_be_undefined =
          ref $syntax ? exists $syntax->{ $self->undefined } : $syntax =~ /u/;
    }
    elsif ( defined $value ) {
        return ref $value ? $value : $self->convert_value( $value, $vname )
          if ref $value ne 'ARRAY';

        croak __PACKAGE__
          . ": variable '$vname' is an array: should be a string or a node$file";
    }

    unless ( defined $value ) {
        if ($can_be_undefined) {
            return undef if ref $syntax;
            return [] if $syntax =~ /a/;
            return 0 if $syntax =~ /B/;
            return undef;
        }

        croak __PACKAGE__ . ": request for undefined variable '$vname'$file";
    }

    if ( ref $syntax ) {
        return $value if eval { $value->isa(__PACKAGE__) };

        croak __PACKAGE__ . ": variable '$vname' should be a node$file";
    }

    my $type = syntax_check_get_type($syntax);

    if ( $syntax !~ /a/ ) {
        croak __PACKAGE__
          . ": variable '$vname' is an array but should be a $types{$type}->{d}$file"
          if ref $value eq 'ARRAY';    #"}"
        croak __PACKAGE__
          . ": variable '$vname' is a node but should be a $types{$type}->{d}$file"
          if ref $value;               #"}"

        $value = $self->convert_value( $value, $vname );

        return $value if $type eq 'S';

        $value =~ s/^\s+//;
        $value =~ s/\s+$//;

        croak __PACKAGE__
          . ": value '$value' for variable '$vname' is not a prooper $types{$type}->{d}$file"
          unless $value =~ /$types{$type}->{e}/i;    #}"}"

        return $value if $type ne 'B';
        return $value =~ /(1|on|yes|true)/i ? 1 : 0;
    }

    my $ref = ref $value;
    my @ret;
    my $arr = $ref ? $value : [$value];

    croak __PACKAGE__ . ": variable '$vname' should be an array$file"
      if $ref && $ref ne 'ARRAY';

    if ( $type eq 'S' ) {
        @ret = @$arr;
    }
    else {
        foreach $value (@$arr) {
            $value =~ s/^\s+//;
            $value =~ s/\s+$//;

            my @values = split /\s*,\s*/, $value;

            foreach $value (@values) {
                croak __PACKAGE__
                  . ": element '$value' of variable '$vname' is not a prooper $types{$type}->{d}$file"
                  if $value !~ /$types{$type}->{e}/i;    #}"}"

                push @ret, $value;
            }
        }
    }

    return [ map $self->convert_value( $_, $vname ), @ret ];
}

sub syntax_check_get_type {
    my ($syntax) = @_;

    foreach (qw( A B D E I N T )) {
        return $_ if $syntax =~ /$_/;
    }

    return 'S';
}

my %back_slash = (
    36  => 36,
    92  => 92,
    97  => 7,
    98  => 8,
    102 => 12,
    110 => 10,
    114 => 13,
    116 => 9,
    118 => 11,
);

sub convert_value {
    my ( $self, $value, $vname ) = @_;

    my @arr = unpack 'C*', $value;
    my @ret;

    while ( my $c = shift @arr ) {
        if ( $c == 92 && scalar @arr ) {    # \
            my $n = shift @arr;

            if ( $back_slash{$n} ) {
                push @ret, $back_slash{$n};
            }
            else {
                push @ret, 92, $n;
            }
        }
        elsif ( $c == 36 && scalar @arr && $arr[0] == 123 ) {    # $
            my $i;
            my $v;
            my @var_name;

            for ( $i = 1 ; $i < scalar @arr && $arr[$i] != 125 ; ++$i ) {
                push @var_name, $arr[$i];
            }

            croak __PACKAGE__
              . ": systax error in inline variable substitution for value '$value' for variable '$vname'"
              if $i == scalar @arr;
            croak __PACKAGE__
              . ": can't do inline variable substitution for variable '$vname' when reference to root node was lost"
              unless $self->opt->root;

            eval {
                $v = $self->opt->root->get( split /->/, pack 'C*', @var_name );
            };

            croak "$@ during inline variable sostitution for variable '$vname'"
              if $@;
            croak __PACKAGE__
              . ": can't use node or array variable in inline variable sostitution for variable '$vname'"
              if ref $v;

            $v = '' unless defined $v;
            push @ret, unpack 'C*', $v;
            splice @arr, 0, $i + 1;
        }
        else {
            push @ret, $c;
        }
    }

    return pack 'C*', @ret;
}

package Config::General::Hierarchical::Options;

use base 'Class::Accessor::Fast';

my @options = qw( inherits root undefined wild );
our %options = map( ( $_ => 1 ), @options );

__PACKAGE__->mk_accessors( @options, qw( files general struct ) );

package Config::General::Hierarchical::Value;

use base 'Class::Accessor::Fast';

__PACKAGE__->mk_accessors(qw( file value ));

1;

__END__