File Coverage

blib/lib/Config/INI/RefVars.pm

Criterion	Covered	Total	%
statement	173	175	98.8
branch	74	84	88.1
condition	16	18	88.8
subroutine	23	23	100.0
pod	10	10	100.0
total	296	310	95.4

package Config::INI::RefVars;
use 5.010;
use strict;
use warnings;
use feature ":5.10";

use Carp;
use Config;
use Cwd qw(abs_path);
use File::Spec::Functions qw(catdir catfile file_name_is_absolute splitpath);
use Config::INI::RefVars::Builtins;

our $VERSION = '1.01';

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',
              FUNCTIONS         => FLD_KEY_PREFIX . 'FUNCTIONS',
              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',
              DISPATCH_TABLE    => FLD_KEY_PREFIX . 'DISPATCH_TABLE',
             };

my %Globals = ('=:'       => catdir("", ""),
               '=::'      => $Config{path_sep},
               '=VERSION' => $VERSION,
               '=rootdir' => File::Spec::Functions::rootdir(),
               '=tmpdir'  => File::Spec::Functions::tmpdir(),
              );

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

my ($_look_up, $_x_var_name, $_expand_vars, $_user_function_call, $_function_body, $_parse_ini);

my $_dispatch_sub = sub {
  my ($self, $name) = @_;

  my $dispatch = $self->{+DISPATCH_TABLE}
    or croak("Internal error: dispatch table is not initialized");

  my $sub = $dispatch->{$name}
    or croak("unknown function '$name'");

  return $sub;
};

my $_split_dispatch_spec = sub {
  my ($self, $spec) = @_;

  $spec =~ s/^\s+//;
  $spec =~ s/\s+$//;

  croak("empty function call") if $spec eq "";

  my @parts;
  my $buf = "";
  my $level = 0;

  foreach my $token (split(/(\$\(|\))/, $spec)) {
    if ($token eq '$(') {
      ++$level;
      $buf .= $token;
    }
    elsif ($token eq ')') {
      croak("unterminated variable reference") if !$level;
      --$level;
      $buf .= $token;
    }
    else {
      foreach my $subtok (split(/(,)/, $token)) {
        if ($subtok eq ',' && !$level) {
          push(@parts, $buf);
          $buf = "";
        }
        else {
          $buf .= $subtok;
        }
      }
    }
  }
  croak("unterminated variable reference") if $level;

  push(@parts, $buf);

  my $name = shift(@parts) // "";
  $name =~ s/^\s+//;
  $name =~ s/\s+$//;
  croak("empty function name") if $name eq "";

  @parts = map {
    s/^\s+//;
    s/\s+$//;
    $_;
  } @parts;

  return ($name, @parts);
};


my $_dispatch_call = sub {
  my ($self, $curr_sect, $spec, $seen) = @_;

  my ($name, @args) = $self->$_split_dispatch_spec($spec);
  @args = map { $self->$_expand_vars($curr_sect, undef, $_, $seen, 1) } @args;

  my $sub = $self->$_dispatch_sub($name);
  return $sub->(@args) // "";
};


$_function_body = sub {
  my ($self, $curr_sect, $name) = @_;
  my $functions = $self->{+FUNCTIONS} // {};

  if ($name =~ $self->{+VREF_RE}) {
    my ($section, $basename) = ($1, $2);
    return (exists($functions->{$section}) && exists($functions->{$section}{$basename})) ?
      ($section, $basename, $functions->{$section}{$basename}) : ();
  }
  return ($curr_sect, $name, $functions->{$curr_sect}{$name})
    if exists($functions->{$curr_sect}) && exists($functions->{$curr_sect}{$name});

  my $tocopy_section = $self->{+TOCOPY_SECTION};
  return ($tocopy_section, $name, $functions->{$tocopy_section}{$name})
    if ($curr_sect ne $tocopy_section
        && exists($functions->{$tocopy_section})
        && exists($functions->{$tocopy_section}{$name}));
  return;
};


$_user_function_call = sub {
  my ($self, $curr_sect, $spec, $seen) = @_;

  my ($name, @args) = $self->$_split_dispatch_spec($spec);
  @args = map { $self->$_expand_vars($curr_sect, undef, $_, $seen, 1) } @args;

  my ($func_section, $func_name, $body) = $self->$_function_body($curr_sect, $name);

  if (!defined($body)) {
    croak("unknown function '$name'") if $name =~ $self->{+VREF_RE};
    return $self->$_dispatch_sub($name)->(@args) // "";
  }

  my $x_func_name = "[$func_section]#=$func_name";

  croak("recursive function '$x_func_name' calls itself") if exists($seen->{$x_func_name});

  $seen->{$x_func_name} = undef;

  my $variables = $self->{+VARIABLES};
  my $sect_vars = $variables->{$curr_sect} //= {};
  my (%had_arg, %old_arg, %param);

  for my $i (1 .. @args) {
    $param{$i} = $args[$i - 1];
  }

  while ($body =~ /\$\((\d+)\)/g) {
    $param{$1} //= "";
  }

  foreach my $arg (keys(%param)) {
    $had_arg{$arg} = exists($sect_vars->{$arg});
    $old_arg{$arg} = $sect_vars->{$arg} if $had_arg{$arg};
    $sect_vars->{$arg} = $param{$arg};
  }
  my $result;
  eval { $result = $self->$_expand_vars($curr_sect, undef, $body, $seen, 1); 1; } or die($@);

  foreach my $arg (keys(%param)) {
    if ($had_arg{$arg}) {
      $sect_vars->{$arg} = $old_arg{$arg};
    }
    else {
      delete($sect_vars->{$arg});
    }
  }
  delete($seen->{$x_func_name});
  return $result;
};


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} = {%$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(builtins
                                                 cmnt_vl
                                                 global_mode
                                                 not_tocopy
                                                 separator
                                                 tocopy_section
                                                 tocopy_vars
                                                 varname_chk_re
                                               )};

  _check_args(\%args, $allowed_keys);

  my $builtins = delete($args{builtins}) // {};
  croak("builtins must be a hash reference") if ref($builtins) ne 'HASH';
  my $dispatch = Config::INI::RefVars::Builtins::default_dispatch_table();
  foreach my $name (keys(%$builtins)) {
    croak("builtin '$name' is not a CODE reference") if ref($builtins->{$name}) ne 'CODE';
    $dispatch->{$name} = $builtins->{$name};
  }
  my $self = {
              +DISPATCH_TABLE() => $dispatch,
             };

  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 = "[" . $self->{+TOCOPY_SECTION} . "]$comm_var";
    $expanded->{"[$to_sect_name]$comm_var"} = undef
      if exists($expanded->{$comm_x_var_name});
  }
};


my $_read_ini_file = sub {
  my ($path) = @_;

  open(my $fh, '<', $path) or croak("'$path': cannot open file: $!");
  my @lines = <$fh>;
  close($fh) or croak("'$path': cannot close file: $!");

  return \@lines;
};


$_parse_ini = sub {
  my ($self, $src, $curr_section, $include_stack, $src_dir, $src_name) = @_;

  croak("Internal error: argument is not an ARRAY ref") if ref($src) ne 'ARRAY';

  $src_name //= $self->{+SRC_NAME};
  $src_dir  //= '.';
  $include_stack //= {};

  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 $functions   = $self->{+FUNCTIONS};
  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 $_include_file = sub {
    my ($include) = @_;

    $include =~ s/^\s+//;
    $include =~ s/\s+$//;
    $_fatal->("missing file name in include directive") if $include eq "";

    $include = $self->$_expand_vars(defined($curr_section) ? $curr_section : $tocopy_sec,
                                    undef,
                                    $include,
                                    undef,
                                    1,
                                   );

    my $path = file_name_is_absolute($include) ? $include : catfile($src_dir, $include);

    my $abs_path = abs_path($path) or $_fatal->("'$include': cannot resolve include file");

    $_fatal->("'$include': recursive include") if exists($include_stack->{$abs_path});

    local $include_stack->{$abs_path} = undef;

    my ($vol, $dirs) = splitpath($abs_path);
    my $inc_dir = catdir(length($vol // "") ? $vol : (), $dirs);

    my ($inc_tocopy_declared, $inc_curr_section) =
      $self->$_parse_ini($_read_ini_file->($abs_path),
                         $curr_section,
                         $include_stack,
                         $inc_dir,
                         $abs_path,
                        );

    $tocopy_sec_declared ||= $inc_tocopy_declared;
    $curr_section = $inc_curr_section if defined($inc_curr_section);
  };

  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;
      $functions->{$tocopy_sec} //= {};
      $tocopy_sec_declared = 1;
    }
    elsif ($tocopy_vars && !$global_mode) {
      $self->$_cp_tocopy_vars($curr_section);
    }
    else {
      $variables->{$curr_section} = {};
    }
    $functions->{$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];
    $line =~ s/\s+$//;
    next if $line eq "";

    if ($line =~ /^=include(?:\s+(.+))?\z/) {
      $_include_file->($1 // "");
      next;
    }

    if (index($line, ";!") == 0 || index($line, "=") == 0) {
      $_fatal->("directives are not yet supported");
    }

    $line =~ s/^\s+//;
    next if $line eq "" || $line =~ /^[;#]/;

    # 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 ($modifier =~ s/\\\z//) {
      while ($value =~ s/\\\z//) {
        last if $i + 1 >= @$src;
        my $next_line = $src->[++$i];
        $next_line =~ s/\s+$//;

        if (index($next_line, "=") == 0) {
          $_fatal->("directive in line continuation");
        }
        $value .= $next_line;
      }
    }
    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} //= {};
    my $sect_funcs = $functions->{$curr_section} //= {};

    if ($modifier eq '#') {
      $sect_funcs->{$var_name} = $value;
    }
    elsif ($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;
      $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}}} : {})
  };
  $self->{+FUNCTIONS} = {};

  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;
      my $abs_path = abs_path($path) or croak("'$path': cannot resolve file name");
      $src = $_read_ini_file->($abs_path);
      $self->{+SRC_NAME} = $path if !exists($self->{+SRC_NAME});

      my ($vol, $dirs, $file) = splitpath($abs_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 $src_dir = '.';
  my $include_stack = {};

  if (!ref($args{src}) && index($args{src}, "\n") < 0) {
    my $abs_path = abs_path($args{src})
      or croak("'$args{src}': cannot resolve file name");
    $include_stack->{$abs_path} = undef;
    my ($vol, $dirs) = splitpath($abs_path);
    $src_dir = catdir(length($vol // "") ? $vol : (), $dirs);
  }

  my ($tocopy_sec_declared, undef) = $self->$_parse_ini($src,
                                                        undef,
                                                        $include_stack,
                                                        $src_dir,
                                                        $self->{+SRC_NAME},
                                                       );

  my @sections = ((exists($self->{+SECTIONS_H}{$tocopy_section}) ? () : $tocopy_section),
                  @{$self->{+SECTIONS}},
                 );

  foreach my $section (@sections) {
    my $sec_vars = $variables->{$section};

    foreach my $variable (keys(%$sec_vars)) {
      my $value = $sec_vars->{$variable};
      $sec_vars->{$variable} = $self->$_expand_vars($section, $variable, $value);
    }
  }

  if ($cleanup) {
    foreach my $section (keys(%$variables)) {
      my $sec_vars = $variables->{$section};
      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}) {
      foreach my $section (keys(%$variables)) {
        my $sec_vars = $variables->{$section};
        $sec_vars->{'='} = $section;
      }
      @{$tocopy_sec_vars}{keys(%$global_vars)} = values(%$global_vars);
    }
    else {
      foreach my $section (keys(%$variables)) {
        my $sec_vars = $variables->{$section};
        $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 {
  return defined($_[0]->{+SECTIONS}) ? [@{$_[0]->{+SECTIONS}}] : undef;
}

sub sections_h {
  return 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 @raw = ("");
  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;
      $raw[$level - 1] .= '$(' if $level > 1;
    }
    elsif ($token eq ')' && $level) {
      my $raw_expr = $raw[$level];

      if ($result[$level] eq '==') {
        $result[$level - 1] .= $variable;
      }
      elsif ($raw_expr =~ /^\s*=#\s*(.*)$/s) {
        $result[$level - 1] .= $self->$_user_function_call($curr_sect, $1, $seen);
      }
      elsif ($raw_expr =~ /^\s*=&\s*(.*)$/s) {
        $result[$level - 1] .= $self->$_dispatch_call($curr_sect, $1, $seen);
      }
      else {
        $result[$level - 1] .= $self->$_expand_vars(
          $self->$_look_up($curr_sect, $result[$level]),
          $seen,
        );
      }
      $raw[$level - 1] .= $raw_expr . ')';
      pop(@result);
      pop(@raw);
      --$level;
    }
    else {
      $result[$level] .= $token;
      $raw[$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__