Advanced-Config
view release on metacpan or search on metacpan
$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} = $$;
}
$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 behaviour 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;
# 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 );
# 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.
# Returns: The tag hash ... (undef if it doesn't exist)
sub _base_get
{
my $self = shift;
my $tag = shift;
my $opts = 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;
# Returns a hash reference to a local copy of the tag's data ... (or undef)
#######################################
=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
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.
}
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");
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} );
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);
}
=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+$//;
}
#######################################
=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!
$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);
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};
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);
}
}
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 ( );
manipulate the config file. It returns copies of these hashes so feel free to
modify them without fear of affecting the behaviour 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 );
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 ...
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";
lib/Advanced/Config/Options.pm view on Meta::CPAN
$default_read_opts{dbug_test_use_case_parse_override} = 0; # Always off.
# Special undocumented test prog option for overriding fish in read_config().
$default_read_opts{dbug_test_use_case_hide_override} = 0; # Always off.
# ---------------------------------------------------------------------
DBUG_PRINT ("INFO", "Initializing the GET options global hash ...");
# Should always be set in the constructor ...
$default_get_opts{inherit} = 0; # Can inherit from the parent section.
# The generic options ... Who cares where set!
$default_get_opts{required} = 0; # Return undef by default.
$default_get_opts{vcase} = 0; # Case of the value. (0 = as is)
$default_get_opts{split_pattern} = qr /\s+/; # Space separated lists.
# Used in parsing dates for get_date() ...
$default_get_opts{date_language} = "English"; # The language to use in parsing dates.
$default_get_opts{date_language_warn} = 0; # Disable warnings in Date.pm.
$default_get_opts{date_dl_conversion} = 0; # 1-Enable 0-Disable using Date::Language for parsing.
lib/Advanced/Config/Options.pm view on Meta::CPAN
# ==============================================================
=item $ref = apply_get_rules ( $tag, $section, $val1, $val2, $wide, $getOpts )
Returns an updated hash reference containing the requested data value after all
the I<$getOpts> rules have been applied. If the I<$tag> doesn't exist then it
will return B<undef> instead or B<die> if it's I<required>.
I<$val1> is the DATA hash value from the specified section.
I<$val2> is the DATA hash value from the parent section. This value is ignored
unless the I<inherit> option was specified via I<$getOpts>.
I<$wide> tells if UTF-8 dates are allowed.
=cut
# ==============================================================
sub apply_get_rules
{
DBUG_ENTER_FUNC (@_);
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# ==============================================================
sub read_config
{
DBUG_ENTER_FUNC ( @_ );
my $file = shift; # The filename to read ...
my $cfg = shift; # The Advanced::Config object ...
my $opts = $cfg->get_cfg_settings (); # The Read Options ...
# Locate the parent section of the config file.
my $pcfg = $cfg->get_section ();
# Using a variable so that we can be recursive in reading config files.
my $READ_CONFIG;
DBUG_PRINT ("INFO", "Opening the config file named: %s", $file);
unless ( open ($READ_CONFIG, "<", $file) ) {
return DBUG_RETURN ( croak_helper ($opts,
"Unable to open the config file.", 0) );
lib/Advanced/Config/Reader.pm view on Meta::CPAN
my $file = shift || ""; # The config file the value came from ...
my $mask_flag = shift || 0; # Hide/mask sensitive info written to fish?
my $trim_flag = shift || 0; # Tells if we should trim the result or not.
# Only mask ${value} if ${mask_flag} is true ...
DBUG_MASK_NEXT_FUNC_CALL (1) if ( $mask_flag );
DBUG_ENTER_FUNC ( $config, $value, $file, $mask_flag, $trim_flag, @_);
my $opts = $config->get_cfg_settings (); # The Read Options ...
my $pcfg = $config->get_section(); # Get the main/parent section to work with!
# Don't write to Fish if we're hiding any values ...
if ( $mask_flag ) {
DBUG_PAUSE ();
DBUG_MASK ( 0 );
}
# The 1st split of the value into it's component parts ...
my ($left, $tag, $right, $cmt_flag, $mod_tag, $mod_opt, $mod_val, $ot) =
parse_for_variables ( $value, 0, $opts );
( run in 0.244 second using v1.01-cache-2.11-cpan-4d50c553e7e )