Advanced-Config
view release on metacpan or search on metacpan
###
### Copyright (c) 2007 - 2026 Curtis Leach. All rights reserved.
###
### Module: Advanced::Config
=head1 NAME
Advanced::Config - Perl module reads configuration files from various sources.
=head1 SYNOPSIS
use Advanced::Config;
or
require Advanced::Config;
=head1 DESCRIPTION
F<Advanced::Config> is an enhanced implementation of a config file manager
that allows you to manage almost any config file as a true object with a common
interface. It allows you to configure for almost any look and feel inside your
config files.
You will need to create one object per configuration file that you wish to
manipulate. And any updates you make to the object in memory will not make it
back into the config file itself.
It also has options for detecting if the data in the config file has been
updated since you loaded it into memory and allows you to refresh the
configuration object. So that your long running programs never have to execute
against stale configuration data.
This module supports config file features such as variable substitution,
sourcing in other config files, comments, breaking your configuration data
up into sections, encrypting/decrypting individual tag values, and even more ...
So feel free to experiment with this module on the best way to access your
data in your config files. And never have to worry about having multiple
versions of your config files again for Production vs Development vs QA vs
different OS, etc.
=head1 NOTES ON FUNCTIONS WITH MULTIPLE RETURN VALUES
Whenever a function in this module or one if it's helper modules says it can
have multiple return values and you ask for them in scalar mode, it only returns
the first return value. The other return values are tossed. Not the count of
return values as some might expect.
This is because in most cases these secondary return values only have meaning
in special cases. So usually there's no need to grab them unless you plan on
using them.
For a list of the related helper modules see the B<SEE ALSO> section at the
end of this POD. These helper modules are not intended for general use.
=cut
# ---------------------------------------------------------------
package Advanced::Config;
use strict;
use warnings;
# The version of this module!
our $VERSION = "1.14";
use File::Basename;
use File::Copy;
use Sys::Hostname;
use File::Spec;
use Perl::OSType ':all';
use Cwd 'abs_path';
use Advanced::Config::Date;
use Advanced::Config::Options;
use Advanced::Config::Reader;
use Fred::Fish::DBUG 2.09 qw / on_if_set ADVANCED_CONFIG_FISH /;
# The name of the default section ... (even if no sections are defined!)
use constant DEFAULT_SECTION => Advanced::Config::Options::DEFAULT_SECTION_NAME;
# Should only be modifiable via BEGIN ...
my %begin_special_vars;
my $secret_tag;
my $fish_tag;
# This begin block initializes the special variables used
I<load_config>. See L<Advanced::Config::Options> for more details on what
options are available.
And finally if I<$filename> is a relative path, it's relative to the current
directory, not relative to the location of the config file its being merged
into.
Returns B<1> if the config file was loaded and merged. Else B<0>.
=cut
sub merge_config
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $file = shift; # Can be a relative path name if called directly ...
# my $rOpts = shift; # The read options to use ...
my $res = $self->load_config ( $file, @_ );
DBUG_RETURN ( (defined $res) ? 1 : 0 );
}
#######################################
=item $boolean = $cfg->merge_string ( $string[, %override_read_opts] );
Provides a way to merge multiple strings into a single B<Advanced::Config>
object. Modifying the I<$string> afterwards will not affect this object.
Be aware that any tags in common with what's in this string will override the
tag/value pairs from any previous calls to load things into this object.
Just be aware that I<%override_read_opts> is overriding the default options set
during the call to B<new>, not necessarily the same options being used by
I<load_config> or I<load_string>. See L<Advanced::Config::Options> for more
details on what options are available.
Returns B<1> if the string was merged into the object. Else B<0>.
=cut
sub merge_string
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $string = shift; # The string to treat as a config file's contents.
# my $rOpts = shift; # The read options to use ...
my $res = $self->load_string ( $string, @_ );
DBUG_RETURN ( (defined $res) ? 1 : 0 );
}
#######################################
=item $boolean = $cfg->refresh_config ( %refresh_opts );
This boolean function detects if your config file or one of it's dependencies
has been updated. If your config file sources in other config files, those
config files are checked for changes as well.
These changes could be to the config file itself or to any referenced variables
in your config file whose value has changed.
If it detects any updates, then it will reload the config file into memory,
tossing any customizations you may have added via calls to B<set_value()>. It
will keep the current B<Read> options unchanged.
=over 4
=item Supported Refresh Options Are:
"test_only => 1" - It will skip the reloading of the config file even if it
detects something changed. And just tell you if it detected any changes.
"force => 1" - It will assume you know better and that something was updated.
It will almost always return true (B<1>) when used.
=back
It returns true (B<1>) if any updates were detected or the B<force> option was
used. It will return false (B<0>) otherwise.
It will also return false (B<0>) if you never called B<load_conifg()> or
B<load_string()> against this configuration object. In which case there is
nothing to refresh.
=cut
sub refresh_config
{
DBUG_ENTER_FUNC (@_);
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 );
}
#######################################
# Private method ...
# Gets the requested tag from the current section.
# And then apply the required rules against the returned value.
# The {required} option isn't reliable until in this method!
# Returns: The tag hash ... (undef if it doesn't exist)
sub _base_get
{
my $self = shift;
my $tag = shift;
my $opts = shift;
my $disable_req = shift;
# Get the main/parent section to work against!
my $pcfg = $self->{PARENT} || $self;
# Determine what the "get" options must be ...
my $get_opts = $pcfg->{CONTROL}->{get_opts};
$get_opts = get_get_opts ( $opts, $get_opts ) if ( $opts );
# Check if a case insensitive lookup was requested ...
my $t = ( $pcfg->{CONTROL}->{read_opts}->{tag_case} && $tag ) ? lc ($tag) : $tag;
# Check if we're overriding the required flag ...
my $req = $get_opts->{required};
local $get_opts->{required} = $disable_req ? 0 : $req;
# Returns a hash reference to a local copy of the tag's data ... (or undef)
# Handles the inherit option if used.
my $data_ref =apply_get_rules ( $tag, $self->{SECTION_NAME},
$self->{DATA}->{$t}, $pcfg->{DATA}->{$t},
$pcfg->{CONTROL}->{ALLOW_UTF8},
$get_opts );
return ( wantarray ? ($data_ref, $req) : $data_ref );
}
# Private method ...
If a section has no members, it will not appear in the hash.
If I<$dropIfSensitive> is set to a non-zero value, it will not export any data
to the returned hash reference that this module thinks is sensitive.
The returned hash reference has the following keys.
S<$hash_ref-E<gt>{B<section>}-E<gt>{B<tag>}>.
=cut
sub toHash
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $sensitive = shift;
my %data;
foreach my $sect ( $self->find_sections () ) {
# Was the section name itself sensitive ...
next if ( $sensitive && should_we_hide_sensitive_data ( $sect, 1 ) );
my %section_data;
my $cfg = $self->get_section ($sect, 1);
my $cnt = 0;
foreach my $tag ( $cfg->find_tags (undef, 0) ) {
my ($val, $hide) = $cfg->_base_get2 ($tag);
next if ( $sensitive && $hide );
$section_data{$tag} = $val;
++$cnt;
}
# Only add a section that has tags in it!
$data{$sect} = \%section_data if ( $cnt );
}
DBUG_RETURN ( \%data );
}
#######################################
=back
=head2 Encryption/Decryption of your config files.
The methods here deal with the encryption/decryption of your config file before
you use this module to load it into memory. They allow you to make the contents
of your config files more secure.
=over
=item $status = $cfg->encrypt_config_file ( [$file[, $encryptFile[, \%rOpts]]] );
This function encrypts all tag values inside the specified config file that are
marked as ready for encryption and generates a new config file with everything
encrypted. If a tag/value pair isn't marked as ready for encryption it is left
alone. By default this label is B<ENCRYPT>.
After a tag's value has been encrypted, the label in the comment is updated
from B<ENCRYPT> to B<DECRYPT> in the config file.
If you are adding new B<ENCRYPT> tags to an existing config file that already
has B<DECRYPT> tags in it, you must use the same encryption related options in
I<%rOpts> as the last time. Otherwise you won't be able to decrypt all
encrypted values.
Finally if you provide argument I<$encryptFile>, it will write the encrypted
file to that new file instead of overwriting the current file. But if you do
this, you will require the use of the I<alias> option to be able to decrypt
it again using the new name. This file only gets created if the return status
is B<1>.
If you leave off the I<$file> and I<\%rOpts>, it will instead use the values
inherited from the call to B<new>.
This method ignores any request to source in other config files. You must
encrypt each file individually.
It is an error if basename(I<$file>) is a symbolic link and you didn't provide
I<$encryptFile>.
Returns: B<1> if something was encrypted. B<-1> if nothing was encrypted.
Otherwise B<0> on error.
=cut
sub encrypt_config_file
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $file = shift;
my $newFile = shift;
my $rOpts = shift;
my $pcfg = $self->{PARENT} || $self;
my $msg;
if ( $file ) {
$file = $self->_fix_path ( $file );
} elsif ( $pcfg->{CONTROL}->{filename} ) {
$file = $pcfg->{CONTROL}->{filename};
} else {
$msg = "You must provide a file name to encrypt!";
}
unless ( $msg || -f $file ) {
$msg = "No such file to encrypt or it's unreadable! -- $file";
}
if ( -l $file && ! $newFile ) {
$msg = "You can't encrypt a file via it's symbolic link -- $file";
}
my $scratch;
if ( $newFile ) {
$scratch = $self->_fix_path ($newFile);
if ( $scratch eq $file ) {
$msg = "Args: file & encryptFile must be different!";
}
} else {
$scratch = $file . ".$$.encrypted";
}
if ( $rOpts ) {
$rOpts = get_read_opts ($rOpts, $pcfg->{CONTROL}->{read_opts});
} else {
$rOpts = $pcfg->{CONTROL}->{read_opts};
}
if ( $msg ) {
return DBUG_RETURN ( croak_helper ( $rOpts, $msg, 0 ) );
}
my $status = encrypt_config_file_details ($file, $scratch, $rOpts);
# Some type of error ... or nothing was encrypted ...
if ( $status == 0 || $status == -1 ) {
unlink ( $scratch );
# Replacing the original file ...
} elsif ( ! $newFile ) {
unlink ( $file );
move ( $scratch, $file );
}
DBUG_RETURN ( $status );
}
#######################################
=item $status = $cfg->decrypt_config_file ( [$file[, $decryptFile[, \%rOpts]]] );
This function decrypts all tag values inside the specified config file that are
marked as ready for decryption and generates a new config file with everything
decrypted. If a tag/value pair isn't marked as ready for decryption it is left
alone. By default this label is B<DECRYPT>.
After a tag's value has been decrypted, the label in the comment is updated
from B<DECRYPT> to B<ENCRYPT> in the config file.
For this to work, the encryption related options in I<\%rOpts> must match what
was used in the call to I<encrypt_config_file> or the decryption will fail.
Finally if you provide argument I<$decryptFile>, it will write the decrypted
file to that new file instead of overwriting the current file. This file only
gets created if the return status is B<1>.
If you leave off the I<$file> and I<\%rOpts>, it will instead use the values
inherited from the call to B<new>.
This method ignores any request to source in other config files. You must
decrypt each file individually.
It is an error if basename(I<$file>) is a symbolic link and you didn't provide
I<$decryptFile>.
Returns: B<1> if something was decrypted. B<-1> if nothing was decrypted.
Otherwise B<0> on error.
=cut
sub decrypt_config_file
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $file = shift;
my $newFile = shift;
my $rOpts = shift;
my $pcfg = $self->{PARENT} || $self;
my $msg;
if ( $file ) {
$file = $self->_fix_path ( $file );
} elsif ( $pcfg->{CONTROL}->{filename} ) {
$file = $pcfg->{CONTROL}->{filename};
} else {
$msg = "You must provide a file name to encrypt!";
}
unless ( $msg || -f $file ) {
$msg = "No such file to decrypt or it's unreadable! -- $file";
}
if ( -l $file && ! $newFile ) {
$msg = "You can't decrypt a file via it's symbolic link -- $file";
}
my $scratch;
if ( $newFile ) {
$scratch = $self->_fix_path ( $newFile );
if ( $scratch eq $file ) {
$msg = "Args: file & decryptFile must be different!";
}
} else {
$scratch = $file . ".$$.decrypted";
}
( run in 0.529 second using v1.01-cache-2.11-cpan-e1769b4cff6 )