Advanced-Config
view release on metacpan or search on metacpan
} else {
$begin_special_vars{PPID} = -1; # Can't figure out the PPID.
}
$ENV{$secret_tag} = $$;
}
# -----------------------------------------------------
# Calculate the separator used by the current OS
# when constructing a directory tree. (sep)
# -----------------------------------------------------
my ($a, $b) = ("one", "two");
my $p = File::Spec->catfile ($a, $b);
if ( $p =~ m/^${a}(.+)${b}$/ ) {
$begin_special_vars{sep} = $1; # We have it!
} else {
warn "Unknown separator for current OS!\n";
$begin_special_vars{sep} = ""; # Unknown value!
}
# -----------------------------------------------------
# Calculate the program name minus any path info or
# certain file extensions.
# -----------------------------------------------------
if ( $0 eq "-e" ) {
$begin_special_vars{program} = "perl"; # Perl add hock script!
} else {
$begin_special_vars{program} = basename ($0);
# Remove only certain file extensions from the program's name!
if ( $begin_special_vars{program} =~ m/^(.+)[.]([^.]*)$/ ) {
my ($f, $ext) = ($1, lc ($2));
if ( $ext eq "" || $ext eq "pl" || $ext eq "t" ) {
$begin_special_vars{program} = $f;
}
}
}
DBUG_VOID_RETURN ();
}
# Called automatically when this module goes out of scope ...
# At times this might be called before DESTROY ...
END
{
DBUG_ENTER_FUNC ();
DBUG_VOID_RETURN ();
}
# Called automatically when the current instance of module goes out of scope.
# Only called if new() was successfull!
# At times this might be called after END ...
DESTROY
{
DBUG_ENTER_FUNC ();
DBUG_VOID_RETURN ();
}
# ----------------------------------------------------------------------------
# Helper functions that won't appear in the POD.
# They will all start with "_" in their name.
# But they are still considered members of the object.
# These functions can appear throughout this file.
# ----------------------------------------------------------------------------
# Using Cwd's abs_path() bombs on Windows if the file doesn't exist!
# So I'm doing this conversion myself.
# This function doesn't care if the file actually exists or not!
# It just converts a relative path into an absolute path!
sub _fix_path
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $file = shift || "";
my $dir = shift; # If not provided uses current directory!
if ( $file ) {
# Convert relative paths to absolute path names.
# Removes internal ".", but not ".." in the path info ...
# It also doesn't resolve symbolic links.
unless ( File::Spec->file_name_is_absolute ( $file ) ) {
if ( $dir ) {
$file = File::Spec->rel2abs ( File::Spec->catfile ( $dir, $file ) );
} else {
$file = File::Spec->rel2abs ( $file );
}
}
# Now let's remove any relative path info (..) from the new absolute path.
# Still not resolving any symbolic links on purpose!
# I don't agree with File::Spec->canonpath()'s reasoning for not doing it
# that way. So I need to resolve it myself.
my @parts = File::Spec->splitdir ( $file );
foreach ( 1..$#parts ) {
if ( $parts[$_] eq ".." ) {
$parts[$_] = $parts[$_ - 1] = "";
}
}
# It's smart enough to ignore "" in the array!
$file = File::Spec->catdir (@parts);
}
DBUG_RETURN ( $file );
}
# ----------------------------------------------------------------------------
# Start of the exposed methods in the module ...
# ----------------------------------------------------------------------------
=head1 CONSTRUCTORS
To use this module, you must call C<B<new>()> to create the I<Advanced::Config>
object you wish to work with. All it does is create an empty object for you to
reference and returns the C<Advanced::Config> object created. Once you
have this object reference you are good to go! You can either load an existing
config file into memory or dynamically build your own virtual config file or
even do a mixure of both!
=over
# Make sure it's really the parent object ...
$parent = $parent->{PARENT} || $parent;
# Trim so we can check if unique ...
if ( $section ) {
$section =~ s/^\s+//; $section =~ s/\s+$//;
$section = lc ($section);
}
unless ( $section ) {
die ("You must provide a section name to use this constructor.\n");
}
# Creating a new section for the parent object ...
if ( exists $parent->{SECTIONS}->{$section} ) {
die ("Section \"${section}\" already exists!\n");
}
# Links the parent & child objects together ...
$parent->{SECTIONS}->{$section} = $self;
$self->{SECTION_NAME} = $section;
$self->{PARENT} = $parent;
# Holds all the tag data for this section in the config file.
my %data;
$self->{DATA} = \%data;
# Does this section have a sinsitive name?
# If so, all tags in this section are sensitive!
$self->{SENSITIVE_SECTION} = should_we_hide_sensitive_data ($section, 1);
DBUG_RETURN ( $self );
}
#######################################
=back
=head1 THE METHODS
Once you have your B<Advanced::Config> object initialized, you can manipulate
your object in many ways. You can access individual components of your config
file, modify its contents, refresh its contents and even organize it in
different ways.
Here are your exposed methods to help with this manipulation.
=head2 Loading the Config file into memory.
These methods are used to initialize the contents of an B<Advanced::Config>
object.
=over 4
=item $cfg = $cfg->load_config ( [$filename[, %override_read_opts]] );
This method reads the current I<$filename> into memory and converts it into an
object so that you may reference its contents. The I<$filename> must be defined
either here or in the call to B<new()>.
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_config> 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.
On success, it returns a reference to itself so that it can be initialized
separately or as a single unit.
Ex: $cfg = Advanced::Config->new(...)->load_config (...);
On failure it returns I<undef> or calls B<die> if option I<croak> is set!
WARNING: If basename(I<$filename>) is a symbolic link and your config file
contains encrypted data, please review the encryption options about special
considerations.
=cut
sub load_config
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $filename = shift;
my $read_opts = $_[0]; # Don't pop from the stack yet ...
$self = $self->{PARENT} || $self;
# 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!
my $filename = \$string;
# If there's no alias provided, use a default value for it ...
# There is no filename to use for decryption purposes without it.
$read_opts->{alias} = "STRING" unless ( $read_opts->{alias} );
# Dynamically correct based on type of string ...
$read_opts->{use_utf8} = ( $string =~ m/[^\x00-\xff]/ ) ? 1 : 0;
# Behaves diferently based on who calls us ...
my $c = (caller(1))[3] || "";
my $by = __PACKAGE__ . "::merge_string";
if ( $c eq $by ) {
# Manually merging in another string as a config file.
push (@{$self->{CONTROL}->{MERGE}}, $filename);
} else {
# Loading the original string ...
$self->_wipe_internal_data ( $filename );
}
# So refresh logic will work ...
$self->{CONTROL}->{REFRESH_MODIFY_TIME}->{$filename} = 0; # No timestamp!
$self->{CONTROL}->{REFRESH_READ_OPTIONS}->{$filename} = get_read_opts ($read_opts);
# So will auto-clear if die is called!
If the requested B<tag> couldn't be found, they return B<undef>. But if the
I<required> option was used, it may call B<die> instead!
But normally they just return the requested B<tag>'s value.
They all use F<%override_get_opts>, passed by value or by reference, as an
optional argument that overrides the default options provided in the call
to F<new()>. The I<inherit> and I<required> options discussed above are two
such options. In most cases this hash argument isn't needed. So leave it off
if you are happy with the current defaults!
See the POD under L<Advanced::Config::Options>, I<The Get Options> for more
details on what options you may override.
Only the B<L<get_value>> function was truly needed. But the other I<get>
methods were added for a couple of reasons. First to make it clear in your code
what type of value is being returned and provide the ability to do validation of
the B<tag>'s value without having to validate it yourself! Another benefit was
that it drastically reduced the number of exposed I<Get Options> needed for this
module. Making it easier to use.
Finally when these extra methods apply their validation, if the B<tag>'s value
fails the test, it treats it as a I<B<tag> not found> situation as described
above.
=over
=item $value = $cfg->get_value ( $tag[, %override_get_opts] );
This function looks up the requested B<tag>'s value and returns it.
See common details above.
=cut
sub get_value
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $opt_ref = $_[0]; # The override options ...
$opt_ref = $self->_get_opt_args ( @_ ) if ( defined $opt_ref );
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value );
}
#######################################
# A helper function to handle the various ways to find a hash as an argument!
# Handles all 3 cases.
# undef - No arguments
# hash ref - passed by reference
# something else - passed by value. (array)
sub _get_opt_args
{
my $self = shift; # Reference to the current section.
my $opt_ref = $_[0]; # May be undef, a hash ref, or start of a hash ...
# Convert the parameter array into a regular old hash reference ...
my %opts;
unless ( defined $opt_ref ) {
$opt_ref = \%opts;
} elsif ( ref ($opt_ref) ne "HASH" ) {
%opts = @_;
$opt_ref = \%opts;
}
return ( $opt_ref ); # The hash reference to use ...
}
#######################################
# Another helper function to help with evaluating which value to use ...
# Does a 4 step check.
# 1) Use the $value if provided.
# 2) If the key exists in the hash returned by _get_opt_args(), use it.
# 3) Look it up in the default "Get Options" set via call to new().
# 4) undef if all the above fail.
sub _evaluate_hash_values
{
my $self = shift; # References the current section.
my $key = shift; # The hash key to look up ...
my $ghash = shift; # A hash ref returned by _get_opt_args().
my $value = shift; # Use only if explicitly set ...
unless ( defined $value ) {
if ( defined $ghash && exists $ghash->{$key} ) {
$value = $ghash->{$key}; # Passed via the get options hash ...
} else {
# Use the default from the call to new() ...
my $pcfg = $self->{PARENT} || $self;
if ( exists $pcfg->{CONTROL}->{get_opts}->{$key} ) {
$value = $pcfg->{CONTROL}->{get_opts}->{$key};
}
}
}
return ( $value ); # The value to use ...
}
#######################################
=item $value = $cfg->get_integer ( $tag[, $rt_flag[, %override_get_opts]] );
This function looks up the requested B<tag>'s value and returns it if its an
integer. If the B<tag>'s value is a floating point number (ex 3.6), then the
value is either truncated or rounded up based on the setting of the I<rt_flag>.
If I<rt_flag> is set, it will perform truncation, so 3.6 becomes B<3>. If the
flag is B<undef> or zero, it does rounding, so 3.6 becomes B<4>. Meaning the
default is rounding.
Otherwise if the B<tag> doesn't exist or its value is not numeric it will
return B<undef> unless it's been marked as I<required>. In that case B<die>
may be called instead.
=cut
sub find_tags
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $pattern = shift;
my $inherit = shift; # undef, 0, or 1.
my @lst; # The list of tags found ...
my $pcfg = $self->{PARENT} || $self;
$inherit = $pcfg->{CONTROL}->{get_opts}->{inherit} unless (defined $inherit);
foreach my $tag ( sort keys %{$self->{DATA}} ) {
unless ( $pattern ) {
push (@lst, $tag);
} elsif ( $tag =~ m/${pattern}/i ) {
push (@lst, $tag);
}
}
# Are we searching the parent/main section as well?
if ( $inherit && $pcfg != $self ) {
DBUG_PRINT ("INFO", "Also searching the 'main' section ...");
foreach my $tg ( sort keys %{$pcfg->{DATA}} ) {
# Ignore tags repeated from the current section
next if ( exists $self->{DATA}->{$tg} );
unless ( $pattern ) {
push (@lst, $tg);
} elsif ( $tg =~ m/$pattern/i ) {
push (@lst, $tg);
}
}
@lst = sort ( @lst ); # Sort the merged list.
}
DBUG_RETURN ( @lst );
}
#######################################
# No pod on purpose since exposing it would just cause confusion.
# It's a special case variant for find_tags().
# Just called from Advanced::Config::Reader::apply_modifier.
sub _find_variables
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $pattern = shift;
my %res;
# Find all tags begining with the pattern ...
foreach ( $self->find_tags ("^${pattern}") ) {
$res{$_} = 1;
}
# Find all environment variables starting with the given pattern ...
foreach ( keys %ENV ) {
# Never include these 2 special tags in any list ...
next if ( defined $secret_tag && $secret_tag eq $_ );
next if ( defined $fish_tag && $fish_tag eq $_ );
$res{$_} = 4 if ( $_ =~ m/^${pattern}/ );
}
# Skip checking the Perl special variables we use (rule 5)
# Since it's now part of (rule 6)
# Check the pre-defined module variables ... (rule 6)
foreach ( keys %begin_special_vars ) {
$res{$_} = 6 if ( $_ =~ m/^${pattern}/ );
}
# The special date variables ... (rule 7)
my $pcfg = $self->{PARENT} || $self;
foreach ( keys %{$pcfg->{CONTROL}->{DATES}} ) {
$res{$_} = 7 if ( $_ =~ m/^${pattern}/ );
}
DBUG_RETURN ( sort keys %res );
}
#######################################
=item @list = $cfg->find_values ( $pattern[, $override_inherit] );
It returns a list of all tags whose values contains the passed pattern.
If the pattern is B<undef> or the empty string, it will return all tags in
the current section. Otherwise it does a case insensitive comparison of the
pattern against each tag's value to see if it should be returned or not.
If I<override_inherit> is provided it overrides the current I<inherit> option's
setting. If B<undef> it uses the current I<inherit> setting. If I<inherit>
evaluates to true, it looks in the current section I<and> the main section for
a match. Otherwise it just looks in the current section.
The returned list of tags will be sorted in alphabetical order.
=cut
sub find_values
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $pattern = shift;
my $inherit = shift;
my @lst; # The list of tags found ...
my $pcfg = $self->{PARENT} || $self;
$inherit = $pcfg->{CONTROL}->{get_opts}->{inherit} unless (defined $inherit);
foreach my $tag ( sort keys %{$self->{DATA}} ) {
unless ( $pattern ) {
your config files when they are loaded into memory.
Variables in the config file are surrounded by anchors such as B<${>nameB<}>.
But it's passed as B<name> without any anchors when this method is called.
The precedence for looking up a variable's value to return is as follows:
0. Is it the special "shft3" variable or one of its variants?
1. Look for a tag of that same name previously defined in the current section.
2. If not defined there, look for the tag in the "main" section.
3. Special Case, see note below about periods in the variable name.
4. If not defined there, look for a value in the %ENV hash.
5. If not defined there, does it represent a special Perl variable?
6. If not defined there, is it a predefined Advanced::Config variable?
7. If not defined there, is it some predefined special date variable?
8. If not defined there, the result is undef.
If a variable was defined in the config file, it uses the tag's value when the
line gets parsed. But when you call this method in your code after the config
file has been loaded into memory, it uses the final value for that tag.
The special B<${>shft3B<}> variable is a way to insert comment chars into a
tag's value in the config file when you can't surround it with quotes. This
variable is always case insensitive and if you repeat the B<3> in the name, you
repeat the comment chars in the substitution.
* a = ${shft3} - Returns "#" for a.
* b = ${SHFT33} - Returns "##" for b.
* c = ${ShFt333} - Returns "###" for c.
* etc ...
And since this variable has special meaning, if you try to define one of the
B<SHFT3> variants as a tag in your config file, or call C<set_value> with it,
it will be ignored and a warning will be printed to your screen!
If the variable had a period (B<.>) in it's name, and it doesn't match anything
(rules 0 to 2), it follows rule B<3> and it treats it as a reference to a tag in
another section. So see F<rule_3_section_lookup> for details on how this works.
This module provides you special predefined variables (rules 5, 6 & 7) to help
make your config files more dynamic without the need of a ton of code on your
end. If you want to override the special meaning for these variables, all you
have to do is define a tag in the config file of the same name to override it.
Or just don't use these variables in the 1st place.
For rule B<5>, the special Perl variables you are allowed to reference are:
B<$$>, B<$0>, and B<$^O>. (Each must appear in the config file as: B<${$}>,
B<${0}> or B<${^O}>.)
For rule B<6>, the predefined module variables are: ${PID}, ${PPID}, ${user},
${hostname}, ${program}, ${flavor} and ${sep} (The ${flavor} is defined by
F<Perl::OSType> and ${sep} is the path separator defined by F<File::Spec>
for your OS.) The final variable ${section} tells which section this variable
was used in.
Finally for rule B<7> it provides some special date variables. See
B<F<Advanced::Config::Options::set_special_date_vars>> for a complete list of
what date related variables are defined. The most useful being ${today} and
${yesterday} so that you can dynamically name your log files
F</my_path/my_log.${today}.txt> and you won't need any special date roll logic
to start a new log file.
=cut
sub lookup_one_variable
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $var = shift; # The name of the variable, minus the ${...}.
my $pcfg = $self->{PARENT} || $self; # Get the main section ...
# Silently disable calling "die" or "warn" on all get/set calls ...
local $pcfg->{CONTROL}->{get_opts}->{required} = -9876;
my $opts = $pcfg->{CONTROL}->{read_opts};
# Did we earlier request case insensitive tag lookups?
$var = lc ($var) if ( $opts->{tag_case} );
# The default return values ...
my ( $val, $mask_flag, $file, $encrypt_flag ) = ( undef, 0, "", 0 );
if ( $var =~ m/^shft(3+)$/i ) {
# 0. The special comment variable ... (Can't override)
$val = $1;
my $c = $opts->{comment}; # Usually a "#".
$val =~ s/3/${c}/g;
} else {
# 1. Look in the current section ...
( $val, $mask_flag, $file, $encrypt_flag ) = $self->_base_get2 ( $var );
# 2. Look in the parent section ... (if not already there)
if ( ! defined $val && $self != $pcfg ) {
( $val, $mask_flag, $file, $encrypt_flag ) = $pcfg->_base_get2 ( $var );
}
# 3. Look in the requested section(s) ...
if ( ! defined $val && $var =~ m/[.]/ ) {
($val, $mask_flag, $encrypt_flag) = $self->rule_3_section_lookup ( $var );
}
# 4. Look in the %ENV hash ...
if ( ! defined $val && defined $ENV{$var} ) {
$val = $ENV{$var};
$mask_flag = should_we_hide_sensitive_data ($var);
# Record so refresh logic will work when %ENV vars change.
$pcfg->{CONTROL}->{ENV}->{$var} = $val;
}
# 5. Look at the special Perl variables ... (now done as part of 6.)
# 6. Is it one of the predefined module variables ...
# Variables should either be all upper case or all lower case!
# But allowing for mixed case.
if ( ! defined $val ) {
if ( exists $begin_special_vars{$var} ) {
$val = $begin_special_vars{$var};
} elsif ( exists $begin_special_vars{lc ($var)} ) {
$val = $begin_special_vars{lc ($var)};
( run in 1.489 second using v1.01-cache-2.11-cpan-39bf76dae61 )