view release on metacpan or  search on metacpan

Config.pm  view on Meta::CPAN

   # Get the filename to read ...
   if ( $filename ) {
      $filename = $self->_fix_path ($filename);
   } else {
      $filename = $self->{CONTROL}->{filename};
   }

   # Get the read options ...
   my $new_opts;
   if ( ! defined $read_opts ) {
      my %none;
      $new_opts = \%none;
   } else {
      $read_opts = {@_}  if ( ref ($read_opts) ne "HASH" );
      $new_opts = $read_opts;
   }
   $read_opts = get_read_opts ( $read_opts, $self->{CONTROL}->{read_opts} );

   unless ( $filename ) {
      my $msg = "You must provide a file name to load!";
      return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
   }

   unless ( -f $filename ) {
      my $msg = "No such file or it's unreadable! -- $filename";
      return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
   }

   DBUG_PRINT ("READ", "Reading a config file into memory ... %s", $filename);

   unless ( -f $filename && -r _ ) {
      my $msg = "Your config file name doesn't exist or isn't readable.";
      return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
   }

   # Behaves diferently based on who calls us ...
   my $c = (caller(1))[3] || "";
   my $by  = __PACKAGE__ . "::merge_config";
   my $by2 = __PACKAGE__ . "::_load_config_with_new_date_opts";
   if ( $c eq $by ) {
      # Manually merging in another config file.
      push (@{$self->{CONTROL}->{MERGE}}, $filename);
   } elsif ( $c eq $by2 ) {
      # Sourcing in a file says to remove these old decryption opts.
      delete $read_opts->{alias}            unless ( $new_opts->{alias} );
      delete $read_opts->{pass_phrase}      unless ( $new_opts->{pass_phrase} );
      delete $read_opts->{encrypt_by_user}  unless ( $new_opts->{encrypt_by_user} );
   } else {
      # Loading the original file ...
      $self->_wipe_internal_data ( $filename );
   }

   # Auto add the alias if it's a symbolic link & there isn't an alias.
   # Otherwise decryption won't work!
   if ( -l $filename && ! $read_opts->{alias} ) {
      $read_opts->{alias} = abs_path( $filename );
   }

   # So refresh logic will work ...
   $self->{CONTROL}->{REFRESH_MODIFY_TIME}->{$filename}  = (stat( $filename ))[9];
   $self->{CONTROL}->{REFRESH_READ_OPTIONS}->{$filename} = get_read_opts ($read_opts);

   # So will auto-clear if die is called!
   local $self->{CONTROL}->{RECURSION}->{$filename} = 1;

   # Temp override of the default read options ...
   local $self->{CONTROL}->{read_opts} = $read_opts;

   unless ( read_config ( $filename, $self ) ) {
      my $msg = "Reading the config file had serious issues!";
      return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
   }

   DBUG_RETURN ( $self );
}

#######################################

=item $cfg = $cfg->load_string ( $string[, %override_read_opts] );

This method takes the passed I<$string> and treats it's value as the contents of
a config file.  Modifying the I<$string> afterwards will not affect things.  You
can use this as an alternative to F<load_config>.

Each time you call this method, it wipes the contents of the object and starts
you from a clean slate again.  Making it safe to call multiple times if needed.

The I<%override_read_opts> options apply just to the current call to
I<load_string> and will be forgotten afterwards.  If you want these options
to persist between calls, set the option via the call to B<new()>.  This
argument can be passed either by value or by reference.  Either way will work.
See L<Advanced::Config::Options> for more details.

If you plan on decrypting any values in the string, you must use the B<alias>
option in order for them to be successfully decrypted.

On success, it returns a reference to itself so that it can be initialized
separately or as a single unit.

=cut

sub load_string
{
   DBUG_ENTER_FUNC ( @_ );
   my $self      = shift;
   my $string    = shift;    # The string to treat as a config file's contents.
   my $read_opts = $_[0];    # Don't pop from the stack yet ...

   $self = $self->{PARENT} || $self;

   # Get the read options ...
   $read_opts = {@_}  if ( ref ($read_opts) ne "HASH" );
   $read_opts = get_read_opts ( $read_opts, $self->{CONTROL}->{read_opts} );

   unless ( $string ) {
      my $msg = "You must provide a string to use this method!";
      return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
   }

   # The filename is a reference to the string passed to this method!

Config.pm  view on Meta::CPAN

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

   my $updated = 0;    # Assume no updates ...
   my $skip    = 0;

   # Do a case insensitive lookup of the options hash ...
   foreach my $k ( keys %opts ) {
      next  unless ( $opts{$k} );        # Skip if set to false ...

      if ( $k =~ m/^force$/i ) {
         $updated = 1;       # Force an update ...
      } elsif ( $k =~ m/^test_only$/i ) {
         $skip = 1;          # Skip any refresh of the config file ...
      }
   }

   $self = $self->{PARENT} || $self;      # Force to the "main" section ...

   if ( $self->{CONTROL}->{SENSITIVE_CNT} != sensitive_cnt () ) {
      $updated = 1;
   }

   # If not forcing an update, try to detect any changes to the %ENV hash ...
   unless ( $updated ) {
      DBUG_PRINT ("INFO", "Checking for changes to %ENV ...");
      foreach my $k ( sort keys %{$self->{CONTROL}->{ENV}} ) {
         if ( ! defined $ENV{$k} ) {
            $updated = 1;    # Env. Var. was removed from the environment.
         } elsif ( $ENV{$k} ne $self->{CONTROL}->{ENV}->{$k} ) {
            $updated = 1;    # Env. Var. was modified ...
         }

         if ( $updated ) {
            DBUG_PRINT ("WARN", "ENV{%s} changed it's value!", $k);
            last;
         }
      }
   }

   # If any of the special date vars were referenced in the config file,
   # assume the program's been running long enough for one of them to change!
   my %dates;
   if ( $self->{CONTROL}->{DATE_USED} ) {
      DBUG_PRINT ("INFO", "Checking the special date variables for changes ...");
      my $res = set_special_date_vars ($self->{CONTROL}->{date_opts},
                                       \%dates, $self->{CONTROL}->{DATES});
      if ( $res >= $self->{CONTROL}->{DATE_USED} ) {
         DBUG_PRINT ("WARN", "A referenced special date variable's value changed!");
         $updated = 1;
      } else {
         $dates{timestamp} = $self->{CONTROL}->{DATES}->{timestamp};
      }
   }

   # Try to detect if any config files were modified ...
   unless ( $updated ) {
      DBUG_PRINT ("INFO", "Checking the file timestamps ...");
      foreach my $f ( sort keys %{$self->{CONTROL}->{REFRESH_MODIFY_TIME}} ) {
         # Can't do ref($f) since key is stored as a string here.
         my $modify_time = ( $f =~ m/^SCALAR[(]0x[0-9a-f]+[)]$/ ) ? 0 : (stat( $f ))[9];

         if ( $modify_time > $self->{CONTROL}->{REFRESH_MODIFY_TIME}->{$f} ) {
            DBUG_PRINT ("WARN", "File was modified: %s", $f);
            $updated = 1;
            last;
         }
      }
   }

   # Refresh the config file's contents in memory ...
   if ( $updated && $skip == 0 ) {
      my $f = $self->{CONTROL}->{filename};
      my @mlst = @{$self->{CONTROL}->{MERGE}};
      my $opts = $self->{CONTROL}->{REFRESH_READ_OPTIONS};

      # Update date info gathered earlier only if these vars are used.
      if ( $self->{CONTROL}->{DATE_USED} ) {
         $self->{CONTROL}->{DATES}     = \%dates;
         $self->{CONTROL}->{DATE_USED} = 0;
      }

      my $reload;
      DBUG_PRINT ("LOG", "Calling Load Function ... %s", ref ($f));
      if ( ref ( $f ) eq "SCALAR" ) {
         $reload = $self->load_string ( ${$f}, $opts->{$f} );
      } else {
         $reload = $self->load_config ( $f, $opts->{$f} );
      }
      return DBUG_RETURN ( 0 )  unless ( defined $reload );  # Load failed ???

      foreach my $m (@mlst) {
         DBUG_PRINT ("LOG", "Calling Merge Function ... %s", ref ($m));
         if ( ref ( $m ) eq "SCALAR" ) {
            $self->merge_string ( ${$m}, $opts->{$m} );
         } else {
            $self->merge_config ( $m, $opts->{$m} );
         }
      }
   }

   DBUG_RETURN ( $updated );
}

#######################################

# Private method ...
# Checks for recursion while sourcing in sub-files.
# Returns: 1 (yes) or 0 (no)

sub _recursion_check
{
   DBUG_ENTER_FUNC (@_);
   my $self = shift;
   my $file = shift;

   # Get the main/parent section to work against!
   $self = $self->{PARENT} || $self;

   DBUG_RETURN ( exists $self->{CONTROL}->{RECURSION}->{$file} ? 1 : 0 );
}