view release on metacpan or  search on metacpan

lib/Config/General/Hierarchical.pm  view on Meta::CPAN

#
# 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 <icc |AT| cpan.org>.
# 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/;