File Coverage

blib/lib/Config/Natural.pm

Criterion	Covered	Total	%
statement	323	341	94.7
branch	118	164	71.9
condition	20	53	37.7
subroutine	33	33	100.0
pod	19	19	100.0
total	513	610	84.1

package Config::Natural;

use strict;
use Carp qw(carp croak);
use File::Spec;
use FileHandle;

{ no strict;
  $VERSION = '1.01';
}

# class option
my %options = (
    quiet => 0,
);


#
# new()
# ---
sub new {
    my $class = shift;
    my $self = bless {
        options => {
            'comment_line_symbol'     => '#',
            'affectation_symbol'      => '=',
            'append_symbol'           => '+',
            'multiline_begin_symbol'  => '-',
            'multiline_end_symbol'    => '.',
            'array_begin_symbol'      => '(',
            'array_end_symbol'        => ')',
            'list_begin_symbol'       => '{',
            'list_end_symbol'         => '}',
            'include_symbol'          => 'include',
            'case_sensitive'          => 1,
            'auto_create_surrounding_list' => 0,
            'read_hidden_files'       => 0,
            'strip_indentation'       => 0,
        },
        state => {  },
        param => {  },
        handlers => {  },
        prefilter => 0,
        filter => 0,
    }, $class;

    if(ref $_[0] eq 'HASH') {
        my $opts = shift;
        for my $option (keys %$opts) {
            $options{$option} = $opts->{$option} if exists $options{$option};
            $self->{'options'}{$option} = $opts->{$option};
            $self->filter($opts->{$option}) if $option eq 'filter';
            $self->prefilter($opts->{$option}) if $option eq 'prefilter';
        }
    }
    $self->read_source(shift) if @_;
    return $self;
}


#
# AUTOLOAD()
# --------
sub AUTOLOAD {
    no strict;
    my $self = $_[0];
    my $type = ref $self || croak "I am not an object, so don't call me that way.";
    my $name = $AUTOLOAD;
    $name =~ s/.*:://;

    carp "Unknown option '$name'"
      unless exists $options{$name} or defined $self->{options}{$name};

    my $code = q{
        sub {
            my $self = shift;
            my $value = $self->{options}{METHOD};
            $self->{options}{METHOD} = shift if @_;
            return $value
        }
    };
    $code =~ s/METHOD/$name/g;

    *$AUTOLOAD = eval $code;
    goto &$AUTOLOAD;
}


#
# DESTROY()
# -------
sub DESTROY {
    my $self = shift;
    $self->clear_params;
    $self->delete_all;
}


#
# options()
# -------
sub options {
    my $self = shift;
    my $args = _parse_args(@_);
    my @ret_list = ();

    for my $arg (@{$args->{'get'}}) {
        carp "Class option '$arg' does not exist" and next
            unless exists $options{$arg} or $options{'quiet'};
        push @ret_list, $options{$arg};
    }

    for my $arg (keys %{$args->{'set'}}) {
        carp "Class option '$arg' does not exist" and next
            unless exists $options{$arg} or $options{'quiet'};
        $options{$arg} = $args->{'set'}{$arg};
    }

    return wantarray ? @ret_list : $ret_list[0];
}


#
# _read_dir()
# ---------
# Recursively walk through the given directory and read
# all the files encountered
#
sub _read_dir {
    my $self = shift;
    my $dir  = shift;

    return $self->read_source($dir) if -f $dir;

    opendir(DIR, $dir) or croak "Can't read directory '$dir': $!";
    my @list = grep {!/^\.\.?$/} readdir(DIR);  # remove . and ..
    @list = grep {!/^\./} @list unless $self->read_hidden_files;
    closedir(DIR);

    for my $file (@list) {
        my $path = File::Spec->catfile($dir, $file);

        if(-d $path) {
            $self->_read_dir($path)
        } else {
            $self->read_source($path)
        }
    }
}


#
# read_source()
# -----------
# Read the data from the given file or filehandle
#
sub read_source {
    my $self = shift;
    my $file = shift;
    local $_;

    # go to recursive mode if the argument is a directory
    if(-d $file) {
        unshift @_, $self, $file;
        goto &_read_dir
    }

    # ... else open the file
    my $fh = _file_or_handle($file) or croak "Can't open file '$file': $!";

    # keep local copy of the properties we'll use
    my $comment   = $self->comment_line_symbol;
    my $aff_sym   = $self->affectation_symbol;
    my $app_sym   = $self->append_symbol;
    my $multiline = $self->multiline_begin_symbol;
    my $multi_end = $self->multiline_end_symbol;
    my $array     = $self->array_begin_symbol;
    my $array_end = $self->array_end_symbol;
    my $list      = $self->list_begin_symbol;
    my $list_end  = $self->list_end_symbol;
    my $include   = $self->include_symbol;
    my $state     = $self->{'state'};

    # store the name of the last opened file
    $state->{'filename'} = $file;

    while(<$fh>) {
        ## execute the prefilter if present
        $self->{'prefilter'} and $_ = &{$self->{'prefilter'}}($self, $_);

        next if /^\s*$/;  # skip empty lines
        next if /^\s*$comment/;  # skip comments
        chomp;

        ## include statement
        if(/^\s*\Q${include}\E\s+(\S+)\s*$/) {
            my $included = $1;
            my @path = File::Spec->splitdir($state->{'filename'});
            pop @path;  # remove the current file name from the path
            $included = File::Spec->catdir(@path, $included);
            $self->read_source($included);
            next
        }

        ## begin of a new list
        if(/^\s*(\S+)\s*\Q${list}\E\s*$/) {
            push @{$state->{lists_names}}, $1;
            push @{$state->{lists_stacks}}, {};
            next
        }

        ## end of the current list
        if(/^\s*\Q${list_end}\E\s*$/) {
            my $lists_stacks = $state->{'lists_stacks'};
            my $curlistname = pop @{$state->{'lists_names'}};
            my $curlistref  = pop @$lists_stacks;

            if(@$lists_stacks) {
                push @{ $$lists_stacks[-1] ->{ $curlistname } }, $curlistref
            } else {
                push @{$self->{'param'}{$curlistname}}, $curlistref
            }

            next
        }

        ## parameter affectation
        my($field,$value) = (/^\s*(\S+)\s*\Q${app_sym}\E?\s*\Q${aff_sym}\E\s*(.*)$/);

        ## detect append mode
        my $append = /^\s*(\S+)\s*\Q${app_sym}\E\s*\Q${aff_sym}\E\s*(.*)$/;
        my $prev_value = ${$state->{'lists_names'}}[-1] ?
                $state->{'lists_stacks'}[-1]{$field} : $self->{'param'}{$field};

        ## multiline case
        if($value =~ /^\s*\Q${multiline}\E\s*$/) {
            $value = '';
            $value = $prev_value . $value and $append = 0 if $append;
            $_ = <$fh>;

            $self->strip_indentation and my($indent) = (/^(\s*)/);

            while(not /^\s*\Q${multi_end}\E\s*$/) {
                $indent and s/^$indent//;
                $value .= $_;
                $_ = <$fh>;
                last if eof($fh)
            }
        }

        ## array case
        if($value =~ /^\s*\Q${array}\E\s*$/) {
            $value = '';
            $_ = <$fh>;

            while(not /^\s*\Q${array_end}\E\s*$/) {
                s/^\s*//;
                $value .= $_;
                $_ = <$fh>;
                last if eof($fh)
            }

            $append ?
              ( push @$prev_value, split($/, $value) and $append = 0 )
              : $self->param({ $field => [ split $/, $value ] });
            next
        }

        ## create a surrounding list if the parameter already exists
        if($self->auto_create_surrounding_list) {
            my $surrlist   = "${field}s";
            my $root_param = $self->{'param'};
            my $curlistref = ${$self->{'state'}{'lists_stacks'}}[-1];

            if($curlistref) {
                $root_param = $curlistref
            }

            ## the surrounding list doesn't already exist
            if(exists $root_param->{$field} and not exists $root_param->{$surrlist}) {
                $root_param->{$surrlist} = [ { $field => $root_param->{$field} } ];
                delete $root_param->{$field};
            }

            ## add the new parameter to the list
            if(exists $root_param->{$surrlist}) {
                push @{$root_param->{$surrlist}}, { $field => $value };
                next
            }
        }

        ## add the new value to the object parameters
        $value = $prev_value . $value if $append;
        $self->param({ $field => $value });
    }
}


#
# _file_or_handle()
# ---------------
sub _file_or_handle {
    my $file = shift;

    unless(ref $file) {
        my $mode = shift || 'r';
        my $fh = new FileHandle $file, $mode;
        return $fh
    }

    return $file
}


#
# param()
# -----
sub param {
    my $self = shift;
    return $self->all_parameters unless @_;

    my $args = _parse_args(@_);

    my @retlist = ();  # return list

    ## get the value of the desired parameters
    for my $arg (@{$args->{'get'}}) {
        carp "Parameter '$arg' does not exist" and next
            if not exists $self->{'param'}{_case_($self, $arg)} and not $options{'quiet'};

        push @retlist, $self->{'param'}{_case_($self, $arg)}
    }

    ## set the named parameters to new values
    my $param;
    my $current_list = ${$self->{'state'}{'lists_names'}}[-1];
    my @arg_list = keys %{$args->{'set'}};

    if($current_list) {
        $param = ${$self->{'state'}{'lists_stacks'}}[-1];

    } else {
        $param = $self->{'param'};
    }

    for my $arg (@arg_list) {
        my $value = $args->{'set'}{$arg};

        ## use the filter if present
        $self->{'filter'} and
            $value = &{$self->{'filter'}}($self, $value);

        ## use the handler if present
        $self->{'handlers'}{$arg} and
            $value = $self->exec_handler($arg, $value);

        $param->{_case_($self, $arg)} = $value
    }

    return wantarray ? @retlist : $retlist[0]
}


#
# _case_()
# ------
# Check for the case
#
sub _case_ {
    my $self = shift;
    my $param = shift;
    return ($self->case_sensitive ? $param : lc $param)
}


#
# _parse_args()
# -----------
sub _parse_args {
    my %args = ( get => [], set => {} );

    while(my $arg = shift) {
        if(my $ref_type = ref $arg) {

            ## setting multiples parameters using a hashref
            if($ref_type eq 'HASH') {
                local $_;
                for (keys %$arg) {
                    $args{'set'}{$_} = $arg->{$_} if $_
                }

            } else {
                carp "Bad ref $ref_type; ignoring it" unless $options{'quiet'};
                next
            }

        } else {
           ## setting a parameter to a new value
           if(substr($arg, 0, 1) eq '-') {
               $arg = substr($arg, 1);
               my $val = shift;
               carp "Undefined value for parameter '$arg'" and next
                   if not defined $val and not $options{'quiet'};
               $args{'set'}{$arg} = $val if $arg

           ## getting the value of a parameter
           } else {
               push @{$args{'get'}}, $arg
           }
        }
    }

    return \%args
}


#
# prefilter()
# ---------
# Set a new prefilter.
#
sub prefilter {
    my $self = shift;
    my $code = shift;
    croak "Not a CODEREF" unless ref $code eq 'CODE';
    $self->{'prefilter'} = $code;
}


#
# filter()
# ------
# Set a new filter.
#
sub filter {
    my $self = shift;
    my $code = shift;
    croak "Not a CODEREF" unless ref $code eq 'CODE';
    $self->{'filter'} = $code;
}


#
# set_handler()
# -----------
# Set a new handler for a parameter
#
sub set_handler {
    my $self = shift;
    my $param = shift;
    my $code = shift;
    $self->{'handlers'}{$param} = $code;
}


#
# delete_handler()
# --------------
# Delete the handler of the given parameter
#
sub delete_handler {
    my $self = shift;
    my $param = shift;
    delete $self->{'handlers'}{$param};
}


#
# has_handler()
# -----------
# Check if the given parameter has a handler
#
sub has_handler {
    my $self = shift;
    my $param = shift;
    return exists $self->{'handlers'}{$param}
}


#
# exec_handler()
# ------------
# Execute the handler of a parameter
#
sub exec_handler {
    my $self = shift;
    my $param = shift;
    my $value = shift;
    return &{$self->{'handlers'}{$param}}($param, $value)
}


#
# all_parameters()
# --------------
# Return the list of all the parameters at the root level
#
sub all_parameters {
    my $self = shift;
    return keys %{$self->{'param'}}
}


#
# param_tree()
# --------------
# Return the hash tree of all parameters
#
sub param_tree {
    my $self = shift;
    my $tree = {};
    $tree->{$_} = $self->param($_) for($self->param());
    return $tree;
}


#
# value_of()
# --------
# Return the value of the specified parameter
#
sub value_of {
    my $self = shift;
    my $param_path = shift;

    # handle simple cases simply...
    return $self->{'param'}{$param_path} if $self->{'param'}{$param_path};

    # handle more complex cases nicely.
    my @path = split '/', $param_path;
    not $path[0] and shift @path;

    my($name,$index) = ( (shift @path) =~ /^([^[]+)(?:\[([+-]?\d+|\*)\])?$/ );
    my $node = $self->param($name);  $index ||= 0;
    return $node if $index eq '*';

    if(ref $node) {
        $node = $node->[int($index)];
        for my $p (@path) {
            ($name,$index) = ( ($p) =~ /^([^[]+)(?:\[([+-]?\d+|\*)\])?$/ );
            $node = $node->{$name};  $index ||= 0;
            ref $node and $index ne '*' and $node = $node->[int($index)];
        }
    }

    return $node
}


#
# delete()
# ------
# Delete the given parameters
#
sub delete {
    my $self = shift;

    for my $param (@_) {
        carp "Parameter '$param' does not exist" and next
            if not exists $self->{'param'}{_case_($self, $param)} and not $options{'quiet'};
        delete $self->{'param'}{_case_($self, $param)}
    }
}


#
# delete_all()
# ----------
sub delete_all {
    my $self = shift;
    $self->delete($self->all_parameters)
}


#
# clear()
# -----
sub clear {
    my $self = shift;
    for my $param (@_) {
        $self->param({$param => ''})
    }
}


#
# clear_params()
# ------------
sub clear_params {
    my $self = shift;
    for my $param ($self->all_parameters) {
        $self->param({$param => ''})
    }
}


#
# dump_param()
# ----------
sub dump_param {
    my $self = shift;
    my $args = _parse_args(@_);
    my $prefix = $args->{'set'}{'prefix'} || '';
    my $suffix = $args->{'set'}{'suffix'} || '';
    my $nospace = $args->{'set'}{'nospace'} || 0;

    return _dump_tree($self, $self->{'param'}, 0,
        prefix => $prefix, suffix => $suffix, nospace => $nospace)
}


#
# _dump_tree()
# ----------
sub _dump_tree {
    my $self = shift;
    my $tree = shift;
    my $level = shift;
    my %state = @_;
    my $str = '';
    my $sp = $state{'nospace'} ? '' : ' ';

    if(ref $tree eq 'HASH') {

        # add the list name and symbol
        $state{'list_name'} and
        $str .= join '',
                $/, $sp x (($level-1)*2), $state{'list_name'}, $sp,
                $self->list_begin_symbol, $/;

        for my $param (sort keys %$tree) {
            if(ref($tree->{$param})) {
                $str .= _dump_tree($self, $tree->{$param}, $level+1, %state, list_name => $param)

            } else {
                ## multi-line value?
                my $multiline = 1 if $tree->{$param} =~ /\n|\r/;

                $str .= join '',
                        $sp x ($level*2),
                        $state{'prefix'}, $param, $sp, $self->affectation_symbol, $sp,
                        ($multiline ? $self->multiline_begin_symbol . $/ : ''),
                        $tree->{$param},
                        ($multiline ? $self->multiline_end_symbol   . $/ : ''),
                        $state{'suffix'}, $/;
            }
        }

        # add the list end symbol
        $state{'list_name'} and
        $str .= join '',
                $sp x (($level-1)*2), $self->list_end_symbol, $/;

    } elsif(ref $tree eq 'ARRAY') {
        if(ref $tree->[0]) {
            for my $list (@$tree) { $str .= _dump_tree($self, $list, $level, %state) }
        } else {
            $str .= join '',
                    $sp x ($level*2),
                    $state{'prefix'}, $state{'list_name'}, $sp,
                    $self-> affectation_symbol, $sp, $self->array_begin_symbol, $/,
                    (map {($sp x (($level+1)*2)) . $_ . $/} @$tree),
                    $sp x ($level*2), $self->array_end_symbol, $/
        }

    } else {
        warn "unexpected reference type ", ref($tree)
    }

    return $str
}


#
# write_source()
# ------------
# Write the current state of the object to a file
#
sub write_source {
    my $self = shift;

    # use the last filename given to read_source() if no arg
    push @_, $self->{'state'}{'filename'} unless @_;

    my $file = shift;
    my $fh = _file_or_handle($file, 'w');
    print $fh $self->dump_param(@_) or croak "Error while writing to '$file': $!";
}


1;

__END__