nix results from the CPAN

Advanced-Config

use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
use Exporter;

use Advanced::Config::Options;
use Advanced::Config;

use Fred::Fish::DBUG 2.09 qw / on_if_set  ADVANCED_CONFIG_FISH /;

use File::Basename;

$VERSION = "1.14";
@ISA = qw( Exporter );

@EXPORT = qw( read_config  source_file  make_new_section  parse_line
              expand_variables  apply_modifier  parse_for_variables
              format_section_line  format_tag_value_line format_encrypt_cmt
              encrypt_config_file_details  decrypt_config_file_details );

@EXPORT_OK = qw( );

my $skip_warns_due_to_make_test;
my %global_sections;
my $gUserName;

# ==============================================================
# NOTE: It is extreemly dangerous to reference Advanced::Config
#       internals in this code.  Avoid where possible!!!
#       Ask for copies from the module instead.
# ==============================================================
# Any other module initialization done here ...
# This block references initializations done in my other modules.
BEGIN
{
   DBUG_ENTER_FUNC ();

   # What we call our default section ...
   $global_sections{DEFAULT}  = Advanced::Config::Options::DEFAULT_SECTION_NAME;
   $global_sections{OVERRIDE} = $global_sections{DEFAULT};

   $gUserName = Advanced::Config::Options::_get_user_id ();

   # Is the code being run via "make test" environment ...
   if ( $ENV{PERL_DL_NONLAZY} ||
        $ENV{PERL_USE_UNSAFE_INC} ||
        $ENV{HARNESS_ACTIVE} ) {
      $skip_warns_due_to_make_test = 1;
   }

   DBUG_VOID_RETURN ();
}


# ==============================================================
# No fish please ... (called way too often)
# This method is called in 2 ways:
#  1) By parse_line() to determine if ${ln} is a tag/value pair.
#  2) By everyone else to parse a known tag/value pair in ${ln}.
#
# ${ln} is in one of these 3 formats if it's a tag/value pair.
#     tag = value
#     export tag = value    # Unix shell scripts
#     set tag = value       # Windows Batch files

sub _split_assign
{
   my $rOpts = shift;    # The read options ...
   my $ln    = shift;    # The value to split ...
   my $skip  = shift;    # Skip massaging the tag? 

   my ( $tag, $value );
   if ( is_assign_spaces ( $rOpts ) ) {
      ( $tag, $value ) = split ( " ", $ln, 2 );
      $skip = 1;   # This separator doesn't support the prefixes.
   } else {
      my $assign_str  = convert_to_regexp_string ($rOpts->{assign}, 1);
      ( $tag, $value ) = split ( /\s*${assign_str}\s*/, $ln, 2 );
   }

   my $export_prefix = "";

   unless ( $skip ) {
      # Check if one of the export/set variable prefixes were used!
      if ( $tag =~ m/^(export\s+)(\S.*)$/i ) {
         $tag = $2;           # Remove the leading "export" keyword ...
         $export_prefix = $1;
      } elsif ( $tag =~ m/^(set\s+)(\S.*)$/i ) {
         $tag = $2;           # Remove the leading "set" keyword ...
         $export_prefix = $1;
      }
   }

   # Did we request case insensitive tags ... ?
   my $ci_tag = ( $rOpts->{tag_case} && defined $tag ) ? lc ($tag) : $tag;

   return ( $ci_tag, $value, $export_prefix, $tag );
}


# ==============================================================

=item $sts = read_config ( $file, $config )

This method performs the reading and parsing of the given config file and puts
the results into the L<Advanced::Config> object I<$config>.  This object
provides the necessary parsing rules to use.

If a line was too badly mangled to be parsed, it will be ignored and a warning
will be written to your screen.

It returns B<1> on success and B<0> on failure.

Please note that comments are just thrown away by this process and only
tag/value pairs remain afterwards.  Everything else is just instructions to
the parser or how to group together these tag/value pairs.

If it sees something like:  export tag = value, it will export tag's value
to the %ENV hash for you just like it does in a Unix shell script!

Additional modifiers can be found in the comments after a tag/value pair
as well.

=cut

# ==============================================================
sub read_config
{
   DBUG_ENTER_FUNC ( @_ );
   my $file = shift;     # The filename to read ...
   my $cfg  = shift;     # The Advanced::Config object ...

   my $opts = $cfg->get_cfg_settings ();   # The Read Options ...

   # Locate the parent section of the config file.
   my $pcfg = $cfg->get_section ();

   # Using a variable so that we can be recursive in reading config files.
   my $READ_CONFIG;

   DBUG_PRINT ("INFO", "Opening the config file named: %s", $file);

   unless ( open ($READ_CONFIG, "<", $file) ) {
      return DBUG_RETURN ( croak_helper ($opts,
                                        "Unable to open the config file.", 0) );
   }

   # Misuse of this option makes the config file unreadable ...
   if ( $opts->{use_utf8} ) {
      binmode ($READ_CONFIG, "encoding(UTF-8)");
      $pcfg->_allow_utf8 ();   # Tells get_date() that wide char languages are OK!
   }

   # Some common RegExp strings ... Done here to avoid asking repeatably ...
   my $decrypt_str = convert_to_regexp_string ($opts->{decrypt_lbl});
   my $encrypt_str = convert_to_regexp_string ($opts->{encrypt_lbl});
   my $hide_str    = convert_to_regexp_string ($opts->{hide_lbl});
   my $sect_str    = convert_to_regexp_string ($opts->{source_file_section_lbl});

   my $export_str  = convert_to_regexp_string ($opts->{export_lbl});
   my ($lb, $rb) = ( convert_to_regexp_string ($opts->{section_left}),
                     convert_to_regexp_string ($opts->{section_right}) );
   my $assign_str  = convert_to_regexp_string ($opts->{assign});
   my $src_str     = convert_to_regexp_string ($opts->{source});
   my ($lv, $rv) = ( convert_to_regexp_string ($opts->{variable_left}),
                     convert_to_regexp_string ($opts->{variable_right}) );

   # The label separators used when searching for option labels in a comment ...
   my $lbl_sep = '[\s.,$!()-]';

   # Initialize to the default secion ...
   my $section = make_new_section ( $cfg, "" );

   my %hide_section;

   while ( <$READ_CONFIG> ) {
      chomp;
      my $line = $_;             # Save so can use in fish logging later on.

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

   }

   # ---------------------------------------------------------------------------
   # Corrupted variable definition with variables in the comments ...
   # Boy things are getting difficult to parse.  Reverse the previous variable
   # substitutions until the all variables in the comments are unexpanded again!
   # Does a greedy RegExp to grab the 1st comment string encountered.
   # ---------------------------------------------------------------------------
   if ( $unbalanced_leading_var_anchor_with_comments ) {
      $cmts = "";
      foreach my $l (reverse @data) {
         if ( $l =~ m/\s*${comment}\s*(.*)$/ ) {
            $cmts = $1;
            last  unless ( $cmts =~ m/${has_no_cmt}/ );
            $cmts = "";
         }
      }

      if ( $cmts ne "" ) {
         my $cmt2 = convert_to_regexp_string ($cmts);
         $line =~ s/\s*${comment}\s*${cmt2}$//;
         DBUG_PRINT ("LINE", "Unbalanced var def encountered with var comments ...");
         return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
      }

      # If you get here, assume it's not a tag/value pair even if it is!
      # I know I can no longer hope to parse it correctly without a test case.
      # But I really don't think it's possible to get here anymore ...
      warn ("Corrupted variable definition encountered.  Can't split out the comment with variables in it correctly!\n");
      return DBUG_RETURN ( 0, $line, "", "", "");
   }

   # ----------------------------------------------------------------------
   # No variables, no balanced quotes ...
   # But I still think there's a comment to remove!
   # ----------------------------------------------------------------------

   if ( $tv_pair_flag && $value =~ m/(\s*${comment}\s*)(.*)$/ ) {
      $cmts = $2;
      my $cmt2 = convert_to_regexp_string ($1 . $cmts);
      $line =~ s/${cmt2}$//;             # Remove the comment from the line.
      DBUG_PRINT ("LINE", "Last ditch effort to remove the comment from the value ...");
      return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
   }

   $cmts = $line;
   $line =~ s/\s*${comment}.*$//;              # Strip off any comments ....
   $cmts = substr ( $cmts, length ($line) );   # Grab the comments ...
   $cmts =~ s/^\s*${comment}\s*//;             # Remove comment symbol ...

   DBUG_PRINT ("LINE", "Last ditch effort to remove the comment from the line ...");
   DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
}


# ==============================================================

=item ($v[, $h]) = expand_variables ( $config, $string[, $file[, $sensitive[, trim]]] )

This function takes the provided I<$string> and expands any embedded variables
in this string similar to how it's handled by a Unix shell script.

The optional I<$file> tells which file the string was read in from.

The optional I<$sensitive> when set to a non-zero value is used to disable
B<fish> logging when it's turned on because the I<$string> being passed contains
sensitive information.

The optional I<$trim> tells if you may trim the results before it's returned.

It returns the new value $v, once all the variable substitution(s) have
occurred.  And optionally a second return value $h that tells if B<fish> was
paused during the expansion of that value due to something being sensitive.
This 2nd return value $h is meaningless in most situations, so don't ask for it.

All variables are defined as B<${>I<...>B<}>, where I<...> is the variable you
wish to substitute.  If something isn't surrounded by a B<${> + B<}> pair, it's
not a variable.

   A config file exampe:
       tmp1 = /tmp/work-1
       tmp2 = /tmp/work-2
       opt  = 1
       date = 2011-02-03
       logs = ${tmp${opt}}/log-${date}.txt
       date = 2012-12-13

   So when passed "${tmp${opt}}/log-${date}.txt", it would return:
       /tmp/work-1/log-2011-02-03.txt
   And assigned it to B<logs>.

As you can see multiple variable substitutions may be expanded in a single
string as well as nested substitutions.  And when the variable substitution is
done while reading in the config file, all the values used were defined before
the tag was referenced.

Should you call this method after the config file was loaded you get slightly
different results.  In that case the final tag value is used instead and the
2nd date in the above example would have been used in it's place.

See L<Advanced::Config::lookup_one_variable> for more details on how it
evaluates individual variables.

As a final note, if one or more of the referenced variables holds encrypted
values that haven't yet been decrypted, those variables are not resolved.  But
all variables that don't contain encrypted data are resolved.

=cut

# ==============================================================
sub expand_variables
{
   my $config    = shift;           # For the current section of config obj ...
   my $value     = shift;           # The value to parse for variables ...
   my $file      = shift || "";     # The config file the value came from ...
   my $mask_flag = shift || 0;      # Hide/mask sensitive info written to fish?
   my $trim_flag = shift || 0;      # Tells if we should trim the result or not.

   # Only mask ${value} if ${mask_flag} is true ...
   DBUG_MASK_NEXT_FUNC_CALL (1)  if ( $mask_flag );
   DBUG_ENTER_FUNC ( $config, $value, $file, $mask_flag, $trim_flag, @_);

( run in 0.625 second using v1.01-cache-2.11-cpan-df04353d9ac )