Advanced-Config
view release on metacpan or search on metacpan
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
# for "rule 5" & "rule 6" in lookup_one_variable()
# and _find_variables()!
BEGIN
{
DBUG_ENTER_FUNC ();
# -----------------------------------------------
# These are the "Rule 5" special perl varibles.
# Done this way to avoid having to support
# indirect "eval" logic.
# -----------------------------------------------
$begin_special_vars{'0'} = ($0 eq "-e") ? "perl" : $0;
$begin_special_vars{'$'} = $$;
$begin_special_vars{'^O'} = $^O; # MSWin32, aix, etc ...
# ---------------------------------------------
# Start of the "rule 6" initialization ...
# ---------------------------------------------
$begin_special_vars{PID} = $$;
$begin_special_vars{user} = Advanced::Config::Options::_get_user_id ();
$begin_special_vars{hostname} = hostname ();
$begin_special_vars{flavor} = os_type (); # Windows, Unix, etc...
# ---------------------------------------------
# Get the Parent PID if available ... (PPID)
# ---------------------------------------------
eval {
$begin_special_vars{PPID} = getppid ();
};
if ( $@ ) {
DBUG_PRINT ("INFO", "Cheating to get the PPID. It may be wrong!");
# We can't easily get the parent process id for Windows.
# So we're going to cheat a bit. We'll ask if any parent
# or grandparent process used this module before and call it
# the parent process!
$secret_tag = "_ADVANCED_CONFIG_PPID_";
if ( $ENV{$secret_tag} ) {
$begin_special_vars{PPID} = $ENV{$secret_tag};
} 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 ();
}
$cfg = Advanced::Config->new("MyFile.cfg",
{ "assign" => ":=", "comment" => ";" },
{ "required" => 1, "date_language" => "German" },
{ "month_type" => 2, "month_language" => "German" } );
=cut
sub new
{
DBUG_ENTER_FUNC ( @_ );
my $prototype = shift;;
my $filename = shift;
my $read_opts = shift; # A hash ref of "read" options ...
my $get_opts = shift; # Another hash ref of "get" options ...
my $date_opts = shift; # Another hash ref of "date" formatting options ...
my $class = ref ( $prototype ) || $prototype;
my $self = {};
# Create an empty object ...
bless ( $self, $class );
# Creating a new object ... (The main section)
my %control;
# Initialize what options were selected ...
$control{filename} = $self->_fix_path ($filename);
$control{read_opts} = get_read_opts ( $read_opts );
$control{get_opts} = get_get_opts ( $get_opts );
$control{date_opts} = get_date_opts ( $date_opts );
my ( %dates, %empty, %mods, %ropts, %rec, @lst );
# Special Date Variables ...
set_special_date_vars ($control{date_opts}, \%dates);
$control{DATES} = \%dates;
$control{DATE_USED} = 0;
# Environment variables referenced ...
$control{ENV} = \%empty;
# Timestamps & options used for each config file loaded into memory ...
# Controls the refesh logic.
$control{REFRESH_MODIFY_TIME} = \%mods;
$control{REFRESH_READ_OPTIONS} = \%ropts;
# Used to detect recursion ...
$control{RECURSION} = \%rec;
# Used to detect recursion ...
$control{MERGE} = \@lst;
# The count for sensitive entries ...
$control{SENSITIVE_CNT} = sensitive_cnt ();
# Assume not allowing utf8/Unicode/Wide Char dates ...
# Or inside the config file itself.
$control{ALLOW_UTF8} = 0;
# Controls the behavior of this module.
# Only exists in the parent object.
$self->{CONTROL} = \%control;
my $key = $self->{SECTION_NAME} = DEFAULT_SECTION;
my %sections;
$sections{$key} = $self;
$self->{SECTIONS} = \%sections;
# Holds all the tag data for the main section in the config file.
my %data;
$self->{DATA} = \%data;
# Is the data all sensitive?
$self->{SENSITIVE_SECTION} = 0; # No for the default section ...
DBUG_RETURN ( $self );
}
# Only called by Advanced::Config::Reader::read_config() ...
# So not exposed in the POD!
# Didn't rely on read option 'use_utf8' since in many cases
# the option is misleading or just plain wrong!
sub _allow_utf8
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
# Tells calls to Advanced::Config::Options::apply_get_rules() that
# it's ok to use Wide Char Languages like Greek.
my $pcfg = $self->{PARENT} || $self;
$pcfg->{CONTROL}->{ALLOW_UTF8} = 1;
DBUG_VOID_RETURN ();
}
# This private method preps for a clean refresh of the objects contents.
# Kept after the consructor so I can remember to add any new hashes to
# the list below.
sub _wipe_internal_data
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $file = shift; # The main config file
# Wiping the main section automatically wipes everything else ...
$self = $self->{PARENT} || $self;
my ( %env, %mods, %rOpts, %rec, @lst, %sect, %data );
my $key = DEFAULT_SECTION;
$sect{$key} = $self;
$self->{CONTROL}->{filename} = $file;
$self->{CONTROL}->{ENV} = \%env;
$self->{CONTROL}->{REFRESH_MODIFY_TIME} = \%mods;
$self->{CONTROL}->{REFRESH_READ_OPTIONS} = \%rOpts;
$self->{CONTROL}->{RECURSION} = \%rec;
$self->{CONTROL}->{MERGE} = \@lst;
$self->{CONTROL}->{SENSITIVE_CNT} = sensitive_cnt ();
$self->{CONTROL}->{ALLOW_UTF8} = 0;
$self->{SECTIONS} = \%sect;
$self->{DATA} = \%data;
$self->{SENSITIVE_SECTION} = 0; # Not a sensitive section name!
DBUG_VOID_RETURN ();
}
#######################################
# =item $cfg = Advanced::Config->new_section ( $cfg_obj, $section );
# This special case constructor creates a new B<Advanced::Config> object and
# relates it to the given I<$cfg_obj> as a new section named I<$section>.
# It will call die if I<$cfg_obj> is not a valid B<Advanced::Config> object or
# the I<$section> is missing or already in use.
# Returns a reference to this new object.
# =cut
# Stopped exposing to public on 12/30/2019 ... but still used internally.
# In most cases 'create_section' should be called instead!
sub new_section
{
DBUG_ENTER_FUNC ( @_ );
my $prototype = shift;;
my $parent = shift;
my $section = shift;
my $class = ref ( $prototype ) || $prototype;
my $self = {};
# Create an empty object ...
bless ( $self, $class );
if ( ref ( $parent ) ne __PACKAGE__ ) {
die ("You must provide an ", __PACKAGE__, " object as an argument!\n");
}
# 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
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 ...
# 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!
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
{
# 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);
my $value = $self->get_filename ( $tag, $access, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $array_ref = $cfg->get_list_directory ( $tag[, $access[, $pattern[, %override_get_opts]]] );
This is the list version of F<get_directory>. See that function for the meaning
of I<$access>. See F<get_list_values> for the meaning of I<$pattern>.
=cut
sub get_list_directory
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $access = shift; # undef or contains "r", "w" and/or "x" ...
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;
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
my $value = $self->get_directory ( $tag, $access, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
# Private method ...
# Returns (Worked, Hide)
# Caller either wants both values or none of them.
# Should never write to fish ...
sub _base_set
{
my $self = shift;
my $tag = shift;
my $value = shift;
my $file = shift || ""; # The file the tag was defined in.
my $force_sensitive = shift || 0;
my $still_encrypted = shift || 0;
my $has_variables = shift || 0;
# Get the main/parent section to work against!
# my $pcfg = $self->get_section();
my $pcfg = $self->{PARENT} || $self;
# Check if case insensitive handling was requested ...
$tag = lc ($tag) if ( $pcfg->{CONTROL}->{read_opts}->{tag_case} );
if ( $tag =~ m/^shft3+$/i ) {
return ( 0, 0 ); # Set failed ... tag name not allowed.
}
my $hide = ($force_sensitive || $self->{SENSITIVE_SECTION}) ? 1 : 0;
if ( exists $self->{DATA}->{$tag} ) {
$hide = 1 if ( $self->{DATA}->{$tag}->{MASK_IN_FISH} );
} else {
my %data;
$self->{DATA}->{$tag} = \%data;
unless ( $hide ) {
$hide = 1 if ( should_we_hide_sensitive_data ($tag, 1) );
}
}
# The value must never be undefined!
$self->{DATA}->{$tag}->{VALUE} = (defined $value) ? $value : "";
# What file the tag was found in ...
$self->{DATA}->{$tag}->{FILE} = $file;
# Must it be hidden in the fish logs?
$self->{DATA}->{$tag}->{MASK_IN_FISH} = $hide;
# Is the value still encrypted?
$self->{DATA}->{$tag}->{ENCRYPTED} = $still_encrypted ? 1 : 0;
# Does the value still reference variables?
$self->{DATA}->{$tag}->{VARIABLE} = $has_variables ? 1 : 0;
return ( 1, $hide );
}
#######################################
=back
=head2 Manipulating the contents of an Advanced::Config object.
These methods allow you to manipulate the contents of an B<Advanced::Config>
object in many ways. They all just update what's in memory and not the contents
of the config file itself.
So should the contents of this module get refreshed, you will loose any changes
made by these B<4> methods.
=over
=item $ok = $cfg->set_value ( $tag, $value );
Adds the requested I<$tag> and it's I<$value> to the current section in the
I<Advanced::Config> object.
If the I<$tag> already exists, it will be overridden with its new I<$value>.
It returns B<1> on success or B<0> if your request was rejected!
It will also print a warning if it was rejected.
=cut
sub set_value
{
my $self = shift; # Reference to the current section of the object.
my $tag = shift; # The tag set to value ...
my $value = shift;
my ( $worked, $sensitive ) = $self->_base_set ($tag, $value, undef);
DBUG_MASK_NEXT_FUNC_CALL (2) if ( $sensitive );
DBUG_ENTER_FUNC ( $self, $tag, $value, @_ );
unless ( $worked ) {
warn ("You may not use \"${tag}\" as your tag name!\n");
}
DBUG_RETURN ($worked);
}
#######################################
=item $bool = $cfg->rename_tag ( $old_tag, $new_tag );
Renames the tag found in the current section to it's new name. If the
I<$new_tag> already exists it is overwriting by I<$old_tag>. If I<$old_tag>
doesn't exist the rename fails.
Returns B<1> on success, B<0> on failure.
=cut
sub rename_tag
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $old_tag = shift;
my $new_tag = shift;
unless ( defined $old_tag && defined $new_tag ) {
warn ("All arguments to rename_tag() are required!\n");
return DBUG_RETURN (0);
}
if ( $new_tag =~ m/^shft3+$/i ) {
warn ("You may not use \"${new_tag}\" as your new tag name!\n");
return DBUG_RETURN (0);
}
# Get the main/parent section to work against!
my $pcfg = $self->{PARENT} || $self;
# Check if a case insensitive lookup was requested ...
if ( $pcfg->{CONTROL}->{read_opts}->{tag_case} ) {
$old_tag = lc ($old_tag) if ( $old_tag );
$new_tag = lc ($new_tag) if ( $new_tag );
}
if ( $old_tag eq $new_tag ) {
warn ("The new tag name must be different from the old tag name!\n");
return DBUG_RETURN (0);
}
# Was there something to rename ???
if ( exists $self->{DATA}->{$old_tag} ) {
$self->{DATA}->{$new_tag} = $self->{DATA}->{$old_tag};
delete ( $self->{DATA}->{$old_tag} );
return DBUG_RETURN (1);
}
DBUG_RETURN (0);
}
#######################################
=item $bool = $cfg->move_tag ( $tag, $new_section[, $new_tag] );
This function moves the tag from the current section to the specified new
section. If I<$new_tag> was provided that will be the tag's new name in
the new section. If the tag already exists in the new section it will be
overwritten.
If the tag or the new section doesn't exist, the move will fail! It will also
fail if the new section is the current section.
Returns B<1> on success, B<0> on failure.
=cut
sub move_tag
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $tag = shift;
my $new_section = shift;
my $new_tag = shift;
$new_tag = $tag unless ( defined $new_tag );
unless ( defined $tag && defined $new_section ) {
warn ("Both \$tag and \$new_section are required for move_tag()!\n");
return DBUG_RETURN (0);
}
if ( $new_tag =~ m/^shft3+$/i ) {
warn ("You may not use \"${new_tag}\" as your new tag name!\n");
return DBUG_RETURN (0);
}
# Get the main/parent section to work against!
my $pcfg = $self->{PARENT} || $self;
# Check if a case insensitive lookup was requested ...
$tag = lc ($tag) if ( $pcfg->{CONTROL}->{read_opts}->{tag_case} && $tag );
my $cfg = $self->get_section ( $new_section ) || $self;
if ( $self ne $cfg && exists $self->{DATA}->{$tag} ) {
$cfg->{DATA}->{$new_tag} = $self->{DATA}->{$tag};
delete ( $self->{DATA}->{$tag} );
return DBUG_RETURN (1);
}
DBUG_RETURN (0);
}
#######################################
=item $bool = $cfg->delete_tag ( $tag );
This function removes the requested I<$tag> found in the current section from
the configuration data in memory.
Returns B<1> on success, B<0> if the I<$tag> didn't exist.
=cut
sub delete_tag
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $tag = shift;
unless ( defined $tag ) {
return DBUG_RETURN (0); # Nothing to delete!
}
# Get the main/parent section to work against!
my $pcfg = $self->{PARENT} || $self;
# Check if a case insensitive lookup was requested ...
$tag = lc ($tag) if ( $pcfg->{CONTROL}->{read_opts}->{tag_case} && $tag );
# Was there something to delete ???
if ( exists $self->{DATA}->{$tag} ) {
delete ( $self->{DATA}->{$tag} );
return DBUG_RETURN (1);
}
DBUG_RETURN (0);
}
#######################################
=back
=head2 Breaking your Advanced::Config object into Sections.
Defining sections allow you to break up your configuration files into multiple
independent parts. Or in advanced configurations using sections to override
default values defined in the main/unlabled section.
=over
=item $section = $cfg->get_section ( [$section_name[, $required]] );
Returns the I<Advanced::Config> object for the requested section in your config
file. If the I<$section_name> doesn't exist, it will return I<undef>. If
I<$required> is set, it will call B<die> instead.
If no I<$section_name> was provided, it returns the default I<main> section.
=cut
sub get_section
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $section = shift;
my $required = shift || 0;
$self = $self->{PARENT} || $self; # Force to parent section ...
unless ( defined $section ) {
$section = DEFAULT_SECTION;
} elsif ( $section =~ m/^\s*$/ ) {
$section = DEFAULT_SECTION;
} else {
$section = lc ($section);
$section =~ s/^\s+//;
$section =~ s/\s+$//;
}
if ( exists $self->{SECTIONS}->{$section} ) {
return DBUG_RETURN ( $self->{SECTIONS}->{$section} );
}
if ( $required ) {
die ("Section \"$section\" doesn't exist in this ", __PACKAGE__,
" class!\n");
}
DBUG_RETURN (undef);
}
#######################################
=item $name = $cfg->section_name ( );
This function returns the name of the current section I<$cfg> points to.
=cut
sub section_name
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
DBUG_RETURN ( $self->{SECTION_NAME} );
}
#######################################
=item $scfg = $cfg->create_section ( $name );
Creates a new section called I<$name> within the current Advanced::Config object
I<$cfg>. It returns the I<Advanced::Config> object that it created. If a
section of that same name already exists it will return B<undef>.
There is no such thing as sub-sections, so if I<$cfg> is already points to a
section, then it looks up the parent object and associates the new section with
the parent object instead.
=cut
sub create_section
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $name = shift;
# This test bypasses all the die logic in the special case constructor!
# That constructor is no longer exposed in the POD.
if ( $self->get_section ( $name ) ) {
return DBUG_RETURN (undef); # Name is already in use ...
}
DBUG_RETURN ( $self->new_section ( $self, $name ) );
}
#######################################
=back
=head2 Searching the contents of an Advanced::Config object.
This section deals with the methods available for searching for content within
your B<Advanced::Config> object.
=over
=item @list = $cfg->find_tags ( $pattern[, $override_inherit] );
It returns a list of all tags whose name 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 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_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 ) {
push (@lst, $tag);
} else {
my $value = $self->{DATA}->{$tag}->{VALUE};
if ( $value =~ 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);
} else {
my $value = $pcfg->{DATA}->{$tg}->{VALUE};
if ( $value =~ m/$pattern/i ) {
push (@lst, $tg);
}
}
}
@lst = sort (@lst); # Sort the merged list.
}
DBUG_RETURN (@lst);
}
#######################################
=item @list = $cfg->find_sections ( $pattern );
It returns a list of all section names which match this pattern.
If the pattern is B<undef> or the empty string, it will return all the section
names. Otherwise it does a case insensitive comparison of the pattern against
each section name to see if it should be returned or not.
The returned list of section names will be sorted in alphabetical order.
=cut
sub find_sections
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $pattern = shift;
$self = $self->{PARENT} || $self; # Force to parent section ...
my @lst;
foreach my $name ( sort keys %{$self->{SECTIONS}} ) {
unless ( $pattern ) {
push (@lst, $name);
} elsif ( $name =~ m/$pattern/i ) {
push (@lst, $name);
}
}
DBUG_RETURN (@lst);
}
#######################################
=back
=head2 Miscellaneous methods against Advanced::Config object.
These methods while useful don't really fall into a category of their own. So
they are collected here in the miscellaneous section.
=over
=item $file = $cfg->filename ( );
Returns the fully qualified file name used to load the config file into memory.
=cut
sub filename
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
# The request only applies to the parent instance ...
$self = $self->{PARENT} || $self;
DBUG_RETURN( $self->{CONTROL}->{filename} );
}
#######################################
=item ($ropts, $gopts, $dopts) = $cfg->get_cfg_settings ( );
This method returns references to copies of the current options used to
manipulate the config file. It returns copies of these hashes so feel free to
modify them without fear of affecting the behavior of this module.
=cut
sub get_cfg_settings
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
# Get the main/parent section to work against!
my $pcfg = $self->{PARENT} || $self;
my $ctrl = $pcfg->{CONTROL};
my (%r_opts, %g_opts, %d_opts);
%r_opts = %{$ctrl->{read_opts}} if ( $ctrl && $ctrl->{read_opts} );
%g_opts = %{$ctrl->{get_opts}} if ( $ctrl && $ctrl->{get_opts} );
%d_opts = %{$ctrl->{date_opts}} if ( $ctrl && $ctrl->{date_opts} );
DBUG_RETURN ( \%r_opts, \%g_opts, \%d_opts );
}
#######################################
=item $cfg->export_tag_value_to_ENV ( $tag, $value );
Used to export the requested tag/value pair to the %ENV hash. If it's also
marked as an %ENV tag the config file depends on, it updates internal
bookkeeping so that it won't trigger false refreshes.
Once it's been promoted to the %ENV hash the change can't be backed out again.
=cut
sub export_tag_value_to_ENV
{
my $self = shift;
my $tag = shift;
my $value = shift;
my $hide = $_[0] || 0; # Not taken from stack on purpose ...
DBUG_ENTER_FUNC ( $self, $tag, ($hide ? "*"x8 : $value), @_ );
$ENV{$tag} = $value;
# Check if the change afects the refresh logic ...
my $pcfg = $self->{PARENT} || $self;
if ( exists $pcfg->{CONTROL}->{ENV}->{$tag} ) {
$pcfg->{CONTROL}->{ENV}->{$tag} = $value; # It did ...
}
DBUG_VOID_RETURN ();
}
#######################################
=item $sensitive = $cfg->chk_if_sensitive ( $tag[, $override_inherit] );
This function looks up the requested tag in the current section of the config
file and returns if this module thinks the existing value is sensitive (B<1>)
or not (B<0>).
If the tag doesn't exist, it will always return that it isn't sensitive. (B<0>)
An existing tag references sensitive data if one of the following is true.
1) Advanced::Config::Options::should_we_hide_sensitive_data() says it is
or it says the section the tag was found in was sensitive.
2) The config file marked the tag in its comment to HIDE it.
3) The config file marked it as being encrypted.
4) It referenced a variable that was marked as sensitive.
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;
}
# 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
define them in your own config file or with an environment variable of the
same name. But this function doesn't honor any overrides. It just provides
this list on an FYI basis.
The optional I<date_opts> hash allows you to play with the various date formats
available for the special date vars. See B<The Special Date Variable Formatting
Options> section of the Options module for what these options are. Used to
override what was set in the call to new().
=cut
sub print_special_vars
{
DBUG_ENTER_FUNC ( @_ );
my $self = $_[0]; # Will shift later if it's an object as expected!
# Detect if called as part of the object or not.
my $is_obj = ( defined $self && ref($self) eq __PACKAGE__ );
if ( $is_obj ) {
shift; # $cfg->print_special_vars();
} elsif ( defined $self && $self eq __PACKAGE__ ) {
shift; # Advanced::Config->print_special_vars();
} else {
# No shift, called via: Advanced::Config::print_special_vars();
}
my $date_opts = $_[0]; # The optional argument ...
# If it wasn't a hash reference, assume passed by value ...
if ( defined $date_opts && ref ($date_opts) eq "" ) {
my %data = @_;
$date_opts = \%data;
}
# -------------------------------------------------------------
# Start of real work ...
# -------------------------------------------------------------
my ($pcfg, $cmt, $la, $ra, $asgn) = (undef, '#', '${', '}', '=');
if ( $is_obj ) {
# Get the main/parent section to work against!
$pcfg = $self->{PARENT} || $self;
# Look in the Read Options hash for current settings ...
$cmt = $pcfg->{CONTROL}->{read_opts}->{comment};
$la = $pcfg->{CONTROL}->{read_opts}->{variable_left};
$ra = $pcfg->{CONTROL}->{read_opts}->{variable_right};
$asgn = $pcfg->{CONTROL}->{read_opts}->{assign};
}
print STDERR "\n";
print STDERR "${cmt} Examples of the Special Predefined Comment Variable ... (controlled via new)\n";
print STDERR "${cmt} You can't override these variables.\n";
unless ( $is_obj ) {
print STDERR " \${shft3} = #\n";
print STDERR " \${shft33} = ##\n";
print STDERR " \${shft333} = ###\n";
} else {
# Works since Rule # 0 and can't be overridden.
foreach ( "shft3", "shft33", "shft333" ) {
my $v = $self->lookup_one_variable ($_);
print STDERR " ${la}$_${ra} ${asgn} ${v}\n";
}
}
print STDERR " ...\n\n";
print STDERR "${cmt} Any of the variables below can be overridden by putting them\n";
print STDERR "${cmt} into %ENV or predefining them inside your config files!\n\n";
print STDERR "${cmt} The Special Predefined Variables ... (OS/Environment dependant)\n";
foreach my $k ( sort keys %begin_special_vars ) {
print STDERR " ${la}$k${ra} ${asgn} $begin_special_vars{$k}\n";
}
print STDERR "\n";
print STDERR "${cmt} The value of this variable changes based on which section of the config file\n";
print STDERR "${cmt} it's used in! It's value will always match the name of the current section!\n";
my $section = $is_obj ? $self->section_name () : DEFAULT_SECTION;
print STDERR " ${la}section${ra} ${asgn} $section\n";
print STDERR "\n";
my ($opts, %dt);
unless ( $is_obj ) {
$opts = get_date_opts ( $date_opts );
} else {
$opts = get_date_opts ( $date_opts, $pcfg->{CONTROL}->{date_opts} );
}
my $language = $opts->{month_language};
my $type = ( $opts->{use_gmt} ) ? "gmtime" : "localtime";
print STDERR "${cmt} The Special Predefined Date Variables ... (in ${language})\n";
print STDERR "${cmt} The format and language used can vary based on the date options selected.\n";
print STDERR "${cmt} Uses ${type} to convert the current timestamp into the other values.\n";
set_special_date_vars ( $opts, \%dt );
foreach my $k ( sort keys %dt ) {
print STDERR " ${la}$k${ra} ${asgn} $dt{$k}\n";
}
( run in 0.340 second using v1.01-cache-2.11-cpan-df04353d9ac )