view release on metacpan or  search on metacpan

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

   my $opts = (ref ($_[0]) eq "HASH" ) ? $_[0] : {@_};

   # Mask the ${line} return value in fish ...
   # Only gets unmasked in the test scripts:  t/*.t.
   # Always pause since by the time we detect if it should be
   # hidden or not it's too late.  We've already written it to fish!
   unless ( $opts->{dbug_test_use_case_parse_override} ) {
      DBUG_MASK ( 1 );
      DBUG_PAUSE ();
   }

   # Strip of leading & trailing spaces ...
   $line =~ s/^\s+//;
   $line =~ s/\s+$//;

   my $default_quotes = using_default_quotes ( $opts );

   my $comment = convert_to_regexp_string ($opts->{comment}, 1);

   my ($tag, $value) = _split_assign ( $opts, $line, 1 );

   my ($l_quote, $r_quote, $tv_pair_flag) = ("", "", 0);
   my $var_line = $line;

   unless ( defined $tag && defined $value ) {
      $tag = $value = undef;      # It's not a tag/value pair ...

   } elsif ( $tag eq "" || $tag =~ m/${comment}/ ) {
      $tag = $value = undef;      # It's not a valid tag ...

   } else {
      # It looks like a tag/value pair to me ...
      $tv_pair_flag = 1;

      if ( $opts->{disable_quotes} ) {
         ;   # Don't do anything ...

      } elsif ( $default_quotes ) {
         if ( $value =~ m/^(['"])/ ) {
            $l_quote = $r_quote = $1;     # A ' or ".  (Never both)
         }

      # User defined quotes ...
      } else {
         my $q = convert_to_regexp_string ($opts->{quote_left}, 1);
         if ( $value =~ m/^(${q})/ ) {
            $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}/ ||

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

         # Repeating that logic here.
         my $msg = "Encounterd undefined variable ($mod_tag) using shell modifier ${mod_opt}";
         $msg .= " in config file: " . basename ($file)  if ( $file ne "" );
         DBUG_PRINT ("MOD", $msg);
         die ( basename ($0) . ": ${mod_tag}: ${output}.\n" );
      }

      DBUG_PRINT ("MOD",
           "The modifier (%s) is overriding the variable with a default value!",
           $mod_opt);

   # Sub-string removal ...
   } elsif ( $mod_opt eq "##" || $mod_opt eq "#" ||     # From beginning
             $mod_opt eq "%%" || $mod_opt eq "%" ) {    # From end
      my $greedy  = ( $mod_opt eq "##" || $mod_opt eq "%%" );
      my $leading = ( $mod_opt eq "#"  || $mod_opt eq "##" );
      my $reverse_msg = "";    # Both the message & control flag ...

      $output = $alt_val;

      # Now replace shell script wildcards with their Perl equivalents.
      # A RegExp can't do non-greedy replaces anchored to the end of string!
      # So we need the reverse logic to do so.
      my $regExpVal = convert_to_regexp_modifier ($mod_val);
      $regExpVal =~ s/[?]/./g;         # ? --> .     (any one char)
      if ( $greedy ) {
         $regExpVal =~ s/[*]/.*/g;     # * --> .*    (zero or more greedy chars)
      } elsif ( $leading ) {
         $regExpVal =~ s/[*]/(.*?)/g;  # * --> (.*?) (zero or more chars)
      } elsif ( $regExpVal =~ m/[*]/ ) {
         # Non-Greedy with one or more wild cards present ("*")!
         $leading = 1;                 # Was false before.
         $regExpVal = reverse ($regExpVal);
         $regExpVal =~ s/[*]/(.*?)/g;  # * --> (.*?) (zero or more chars)
         $output = reverse ($output);
         $reverse_msg = "  Reversed for non-greedy strip.";
      }

      if ( $leading ) {
         $regExpVal = '^' . $regExpVal;
      } else {
         # Either greedy trailing or no *'s in trailing regular expression!
         $regExpVal .= '$';
      }

      $output =~ s/${regExpVal}//;     # Strip off the matching values ...
      $output = reverse ($output)  if ( $reverse_msg ne "" );

      DBUG_PRINT ("MOD",
                  "The modifier (%s) converted \"%s\" to \"%s\".%s\nTo trim the value to: %s",
                  $mod_opt, $mod_val, $regExpVal, $reverse_msg, $output);

   } elsif ( $mod_opt eq "LENGTH" ) {
      $output = length ( $alt_val );
      DBUG_PRINT ("MOD", "Setting the length of variable \${#%s} to: %d.",
                  $mod_tag, $output);

   } elsif ( $mod_opt eq "LIST" ) {
      my @lst = $cfg->_find_variables ( $mod_val );
      $output = join (" ", @lst);
      DBUG_PRINT ("MOD", "Getting all varriables starting with %s", $mod_val);

   } elsif ( $mod_opt eq "!" ) {
      ($output, $mask) = $cfg->lookup_one_variable ( $alt_val );
      if ( $mask == -1 ) {
         $mask = -2;    # Indirect reference to encrypted value
         $output = $alt_val;  # Replace with new variable name
      } elsif ( $mask ) {
         DBUG_MASK (0);
      }
      DBUG_PRINT ("MOD", "Indirectly referencing variable %s (%s)", $alt_val, $mask);

   } elsif ( $mod_opt eq "//" ) {
      my ($ptrn, $val) = split ("/", $mod_val);
      $output = $alt_val;
      $output =~ s/${ptrn}/${val}/g;
      DBUG_PRINT ("MOD", "Global replacement in %s", $alt_val);

   } elsif ( $mod_opt eq "/" ) {
      my ($ptrn, $val) = split ("/", $mod_val);
      $output = $alt_val;
      $output =~ s/${ptrn}/${val}/;
      DBUG_PRINT ("MOD", "1st replacement in %s", $alt_val);

   } elsif ( $mod_opt eq ":" ) {
      my ($offset, $length) = split (":", $mod_val);
      if ( defined $length && $length ne "" ) {
         $output = substr ( $alt_val, $offset, $length);
      } else {
         $output = substr ( $alt_val, $offset);
      }
      DBUG_PRINT ("MOD", "Substring (%s)", $output);

   # The 6 case manipulation modifiers ...
   } elsif ( $mod_opt eq "^^" ) {
      $output = uc ($alt_val);
      DBUG_PRINT ("MOD", "Upshift string (%s)", $output);
   } elsif ( $mod_opt eq ",," ) {
      $output = lc ($alt_val);
      DBUG_PRINT ("MOD", "Downshift string (%s)", $output);
   } elsif ( $mod_opt eq "~~" ) {
      $output = $alt_val;
      $output =~ s/([A-Z])|([a-z])/defined $1 ? lc($1) : uc($2)/gex;
      DBUG_PRINT ("MOD", "Reverse case of each char in string (%s)", $output);
   } elsif ( $mod_opt eq "^" ) {
      $output = ucfirst ($alt_val);
      DBUG_PRINT ("MOD", "Upshift 1st char in string (%s)", $output);
   } elsif ( $mod_opt eq "," ) {
      $output = lcfirst ($alt_val);
      DBUG_PRINT ("MOD", "Downshift 1st char in string (%s)", $output);
   } elsif ( $mod_opt eq "~" ) {
      $output = ucfirst ($alt_val);
      $output = lcfirst ($alt_val)   if ( $alt_val eq $output );
      DBUG_PRINT ("MOD", "Reverse case of 1st char in string (%s)", $output);

   } else {
      DBUG_PRINT ("MOD",
                  "The modifier (%s) didn't affect the variable's value!",
                  $mod_opt);
      $output = $value;
   }