File Coverage

blib/lib/Config/Settings.pm

Criterion	Covered	Total	%
statement	66	66	100.0
branch	24	24	100.0
condition	2	2	100.0
subroutine	12	12	100.0
pod	3	3	100.0
total	107	107	100.0

package Config::Settings;

use Carp qw/confess/;
use Parse::RecDescent;

use strict;
use warnings;

our $VERSION = '0.02';

my $parser = Parse::RecDescent->new (<<'EOF');
config:
   scope

scope:
  assignment(s? /;+/) /;*/
  { $return = [ 'SCOPE',@{ $item[1] } ] }

assignment:
  deep_assignment | direct_assignment | true_assignment |

deep_assignment:
  keyword keyword value
  { $return = [ $item[1] => $item[2] => $item[3] ]; 1 }

direct_assignment:
  keyword value
  { $return = [ $item[1] => $item[2] ]; 1 }

true_assignment:
  keyword
  { $return = [ $item[1] => 1 ]; 1 }

keyword:
  integer | string | bareword

value:
  integer | string | list | hash | symbol

bareword:
  /[\w:]+/

integer:
  /\d+/

string:

  { $return = $item[1][2]; 1 }

list:
  "[" value(s?) "]"
  { $return = [ 'LIST',@{ $item[2] } ]; 1 }

hash:
  "{" scope "}"
  { $return = $item[2]; 1 }

symbol:
  bareword
  { $return = [ 'SYMBOL',$item[1] ]; 1 }

EOF

my %default_symbols = (
  null  => undef,
  true  => 1,
  false => '',
);

sub new {
  my $class = shift;

  my $node = (ref $_[0] eq 'HASH' ? $_[0] : { @_ });

  $node->{symbol_table} ||= { %default_symbols };

  return bless $node,$class;
}

sub parse_file {
  my ($self,$file) = @_;

  open (my $fh,$file) or confess $!;

  my $content = do { local $/; <$fh> };

  close $fh;

  return $self->parse ($content);
}

sub parse {
  my ($self,$content) = @_;

  return $self->_process_value ($parser->config ($content));
}

sub _process_scope {
  my ($self,$scope) = @_;

  my %result;

  foreach my $assignment (@$scope) {
    my ($key,$value) = @$assignment;

    if (@$assignment > 2) {
      $self->_deep_assignment (\%result,@$assignment);
    } else {
      $self->_simple_assignment (\%result,@$assignment);
    }
  }

  return \%result;
}

sub _simple_assignment {
  my ($self,$hashref,$key,$value) = @_;

  $value = $self->_process_value ($value);

  if (exists $hashref->{$key}) {
    if (ref $hashref->{$key} eq 'ARRAY') {
      push @{ $hashref->{$key} },$value;
    } else {
      $hashref->{$key} = [ $hashref->{$key},$value ];
    }
  } else {
    $hashref->{$key} = $value;
  }

  return;
}

sub _deep_assignment {
  my ($self,$hashref,$key1,$key2,$value) = @_;

  $value = $self->_process_value ($value);

  $key2 = $self->_process_value ($key2);

  if (ref $hashref->{$key1} eq 'HASH') {
    $hashref->{$key1}->{$key2} = $value;
  } else {
    $hashref->{$key1} = { $key2 => $value };
  }

  return;
}

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

  if (ref $value) {
    my $value_type = shift @$value;

    if ($value_type eq 'SCOPE') {
      $value = $self->_process_scope ($value);
    } elsif ($value_type eq 'LIST') {
      $value = [ map { $self->_process_value ($_) } @$value ];
    } elsif ($value_type eq 'SYMBOL') {
      $value = $self->_process_symbol (@$value);
    } else {
      confess "Uh oh, this should never happen";
    }
  }

  return $value;
}

sub _process_symbol {
  my ($self,$symbol) = @_;

  my $value;

  if (exists $self->{symbol_table}->{ $symbol }) {
    my $symbol_entry = $self->{symbol_table}->{ $symbol };

    $value = (ref $symbol_entry eq 'CODE' ? $symbol_entry->() : $symbol_entry);
  } else {
    confess "No such symbol '$symbol' in symbol table";
  }

  return $value;
}

1;

__END__