view release on metacpan or  search on metacpan

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

Each config file is highly customizable.  Where you are allowed to alter the
comment char from B<#> to anything you like, such as B<;;>.  The same is true
for things like the assignment operator (B<=>), and many other character
sequences with special meaning to this module.

So to avoid confusion, when I talk about a feature, I'll talk about it's default
appearance and let it be safely assumed that the same will hold true if you've
overridden it's default character sequence with something else.  Such as when
discussing comments as 'B<#>', even though you could have overridden it as
'B<;*;>'.  See L<Advanced::Config::Options> for a list of symbols you can
overrides.

You are also allowed to surround your values with balanced quotes or leave them
off entirely.  The only time you must surround your value with quotes is when
you want to preserve leading or trailing spaces in your value.  Without balanced
quotes these spaces are trimmed off.  Also if you need a comment symbol in your
tag's value, the entire value must be surrounded by quotes! Finally, unbalanced
quotes can behave very strangly and are not stripped off.

So in general white space in your config file is basically ignored unless it's
surrounded by printable chars or quotes.

Sorry you can't use a comment symbol as part of your tag's name.

See L<Advanced::Config::Examples> for some sample config files.  You may also
find a lot of example config files in the package you downloaded from CPAN to
install this module from under I<t/config>.

=head1 FUNCTIONS

=over 4

=cut

package Advanced::Config::Reader;

use strict;
use warnings;

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

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

      } elsif ( ! $still_encrypted ) {
         ($value, $hide) = expand_variables ( $cfg, $value, $file, $hide, ($lq ? 0 : 1) );
         if ( $hide == -1 ) {
            # $still_encrypted = $still_variables = 1;
            $still_variables = 1;  # Variable(s) points to encrypted data.
         }
      }

      # Export one value to %ENV ... (once set, can't back it out again!)
      $cfg->export_tag_value_to_ENV ( $tag, $value, $hide )  if ($export_flag);

      # Add to the current section in the Advanced::Config object ...
      $cfg->_base_set ($tag, $value, $file, $hide, $still_encrypted, $still_variables);
   }   # End while reading the config file ...

   close ( $READ_CONFIG );

   DBUG_RETURN (1);
}


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

=item $boolean = source_file ($config, $def_sct, $new_file, $curr_file)

This is a private method called by I<read_config> to source in the requested
config file and merge the results into the current config file.

If I<$def_sct> is given, it will be the name of the current section that the
sourced in file is to use for it's default unlabeled section.  If the default
section name has been hard coded in the config file, this value overrides it.

The I<$new_file> may contain variables and after they are expanded the
source callback function is called before I<load_config()> is called.
See L<Advanced::Config::lookup_one_variable> for rules on variable expansion.

If I<$new_file> is a relative path, it's a relative path from the location
of I<$curr_file>, not the program's current directory!

If a source callback was set up, it will call it here.

This method will also handle the removal of decryption related options if new
ones weren't provided by the callback function.  See Advanced::Config::Options
for more details.

Returns B<1> if the new file successfully loaded.  Else B<0> if something went
wrong during the load!

=cut

sub source_file
{
   DBUG_ENTER_FUNC (@_);
   my $cfg            = shift;
   my $defaultSection = shift;  # The new default section if not "".
   my $new_file       = shift;  # May contain variables to expand ...
   my $old_file       = shift;  # File we're currently parsing. (has abs path)

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

   local $global_sections{OVERRIDE} = $defaultSection  if ( $defaultSection );

   my $pcfg = $cfg->get_section ();  # Back to the main/default section ...

   my $file = $new_file = expand_variables ($pcfg, $new_file, undef, undef, 1);

   # Get the full name of the file we're sourcing in ...
   $file = $pcfg->_fix_path ( $file, dirname ( $old_file ) );

   unless ( -f $file && -r _ ) {
      my $msg = "No such file to source in or it's unreadable ( $file )";
      return DBUG_RETURN ( croak_helper ( $rOpts, $msg, 0 ) );
   }

   if ( $cfg->_recursion_check ( $file ) ) {
      my $msg = "Recursion detected while sourcing in file ( $new_file )";
      if ( $rOpts->{trap_recursion} ) {
         # The request is a fatal error!
         return DBUG_RETURN ( croak_helper ( $rOpts, $msg, 0 ) );
      } else {
         DBUG_PRINT ("RECURSION", $msg);
         return DBUG_RETURN ( 1 );   # Just ignore the request ...
      }
   }

   # The returned callback option(s) will be applied to the current
   # settings, not the default settings if not a compete set!
   my ($r_opts, $d_opts);
   if ( exists $rOpts->{source_cb} && ref ( $rOpts->{source_cb} ) eq "CODE" ) {
      ($r_opts, $d_opts) = $rOpts->{source_cb}->( $file, $rOpts->{source_cb_opts} );
   }

   if ( $rOpts->{inherit_pass_phase} && $rOpts->{pass_phrase} ) {
      my %empty;
      $r_opts = \%empty  unless ( defined $r_opts );
      $r_opts->{pass_phrase} = $rOpts->{pass_phrase}  unless ( $r_opts->{pass_phrase} );
   }

   my $res = $pcfg->_load_config_with_new_date_opts ( $file, $r_opts, $d_opts );

   DBUG_RETURN ( (defined $res) ? 1 : 0 );
}


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

=item $name = make_new_section ($config, $section)

This is a private method called by I<read_config> to create a new section
in the L<Advanced::Config> object if a section of that name doesn't already
exist.

The I<$section> name is allowed to contain variables to expand before the
string is used.  But those variables must be defined in the I<main> section.

Returns the name of the section found/created in lower case.

=cut

sub make_new_section
{
   DBUG_ENTER_FUNC (@_);
   my $config   = shift;
   my $new_name = shift;

   # Check if overriding the default section with a new name ...
   if ( $new_name eq "" || $new_name eq $global_sections{DEFAULT} ) {
      if ( $global_sections{DEFAULT} ne $global_sections{OVERRIDE} ) {
         DBUG_PRINT ("OVERRIDE", "Overriding section '%s' with section '%s'",
                     $new_name, $global_sections{OVERRIDE});
         $new_name = $global_sections{OVERRIDE};
      }
   }

   my $pcfg = $config->get_section ();    # Back to the main section ...

   my $val = expand_variables ($pcfg, $new_name, undef, undef, 1);
   $new_name = lc ( $val );

   # Check if the section name is already in use ...
   my $old = $pcfg->get_section ( $new_name );
   if ( $old ) {
      return DBUG_RETURN ( $old->section_name() );
   }

   # Create the new section now that we know it's name is unique ...
   my $scfg = $pcfg->create_section ( $new_name );

   if ( $scfg ) {
      return DBUG_RETURN ( $scfg->section_name () );
   }

   # Should never, ever happen ...
   DBUG_PRINT ("WARN", "Failed to create the new section: %s.", $new_name);

   DBUG_RETURN ("");    # This is the main/default section being returned.
}


# ==============================================================
# Allows a config file to run a random command when it's loaded into memory.
# Only allowed if explicity enabled & configured!
# Decided it's too dangerous to use, so never called outside of a POC example!
sub _execute_backquoted_cmd
{
   my $rOpts = shift;
   my $hide  = shift;
   my $tag   = shift;
   my $value = shift;

   return ( $value )  unless ( $rOpts->{enable_backquotes} );

   # Left & right backquotes ...
   my ($lbq, $rbq) = ( convert_to_regexp_string ($rOpts->{backquote_left}, 1),
                       convert_to_regexp_string ($rOpts->{backquote_right}, 1) );

   unless ( $value =~ m/^${lbq}(.*)${rbq}$/ ) {
      return ( $value );   # No balanced backquotes detected ...
   }
   my $cmd = $1;           # The command to run ...

   # DBUG_MASK_NEXT_FUNC_CALL (3)  if ( $hide );      # Never hide value (cmd to run)
   DBUG_ENTER_FUNC ($rOpts, $hide, $tag, $value, @_);
   DBUG_MASK (0)  if ( $hide );    # OK to hide the results.

   if ( $cmd =~ m/[`]/ ) {
      DBUG_PRINT ('INFO', 'Your command may not have backquotes (`) in it!');
   } elsif ( $cmd =~ m/^\s*$/ ) {
      DBUG_PRINT ('INFO', 'Your command must have a value!');

   } else {