File Coverage

blib/lib/Config/Processor.pm

Criterion	Covered	Total	%
statement	231	235	98.3
branch	80	90	88.8
condition	11	12	91.6
subroutine	28	30	93.3
pod	2	2	100.0
total	352	369	95.3

package Config::Processor;

use 5.008000;
use strict;
use warnings;

our $VERSION = '0.28';

use File::Spec;
use YAML::XS qw( LoadFile );
use Cpanel::JSON::XS;
use Hash::Merge;
use Scalar::Util qw( refaddr readonly );
use Carp qw( croak );

my %FILE_EXTENSIONS_MAP = (
  yml  => 'yaml',
  yaml => 'yaml',
  json => 'json',
  jsn  => 'json',
);

sub new {
  my $class  = shift;
  my %params = @_;

  my $self = bless {}, $class;

  $self->{dirs} = $params{dirs} || [];
  unless ( @{ $self->{dirs} } ) {
    push( @{ $self->{dirs} }, '.' );
  }

  $self->{interpolate_variables} = exists $params{interpolate_variables}
      ? $params{interpolate_variables} : 1;
  $self->{process_directives} = exists $params{process_directives}
      ? $params{process_directives} : 1;
  $self->{export_env} = $params{export_env};

  my $merger = Hash::Merge->new;
  $merger->specify_behavior(
    { SCALAR => {
        SCALAR => sub { $_[1] },
        ARRAY  => sub { $_[1] },
        HASH   => sub { $_[1] },
      },
      ARRAY => {
        SCALAR => sub { $_[1] },
        ARRAY  => sub { $_[1] },
        HASH   => sub { $_[1] },
      },
      HASH => {
        SCALAR => sub { $_[1] },
        ARRAY  => sub { $_[1] },
        HASH   => sub { $merger->_merge_hashes( $_[0], $_[1] ) },
      },
    },
    'CONFIG_PRECEDENT',
  );
  $self->{_merger} = $merger;

  $self->{_config}     = undef;
  $self->{_vars}       = {};
  $self->{_seen_nodes} = {};

  return $self;
}

{
  no strict 'refs';

  foreach my $name (
      qw( interpolate_variables process_directives export_env ) )
  {
    *{$name} = sub {
      my $self = shift;

      if (@_) {
        $self->{$name} = shift;
      }

      return $self->{$name};
    }
  }
}

sub load {
  my $self = shift;
  my @config_sections = @_;

  $self->{_config} = $self->_build_tree(@config_sections);
  if ( $self->{export_env} ) {
    $self->{_config} = $self->{_merger}->merge( $self->{_config},
        { ENV => {%ENV} } );
  }
  $self->_process_tree( $self->{_config}, [] );

  $self->{_vars}       = {};
  $self->{_seen_nodes} = {};

  return $self->{_config};
}

sub _build_tree {
  my $self = shift;
  my @config_sections = @_;

  my $config = {};

  foreach my $config_section (@config_sections) {
    next unless defined $config_section;

    if ( ref($config_section) eq 'HASH' ) {
      $config = $self->{_merger}->merge( $config, $config_section );
    }
    else {
      my %not_found_idx;
      my @file_patterns = split( /\s+/, $config_section );

      foreach my $dir ( @{ $self->{dirs} } ) {
        foreach my $file_pattern ( @file_patterns ) {
          my @file_pathes = glob( File::Spec->catfile( $dir, $file_pattern ) );

          foreach my $file_path (@file_pathes) {
            next if -d $file_path;

            unless ( $file_path =~ m/\.([^.]+)$/ ) {
              croak "File extension not specified."
                  . " Don't known how parse $file_path";
            }

            my $file_ext  = $1;
            my $file_type = $FILE_EXTENSIONS_MAP{$file_ext};

            unless ( defined $file_type ) {
              croak "Unknown file extension \".$file_ext\" encountered."
                  . " Don't known how parse $file_path";
            }

            unless ( -e $file_path ) {
              $not_found_idx{$file_pattern} ||= 0;
              $not_found_idx{$file_pattern}++;

              next;
            }

            my @data = eval {
              my $method = "_load_$file_type";
              return $self->$method($file_path);
            };
            if ($@) {
              croak "Can't parse $file_path\n$@";
            }

            foreach my $data_chunk (@data) {
              $config = $self->{_merger}->merge( $config, $data_chunk );
            }
          }
        }
      }

      my @not_found = grep {
        $not_found_idx{$_} == scalar @{ $self->{dirs} }
      } keys %not_found_idx;

      if ( @not_found ) {
        croak "Can't locate " . join( ', ', @not_found )
            . " in " . join( ', ', @{ $self->{dirs} } );
      }
    }
  }

  return $config;
}

sub _load_yaml {
  my $self      = shift;
  my $file_path = shift;

  return LoadFile($file_path);
}

sub _load_json {
  my $self      = shift;
  my $file_path = shift;

  open( my $fh, '<', $file_path ) || die "Can't open $file_path: $!";
  my @data = ( decode_json( join( '', <$fh> ) ) );
  close($fh);

  return @data;
}

sub _process_tree {
  my $self = shift;
  my $ancs = pop;

  return if readonly( $_[0] );

  $_[0] = $self->_process_node( $_[0], $ancs );

  if ( my $node_addr = refaddr( $_[0] ) ) {
    return if $self->{_seen_nodes}{$node_addr};

    $self->{_seen_nodes}{$node_addr} = 1;
  }

  if ( ref( $_[0] ) eq 'HASH' ) {
    foreach ( values %{ $_[0] } ) {
      $self->_process_tree( $_, [ $_[0], @{$ancs} ] );
    }
  }
  elsif ( ref( $_[0] ) eq 'ARRAY' ) {
    foreach ( @{ $_[0] } ) {
      $self->_process_tree( $_, [ $_[0], @{$ancs} ] );
    }
  }

  return;
}

sub _process_node {
  my $self = shift;
  my $node = shift;
  my $ancs = shift;

  return unless defined $node;

  if ( !ref($node) && $self->{interpolate_variables} ) {
    $node =~ s/\$((\$?)\{([^\}]*)\})/
        $2 ? $1 : ( $self->_resolve_var( $3, [ @{$ancs} ] ) || '' )/ge;
  }
  elsif ( ref($node) eq 'HASH' && $self->{process_directives} ) {
    if ( defined $node->{var} ) {
      $node = $self->_resolve_var( $node->{var}, [ @{$ancs} ] );
    }
    elsif ( defined $node->{include} ) {
      $node = $self->_build_tree( $node->{include} );
    }
    else {
      if ( defined $node->{underlay} ) {
        my $layer = delete $node->{underlay};
        $layer = $self->_process_layer( $layer, $ancs );
        $node = $self->{_merger}->merge( $layer, $node );
      }

      if ( defined $node->{overlay} ) {
        my $layer = delete $node->{overlay};
        $layer = $self->_process_layer( $layer, $ancs );
        $node = $self->{_merger}->merge( $node, $layer );
      }
    }
  }

  return $node;
}

sub _process_layer {
  my $self  = shift;
  my $layer = shift;
  my $ancs  = shift;

  if ( ref($layer) eq 'HASH' ) {
    $layer = $self->_process_node( $layer, $ancs );
  }
  elsif ( ref($layer) eq 'ARRAY' ) {
    my $new_layer = {};

    foreach my $node ( @{$layer} ) {
      $node = $self->_process_node( $node, $ancs );
      $new_layer = $self->{_merger}->merge( $new_layer, $node );
    }

    $layer = $new_layer;
  }

  return $layer;
}

sub _resolve_var {
  my $self = shift;
  my $name = shift;
  my $ancs = shift;

  my $value;

  if ( $name =~ m/^\./ ) {
    my $node;
    my @tokens = split( /\./, $name, -1 );

    while (1) {
      my $token = $tokens[0];
      $token =~ s/^\s+//;
      $token =~ s/\s+$//;

      last if length($token) > 0;

      shift @tokens;

      last unless @tokens;
      next unless @{$ancs};

      $node = shift @{$ancs};
    }

    $value = eval {
      $self->_fetch_value( $node, $ancs, \@tokens );
    };

    if ($@) {
      chomp $@;
      die qq{Can't resolve variable "$name"; $@\n};
    }
  }
  else {
    my $vars = $self->{_vars};

    unless ( defined $vars->{$name} ) {
      my @tokens = split( /\./, $name, -1 );

      $vars->{$name} = eval {
        $self->_fetch_value( $self->{_config}, [], \@tokens );
      };

      if ($@) {
        chomp $@;
        die qq{Can't resolve variable "$name"; $@\n};
      }
    }

    $value = $vars->{$name};
  }

  return $value;
}

####
sub _fetch_value {
  my $self   = shift;
  my $node   = shift;
  my $ancs   = shift;
  my $tokens = shift;

  return $node unless @{$tokens};

  my $value;

  while (1) {
    my $token = shift @{$tokens};
    $token =~ s/^\s+//;
    $token =~ s/\s+$//;

    if ( ref($node) eq 'HASH' ) {
      last unless defined $node->{$token};

      unshift( @{$ancs}, $node );

      unless ( @{$tokens} ) {
        $node->{$token} = $self->_process_node( $node->{$token}, $ancs );
        $value = $node->{$token};

        last;
      }

      last unless ref( $node->{$token} );

      $node = $node->{$token};
    }
    else { # ARRAY
      if ( $token =~ m/\D/ ) {
        die qq{Argument "$token" isn't numeric in array element.\n};
      }

      last unless defined $node->[$token];

      unshift( @{$ancs}, $node );

      unless ( @{$tokens} ) {
        $node->[$token] = $self->_process_node( $node->[$token], $ancs );
        $value = $node->[$token];

        last;
      }

      last unless ref( $node->[$token] );

      $node = $node->[$token];
    }
  }

  return $value;
}

1;
__END__