view release on metacpan or  search on metacpan

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

  _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;
    }

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

              @_ );
  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}}