File Coverage

blib/lib/Config/INI/RefVars.pm

Criterion	Covered	Total	%
statement	154	156	98.7
branch	67	72	93.0
condition	10	11	90.9
subroutine	21	21	100.0
pod	10	10	100.0
total	262	270	97.0

package Config::INI::RefVars;
use 5.010;
use strict;
use warnings;
use Carp;

use feature ":5.10";

use Config;
use File::Spec::Functions qw(catdir rel2abs splitpath);

our $VERSION = '0.21';

use constant DFLT_TOCOPY_SECTION  => "__TOCOPY__";

use constant FLD_KEY_PREFIX => __PACKAGE__ . ' __ ';

use constant {EXPANDED          => FLD_KEY_PREFIX . 'EXPANDED',

              CMNT_VL           => FLD_KEY_PREFIX . 'CMNT_VL',
              TOCOPY_SECTION    => FLD_KEY_PREFIX . 'TOCOPY_SECTION',
              CURR_TOCP_SECTION => FLD_KEY_PREFIX . 'CURR_TOCP_SECTION',
              TOCOPY_VARS       => FLD_KEY_PREFIX . 'TOCOPY_VARS',
              NOT_TOCOPY        => FLD_KEY_PREFIX . 'NOT_TOCOPY',
              SECTIONS          => FLD_KEY_PREFIX . 'SECTIONS',
              SECTIONS_H        => FLD_KEY_PREFIX . 'SECTIONS_H',
              SRC_NAME          => FLD_KEY_PREFIX . 'SRC_NAME',
              VARIABLES         => FLD_KEY_PREFIX . 'VARIABLES',
              GLOBAL_VARS       => FLD_KEY_PREFIX . 'GLOBAL_VARS',
              GLOBAL_MODE       => FLD_KEY_PREFIX . 'GLOBAL_MODE',
              VREF_RE           => FLD_KEY_PREFIX . 'VREF_RE',
              SEPARATOR         => FLD_KEY_PREFIX . 'SEPARATOR',
              BACKUP            => FLD_KEY_PREFIX . 'BACKUP',
              VARNAME_CHK_RE    => FLD_KEY_PREFIX . 'VARNAME_CHK_RE',
             };

my %Globals = ('=:'       => catdir("", "",),
               '=::'      => $Config{path_sep},
               '=VERSION' => $VERSION);


# Match punctuation chars, but not the underscores.
my $Modifier_Char = '[^_[:^punct:]]';

my ($_look_up, $_x_var_name, $_expand_vars);

my $_check_tocopy_vars = sub {
  my ($self, $tocopy_vars, $set) = @_;
  croak("'tocopy_vars': expected HASH ref") if ref($tocopy_vars) ne 'HASH';
  $tocopy_vars = { %$tocopy_vars };
  while (my ($var, $value) = each(%$tocopy_vars)) {
    croak("'tocopy_vars': value of '$var' is a ref, expected scalar") if ref($value);
    if (!defined($value)) {
      carp("'tocopy_vars': value '$var' is undef - treated as empty string");
      $tocopy_vars->{$var} = "";
    }
    croak("'tocopy_vars': variable '$var': name is not permitted")
      if ($var =~ /^\s*$/ || $var =~ /^[[=;]/);
  }
  #  @{$self->{+TOCOPY_VARS}}{keys(%$tocopy_vars)} = values(%$tocopy_vars) if $set;
  $self->{+TOCOPY_VARS} = {%$tocopy_vars} if $set;
  return $tocopy_vars;
};


my $_check_not_tocopy = sub {
  my ($self, $not_tocopy, $set) = @_;
  my $ref = ref($not_tocopy);
  if ($ref eq 'ARRAY') {
    foreach my $v (@$not_tocopy) {
      croak("'not_tocopy': undefined value in array") if !defined($v);
      croak("'not_tocopy': unexpected ref value in array") if ref($v);
    }
    $not_tocopy = {map {$_ => undef} @$not_tocopy};
  }
  elsif ($ref eq 'HASH') {
    $not_tocopy = %{$not_tocopy};
  }
  else {
    croak("'not_tocopy': unexpected type: must be ARRAY or HASH ref");
  }
  $self->{+NOT_TOCOPY}= $not_tocopy if $set;
  return $not_tocopy;
};


sub new {
  my ($class, %args) = @_;
  state $allowed_keys = {map {$_ => undef} qw(tocopy_section tocopy_vars not_tocopy global_mode
                                              separator cmnt_vl varname_chk_re)};
  _check_args(\%args, $allowed_keys);
  my $self = {};
  croak("'tocopy_section': must not be a reference") if ref($args{tocopy_section});
  if (exists($args{separator})) {
    state $allowed_sep_chars = "#!%&',./:~\\";
    my $sep = $args{separator};
    croak("'separator': unexpected ref type, must be a scalar") if ref($sep);
    croak("'separator': invalid value. Allowed chars: $allowed_sep_chars")
      if $sep !~ m{^[\Q$allowed_sep_chars\E]+$};
    $self->{+SEPARATOR} = $sep;
    $self->{+VREF_RE} = qr/^(.*?)(?:\Q$sep\E)(.*)$/;
  }
  else {
    $self->{+VREF_RE} = qr/^\[\s*(.*?)\s*\](.*)$/;
  }
  $self->{+CMNT_VL} = $args{cmnt_vl};
  $self->{+TOCOPY_SECTION} = $args{tocopy_section} // DFLT_TOCOPY_SECTION;
  $self->$_check_tocopy_vars($args{tocopy_vars}, 1) if exists($args{tocopy_vars});
  $self->$_check_not_tocopy($args{not_tocopy},   1) if exists($args{not_tocopy});
  $self->{+GLOBAL_MODE} = !!$args{global_mode};
  if (exists($args{varname_chk_re})) {
    croak("'varname_chk_re': must be a compiled regex") if ref($args{varname_chk_re}) ne 'Regexp';
    $self->{+VARNAME_CHK_RE} = $args{varname_chk_re};
  }
  return bless($self, $class);
}


my $_expand_value = sub {
  return $_[0]->$_expand_vars($_[1], undef, $_[2]);
};

#
# We assume that this is called when the target section is still empty and if
# tocopy vars exist.
#
my $_cp_tocopy_vars = sub {
  my ($self, $to_sect_name) = @_;
  my $comm_sec   = $self->{+VARIABLES}{$self->{+TOCOPY_SECTION}} // die("no tocopy vars");
  my $not_tocopy = $self->{+NOT_TOCOPY};
  my $to_sec     = $self->{+VARIABLES}{$to_sect_name} //= {};
  my $expanded   = $self->{+EXPANDED};
  foreach my $comm_var (keys(%$comm_sec)) {
    next if exists($not_tocopy->{$comm_var});
    $to_sec->{$comm_var} = $comm_sec->{$comm_var};
    my $comm_x_var_name = "[$comm_sec]$comm_var";   # see _x_var_name()
    $expanded->{"[$to_sect_name]$comm_var"} = undef if exists($expanded->{$comm_x_var_name});
  }
};


my $_parse_ini = sub {
  my ($self, $src) = @_;
  my $src_name;
  if (ref($src)) {
    croak("Internal error: argument is not an ARRAY ref") if ref($src) ne 'ARRAY';
    $src_name = $self->{+SRC_NAME};
  }
  else {
    $src_name = $src;
    $src = [do { local (*ARGV); @ARGV = ($src_name); <> }];
  }
  my $curr_section;
  my $cmnt_vl     = $self->{+CMNT_VL};
  my $sections    = $self->{+SECTIONS};
  my $sections_h  = $self->{+SECTIONS_H};
  my $expanded    = $self->{+EXPANDED};
  my $variables   = $self->{+VARIABLES};
  my $tocopy_sec  = $self->{+TOCOPY_SECTION};
  my $tocopy_vars = $variables->{$tocopy_sec}; # hash key need not to exist!
  my $global_mode = $self->{+GLOBAL_MODE};
  my $vnm_chk_re  = $self->{+VARNAME_CHK_RE};

  my $tocopy_sec_declared;

  my $i;                        # index in for() loop
  my $_fatal = sub { croak("'$src_name': ", $_[0], " at line ", $i + 1); };

  my $set_curr_section = sub {
    $curr_section = shift;
    if ($curr_section eq $tocopy_sec) {
      $_fatal->("tocopy section '$tocopy_sec' must be first section") if @$sections;
      $tocopy_vars = $variables->{$tocopy_sec} = {} if !$tocopy_vars;
      $tocopy_sec_declared = 1;
    }
    elsif ($tocopy_vars && !$global_mode) {
      $self->$_cp_tocopy_vars($curr_section);
    }
    else {
      $variables->{$curr_section} = {};
    }
    $_fatal->("'$curr_section': duplicate header") if exists($sections_h->{$curr_section});
    $sections_h->{$curr_section} = @$sections; # Index!
    push(@$sections, $curr_section);
  };

  for ($i = 0; $i < @$src; ++$i) {
    my $line = $src->[$i];
    if (index($line, ";!") == 0 || index($line, "=") == 0) {
      $_fatal->("directives are not yet supported");
    }
    $line =~ s/^\s+//;
    next if $line eq "" || $line =~ /^[;#]/;
    $line =~ s/\s+$//;
    # section header
    if (index($line, "[") == 0) {
      $line =~ s/\s*[#;][^\]]*$//;
      $line =~ /^\[\s*(.*?)\s*\]$/ or $_fatal->("invalid section header");
      $set_curr_section->($1);
      next;
    }

    # var = val
    $line =~ s/\s+;.*$// if $cmnt_vl;
    $set_curr_section->($tocopy_sec) if !defined($curr_section);
    $line =~ /^(.*?)\s*($Modifier_Char*?)=(?:\s*)(.*)/ or
      $_fatal->("neither section header nor key definition");
    my ($var_name, $modifier, $value) = ($1, $2, $3);
    if ($vnm_chk_re) {
      croak("'$var_name': var name does not match varname_chk_re") if $var_name !~ $vnm_chk_re;
    }
    my $x_var_name = $self->$_x_var_name($curr_section, $var_name);
    my $exp_flag = exists($expanded->{$x_var_name});
    $_fatal->("empty variable name") if $var_name eq "";
    my $sect_vars = $variables->{$curr_section} //= {};
    if ($modifier eq "") {
      delete $expanded->{$x_var_name} if $exp_flag;
      $sect_vars->{$var_name} = $value;
    }
    elsif ($modifier eq '?') {
      $sect_vars->{$var_name} = $value if !exists($sect_vars->{$var_name});
    }
    elsif ($modifier eq '??') {
      $sect_vars->{$var_name} = $value if (!exists($sect_vars->{$var_name})
                                           || $sect_vars->{$var_name} eq "");
    }
    elsif ($modifier eq '+') {
      if (exists($sect_vars->{$var_name})) {
        $sect_vars->{$var_name} .= " "
          . ($exp_flag ? $self->$_expand_value($curr_section, $value) : $value);
      }
      else {
        $sect_vars->{$var_name} = $value;
      }
    }
    elsif ($modifier eq '.') {
      $sect_vars->{$var_name} = ($sect_vars->{$var_name} // "")
        . ($exp_flag ? $self->$_expand_value($curr_section, $value) : $value);
    }
    elsif ($modifier eq ':') {
      delete $expanded->{$x_var_name} if $exp_flag; # Needed to make _expand_vars corectly!
      $sect_vars->{$var_name} = $self->$_expand_vars($curr_section, $var_name, $value, undef, 1);
    }
    elsif ($modifier eq '+>') {
      if (exists($sect_vars->{$var_name})) {
        $sect_vars->{$var_name} =
          ($exp_flag ? $self->$_expand_value($curr_section, $value) : $value)
          . ' ' . $sect_vars->{$var_name};
      }
      else {
        $sect_vars->{$var_name} = $value;
      }
    }
    elsif ($modifier eq '.>') {
      $sect_vars->{$var_name} =
        ($exp_flag ? $self->$_expand_value($curr_section, $value) : $value)
        . ($sect_vars->{$var_name} // "");
    }
    else {
      $_fatal->("'$modifier': unsupported modifier");
    }
  }
  return ($tocopy_sec_declared, $curr_section);
};


sub parse_ini {
  my $self = shift;
  my %args = (cleanup => 1,
              @_ );
  state $allowed_keys = {map {$_ => undef} qw(cleanup src src_name
                                              tocopy_section tocopy_vars not_tocopy)};
  state $dflt_src_name = "INI data";
  _check_args(\%args, $allowed_keys);
  foreach my $scalar_arg (qw(tocopy_section src_name)) {
     croak("'$scalar_arg': must not be a reference") if ref($args{$scalar_arg});
   }
  delete $self->{+SRC_NAME} if exists($self->{+SRC_NAME});
  $self->{+SRC_NAME} = $args{src_name} if exists($args{src_name});
  my (      $cleanup, $src, $tocopy_section, $tocopy_vars, $not_tocopy) =
    @args{qw(cleanup   src   tocopy_section   tocopy_vars   not_tocopy)};

  croak("'src': missing mandatory argument") if !defined($src);
  my $backup = $self->{+BACKUP} //= {};
  if (defined($tocopy_section)) {
    $backup->{tocopy_section} = $self->{+TOCOPY_SECTION};
    $self->{+TOCOPY_SECTION}  = $tocopy_section;
  }
  else {
    $tocopy_section = $self->{+TOCOPY_SECTION};
  }
  $self->{+CURR_TOCP_SECTION} = $tocopy_section;
  $Globals{'=TO_CP_SEC'} = $tocopy_section;
  if ($tocopy_vars) {
    $backup->{tocopy_vars} = $self->{+TOCOPY_VARS};
    $self->$_check_tocopy_vars($tocopy_vars, 1);
  }
  if ($not_tocopy) {
    $backup->{not_tocopy} = $self->{+NOT_TOCOPY};
    $self->$_check_not_tocopy($not_tocopy, 1)
  }
  $self->{+SECTIONS}   = [];
  $self->{+SECTIONS_H} = {};
  $self->{+EXPANDED}   = {};
  $self->{+VARIABLES}  =
    {$tocopy_section => ($self->{+TOCOPY_VARS} ? {%{$self->{+TOCOPY_VARS}}} : {})};

  my $global_vars = $self->{+GLOBAL_VARS} = {%Globals};
  my $variables = $self->{+VARIABLES};
  my $tocopy_sec_vars = $variables->{$tocopy_section};
  if (my $ref_src = ref($src)) {
    $self->{+SRC_NAME} = $dflt_src_name if !exists($self->{+SRC_NAME});
    if ($ref_src eq 'ARRAY') {
      $src = [@$src];
      foreach my $entry (@$src) {
        croak("'src': unexpected ref type in array") if ref($entry);
        if (!defined($entry)) {
          carp("'src': undef entry - treated as empty string");
          $entry = "";
        }
      }
    }
    else {
      croak("'src': $ref_src: ref type not allowed");
    }
  }
  else {
    if (index($src, "\n") < 0) {
      my $path = $src;
      $src = [do { local (*ARGV); @ARGV = ($path); <> }];
      $self->{+SRC_NAME} = $path if !exists($self->{+SRC_NAME});
      my ($vol, $dirs, $file) = splitpath(rel2abs($path));
      @{$global_vars}{'=INIfile', '=INIdir'} = ($file, catdir(length($vol // "") ? $vol : (),
                                                              $dirs));
    }
    else {
      $src = [split(/\n/, $src)];
      $self->{+SRC_NAME} = $dflt_src_name if !exists($self->{+SRC_NAME});
    }
  }
  $global_vars->{'=srcname'} = $self->{+SRC_NAME};

  my ($tocopy_sec_declared, undef) = $self->$_parse_ini($src);

  my @sections = (exists($self->{+SECTIONS_H}{$tocopy_section}) ? () : $tocopy_section,
                  @{$self->{+SECTIONS}}
                 );
  foreach my $section (@sections) {
    my $sec_vars = $variables->{$section};
    while (my ($variable, $value) = each(%$sec_vars)) {
      $sec_vars->{$variable} = $self->$_expand_vars($section, $variable, $value);
    }
  }
  if ($cleanup) {
    while (my ($section, $sec_vars) = each(%{$variables})) {
      foreach my $var (keys(%$sec_vars)) {
        delete $sec_vars->{$var} if index($var, '=') >= 0;
      }
    }
    delete $variables->{$self->{+TOCOPY_SECTION}} if (!$tocopy_sec_declared && !%$tocopy_sec_vars);
  }
  else {
    if ($self->{+GLOBAL_MODE}) {
      while (my ($section, $sec_vars) = each(%{$variables})) {
        $sec_vars->{'='} = $section;
      }
      @{$tocopy_sec_vars}{keys(%$global_vars)} = values(%$global_vars);
    }
    else {
      while (my ($section, $sec_vars) = each(%{$variables})) {
        $sec_vars->{'='} = $section;
        @{$sec_vars}{keys(%$global_vars)} = values(%$global_vars);
      }
    }
  }
  $self->{+TOCOPY_SECTION} = $backup->{tocopy_section} if exists($backup->{tocopy_section});
  $self->{+TOCOPY_VARS}    = $backup->{tocopy_vars}    if exists($backup->{tocopy_vars});
  $self->{+NOT_TOCOPY}     = $backup->{not_tocopy}     if exists($backup->{not_tocopy});
  $backup = {};
  return $self;
}


sub current_tocopy_section {$_[0]->{+CURR_TOCP_SECTION}}
sub tocopy_section  {$_[0]->{+TOCOPY_SECTION}}
sub global_mode     {$_[0]->{+GLOBAL_MODE}}
sub sections        { defined($_[0]->{+SECTIONS})   ? [@{$_[0]->{+SECTIONS}}]     : undef}
sub sections_h      { defined($_[0]->{+SECTIONS_H}) ? +{ %{$_[0]->{+SECTIONS_H}} } : undef }
sub separator       {$_[0]->{+SEPARATOR}}
sub src_name        {$_[0]->{+SRC_NAME}}
sub variables       { my $vars = $_[0]->{+VARIABLES} // return undef;
                      return  {map {$_ => {%{$vars->{$_}}}} keys(%$vars)};
                    }


$_look_up = sub {
  my ($self, $curr_sect, $variable) = @_;
  my $matched = $variable =~ $self->{+VREF_RE};
  my ($v_section, $v_basename) = $matched ? ($1, $2) : ($curr_sect, $variable);
  my $v_value;
  my $variables = $self->{+VARIABLES};
  my $tocopy_section = $self->{+TOCOPY_SECTION};
  if (!exists($variables->{$v_section})) {
    $v_value = "";
  }
  elsif (exists($variables->{$v_section}{$v_basename})) {
    $v_value = $variables->{$v_section}{$v_basename};
  }
  elsif ($v_basename !~ /\S/) {
    $v_value = $v_basename;
  }
  elsif ($v_basename eq '=') {
    $v_value = $v_section;
  }
  elsif ($v_basename =~ /^=(?:ENV|env):\s*(.*)$/) {
    $v_value = $ENV{$1} // "";
  }
  elsif ($v_basename =~ /^=CONFIG:\s*(.*)$/) {
    $v_value = $Config{$1} // "";
  }
  elsif (exists($self->{+GLOBAL_VARS}{$v_basename})) {
    $v_value = $self->{+GLOBAL_VARS}{$v_basename};
  }
  elsif ($self->{+GLOBAL_MODE} && exists($variables->{$tocopy_section}{$v_basename})) {
    if (!$matched && $curr_sect ne $tocopy_section && exists($self->{+NOT_TOCOPY}{$v_basename})) {
      $v_value = "";
    }
    else {
      $v_value = $variables->{$tocopy_section}{$v_basename};
    }
  }
  else {
    $v_value = "";
  }
  die("Internal error") if !defined($v_value);
  return wantarray ? ($v_section, $v_basename, $v_value) : $v_value;
};

# extended var name
$_x_var_name = sub {
  my ($self, $curr_sect, $variable) = @_;

  if ($variable =~ $self->{+VREF_RE}) {
    return ($2, "[$1]$2");
  }
  else {
    return ($variable, "[$curr_sect]$variable");
  }
};


$_expand_vars = sub {
  my ($self, $curr_sect, $variable, $value, $seen, $not_seen) = @_;
  my $top = !$seen;
  my @result = ("");
  my $level = 0;
  my $x_variable_name;
  if (defined($variable)) {
    ((my $var_basename), $x_variable_name) = $self->$_x_var_name($curr_sect, $variable);
    return $self->$_look_up($curr_sect, $variable) if (exists($self->{+EXPANDED}{$x_variable_name})
                                                       || $var_basename =~ /^=(?:ENV|CONFIG):/);
    croak("recursive variable '", $x_variable_name, "' references itself")
      if exists($seen->{$x_variable_name});
    $seen->{$x_variable_name} = undef if !$not_seen;
  }
  foreach my $token (split(/(\$\(|\))/, $value)) {
    if ($token eq '$(') {
      ++$level;
    }
    elsif ($token eq ')' && $level) {
      # Now $result[$level] contains the name of a referenced variable.
      if ($result[$level] eq '==') {
        $result[$level - 1] .= $variable;
      }
      else {
        $result[$level - 1] .=
          $self->$_expand_vars($self->$_look_up($curr_sect, $result[$level]), $seen);
      }
      pop(@result);
      --$level;
    }
    else {
      $result[$level] .= $token;
    }
  }
  croak("'$x_variable_name': unterminated variable reference") if $level;
  $value = $result[0];
  if ($x_variable_name) {
    $self->{+EXPANDED}{$x_variable_name} = undef if $top;
    delete $seen->{$x_variable_name};
  }
  return $value;
};


#
# This is a function, not a method!
#
sub _check_args {
  my ($args, $allowed_args) = @_;
  foreach my $key (keys(%$args)) {
    croak("'$key': unsupported argument") if !exists($allowed_args->{$key});
  }
  delete @{$args}{ grep { !defined($args->{$_}) } keys(%$args) };
}


1; # End of Config::INI::RefVars



__END__