view release on metacpan or  search on metacpan

lib/Advanced/Config/Reader.pm  view on Meta::CPAN

            $l_quote = $q;
            $r_quote = convert_to_regexp_string ($opts->{quote_right}, 1);
         }
      }

      $var_line = $value;
   }

   # Comment still in value, but still haven't proved any quotes are balanced.
   DBUG_PRINT ("DEBUG", "Tag (%s),  Value (%s),  Proposed Left (%s),  Right (%s)",
                        $tag, $value, $l_quote, $r_quote);

   my $cmts = "";

   # Was the value in the tag/value pair starting with a left quote?
   if ( $tv_pair_flag && $l_quote ne "" ) {
      my ($q1, $val2, $q2);

      # Now check if they were balanced ...
      if ( $value =~ m/^(${l_quote})(.*)(${r_quote})(\s*${comment}.*$)/ ) {
         ($q1, $val2, $q2, $cmts) = ($1, $2, $3, $4);   # Has a comment ...
      } elsif ( $value =~ m/^(${l_quote})(.*)(${r_quote})\s*$/ ) {
         ($q1, $val2, $q2, $cmts) = ($1, $2, $3, "");   # Has no comment ...
      }

      # If balanced quotes were found ...
      if ( $q1 ) {
         # If the surrounding quotes don't have quotes inside them ...
         # IE not malformed ...
         unless ( $val2 =~ m/${l_quote}/ || $val2 =~ m/${r_quote}/ ) {
            my $cmt2 = convert_to_regexp_string ($cmts);
            $cmts =~ s/^\s*${comment}\s*//;            # Remove comment symbol ...
            $line =~ s/${cmt2}$//  if ($cmt2 ne "" );  # Remove the comments ...

            DBUG_PRINT ("LINE", "Balanced Quotes encountered for removal ...");
            return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, $l_quote, $r_quote);
         }
      }
   }

   # The Quotes weren't balanced, so they can no longer be removed from
   # arround the value of what's returned!
   $l_quote = $r_quote = "";

   # ----------------------------------------------------------------------
   # If no comments in the line, just return the trimmed string ...
   # Both tests are needed due to custom comment/assign strings!
   # ----------------------------------------------------------------------
   if ( $line !~ m/${comment}/ ) {
      DBUG_PRINT ("LINE", "Simply no comments to worry about ...");
      return DBUG_RETURN ( $tv_pair_flag, $line, "", "", "" );
   }

   # Handles case where a comment char embedded in the assignment string.
   if ( $tv_pair_flag && $value !~ m/${comment}/ ) {
      DBUG_PRINT ("LINE", "Simply no comments in the value to worry about ...");
      return DBUG_RETURN ( $tv_pair_flag, $line, "", "", "" );
   }

   # ----------------------------------------------------------------------
   # If not protected by balanced quotes, verify the comment symbol detected
   # isn't actually a variable modifier.  Variables are allowed in most places
   # in the config file, not just in tag/value pairs.
   # ----------------------------------------------------------------------

   # The left & right anchor points for variable substitution ...
   my $lvar = convert_to_regexp_string ($opts->{variable_left}, 1);
   my $rvar = convert_to_regexp_string ($opts->{variable_right}, 1);

   # Determine what value to use in variable substitutions that doesn't include
   # a variable tag, or a comment tag, or a value in the $line.
   my $has_no_cmt;
   foreach ("A" .. "Z", "@") {
      $has_no_cmt = ${_}x10;
      last  unless ( $has_no_cmt =~ m/${comment}/ ||
                     $has_no_cmt =~ m/${lvar}/    ||
                     $has_no_cmt =~ m/${rvar}/    ||
                     $line       =~ m/${has_no_cmt}/ );
   }
   if ( $has_no_cmt eq "@"x10 ) {
      warn ("May be having variable substitution issues in parse_line()!\n");
   }

   # Strip out all the variables from the value ...
   # Assumes processing variables from left to right ...
   # Need to evaluate even if variables are disabled to parse correctly ...
   my @parts = parse_for_variables ($var_line, 1, $opts);
   my $cmt_found = 0;
   my $count_var = 0;
   my @data;
   while (defined $parts[0]) {
      $cmt_found = $parts[3];
      push (@data, $var_line);
      last  if ($cmt_found);
      $var_line = $parts[0] . $has_no_cmt . $parts[2];
      @parts = parse_for_variables ($var_line, 1, $opts);
      ++$count_var;
   }
   push (@data, $var_line);

   my $unbalanced_leading_var_anchor_with_comments = 0;
   if ( $cmt_found && $parts[0] =~ m/(\s*${comment}\s*)(.*$)/ ) {
      # parts[1] is parts[7] trimmed ... so join back together with untrimmed.
      $cmts = $2 . $opts->{variable_left}  . $parts[7]
                 . $opts->{variable_right} . $parts[2];
      my $str = convert_to_regexp_string ( $1 . $cmts );
      $line =~ s/${str}$//;
      DBUG_PRINT ("LINE", "Variables encountered with variables in comment ...");
      return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
   } elsif ( $count_var ) {
      if ( $var_line =~ m/(\s*${comment}\s*)(.*)$/ ) {
         $cmts = $2;
         if ( $cmts =~ m/${has_no_cmt}/ ) {
            $unbalanced_leading_var_anchor_with_comments = 1;
         } else {
            my $cmt2 = convert_to_regexp_string ($1 . $cmts);
            $line =~ s/${cmt2}$//;
            DBUG_PRINT ("LINE", "Variables encountered with constant comment ...");
         }
      } else {
         $cmts = "";