view release on metacpan or  search on metacpan

lib/Config/INI/RefVars.pm  view on Meta::CPAN

      $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