Advanced-Config
view release on metacpan or search on metacpan
} 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 ...
# Gets the requested tag value from the current section.
# Returns: All 5 of the hash members individually ... + required flag setting.
sub _base_get2
{
my $self = shift;
my $tag = shift;
my $opts = shift;
my ($data, $req) = $self->_base_get ( $tag, $opts, 0 );
if ( defined $data ) {
return ( $data->{VALUE}, $data->{MASK_IN_FISH}, $data->{FILE}, $data->{ENCRYPTED}, $data->{VARIABLE}, $req );
} else {
return ( undef, 0, "", 0, 0, $req ); # No such tag ...
}
}
# Private method ...
# Gets the requested tag date value from the current section.
# or treat the tag name as the date if the tag doesn't exist!
# Returns: All 5 of the hash members individually ... + required flag setting.
sub _base_get3_date_str
{
my $self = shift;
my $tag = shift;
my $opts = shift;
my $hyd_flg = shift; # Is it OK to return a HYD as HYD?
my $cvt_hyd_flg = shift; # Is it OK to convert a HYD into a date str?
if ($hyd_flg && $cvt_hyd_flg) {
local $opts->{required} = 1;
croak_helper ($opts, "Programming error! Can't set both hyd flags to true.", undef);
}
my ($data, $req);
{
local $opts->{date_active} = 0;
($data, $req) = $self->_base_get ( $tag, $opts, 1 ); # Does tag exist?
}
# If the tag doesn't exist, use $tag as a date string instead.
unless ( defined $data ) {
my $yr = _validate_date_str ($tag);
if ( defined $yr ) {
return ( $tag, 0, "", 0, 0, $req ); # We have a valid date string!
} elsif ( $hyd_flg && $tag =~ m/^[-]?\d+$/ ) {
return ( $tag, 0, "", 0, 0, $req ); # We have a valid HYD string!
} elsif ( $cvt_hyd_flg && $tag =~ m/^[-]?\d+$/ ) {
my $dt = convert_hyd_to_date_str ($tag);
return ( $dt, 0, "", 0, 0, $req ); # We have a valid date string!
} else {
local $opts->{required} = $req;
croak_helper ($opts, "No such tag ($tag), nor is it a date string.", undef);
return ( undef, 0, "", 0, 0, $req ); # No such tag/date ...
}
}
# The tag exists, then it must reference a date!
local $opts->{date_active} = 1;
($data, $req) = $self->_base_get ( $tag, $opts, 0 );
if ( defined $data ) {
return ( $data->{VALUE}, $data->{MASK_IN_FISH}, $data->{FILE}, $data->{ENCRYPTED}, $data->{VARIABLE}, $req );
} else {
return ( undef, 0, "", 0, 0, $req ); # Not a date ...
}
}
#######################################
=back
=head2 Accessing the contents of an Advanced::Config object.
These methods allow you to access the data loaded into this object.
They all look in the current section for the B<tag> and if the B<tag> couldn't
be found in this section and the I<inherit> option was also set, it will then
look in the parent/main section for the B<tag>. But if the I<inherit> option
wasn't set it wouldn't look there.
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!
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 get_integer
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $rt_flag = shift; # 1 - truncate, 0 - rounding.
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Flag if we should use truncation (2) or rounding (1) if needed ...
local $opt_ref->{numeric} = $rt_flag ? 2 : 1;
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value );
}
#######################################
=item $value = $cfg->get_numeric ( $tag[, %override_get_opts] );
This function looks up the requested B<tag>'s value and returns it if its
value is numeric. Which means any valid integer or floating point number!
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 get_numeric
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Asking for a floating point number ...
local $opt_ref->{numeric} = 3;
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value );
}
#######################################
=item $value = $cfg->get_boolean ( $tag[, %override_get_opts] );
Treats the B<tag>'s value as a boolean value and returns I<undef>,
B<0> or B<1>.
Sometimes you just want to allow for basically a true/false answer
without having to force a particular usage in the config file.
This function converts the B<tag>'s value accordingly.
So it handles pairs like: Yes/No, True/False, Good/Bad, Y/N, T/F, G/B, 1/0,
On/Off, etc. and converts them into a boolean value. This test is case
insensitive. It never returns what's actually in the config file.
If it doesn't recognize something it always returns B<0>.
=cut
sub get_boolean
{
DBUG_ENTER_FUNC ( @_ );
# Tells how to sort the resulting array ...
local $opt_ref->{sort} =
$self->_evaluate_hash_values ("sort", $opt_ref, $sort);
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $hash_ref = $cfg->get_hash_values ( $tag[, $pattern[, $value[, \%merge[, %override_get_opts]]]] );
This method is a bit more complex than L<get_list_values>. Like that method it
splits up the B<tag>'s value into an array. But it then converts that array
into the keys of a hash whose value for each entry is set to I<value>.
Then if the optional I<merge> hash reference was provided, and that key isn't
present in that hash, it adds the missing value to the I<merge> hash. It never
overrides any existing entries in the I<merge> hash!
It always returns the hash reference based on the B<tag>'s split value or an
empty hash if the B<tag> doesn't exist or has no value.
=cut
sub get_hash_values
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $split_ptrn = shift; # The split pattern to use to call to split().
my $hash_value = shift; # Value to assign to each hash member.
my $merge_ref = shift; # A hash to merge the results into
# my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
my $key_vals = $self->get_list_values ($tag, $split_ptrn, 0, @_);
my %my_hash;
if ( $key_vals ) {
# Will we be merging the results into a different hash?
my $m_flg = ( $merge_ref && ref ($merge_ref) eq "HASH" ) ? 1 : 0;
# Build the hash(s) from the array ...
foreach ( @{$key_vals} ) {
$my_hash{$_} = $hash_value;
if ( $m_flg && ! exists $merge_ref->{$_} ) {
$merge_ref->{$_} = $hash_value;
}
}
}
DBUG_RETURN ( \%my_hash );
}
#######################################
=item $array_ref = $cfg->get_list_integer ( $tag[, $rt_flag[, $pattern[, $sort[, %override_get_opts]]]] );
This is the list version of F<get_integer>. See that function for the meaning
of I<$rt_flag>. See F<get_list_values> for the meaning of I<$pattern> and
I<$sort>.
=cut
sub get_list_integer
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $rt_flag = shift; # 1 - truncate, 0 - rounding.
my $split_ptrn = shift; # The split pattern to use to call to split().
my $sort = shift; # The sort order.
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Tells us to split the tag's value up into an array ...
local $opt_ref->{split} = 1;
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
# Tells how to sort the resulting array ...
local $opt_ref->{sort} =
$self->_evaluate_hash_values ("sort", $opt_ref, $sort);
my $value = $self->get_integer ( $tag, $rt_flag, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $array_ref = $cfg->get_list_numeric ( $tag[, $pattern[, $sort[, %override_get_opts]]] );
This is the list version of F<get_numeric>. See F<get_list_values> for the
meaning of I<$pattern> and I<$sort>.
=cut
sub get_list_numeric
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $split_ptrn = shift; # The split pattern to use to call to split().
my $sort = shift; # The sort order.
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Tells us to split the tag's value up into an array ...
local $opt_ref->{split} = 1;
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
# Tells how to sort the resulting array ...
local $opt_ref->{sort} =
$self->_evaluate_hash_values ("sort", $opt_ref, $sort);
my $value = $self->get_numeric ( $tag, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $array_ref = $cfg->get_list_boolean ( $tag[, $pattern[, %override_get_opts]] );
This is the list version of F<get_boolean>. See F<get_list_values> for the
meaning of I<$pattern>.
=cut
sub get_list_boolean
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $split_ptrn = shift; # The split pattern to use to call to split().
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Tells us to split the tag's value up into an array ...
local $opt_ref->{split} = 1;
=item $bool = $cfg->chk_if_still_uses_variables ( $tag[, $override_inherit] );
This function looks up the requested tag in the current section of the config
file and returns if the tag's value contained variables that failed to expand
when the config file was parsed. (B<1> - has variable, B<0> - none.)
If the tag doesn't exist, or you called C<set_value> to create it, this function
will always return B<0> for that tag!
There are only two cases where it can ever return true (B<1>). The first case
is when you used the B<disable_variables> option. The second case is if you
used the B<disable_decryption> option and you had a variable that referenced
a tag that is still encrypted. But use of those two options should be rare.
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 for the tag.
=cut
sub chk_if_still_uses_variables
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $inherit = shift; # undef, 0, or 1.
my $pcfg = $self->{PARENT} || $self;
$inherit = $pcfg->{CONTROL}->{get_opts}->{inherit} unless (defined $inherit);
local $pcfg->{CONTROL}->{get_opts}->{inherit} = $inherit;
my $bool = ($self->_base_get2 ( $tag ))[4];
DBUG_RETURN ( $bool );
}
#######################################
=item $string = $cfg->toString ( [$addEncryptFlags[, \%override_read_opts] );
This function converts the current object into a string that is the equivalent
of the config file loaded into memory without any comments.
If I<$addEncryptFlags> is set to a non-zero value, it will add the needed
comment to the end of each line saying it's waiting to be encrypted. So that
you may later call B<encrypt_string> to encrypt it.
If you provide I<%override_read_opts> it will use the information in that hash
to format the string. Otherwise it will use the defaults from B<new()>.
=cut
sub toString
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $encrypt_flag = shift;
my $read_opts = $self->_get_opt_args ( @_ ); # The override options ...
my $pcfg = $self->{PARENT} || $self;
my $rOpts = get_read_opts ($read_opts, $pcfg->{CONTROL}->{read_opts});
my $cmt = "";
if ( $encrypt_flag ) {
$cmt = " " . format_encrypt_cmt ( $rOpts );
}
my $line;
my $string = "";
my $cnt = 0;
foreach my $name ( $self->find_sections () ) {
my $cfg = $self->get_section ($name);
$line = format_section_line ($name, $rOpts);
$string .= "\n${line}\n";
++$cnt if ( should_we_hide_sensitive_data ( $name, 1 ) );
foreach my $tag ( $cfg->find_tags (undef, 0) ) {
++$cnt if ( $cfg->chk_if_sensitive ($tag, 0) );
$line = format_tag_value_line ($cfg, $tag, $rOpts);
$string .= " " . ${line} . ${cmt} . "\n";
}
}
# Mask the return value if anything seems sensitive.
DBUG_MASK (0) if ( $cnt > 0 );
DBUG_RETURN ( $string );
}
#######################################
=item $hashRef = $cfg->toHash ( [$dropIfSensitive] );
This function converts the current object into a hash reference that is the
equivalent of the config file loaded into memory. Modifying the returned
hash reference will not modify this object's content.
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);
sub decrypt_string
{
DBUG_MASK_NEXT_FUNC_CALL ( 2 ); # mask the alias.
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $string = shift; # The string to treat as a config file's contents.
my $alias = shift; # The alias to use during encryption ...
my $read_opts = $self->_get_opt_args ( @_ ); # The override options ...
unless ( $string ) {
my $msg = "You must provide a string to use this method!";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
unless ( $alias ) {
my $msg = "You must provide an alias 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 $scratch;
my $src_file = \$string;
my $dst_file = \$scratch;
# Put the alias into the read option hash ...
local $read_opts->{alias} = basename ($alias);
my $pcfg = $self->{PARENT} || $self;
my $rOpts = get_read_opts ($read_opts, $pcfg->{CONTROL}->{read_opts});
my $status = decrypt_config_file_details ($src_file, $dst_file, $rOpts);
$scratch = undef if ( $status == 0 );
DBUG_RETURN ( $scratch );
}
#######################################
=back
=head2 Handling Variables in your config file.
These methods are used to resolve variables defined in your config file when
it gets loaded into memory by this module. It is not intended for general use
except as an explanation on how variables work.
=over
=item ($value, $status) = $cfg->lookup_one_variable ( $variable_name );
This method takes the given I<$variable_name> and returns its value.
It returns I<undef> if the given variable doesn't exist. And the optional 2nd
return value tells us about the B<status> of the 1st return value.
If the B<status> is B<-1>, the returned value is still encrypted. If set to
B<1>, the value is considered sensitive. In all other cases this B<status> flag
is set to B<0>.
This method is frequently called internally if you define any variables inside
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)};
} elsif ( exists $begin_special_vars{uc ($var)} ) {
$val = $begin_special_vars{uc ($var)};
} elsif ( $var eq "section" ) {
$val = $self->section_name ();
}
}
# 7. Is it one of the special date variables ...
# All these date vars only use lower case!
if ( ! defined $val ) {
my $lc_var = lc ($var);
if ( defined $pcfg->{CONTROL}->{DATES}->{$lc_var} ) {
$val = $pcfg->{CONTROL}->{DATES}->{$lc_var};
# Record so refresh logic will work when the date changes.
# Values:
# 0 - unknown date variable. (so refresh will ignore it.)
# 1 - MM/DD/YYYY referenced. (refresh on date change.)
# 2 - MM or MM/YYYY referenced. (refresh if the month changes.)
# 3 - YYYY referenced. (refresh if the year changes.)
my $rule = 0;
if ( $lc_var =~ m/^((yesterday)|(today)|(tomorrow)|(dow)|(doy)||(dom))$/ ) {
$rule = 1;
} elsif ( $lc_var =~ m/^((last)|(this)|(next))_month$/ ) {
$rule = 2;
} elsif ( $lc_var =~ m/^((last)|(this)|(next))_period$/ ) {
$rule = 2;
} elsif ( $lc_var =~ m/^((last)|(this)|(next))_year$/ ) {
$rule = 3;
}
# Don't record if {timestamp} used. (rule == 0)
# Save the smallest rule referenced ...
if ( $rule != 0 ) {
if ( $pcfg->{CONTROL}->{DATE_USED} == 0 ) {
$pcfg->{CONTROL}->{DATE_USED} = $rule;
} elsif ( $pcfg->{CONTROL}->{DATE_USED} > $rule ) {
$pcfg->{CONTROL}->{DATE_USED} = $rule;
}
}
}
}
# 8. Then it must be undefined ... (IE: an unknown variable)
}
# Mask the return value in fish ???
DBUG_MASK ( 0 ) if ( $mask_flag);
# Is the return value still encryped ???
$mask_flag = -1 if ( $encrypt_flag );
DBUG_RETURN ( $val, $mask_flag )
}
# ==============================================================
=item ($value, $sens, $encrypt) = $cfg->rule_3_section_lookup ( $variable_name );
When a variable has a period (B<.>) in its name, it could mean that this
variable is referencing a tag from another section of the config file. So this
helper method to F<lookup_one_variable> exists to perform this complex check.
For example, a variable called B<${>xxx.extraB<}> would look in Section "xxx"
for tag "extra".
Here's another example with multiple B<.>'s in its name this time. It would
look up variable B<${>one.two.threeB<}> in Section "one.two" for tag "three".
And if it didn't find it, it would next try Section "one" for tag "two.three".
If it found such a variable, it returns it's value. If it didn't find anything
it returns B<undef>. The optional 2nd and 3rd values tells you more about the
returned value.
I<$sens> is a flag that tells if the data value should be considered sensitive
or not.
I<$encrypt> is a flag that tells if the value still needs to be decrypted or
not.
=cut
sub rule_3_section_lookup
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $var_name = shift; # EX: abc.efg.xyz ...
my ( $val, $fish_mask, $f, $encrypted ) = ( undef, 0, "", 0 );
# If the variable name isn't named correctly ...
if ( $var_name !~ m/\./ ) {
return DBUG_RETURN ($val, $fish_mask, $encrypted);
}
# Silently disable calling "die" or "warn" on all get/set calls ...
my $pcfg = $self->{PARENT} || $self; # Get the main section ...
local $pcfg->{CONTROL}->{get_opts}->{required} = -9876;
# So trailing ... in varname won't cause issues ...
my @parts = split (/\s*[.]\s*/, $var_name . ".!");
pop (@parts); # Remove that pesky trailing "!" I just added!
# Now look for the requested tag in the proper section ...
for ( my $i = $#parts - 1; $i >= 0; --$i ) {
my $section = join (".", (@parts)[0..$i]);
my $sect = $self->get_section ( $section );
next unless ( defined $sect );
my $tag = join (".", (@parts)[$i+1..$#parts]);
( $val, $fish_mask, $f, $encrypted ) = $sect->_base_get2 ( $tag );
# Stop looking if we found anything ...
if ( defined $val ) {
DBUG_PRINT ("RULE-3", "Found Section/Tag: %s/%s", $section, $tag);
last;
}
}
# Controls if the return value needs to be masked in fish ...
DBUG_MASK ( 0 ) if ( $fish_mask );
DBUG_RETURN ( $val, $fish_mask, $encrypted );
}
# ======================================================================
=item $cfg->print_special_vars ( [\%date_opts] );
This function is for those individuals who don't like to read the POD too
closely, but still need a quick and dirty way to list all the special config
file variables supported by this module.
It prints to STDERR the list of these special variables and their current
values. These values can change based on the options used in the call to new()
or what OS you are running under. Or even what today's date is.
Please remember it is possible to override most of these variables if you first
( run in 1.744 second using v1.01-cache-2.11-cpan-140bd7fdf52 )