Advanced-Config
view release on metacpan or search on metacpan
- Corrected POD usage for new() in Cofig.pm.
date_language was listed in wrong hash.
- Fixed tons of typos in the POD for all *.pm files.
1.13 2025-02-13 08:30:00
- Skipped unlucky release 13.
1.12 2025-02-06 08:30:00
- Fixed typo in POD link in Date.pm.
- Fixed t/70-validate_date_vars.t to handle timestamp test on even slower
running machines. Increased delay allowed from 20 sec to 2 min & modified
test msg to say how close it is. Grabbing the current timestamp during the
test is proving problematic. (Problem is with the test, not the module.)
1.11 2025-01-29 08:30:00
- Fixed t/70-validate_date_vars.t to handle timestamp test on slow running
machines.
- Fixed t/10-validate_simple_cfg.t to properly get the userid for all
platforms.
1.10 2025-01-01 08:30:00
- Fixed t/75-check_all_languages.t to ignore buggy language definitions.
- Fixed t/75-check_all_languages.t & t/76-check_all_languages2.t to
make sure it creates the fish log before it tries to load optional
modules. So the developer tests will find the proper number of
fish files. Also speeded up the test cases.
- Fixed POD NAME on all *.pm files to follow Perl standards.
- Corrected various typos in the POD.
- Updated stale links in the POD.
- Config.pm & Options.pm - Added On/Off to get_boolean() & updated the POD
to say so.
- Config.pm - removed depreciated function section().
- Makefile.PL - Fixed build script bug.
- Fixed to require Fred::Fish::DBUG v2.09 so I could use it's new Test module
in the t/*.t test scripts. Simplified a lot of code.
- Updated copyright to 2025 in all files.
1.09 2020-10-05 08:30:00
- Fixed so minimum version of 2.01 required for using Fred::Fish::DBUG.
- Modified all *.pm files to eliminate the BEGIN logic the older versions
of DBUG required.
- Modified all t/*.t test progs to use Fred::Fish::DBUG 2.01 qw / on /;
1.07 2020-02-20 08:30:00
- Updated copyrights to 2020 on all files.
- Made some corrections to the README file.
- Reader.pm - Added an optional trim flag to expand_variables().
- Reader.pm - Fixed balanced quote bug in parse_line().
- Fixed t/60-recursion-test.t & 60-recursion-test.cfg to handle trim
properly.
- 40-validate-modifiers.cfg - Modified to highlight the parse_line()
balanced quote issue was fixed.
- Reader.pm - Fixed disable quotes bug by checking 1st in parse_line()
quote detection section.
- Config.pm - Changed section() to get_section(), depreciating section()
with a stub function that prints warning if used.
- Config.pm - Added create_section() and no longer exposed new_section()
in the POD. Also added new flag SENSITIVE_SECTION to tell if the section
name was sensitive to fix bug in _base_set() & set_value().
- Reader.pm - Fixed to use get_section() & create_section().
- Reader.pm - Fixed hide section bug in read_config().
- t/*.t - Fixed several test cases to use get_section().
- t/11-manual_build.t - Fixed to use create_section() and to also create
a sensitive section to verify masking words correctly for set_value().
- Options.pm - Fixed floating point numeric checks in apply_get_rules().
- 13-alt-get-tests.t & 13-alt-get-tests.cfg - fixed to allow 1. and .1
as valid numeric test values. Also added numeric flag to compare
arrays function. Also added additional floating point tests.
- Options.pm - Fixed sudo bug returning wrong user in _get_user_id().
- Config.pm - Fixed issue with print_special_vars() when called incorrectly.
- Options.pm - Made corrections to the POD.
- Date.pm - Fixed issue with lc/uc. IE: In German -- M RZ vs m rz
- Date.pm - Added wide char flag to _swap_common(), init_special_date_arrays()
and swap_language() to allow for wide char/utf8 support.
in the helper package to calculate which log dir to put the log
file into.
- Reader.pm - fixed perl 5.28 bitwise exclusive or on Unicode strings being
depreciated.
1.06 2019-11-01 08:30:00
- Removed the DBUG_REGISTER call from all modules since it's definition
changed in DBUG (v1.08) and was depreciated.
- Added the 3 back quote options for allowing your config files to run
commands to set a tag's value per a user request. (Disabled by default)
- Then removed it for being too much of a security concern. Left the options
in as comments so I can remember why I backed it out until I can figure out
better protection from malicious actors.
- Improved disable tests in t/20-sensitive.t & it's config file.
- Some minor POD corrections to all the modules.
- Fixed expand_variables() in Reader.pm to continue expanding non-encrypted
variables after an encrypted one was hit when option "disable_decryption"
is used.
- Fixed POD in Options.pm to reflect how "disable_decryption" now works
with variables enabled.
- Added 27-disable_decrypt_test.t to test out this feature.
- Fixed tests t/28-sensitive_tests.t & t/35-improper_tests.t which broke
when we fixed expand_variables().
Never uploaded to CPAN.
1.05 2019-05-30 08:30:00
- Added print_special_vars() as a quick & dirty way to get a list of the
special variables supported by this module.
- Added "section" as a new special variable!
- Added "section" test to t/12-validate_sections.t to validate the new
variable works correctly.
- Options.pm - Added "use_gmt" as a new "Special Date Variable Formatting
Option" to allow the use of gmtime instead of localtime when calculating
the date variable values.
- Options.pm - Fixed bug calculating yesterday/tomorrow when going on/off
daylight savings time during today. Also allowed for leap seconds.
- Config.pm - Removed DBUG code that conflicted with latest release of
the DBUG module (v1.06). So still compatible with earlier releases.
- helper1234.pm - Provided a fix for the DBUG incompatibility issue.
- t/*.t - Fixed all test cases to call the new method in helper1234.pm
for when it would hit the incompatibility.
- Forced t/00-basic.t to enforce minimum module versions for "make test".
Never uploaded to CPAN.
1.04 2019-03-13 08:30:00
- Broke circular references that was requiring the same logic in multiple
manipulate. And any updates you make to the object in memory will not make it
back into the config file itself.
It also has options for detecting if the data in the config file has been
updated since you loaded it into memory and allows you to refresh the
configuration object. So that your long running programs never have to execute
against stale configuration data.
This module supports config file features such as variable substitution,
sourcing in other config files, comments, breaking your configuration data
up into sections, encrypting/decrypting individual tag values, and even more ...
So feel free to experiment with this module on the best way to access your
data in your config files. And never have to worry about having multiple
versions of your config files again for Production vs Development vs QA vs
different OS, etc.
=head1 NOTES ON FUNCTIONS WITH MULTIPLE RETURN VALUES
Whenever a function in this module or one if it's helper modules says it can
have multiple return values and you ask for them in scalar mode, it only returns
the first return value. The other return values are tossed. Not the count of
return values as some might expect.
This is because in most cases these secondary return values only have meaning
in special cases. So usually there's no need to grab them unless you plan on
using them.
For a list of the related helper modules see the B<SEE ALSO> section at the
end of this POD. These helper modules are not intended for general use.
=cut
# ---------------------------------------------------------------
package Advanced::Config;
use strict;
use warnings;
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 ();
# ---------------------------------------------
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!
when this module looks something up in the config file. Feel free to leave as
B<undef> if you're satisfied with this module's default behavior.
F<\%date_var_opts> is an optional hash reference that defines the default
formatting of the special predefined date variables. Feel free to leave as
B<undef> if you're satisfied with the default formatting rules.
See the POD under L<Advanced::Config::Options> for more details on what options
these three hash references support! Look under the S<I<The Read Options>>,
S<I<The Get Options>>, and S<I<The Special Date Variable Formatting Options>>
sections of the POD.
It returns the I<Advanced::Config> object created.
Here's a few examples:
# Sets up an empty object.
$cfg = Advanced::Config->new();
# Just specifies the config file to use ...
$cfg = Advanced::Config->new("MyFile.cfg");
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 );
# 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
{
# 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
Provides a way to merge multiple config files into a single B<Advanced::Config>
object. Useful when the main config file can't source in the passed config
file due to different I<%read_opts> settings, or when a shared config file
can't be modified to source in a sub-config file, or if for some reason you
can't use the I<source_cb> Read Option during the initial load.
Be aware that any tags in common with what's in this file will override the
tag/value pairs from any previous calls to I<load_config> or I<merge_config>.
You may also reference any tags in the previous loads as variables during this
load. And if you have sections in common, it will merge each section's
tag/value pairs as well.
Just be aware that I<%override_read_opts> is overriding the default options set
during the call to B<new>, not necessarily the same options being used by
I<load_config>. See L<Advanced::Config::Options> for more details on what
options are available.
And finally if I<$filename> is a relative path, it's relative to the current
directory, not relative to the location of the config file its being merged
into.
foreach my $k ( keys %opts ) {
next unless ( $opts{$k} ); # Skip if set to false ...
if ( $k =~ m/^force$/i ) {
$updated = 1; # Force an update ...
} elsif ( $k =~ m/^test_only$/i ) {
$skip = 1; # Skip any refresh of the config file ...
}
}
$self = $self->{PARENT} || $self; # Force to the "main" section ...
if ( $self->{CONTROL}->{SENSITIVE_CNT} != sensitive_cnt () ) {
$updated = 1;
}
# If not forcing an update, try to detect any changes to the %ENV hash ...
unless ( $updated ) {
DBUG_PRINT ("INFO", "Checking for changes to %ENV ...");
foreach my $k ( sort keys %{$self->{CONTROL}->{ENV}} ) {
if ( ! defined $ENV{$k} ) {
# 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 $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?
#######################################
=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
=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;
}
#######################################
# 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;
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 );
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 );
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 ( @_ );
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 ...
# Turns on the treat as a boolean option ...
local $opt_ref->{auto_true} = 1;
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value );
There are also a few date related options for I<%override_get_opts> to use that
you may find useful.
See L<Advanced::Config::Date> for more details.
=cut
sub get_date
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $language = shift; # The language the date appears in ...
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
local $opt_ref->{date_active} = 1;
local $opt_ref->{date_language} = $language if ( defined $language );
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
This date format makes it very easy to do math against dates,
See L<Advanced::Config::Date> for more details.
=cut
sub get_hyd_date
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $language = shift; # The language the date appears in ...
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
local $opt_ref->{date_active} = 1;
local $opt_ref->{date_language} = $language if ( defined $language );
my ( $value, $sensitive, $required ) = ($self->_base_get3_date_str ( $tag, $opt_ref, 0, 0 ))[0,1,5];
if ( $sensitive ) {
DBUG_MASK (0);
Finally if B<$tag> still didn't match it checks if it's an integer and it
assumes you want the I<dow> for a I<hyd> date.
See L<Advanced::Config::Date> for more details.
=cut
sub get_dow_date
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $language = shift; # The language the date appears in ...
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
local $opt_ref->{date_active} = 1;
local $opt_ref->{date_language} = $language if ( defined $language );
my ( $value, $sensitive, $required ) = ($self->_base_get3_date_str ( $tag, $opt_ref, 1, 0 ))[0,1,5];
if ( $sensitive ) {
DBUG_MASK (0);
But if the tag B<$tag> doesn't exist in the config file, and it's name is in the
format of I<YYYY-MM-DD>, it will return the I<doy> for that date instead.
See L<Advanced::Config::Date> for more details.
=cut
sub get_doy_date
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $language = shift; # The language the date appears in ...
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
local $opt_ref->{date_active} = 1;
local $opt_ref->{date_language} = $language if ( defined $language );
my ( $value, $sensitive, $required ) = ($self->_base_get3_date_str ( $tag, $opt_ref, 0, 0 ))[0,1,5];
if ( $sensitive ) {
DBUG_MASK (0);
B<$date_str> = get_adjusted_date (I<$hyd>, 0, 0);
See L<Advanced::Config::Date> for more details.
=cut
sub get_adjusted_date
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $adjYrs = shift; # Number of years to adjust.
my $adjMons = shift; # Number of months to adjust.
my $language = shift; # The language the date appears in ...
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
local $opt_ref->{date_active} = 1;
local $opt_ref->{date_language} = $language if ( defined $language );
my ( $value, $sensitive, $required ) = ($self->_base_get3_date_str ( $tag, $opt_ref, 0, 1 ))[0,1,5];
The B<access> levels are B<r> for read, B<w> for write and B<x> for execute.
You may also combine them if you wish in any order.
Ex: B<rw>, B<xwr>, B<rx> ...
=cut
sub get_filename
{
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 $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Verify that the tag's value points to an existing filename ...
local $opt_ref->{filename} = 1; # Existance ...
if ( defined $access ) {
$opt_ref->{filename} |= 2 if ( $access =~ m/[rR]/ ); # -r--
$opt_ref->{filename} |= 4 if ( $access =~ m/[wW]/ ); # --w-
$opt_ref->{filename} |= 2 | 8 if ( $access =~ m/[xX]/ ); # -r-x
The B<access> levels are B<r> for read and B<w> for write. You may also combine
them if you wish in any order. Ex: B<rw> or B<wr>.
=cut
sub get_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" and/or "w" ...
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Verify that the tag's value points to an existing directory ...
# Execute permission is always required to reference a directory's contents.
local $opt_ref->{directory} = 1; # Existance ...
if ( defined $access ) {
$opt_ref->{directory} |= 2 | 8 if ( $access =~ m/[rR]/ ); # dr-x
$opt_ref->{directory} |= 4 | 8 if ( $access =~ m/[wW]/ ); # d-wx
=over
=item $array_ref = $cfg->get_list_values ( $tag[, $pattern[, $sort[, %override_get_opts ]]] );
This function looks up the requested B<tag>'s value and then splits it up into
an array and returns a reference to it.
If I<sort> is 1 it does an ascending sort. If I<sort> is -1, it will do a
descending sort instead. By default it will do no sort.
See the common section above for more details.
=cut
sub get_list_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 $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} =
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 ) {
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 ...
=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} =
=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;
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
This is the list version of F<get_date>. See F<get_list_values> for the
meaning of I<$pattern>. In this case I<$pattern> is a required option since
dates bring unique parsing challenges and the default value usually isn't good
enough.
=cut
sub get_list_date
{
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 $language = shift; # The languate the date appears in ...
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 ... (it's required this time!)
# So allow in either place, argument or option.
=item $array_ref = $cfg->get_list_filename ( $tag[, $access[, $pattern[, %override_get_opts]]] );
This is the list version of F<get_filename>. See that function for the meaning
of I<$access>. See F<get_list_values> for the meaning of I<$pattern>.
=cut
sub get_list_filename
{
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} =
=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} =
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;
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 (@_);
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");
$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;
$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.
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 ) {
}
#######################################
=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;
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);
}
}
}
#######################################
=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
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 );
$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.
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_sensitive
{
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 $sensitive = ($self->_base_get2 ( $tag ))[1];
DBUG_RETURN ( $sensitive );
}
#######################################
=item $encrypted = $cfg->chk_if_still_encrypted ( $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 still encrypted
(B<1>) or not (B<0>).
If the tag doesn't exist, it will always return B<0>!
This module always automatically decrypts everything unless the "Read" option
B<disable_decryption> was used. In that case this method was added to detect
which tags still needed their values decrypted before they were used.
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_encrypted
{
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 $encrypted = ($self->_base_get2 ( $tag ))[3];
DBUG_RETURN ( $encrypted );
}
#######################################
=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];
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";
}
#######################################
=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);
my $cnt = 0;
foreach my $tag ( $cfg->find_tags (undef, 0) ) {
my ($val, $hide) = $cfg->_base_get2 ($tag);
next if ( $sensitive && $hide );
$section_data{$tag} = $val;
++$cnt;
}
# Only add a section that has tags in it!
$data{$sect} = \%section_data if ( $cnt );
}
DBUG_RETURN ( \%data );
}
#######################################
=back
=head2 Encryption/Decryption of your config files.
The methods here deal with the encryption/decryption of your config file before
you use this module to load it into memory. They allow you to make the contents
of your config files more secure.
=over
=item $status = $cfg->encrypt_config_file ( [$file[, $encryptFile[, \%rOpts]]] );
This function encrypts all tag values inside the specified config file that are
marked as ready for encryption and generates a new config file with everything
encrypted. If a tag/value pair isn't marked as ready for encryption it is left
alone. By default this label is B<ENCRYPT>.
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.
* 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;
}
# 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};
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
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 );
}
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 %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} 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};
t/01-basic_regexp.t
t/02-basic_parse_line_01_defaults.t
t/02-basic_parse_line_02_overrides.t
t/02-basic_parse_line_03_same_start_stop.t
t/04-basic.t
t/05-basic_use.t
t/06-basic_require.t
t/09-basic_date.t
t/10-validate_simple_cfg.t
t/11-manual_build.t
t/12-validate_sections.t
t/13-alt-get-tests.t
t/15-validate_multi_source_cfg.t
t/20-validate_encrypt_decrypt.t
t/27-disable_decrypt_test.t
t/28-sensitive_tests.t
t/30-alt_symbols_cfg.t
t/35-improper_tests.t
t/40-validate-modifiers.t
t/50-validate-merge.t
t/55-validate-strings.t
t/56-tohash.t
t/60-recursion-test.t
t/70-validate_date_vars.t
t/75-check_all_languages.t
t/76-check_all_languages2.t
t/99-failure.t
t/log_details/abc.log
t/log_summary/abc.log
t/config/10-simple.cfg
t/config/12-use_sections.cfg
t/config/13-alt-get-tests.cfg
t/config/15-multi_source_01_main.cfg
t/config/15-multi_source_02_first.cfg
t/config/15-multi_source_03_second.cfg
t/config/15-multi_source_04_third.cfg
t/config/20-0-encrypt-decrypt.cfg
t/config/21-0-encrypt-decrypt.cfg
t/config/22-0-encrypt-decrypt.cfg
t/config/25-0-encrypt-decrypt-src.cfg
t/config/27-disable_decrypt_test.cfg
t/config/28-sensitive.cfg
t/config/30-alt_symbol_control.cfg
t/config/30-alt_symbols_01.cfg
t/config/30-alt_symbols_02.cfg
t/config/30-alt_symbols_03.cfg
't/config/30-alt_symbols_04 multi section test.cfg'
't/config/30-alt_symbols_05 space assign.cfg'
't/config/30-alt_symbols_70 merge multiple files.cfg'
t/config/30-alt_symbols_71_empty.cfg
t/config/30-alt_symbols_72_empty.cfg
t/config/30-alt_symbols_80_overlap.cfg
t/config/30-alt_symbols_81_merge_same_file.cfg
t/config/40-validate-modifiers.cfg
t/config/50-merge_a.cfg
t/config/50-merge_b.cfg
t/config/50-merge_c.cfg
Makefile.PL view on Meta::CPAN
$params{ABSTRACT} = 'A powerfull pure perl config file manager.';
}
## An Extra Kwalitee Metric setting.
if ( $ExtUtils::MakeMaker::VERSION >= 6.31 ) {
$params{LICENSE} = 'perl';
}
## An Extra Kwalitee Metric setting.
## The earliest release of Perl I've personally tested this module with!
## Comment out this section out if you wish to try it with an earlier release!
if ( $ExtUtils::MakeMaker::VERSION >= 6.48 ) {
$params{MIN_PERL_VERSION} = '5.008008'; # Perl Version 5.8.8
}
optional ();
WriteMakefile ( %params );
sub optional
{
you have with my module if you provide the following files demonstrating the
bug/issue you are hitting.
1) A sample config file.
2) A sample program that uses the config file and demonstrates the bug.
3) The fish log generated. (optional) But I'll request one if the issue
isn't reproducible on my end with what you gave me.
If it's a true bug, I'll probably use your sample program as the basis for a
new test case in a future release.
See a section below on how to turn on the logs of Fred::Fish::DBUG that
Advanced::Config uses to trace it's functionality to show why the code is
having issues.
# -----------------------------------------------------------------------------
# What if a test case fails?
# -----------------------------------------------------------------------------
In this case there should already be logs to send out. Each and every test
program that comes with this module generates very verbose logging of what's
happening. So just open a CPAN ticket and attach the log to the ticket. Do
not cut and paste the logs contents into the ticket! It just makes the ticket
So only set the 'ADVANCED_CONFIG_FISH' environment variable when you really need
to see detailed logging.
# -----------------------------------------------------------------------------
# Major features of this module:
# -----------------------------------------------------------------------------
1) Supports simple config files. (Tag/Value pairs with comments.)
2) Supports sourcing in other config files to dynamically create one big
config file to reference as a single object.
3) Supports the use of variables in the config file.
4) Supports the use of sections to better organize your config file's data.
5) Supports inheritance between sections.
6) Supports encrypting/decrypting values in your config files to keep
the contents of your config files safe from prying eyes but usable in
your code.
7) Supports the overriding of the default operators used. Such as using
different comment indicators or other special symbols interpreted when
loading the config file into memory.
8) Detecting if a config file has been updated since your program first
loaded it for dynamic refreshes for long running processes.
9) Custom accessor functions (get_*), allowing you to do basic validation
that each tag contains the expected data type.
full_developer_test.pl.src view on Meta::CPAN
local $ENV{FAIL_TEST_99} = 1 if ( $details_flag );
run_make_test ( $make, 0, MAX, "-", "Fred::Fish::DBUG::ON, providing detailed logging. (slow)" );
};
if ( $@ ) {
$detail_msg = $@;
}
my $t2 = time ();
print_status ( $summary_msg, $detail_msg );
printf "Pass 1: %.1f second(s)\n", ($t1 - $t0);
printf "Pass 2: %.1f second(s)\n", ($t2 - $t1);
print "\n";
return;
}
# Run a test suite in the requested mode ...
sub run_make_test
{
my $make = shift; # Which make command to use.
lib/Advanced/Config/Date.pm view on Meta::CPAN
# Built from the optional @Date::Language::English::Dsuf array ...
"1st" => 1, "2nd" => 2, "3rd" => 3, "4th" => 4, "5th" => 5,
"6th" => 6, "7th" => 7, "8th" => 8, "9th" => 9, "10th" => 10,
"11th" => 11, "12th" => 12, "13th" => 13, "14th" => 14, "15th" => 15,
"16th" => 16, "17th" => 17, "18th" => 18, "19th" => 19, "20th" => 20,
"21st" => 21, "22nd" => 22, "23rd" => 23, "24th" => 24, "25th" => 25,
"26th" => 26, "27th" => 27, "28th" => 28, "29th" => 29, "30th" => 30,
"31st" => 31,
# From Date::Manip::Lang::english::Language->{nth} arrays ...
'first' => -1, 'second' => -2, 'third' => -3,
'fourth' => -4, 'fifth' => -5, 'sixth' => -6,
'seventh' => -7, 'eighth' => -8, 'ninth' => -9,
'tenth' => -10, 'eleventh' => -11, 'twelfth' => -12,
'thirteenth' => -13, 'fourteenth' => -14, 'fifteenth' => -15,
'sixteenth' => -16, 'seventeenth' => -17, 'eighteenth' => -18,
'nineteenth' => -19, 'twentieth' => -20, 'twenty-first' => -21,
'twenty-second' => -22, 'twenty-third' => -23, 'twenty-fourth' => -24,
'twenty-fifth' => -25, 'twenty-sixth' => -26, 'twenty-seventh' => -27,
'twenty-eighth' => -28, 'twenty-ninth' => -29, 'thirtieth' => -30,
'thirty-first' => -31,
# From Date::Manip::Lang::english::Language->{nth} arrays ...
'one' => -1, 'two' => -2, 'three' => -3,
'four' => -4, 'five' => -5, 'six' => -6,
'seven' => -7, 'eight' => -8, 'nine' => -9,
'ten' => -10, 'eleven' => -11, 'twelve' => -12,
'thirteen' => -13, 'fourteen' => -14, 'fifteen' => -15,
lib/Advanced/Config/Examples.pm view on Meta::CPAN
=head1 HISTORY
This module started out as a parser of unix shell script data files so that
shell scripts and perl programs could share the same config files. Hence the
support of shell script variables, quotes and the sourcing in of sub-files.
Allowing for limited logic in your config files.
From there it just grew to support non-unix features such as windows batch
files and more generic configuration features. Such as being able handle
various formatting of config files and the ability to obscure or encrypt values
from casual snooping. Or the addition of sections to allow the same config
file to be used on multiple servers and OS.
So today it's a powerful tool that turns your config files into objects your
perl code can reference and manipulate.
=head1 SURROUNDING A VALUE WITH QUOTES IN YOUR CONFIG FILE
If you surround a value with balanced quotes, those quotes are automatically
removed before that value is assigned to it's tag. Quotes are supported mostly
for readability and as a way to allow comment symbols in your value. Or a way
lib/Advanced/Config/Examples.pm view on Meta::CPAN
By default variables are in the format of B<${>...B<}>. Where ... is your
variable's name and the B<${> & B<}> strings are the default surrounding anchors
that define it as a variable.
For more on this see the following link on Parameter Expansion:
L<https://web.archive.org/web/20200309072646/https://wiki.bash-hackers.org/syntax/pe>
This module supports most of the parameter expansions listed in the link except
for those dealing with arrays. Other modifier rules may be added upon request.
Things get a bit more complex evaluating variables if you've defined sections
in your config file.
See the POD for B<lookup_one_variable>() in L<Advanced::Config> for step by step
instructions on expanding a variable's name.
For a list of special variables try calling:
S<Advanced::Config-E<gt>print_special_vars();>
=head1 SOURCING IN OTHER CONFIG FILES
lib/Advanced/Config/Examples.pm view on Meta::CPAN
If recursion is detected, this module silently refuses to reload the problem
config file and breaks the recursion. But you have the option of treating it
as a fatal error instead. Recursion is detected even if you source in a
symbolic link back to the original file.
It is always a fatal error if the requested config file doesn't exist!
=head1 CONTROLLING THE PARSING OF YOUR CONFIG FILES
See I<The Read Options> section of L<Advanced::Config::Options> for what options
are available for customizing how your configuration files gets parsed.
While I<The Get Options> section covers options for looking up the value for
a given tag generated.
=head1 ENCRYPTING VALUES IN YOUR CONFIG FILE
This module has hooks to allow the encryption/decryption of values in your
config file. It can do it in two levels. Simple obscuring of the tag's value
or true encryption/decryption. See L<Advanced::Config::Options> for more
details on how to do this.
=head1 CONFIG FILE EXAMPLES
lib/Advanced/Config/Examples.pm view on Meta::CPAN
# This shows that you can put some logic in your config files so that
# your config files can be shared across platforms without having
# to have multiple versions of that config file or add complex platform
# specific logic into your perl code.
To load it into memory do:
my $cfg = Advanced::config->new ("complex.cfg")->load_config();
=item BREAKING YOUR CONFIG FILE INTO SECTIONS (section.cfg)
abc = lmn # Has no section, so considered in section "main".
user = me
pwd = nope!
[ host 1 ]
abc = xyz
pwd = password1
[host 2]
abc=abc
pwd = password2
lib/Advanced/Config/Examples.pm view on Meta::CPAN
[ HOST 3 ]
abc = 123
pwd = password3
[ HOST 2 ]
efg = repeat # Section "host 2" has 3 tags in it. "abc", "efg" & "pwd".
[ Host 4 ]
user = you
Please note that section names are case insensitive and the tag abc's value
depends on what section of the config file you are currently looking at. This
way you may repeat tags between sections and know that each section is
independent of each other. As if each section was in its own config file.
Or you can interpret each section as overrides to tags in the main section
using the B<inherit> option. Where if a tag isn't defined in the current
section, it then looks in the main section for it. Say you're on host 1 and
you want to log into your application. You need both a user & pwd pair to do
this. When you look up the pwd, you find it in host 1, but when you try to
look up the user, it can't find it in the current section, so it looks in the
main section for it instead. In effect all 4 sections have all variables from
main included in each section. With the local tags overriding what's in main.
A neat way to handle minor differences that would otherwise require you to
have multiple config files you'd need to keep in sync.
To load it into memory do:
my $cfg = Advanced::config->new ("section.cfg")->load_config();
or
my $cfg = Advanced::config->new ("section.cfg", {inherit => 1})->load_config();
=item SOURCING IN FILES WITH SECTIONS (src_sect.cfg)
By default, when sourcing in another config file it's default section is
also called "B<main>". This is true even when you are sourcing in a file
inside a named section block. That name isn't inherited by default.
And if that config file also uses sections, those section names are preserved.
But sometimes you'd like to source in a sub-file as if any tag appearing
outside a section was defined in the original file's current section. In
that case follow the file name with the appropriate label. Which by default
is B<DEFAULT>.
. simple.cfg # All variables appear in the main section.
[ section 1 ]
. simple.cfg # All variables appear in the main section as well.
[ section 2 ]
. simple.cfg # DEFAULT - all variables from this config file will appear as members of "section 2".
[ section 3 ]
. section.cfg # DEFAULT - tags abc, user & pwd are now in 'section 3', while everything else stays in it's defined section.
To load it into memory do:
my $cfg = Advanced::config->new ("src_sect.cfg")->load_config();
=item USING STRANGE LOOKING CONFIG FILES (product-1.cfg)
Sometimes you want to look at a config file owned by another product that
doesn't follow the formatting expected by this module by default. So this
module allows you a way to provide new rules for parsing a config file to
make these differences irrelevant.
Lets assume this config file used ";", not "#" as the comment char, "::", not
"=" as it's assignment operator, and finally used "include", not "." when
lib/Advanced/Config/Options.pm view on Meta::CPAN
=head2 Z<>
=head1 The Read Options
In most cases the defaults should do nicely for you. But when you share config
files between applications, you may not have any control over the config file's
format. This may also apply if your organization requires a specific format
for its config files.
So this section deals with the options you can use to override how it parses and
interprets the config file when it is loaded into memory. None of these options
below allows leading or trailing spaces in the option's value. And if any are
found, they will be automatically trimmed off before their value is used.
Internal spaces are OK when non-numeric values are expected. In most cases
values with a length of B<0> or B<undef> are not allowed.
Just be aware that some combinations of I<Read> options may result in this
module being unable to parse the config file. If you encounter such a
combination open a CPAN ticket and I'll see what I can do about it. But some
combinations may just be too ambiguous to handle.
lib/Advanced/Config/Options.pm view on Meta::CPAN
names.
B<disable_decryption> - Defaults to B<0>. Set to B<1> if you want to disable
decrypting values that have been marked as encrypted. If a variable references
an encrypted value while disable_decription is active, that variable isn't
expanded.
=cut
# B<enable_backquotes> - Defaults to B<0>. Set to B<1> if you want to enable
# this feature. It's disabled by default since it can be considered a security
# hole if an unauthorized user can modify your config file or your code.
=pod
B<trap_recursion> - Defaults to B<0>. Set to B<1> if you want to treat
recursion as a fatal error when loading a config file. By default it just
ignores the recursion request to prevent infinite loops.
B<source_cb_opts> - A work area for holding values between calls to the
callback function. This is expected to be a hash reference to provide any
lib/Advanced/Config/Options.pm view on Meta::CPAN
B<assign> - Defaults to B<=>. You may use this option to override what string
of characters make up the assignment operator. It's used to split a line
into a tag/value pair. If you want the special case of no separator, IE the
first space separates a tag/value pair, try setting it to B<\\s> since the
interface doesn't allow whitespace as a value.
B<comment> - Defaults to B<#>. This is the comment symbol used when parsing
your config file and everything after it is ignored in most cases. The first
case is when it appears between balanced quotes as part of a tag's value, it's
not considered the start of a comment. The other case is when you put one
of the labels in the comments to override default behavior. (See next section)
B<source> - Defaults to "B<.>". When followed by a file name, this is an
instruction to source in another config file (similar to how it works in a
I<Unix> shell script.) Another common setting for this option is "include".
B<section_left> & B<section_right> - This pair is used to anchor breaking
your config file into multiple independent sections. The defaults are B<[>
and B<]>.
B<variable_left> & B<variable_right> - This pair is used to anchor a variable
definition. Any value between these anchors will be a variable name and it's
value will be used instead, unless you've disabled this expansion. The defaults
are B<${> and B<}>. If you override these anchors to both have the same value,
then the optional variable modifiers are not supported nor are nested variables.
B<quote_left> & B<quote_right> - This pair is used to define what balanced
quotes look like in your config file. By default, it allows you to use either
B<"> or B<'> as a matching pair. But if you override one of them you must
override both. And in that case it can only be with literal values. If the
quotes surrounding a tag's value are balanced, the quotes will be automatically
removed from the value. If they are unbalanced the quotes will not be removed.
=cut
# B<backquote_left> & B<backquote_right> - This pair is used to surround a command
# you wish to run, just like in Perl itself. What the command writes to STDOUT
# becomes the tag's value. Assumes the command takes nothing from STDIN. Due to
# security concerns you must explicitly set these values yourself before they are
# usable. A good value is the backqoute itself (B<`>). But use something else
# if you don't want to be so obvious about it.
=pod
=back
=head2 Modifiers in the trailing Comments for tag/value pairs.
In some cases we need to handle exceptions to the rule. So we define labels
lib/Advanced/Config/Options.pm view on Meta::CPAN
B<encrypt_lbl> - Defaults to "B<ENCRYPT>". Tells this module that you are
waiting for this tag's value to be encrypted in the config file. It assumes
the value is still in clear text. When present it assumes the value is
sensitive as well.
B<decrypt_lbl> - Defaults to "B<DECRYPT>". Tells this module that this value
has already been encrypted and needs to be decrypted before it is used. When
present it assumes that the value is sensitive as well.
B<source_file_section_lbl> - Defaults to "B<DEFAULT>". Tells this module to
use the current section as the default/unlabeled section in the file being
source in. This new value will be inherited should the sourced in file source
in any further files.
=back
=head2 Encryption/Decryption options. (or Encode/Decode options.)
The following options deal with the encryption/decryption of the contents of a
config file. Only the encryption of a tag's value is supported. And this is
triggered by the appropriate label in the comment on the same line after the
lib/Advanced/Config/Options.pm view on Meta::CPAN
config file's contents. It's main use is to prevent casual browsers of your
file system from being able to examine your config files using their favorite
editor to capture sensitive data from your config files.
By default, the I<basename> of the config file's name and the tag's name are the
keys used to encode each value in the config file. This means that each tag's
value in the config file uses a different key to obscure it. But by using just
the defaults, anyone using this module may automatically decode everything in
the config file just by writing a perl program that uses this module.
But by using the options below, you gain additional security even without using
true encryption. Since if you don't know the options used, you can't easily
decode each tag's value even by examining the code. Just be aware that using
too many keys with too similar values could cancel each other out and weaken
the results.
These options are ignored if you've disabled decryption.
When you source in another file in your config files, the current values
for B<alias>, B<pass_phrase> and B<encrypt_by_user> are not inherited. But the
remaining options are. See option B<source_cb> if you need to set them in this
lib/Advanced/Config/Options.pm view on Meta::CPAN
module will "never" examine the contents of this hash!
=back
=head1 ==================================================================
=head2 Z<>
=head1 The Get Options
This section deals with the options you can use to override how the I<B<get>>
methods behave when you try to access the values for individual tags. None
of the options below allows leading or trailing spaces in it's value. If any
are found, they will be automatically trimmed off before their value is used.
Internal spaces are OK.
These options can be set as global defaults via the call to the constructor,
B<new()>, or for individual B<get_...> calls if you don't like the defaults
for individual calls.
But it is strongly recommended that the B<inherit> option only be set in the
constructor and not changed elsewhere. Changing its value between calls can
cause strange behavior if you do so. Since it globally affects how this
module locates the requested tag and affects variable lookups when the
config file is parsed.
After that, where to set the other options is more a personal choice than
anything else.
=over 4
B<inherit> - Defaults to B<0> where each section is independent, the tag either
exists or it doesn't in the section. Set to B<1> if each section should be
considered an override for what's in the main section. IE if tag "abc" doesn't
exist in the current section, it next looks in the main section for it.
B<required> - This controls what happens when the requested tag doesn't exist
in your I<Advanced::Config> object. Set to B<0> to return B<undef> (default),
B<-1> to return B<undef> and write a warning to your screen, B<1> to call
die and terminate your program.
B<vcase> - Controls what case to force all values to. Defaults to B<0> which
says to preserve the case as entered in the config file. Use B<1> to convert
everything to upper case. Use B<-1> to convert everything to lower case.
lib/Advanced/Config/Options.pm view on Meta::CPAN
croak_helper
set_special_date_vars
change_special_date_vars
);
@EXPORT_OK = qw( );
use Advanced::Config::Date;
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_NAME => "main"; # Must be in lower case!
my %default_read_opts;
my %default_get_opts;
my %default_date_opts;
my @hide_from_fish;
# ==============================================================
# Get who you're currrently logged in as.
lib/Advanced/Config/Options.pm view on Meta::CPAN
$default_read_opts{disable_decryption} = 0; # Don't disable decryption!
# $default_read_opts{enable_backquotes} = 0; # Don't allow random command execution.
$default_read_opts{trap_recursion} = 0; # Recursion is ignored, not fatal
$default_read_opts{source_cb} = __PACKAGE__->can ("_source_callback_stub");
$default_read_opts{source_cb_opts} = \%src_empty;
# The file parsing options ...
$default_read_opts{assign} = '='; # The assignment operator
$default_read_opts{comment} = '#'; # The comment symbol
$default_read_opts{source} = '.'; # The file source symbol
$default_read_opts{section_left} = '['; # The start section string
$default_read_opts{section_right} = ']'; # The end section string
$default_read_opts{variable_left} = '${'; # The start variable string
$default_read_opts{variable_right} = '}'; # The end variable string
# Unlikely default values due to security concerns.
# $default_read_opts{backquote_left} = '`'x101; # The start backquote string
# $default_read_opts{backquote_right} = '`'x102; # The end backquote string
# The quote chars ... (Special case doesn't work for anything else.)
# See using_default_quotes() if this changes ...
$default_read_opts{quote_left} = $default_read_opts{quote_right} = "['\"]";
# The tag/value modifiers. These labels are found inside the comments!
$default_read_opts{export_lbl} = "EXPORT"; # Label for a single %ENV.
$default_read_opts{hide_lbl} = "HIDE"; # Mark as sensitive.
$default_read_opts{encrypt_lbl} = "ENCRYPT"; # Pending encryption.
$default_read_opts{decrypt_lbl} = "DECRYPT"; # Already encrypted.
$default_read_opts{source_file_section_lbl} = "DEFAULT"; # Override default.
# The Encrypt/Decrypt options ... (Encode/Decode)
my %empty_encrypt;
$default_read_opts{alias} = "";
$default_read_opts{pass_phrase} = "";
$default_read_opts{inherit_pass_phrase} = 0;
$default_read_opts{encrypt_by_user} = 0;
$default_read_opts{encrypt_cb} = __PACKAGE__->can ("_encryption_callback_stub");
$default_read_opts{encrypt_cb_opts} = \%empty_encrypt;
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
my $ref = \%def;
$ref = _get_opt_base ( $current, $ref ) if ( defined $current );
$ref = _get_opt_base ( $user_opts, $ref ) if ( defined $user_opts );
DBUG_RETURN ( $ref );
}
# ==============================================================
=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 (@_);
my $tag = shift; # The tag we are processing ...
my $section = shift; # The name of the current section ...
my $value1 = shift; # The value hash from the current section ...
my $value2 = shift; # The value hash from the "main" section ...
my $wide_flg = shift; # Tells if langages like Greek are allowed ...
my $get_opts = shift; # The current "Get" options hash ...
# Did we find a value to process?
my $data = $value1;
if ( $get_opts->{inherit} && (! defined $data) ) {
$data = $value2;
}
unless ( defined $data ) {
return DBUG_RETURN ( croak_helper ( $get_opts,
"No such tag ($tag) in section ($section).",
undef ) );
}
# Make a local copy to work with, we don't want to modify the source.
# We're only interested in two entries from the hash: VALUE & MASK_IN_FISH.
# All others are ignored by this method.
my %result = %{$data};
# Do we split up the value? ( Took 2 options to implement the split. )
my @vals;
lib/Advanced/Config/Options.pm view on Meta::CPAN
if ( $run_flg && $fp && $get_opts->{numeric} != 3 ) {
if ( $get_opts->{numeric} == 1 ) {
$v = sprintf ("%.0f", $v); # Round it up ...
} else {
$v = sprintf ("%d", $v); # Truncate it ...
}
}
if ( $err && $run_flg ) {
return DBUG_RETURN ( croak_helper ( $get_opts,
"Value is not numeric ($v) for tag ($tag) in section ($section).",
undef ) );
}
}
# -------------------------------------------------------------------
# Are we expecting to find a date someplace inside this string?
if ( $get_opts->{date_active} ) {
my @order = ( "1", "2", "3", "1,2,3", "1,3,2", "2,3,1", "2,1,3", "3,2,1", "3,1,2" );
my $l = swap_language ( $get_opts->{date_language},
$get_opts->{date_language_warn},
$wide_flg );
my $date = parse_date ( $v, $order[$get_opts->{date_format}],
$get_opts->{date_dl_conversion},
$get_opts->{date_enable_yy} );
if ( $date ) {
$v = $date;
} else {
my $l2 = $get_opts->{date_language} || $l;
return DBUG_RETURN ( croak_helper ( $get_opts,
"Value is not a date ($v) for tag ($tag) in section ($section) for language ($l2).",
undef ) );
}
}
# -------------------------------------------------------------------
# Are we referencing a file?
if ( $get_opts->{filename} ) {
my $valid = 1; # Assume it's a filename ...
$valid = 0 unless ( -f $v );
$valid = 0 if ( ($get_opts->{filename} & 2) && ! -r _ );
lib/Advanced/Config/Options.pm view on Meta::CPAN
# Get today ...
my ($yr, $mon, $day, $hr, $dow, $doy) = $gmt
? (gmtime ($now))[5,4,3,2,6,7]
: (localtime ($now))[5,4,3,2,6,7];
$yr += 1900;
my $month = $month_ref->[$mon];
$dates->{today} = _fmt_date ($sep, $order, $yr, $month, $day);
# Get yesterday's date ...
my $sec = ($hr + 2) * 3600 + 2; # Convert hours to seconds ...
my ($yr2, $mon2, $day2) = $gmt ? (gmtime ($now - $sec))[5,4,3]
: (localtime ($now - $sec))[5,4,3];
$yr2 += 1900;
my $month2 = $month_ref->[$mon2];
$dates->{yesterday} = _fmt_date ($sep, $order, $yr2, $month2, $day2);
# Get tomorrow's date ...
$sec = (24 - $hr + 1) * 3600 + 2; # Convert hours to seconds ...
my ($yr3, $mon3, $day3) = $gmt ? (gmtime ($now + $sec))[5,4,3]
: (localtime ($now + $sec))[5,4,3];
$yr3 += 1900;
my $month3 = $month_ref->[$mon3];
$dates->{tomorrow} = _fmt_date ($sep, $order, $yr3, $month3, $day3);
DBUG_PRINT (" DATES ($day)", "LAST: %s, NOW: %s, NEXT: %s",
$dates->{yesterday}, $dates->{today}, $dates->{tomorrow});
if ( $prev->{today} && $prev->{today} ne $dates->{today} ) {
$what_changed = 1; # The date changed ...
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
use Advanced::Config::Options;
use Advanced::Config;
use Fred::Fish::DBUG 2.09 qw / on_if_set ADVANCED_CONFIG_FISH /;
use File::Basename;
$VERSION = "1.14";
@ISA = qw( Exporter );
@EXPORT = qw( read_config source_file make_new_section parse_line
expand_variables apply_modifier parse_for_variables
format_section_line format_tag_value_line format_encrypt_cmt
encrypt_config_file_details decrypt_config_file_details );
@EXPORT_OK = qw( );
my $skip_warns_due_to_make_test;
my %global_sections;
my $gUserName;
# ==============================================================
# NOTE: It is extreemly dangerous to reference Advanced::Config
# internals in this code. Avoid where possible!!!
# Ask for copies from the module instead.
# ==============================================================
# Any other module initialization done here ...
# This block references initializations done in my other modules.
BEGIN
{
DBUG_ENTER_FUNC ();
# What we call our default section ...
$global_sections{DEFAULT} = Advanced::Config::Options::DEFAULT_SECTION_NAME;
$global_sections{OVERRIDE} = $global_sections{DEFAULT};
$gUserName = Advanced::Config::Options::_get_user_id ();
# Is the code being run via "make test" environment ...
if ( $ENV{PERL_DL_NONLAZY} ||
$ENV{PERL_USE_UNSAFE_INC} ||
$ENV{HARNESS_ACTIVE} ) {
$skip_warns_due_to_make_test = 1;
}
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
# Misuse of this option makes the config file unreadable ...
if ( $opts->{use_utf8} ) {
binmode ($READ_CONFIG, "encoding(UTF-8)");
$pcfg->_allow_utf8 (); # Tells get_date() that wide char languages are OK!
}
# Some common RegExp strings ... Done here to avoid asking repeatably ...
my $decrypt_str = convert_to_regexp_string ($opts->{decrypt_lbl});
my $encrypt_str = convert_to_regexp_string ($opts->{encrypt_lbl});
my $hide_str = convert_to_regexp_string ($opts->{hide_lbl});
my $sect_str = convert_to_regexp_string ($opts->{source_file_section_lbl});
my $export_str = convert_to_regexp_string ($opts->{export_lbl});
my ($lb, $rb) = ( convert_to_regexp_string ($opts->{section_left}),
convert_to_regexp_string ($opts->{section_right}) );
my $assign_str = convert_to_regexp_string ($opts->{assign});
my $src_str = convert_to_regexp_string ($opts->{source});
my ($lv, $rv) = ( convert_to_regexp_string ($opts->{variable_left}),
convert_to_regexp_string ($opts->{variable_right}) );
# The label separators used when searching for option labels in a comment ...
my $lbl_sep = '[\s.,$!()-]';
# Initialize to the default secion ...
my $section = make_new_section ( $cfg, "" );
my %hide_section;
while ( <$READ_CONFIG> ) {
chomp;
my $line = $_; # Save so can use in fish logging later on.
my ($tv, $ln, $cmt, $lq, $rq) = parse_line ( $line, $opts );
if ( $ln eq "" ) {
DBUG_PRINT ("READ", "READ LINE: %s", $line);
next; # Skip to the next line if only comments found.
}
# Check for lines with no tag/value pairs in them ...
if ( ! $tv ) {
DBUG_PRINT ("READ", "READ LINE: %s", $line);
# EX: . ${file} --- Sourcing in ${file} ...
if ( $ln =~ m/^${src_str}\s+(.+)$/i ) {
my $src = $1;
my $def_section = "";
if ( $cmt =~ m/(^|${lbl_sep})${sect_str}(${lbl_sep}|$)/ ) {
$def_section = $section;
}
my $res = source_file ( $cfg, $def_section, $src, $file );
return DBUG_RETURN (0) unless ( $res );
next;
}
# EX: [ ${section} ] --- Starting a new section ...
if ( $ln =~ m/^${lb}\s*(.+?)\s*${rb}$/ ) {
$section = make_new_section ( $cfg, $1 );
$hide_section{$section} = 0; # Assume not sensitive ...
if ( $cmt =~ m/(^|${lbl_sep})${hide_str}(${lbl_sep}|$)/ ||
should_we_hide_sensitive_data ( $section ) ) {
$hide_section{$section} = 1;
}
next;
}
# Don't know what the config file was thinking of ...
# Don't bother expanding any variables encountered.
DBUG_PRINT ("error", "<Previous line ignored. Unknown format!>");
next;
}
# ------------------------------------------------------------------
# If you get here, you know it's a tag/value pair to parse ...
# Don't forget that any comment can include processing instructions!
# ------------------------------------------------------------------
# Go to the requested section ...
$cfg = $pcfg->get_section ( $section, 1 );
my ($tag, $value, $prefix, $t2) = _split_assign ( $opts, $ln );
# Don't export individually if doing a batch export ...
# If the export option is used, invert the meaning ...
my $export_flag = 0; # Assume not exporting this tag to %ENV ...
if ( $prefix ) {
$export_flag = $opts->{export} ? 0 : 1;
} elsif ( $cmt =~ m/(^|${lbl_sep})${export_str}(${lbl_sep}|$)/ ) {
$export_flag = $opts->{export} ? 0 : 1;
}
# Is the line info sensitive & should it be hidden/masked in fish ???
my $hide = 0;
if ( $hide_section{$section} ||
$cmt =~ m/(^|${lbl_sep})${encrypt_str}(${lbl_sep}|$)/ ||
$cmt =~ m/(^|${lbl_sep})${hide_str}(${lbl_sep}|$)/ ||
should_we_hide_sensitive_data ( $tag, 1 ) ) {
$hide = 1 unless ( $opts->{dbug_test_use_case_hide_override} );
}
if ( $hide ) {
# Some random length so we can't assume the value from the mask used!
my $mask = "*"x8;
if ( $value eq "" ) {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
($value, $hide) = expand_variables ( $cfg, $value, $file, $hide, ($lq ? 0 : 1) );
if ( $hide == -1 ) {
# $still_encrypted = $still_variables = 1;
$still_variables = 1; # Variable(s) points to encrypted data.
}
}
# Export one value to %ENV ... (once set, can't back it out again!)
$cfg->export_tag_value_to_ENV ( $tag, $value, $hide ) if ($export_flag);
# Add to the current section in the Advanced::Config object ...
$cfg->_base_set ($tag, $value, $file, $hide, $still_encrypted, $still_variables);
} # End while reading the config file ...
close ( $READ_CONFIG );
DBUG_RETURN (1);
}
# ==============================================================
=item $boolean = source_file ($config, $def_sct, $new_file, $curr_file)
This is a private method called by I<read_config> to source in the requested
config file and merge the results into the current config file.
If I<$def_sct> is given, it will be the name of the current section that the
sourced in file is to use for it's default unlabeled section. If the default
section name has been hard coded in the config file, this value overrides it.
The I<$new_file> may contain variables and after they are expanded the
source callback function is called before I<load_config()> is called.
See L<Advanced::Config::lookup_one_variable> for rules on variable expansion.
If I<$new_file> is a relative path, it's a relative path from the location
of I<$curr_file>, not the program's current directory!
If a source callback was set up, it will call it here.
lib/Advanced/Config/Reader.pm view on Meta::CPAN
Returns B<1> if the new file successfully loaded. Else B<0> if something went
wrong during the load!
=cut
sub source_file
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift;
my $defaultSection = shift; # The new default section if not "".
my $new_file = shift; # May contain variables to expand ...
my $old_file = shift; # File we're currently parsing. (has abs path)
my $rOpts = $cfg->get_cfg_settings (); # The Read Options ...
local $global_sections{OVERRIDE} = $defaultSection if ( $defaultSection );
my $pcfg = $cfg->get_section (); # Back to the main/default section ...
my $file = $new_file = expand_variables ($pcfg, $new_file, undef, undef, 1);
# Get the full name of the file we're sourcing in ...
$file = $pcfg->_fix_path ( $file, dirname ( $old_file ) );
unless ( -f $file && -r _ ) {
my $msg = "No such file to source in or it's unreadable ( $file )";
return DBUG_RETURN ( croak_helper ( $rOpts, $msg, 0 ) );
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
}
my $res = $pcfg->_load_config_with_new_date_opts ( $file, $r_opts, $d_opts );
DBUG_RETURN ( (defined $res) ? 1 : 0 );
}
# ==============================================================
=item $name = make_new_section ($config, $section)
This is a private method called by I<read_config> to create a new section
in the L<Advanced::Config> object if a section of that name doesn't already
exist.
The I<$section> name is allowed to contain variables to expand before the
string is used. But those variables must be defined in the I<main> section.
Returns the name of the section found/created in lower case.
=cut
sub make_new_section
{
DBUG_ENTER_FUNC (@_);
my $config = shift;
my $new_name = shift;
# Check if overriding the default section with a new name ...
if ( $new_name eq "" || $new_name eq $global_sections{DEFAULT} ) {
if ( $global_sections{DEFAULT} ne $global_sections{OVERRIDE} ) {
DBUG_PRINT ("OVERRIDE", "Overriding section '%s' with section '%s'",
$new_name, $global_sections{OVERRIDE});
$new_name = $global_sections{OVERRIDE};
}
}
my $pcfg = $config->get_section (); # Back to the main section ...
my $val = expand_variables ($pcfg, $new_name, undef, undef, 1);
$new_name = lc ( $val );
# Check if the section name is already in use ...
my $old = $pcfg->get_section ( $new_name );
if ( $old ) {
return DBUG_RETURN ( $old->section_name() );
}
# Create the new section now that we know it's name is unique ...
my $scfg = $pcfg->create_section ( $new_name );
if ( $scfg ) {
return DBUG_RETURN ( $scfg->section_name () );
}
# Should never, ever happen ...
DBUG_PRINT ("WARN", "Failed to create the new section: %s.", $new_name);
DBUG_RETURN (""); # This is the main/default section being returned.
}
# ==============================================================
# Allows a config file to run a random command when it's loaded into memory.
# Only allowed if explicity enabled & configured!
# Decided it's too dangerous to use, so never called outside of a POC example!
sub _execute_backquoted_cmd
{
my $rOpts = shift;
lib/Advanced/Config/Reader.pm view on Meta::CPAN
The optional I<$file> tells which file the string was read in from.
The optional I<$sensitive> when set to a non-zero value is used to disable
B<fish> logging when it's turned on because the I<$string> being passed contains
sensitive information.
The optional I<$trim> tells if you may trim the results before it's returned.
It returns the new value $v, once all the variable substitution(s) have
occurred. And optionally a second return value $h that tells if B<fish> was
paused during the expansion of that value due to something being sensitive.
This 2nd return value $h is meaningless in most situations, so don't ask for it.
All variables are defined as B<${>I<...>B<}>, where I<...> is the variable you
wish to substitute. If something isn't surrounded by a B<${> + B<}> pair, it's
not a variable.
A config file exampe:
tmp1 = /tmp/work-1
tmp2 = /tmp/work-2
lib/Advanced/Config/Reader.pm view on Meta::CPAN
As a final note, if one or more of the referenced variables holds encrypted
values that haven't yet been decrypted, those variables are not resolved. But
all variables that don't contain encrypted data are resolved.
=cut
# ==============================================================
sub expand_variables
{
my $config = shift; # For the current section of config obj ...
my $value = shift; # The value to parse for variables ...
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 );
lib/Advanced/Config/Reader.pm view on Meta::CPAN
$sub_tag = lc ($sub_tag) if ( defined $sub_tag );
}
DBUG_RETURN ( $left, $tag, $right, $cmt_flg, $sub_tag, $sub_opr, $sub_val,
$otag );
}
# ==============================================================
=item $string = format_section_line ( $name, \%rOpts )
Uses the given I<Read Options Hash> to generate a section string
from I<$name>.
=cut
sub format_section_line
{
DBUG_ENTER_FUNC ( @_ );
my $name = shift; # The name of the section ...
my $rOpts = shift;
DBUG_RETURN ( $rOpts->{section_left} . " ${name} " . $rOpts->{section_right} );
}
# ==============================================================
=item $string = format_tag_value_line ( $cfg, $tag, \%rOpts )
It looks up the B<tag> in the I<$cfg> object, then it uses the given
I<Read Options Hash> options to format a tag/value pair string.
lib/Advanced/Config/Reader.pm view on Meta::CPAN
my $rOpts = shift;
unlink ( $scratch );
# The labels to search for ...
my $decrypt_str = convert_to_regexp_string ($rOpts->{decrypt_lbl});
my $encrypt_str = convert_to_regexp_string ($rOpts->{encrypt_lbl});
my $hide_str = convert_to_regexp_string ($rOpts->{hide_lbl});
my $assign_str = convert_to_regexp_string ($rOpts->{assign});
my ($lb, $rb) = ( convert_to_regexp_string ($rOpts->{section_left}),
convert_to_regexp_string ($rOpts->{section_right}) );
# The label separators used when searching for option labels in a comment ...
my $lbl_sep = '[\s.,$!-()]';
my $mask = "*"x8;
DBUG_PRINT ("INFO", "Opening for reading the config file named: %s", $file);
unless ( open (ENCRYPT, "<", $file) ) {
return DBUG_RETURN ( croak_helper ($rOpts,
lib/Advanced/Config/Reader.pm view on Meta::CPAN
}
# Misuse of this option makes the config file unreadable ...
if ( $rOpts->{use_utf8} ) {
binmode (ENCRYPT, "encoding(UTF-8)");
binmode (NEW, "encoding(UTF-8)");
}
my $errMsg = "Unable to write to the scratch file.";
my $hide_section = 0;
my $count = 0;
while ( <ENCRYPT> ) {
chomp;
my $line = $_;
my ($tv, $ln, $cmt, $lq, $rq) = parse_line ( $line, $rOpts );
my ($hide, $encrypt) = (0, 0);
my ($tag, $value, $prefix, $t2);
lib/Advanced/Config/Reader.pm view on Meta::CPAN
($tag, $value, $prefix, $t2) = _split_assign ( $rOpts, $ln );
if ( $cmt =~ m/(^|${lbl_sep})${encrypt_str}(${lbl_sep}|$)/ ) {
($hide, $encrypt) = (1, 1);
# Don't hide the decrypt string ... (already unreadable)
} elsif ( $cmt =~ m/(^|${lbl_sep})${hide_str}(${lbl_sep}|$)/ ) {
$hide = 1;
} else {
if ( $hide_section || should_we_hide_sensitive_data ( $tag, 1 ) ) {
$hide = 1;
}
}
# Is it a section whose contents we need to hide???
} elsif ( $ln =~ m/^${lb}\s*(.+?)\s*${rb}$/ ) {
my $section = lc ($1);
$hide_section = should_we_hide_sensitive_data ( $section, 1 ) ? 1 : 0;
}
unless ( $hide ) {
DBUG_PRINT ("ENCRYPT", $line);
unless (print NEW $line, "\n") {
return DBUG_RETURN ( croak_helper ($rOpts, $errMsg, 0) );
}
next;
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# The labels to search for ...
my $decrypt_str = convert_to_regexp_string ($rOpts->{decrypt_lbl});
my $encrypt_str = convert_to_regexp_string ($rOpts->{encrypt_lbl});
my $hide_str = convert_to_regexp_string ($rOpts->{hide_lbl});
# The label separators used when searching for option labels in a comment ...
my $lbl_sep = '[\s.,$!-()]';
my $assign_str = convert_to_regexp_string ($rOpts->{assign});
my ($lb, $rb) = ( convert_to_regexp_string ($rOpts->{section_left}),
convert_to_regexp_string ($rOpts->{section_right}) );
my $mask = "*"x8;
DBUG_PRINT ("INFO", "Opening for reading the config file named: %s", $file);
unless ( open (DECRYPT, "<", $file) ) {
return DBUG_RETURN ( croak_helper ($rOpts,
"Unable to open the config file.", 0) );
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
}
# Misuse of this option makes the config file unreadable ...
if ( $rOpts->{use_utf8} ) {
binmode (DECRYPT, "encoding(UTF-8)");
binmode (NEW, "encoding(UTF-8)");
}
my $errMsg = "Unable to write to the scratch file.";
my $hide_section = 0;
my $count = 0;
while ( <DECRYPT> ) {
chomp;
my $line = $_;
my ($tv, $ln, $cmt, $lq, $rq) = parse_line ( $line, $rOpts );
my ($hide, $decrypt) = (0, 0);
my ($tag, $value, $prefix, $t2);
lib/Advanced/Config/Reader.pm view on Meta::CPAN
($tag, $value, $prefix, $t2) = _split_assign ( $rOpts, $ln );
if ( $cmt =~ m/(^|${lbl_sep})${decrypt_str}(${lbl_sep}|$)/ ) {
($hide, $decrypt) = (1, 1);
} elsif ( $cmt =~ m/(^|${lbl_sep})${encrypt_str}(${lbl_sep}|$)/ ||
$cmt =~ m/(^|${lbl_sep})${hide_str}(${lbl_sep}|$)/ ) {
$hide = 1;
} else {
if ( $hide_section || should_we_hide_sensitive_data ( $tag, 1 ) ) {
$hide = 1;
}
}
# Is it a section whose contents we need to hide???
} elsif ( $ln =~ m/^${lb}\s*(.+?)\s*${rb}$/ ) {
my $section = lc ($1);
$hide_section = should_we_hide_sensitive_data ( $section, 1 ) ? 1 : 0;
}
unless ( $hide ) {
DBUG_PRINT ("DECRYPT", $line);
unless (print NEW $line, "\n") {
return DBUG_RETURN ( croak_helper ($rOpts, $errMsg, 0) );
}
next;
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
}
$value =~ s/${var}/\\v/sg; # So nothing looks like a variable ...
$value =~ s/\0/\\0/sg; # So no embedded null chars ...
DBUG_RETURN ( $value, $lq, $rq );
}
# ==============================================================
# When an encrypted value is read in from the config file, all escape
# secuences need to be removed before the value can be decrypted.
# These escape sequences were required to avoid parsing issues when
# handling encrypted values.
sub _reverse_escape_sequences
{
DBUG_ENTER_FUNC ( @_ );
my $value = shift; # Encrypted with escape sequences ...
my $rOpts = shift;
my ( $lq, $rq ) = _get_encryption_quotes ( $rOpts );
my $cmt = $rOpts->{comment};
t/10-validate_simple_cfg.t view on Meta::CPAN
print_opts_hash ( "The Read Options", $ropts );
print_opts_hash ( "The Get Options", $gopts );
print_opts_hash ( "The Date Options", $dopts );
# Builds the hash to validate the config file against ...
my ($total, $validate) = init_validation_hash ( $ropts, $dopts );
DBUG_PRINT ("----", "%s", "-"x50);
my @sections = $cfg->find_sections ();
my $cnt = @sections;
dbug_is ($cnt, 1, "The config file doesn't define any sections!");
my @tag_list = $cfg->find_tags ();
$cnt = @tag_list;
dbug_is ($cnt, $total, "Found the expected number of tags in config file ($total)");
DBUG_PRINT ("----", "%s", "-"x50);
$cnt = 0;
foreach ( @tag_list ) {
unless ( exists $validate->{$_} ) {
t/10-validate_simple_cfg.t view on Meta::CPAN
# Since I didn't count the test cases, must end my program
# with a call to this method. Can't do tests in END anymore!
done_testing ();
DBUG_LEAVE (0);
}
# ====================================================================
# All tags defined in the config file must be initialized below!
# The config file is: t/config/10-simple.cfg
# And it's a very basic one without sections or sourcing in of other files!
# NOTE: No tag may have undef as a value!
# This can't happen in this module if a tag is defined!
# Undef means the tag doesn't exist instead!
sub init_validation_hash
{
DBUG_ENTER_FUNC (@_);
my $opts = shift;
my $dopts = shift;
t/11-manual_build.t view on Meta::CPAN
# Turn fish on ...
DBUG_PUSH ( $fish );
DBUG_ENTER_FUNC (@ARGV);
dbug_ok (1, "In the MAIN program ..."); # Test # 2 ...
my $cfg = Advanced::Config->new();
dbug_isa_ok ( $cfg, 'Advanced::Config' );
# Create a separate section ...
my $sn = "help";
# my $sect = $cfg->get_section ( Advanced::Config::Reader::make_new_section ($cfg, $sn) );
my $sect = $cfg->create_section ($sn);
dbug_isa_ok ( $sect, 'Advanced::Config' );
DBUG_PRINT ("FIND", "="x80);
# Manually create some entries into the object ...
$cfg->set_value ("main_tag_1", "Hello World!");
$cfg->set_value ("main_tag_2", "Hello my old friend!");
$cfg->get_section ()->set_value ("main_tag_3", "Hello my new friend!");
$cfg->set_value ("main_tag_pwd", "It's a secret!");
DBUG_PRINT ("FIND", "="x80);
# Manually create some entries in the section ...
$sect->set_value ("help_tag_1", "Help Me!");
$cfg->get_section ($sn)->set_value ("help_tag_2", "Help You!");
$sect->set_value ("main_tag_1", "What's up Doc?");
# Putting in the main section again.
$cfg->set_value ("help_tag_1", "I thought I saw a pussy cat!");
DBUG_PRINT ("FIND", "="x80);
my $jcfg = $cfg->create_section ("jinx pwd");
my $v1 = "Just another secret.";
$jcfg->set_value ("Hide It", $v1);
my $v2 = $jcfg->get_value ("Hide It");
dbug_is ( $v1, $v2, "Hide It tags match! ($v1)" );
DBUG_PRINT ("FIND", "="x80);
# Now let's see what's in the object ...
# Uses 2 different ways per section.
my @lst1 = $cfg->find_tags (); # Main section
my @lst2 = $cfg->get_section ()->find_tags (); # Main section
my @lst3 = $sect->find_tags (); # Help Section
my @lst4 = $cfg->get_section ($sn)->find_tags (); # Help Section
my $cnt1 = @lst1;
my $cnt2 = @lst2;
my $cnt3 = @lst3;
my $cnt4 = @lst4;
my (%main, %help); # Used to predict inherited test results.
dbug_is ($cnt1, $cnt2, "Both main lists contain ${cnt1} entries.");
foreach (0..($cnt1-1)) {
my $v1 = $cfg->get_value ($lst1[$_]);
my $v2 = $cfg->get_section ()->get_value ($lst2[$_]);
dbug_ok ($lst1[$_] eq $lst2[$_] && $v1 eq $v2, "$lst1[$_] is in both lists with a value of \"$v1\"!");
$main{$lst1[$_]} = $v1;
}
dbug_is ( $cnt3, $cnt4, "Both section lists contain ${cnt3} entries.");
foreach (0..($cnt3-1)) {
my $v3 = $sect->get_value ($lst3[$_]);
my $v4 = $cfg->get_section ($sn)->get_value ($lst4[$_]);
dbug_ok ($lst3[$_] eq $lst4[$_] && $v3 eq $v4, "$lst3[$_] is in both lists with a value of \"$v3\"!");
$help{$lst3[$_]} = $v3;
}
# Lets do an "inheritence" test ...
my (@lst5, %both);
foreach ( @lst1, @lst3 ) { $both{$_} += 1; }
foreach ( sort keys %both ) { push ( @lst5, $_ ); }
my @lst6 = $sect->find_tags (undef, 1);
my $cnt5 = @lst5;
my $cnt6 = @lst5;
dbug_is ( $cnt5, $cnt6, "Both inherited section lists contain ${cnt5} entries.");
foreach (0..($cnt5-1)) {
my $t = $lst5[$_];
my $v5 = $sect->get_value ($lst5[$_], inherit => 1);
my $v6 = (exists $help{$t}) ? $help{$t} : $main{$t};
dbug_ok ($lst5[$_] eq $lst6[$_] && $v5 eq $v6, "$lst5[$_] is in both inherited lists with a value of \"$v5\"!");
}
# So we know we are done with the testing ...
done_testing ();
DBUG_LEAVE (0);
}
t/12-validate_sections.t view on Meta::CPAN
if ( $idx == 1 ) {
($cfg, $valid, $mode ) = ( $cfg1, $valid_normal_cfg, "normal" );
} elsif ( $idx == 2 ) {
($cfg, $valid, $mode ) = ( $cfg2, $valid_inherit_cfg, "inherit" );
} else {
dbug_ok (0, "Valid Iteration ... ($idx)");
next;
}
dbug_ok (1, "Processing mode: ${mode}");
my @sections = $cfg->find_sections ();
my $total = keys %{$valid};
my $cnt = @sections;
dbug_is ($cnt, $total, "The config file defines the correct number of sections! ($cnt vs $total)");
my $s;
foreach $s ( @sections ) {
dbug_ok ( exists $valid->{$s}, "Found section '$s' in the validaton hash!" );
}
foreach $s ( sort keys %{$valid} ) {
my $sect = $cfg->get_section ($s);
unless ( $sect ) {
dbug_ok (0, "Found section '$s' in the config file!");
next;
}
# Now let's validate the section contents ...
my @tag_list = $sect->find_tags ();
my $cnt1 = @tag_list;
my $cnt2 = keys %{$valid->{$s}};
dbug_is ($cnt1, $cnt2, "Section '$s' has the correct number of tag/value pairs! ($cnt1)");
# Validating the list of tags in the config file match what's in my validation hash.
$cnt = 0;
foreach my $t ( @tag_list ) {
unless ( exists $valid->{$s}->{$t} ) {
dbug_ok (0, "Tag \"$_\" also exists in the validation hash!");
++$cnt;
}
}
dbug_is ($cnt, 0, "All tags were accounted for in the validation hash for section '$s'!");
# Validating that my hash matches what's in the config file ...
foreach my $t ( sort keys %{$valid->{$s}} ) {
my $val1 = $valid->{$s}->{$t};
my $val2 = $sect->get_value ( $t );
my $chk = (defined $val2) && ($val1 eq $val2);
$val2 = (defined $val2) ? $val2 : "";
dbug_ok ( $chk, "Validating tag \"$t\" in section \"$s\" matches config file. ($val2)" );
unless ( $chk ) {
DBUG_PRINT ("ERROR", "Value should have been: %s", $val1);
}
}
} # End foreach $s loop ...
} # End foreach $idx loop ...
# Since I didn't count the test cases, must end my program
# with a call to this method. Can't do this in END anymore!
done_testing ();
t/12-validate_sections.t view on Meta::CPAN
# Initialize the requested configuration ...
sub init_object
{
DBUG_ENTER_FUNC (@_);
my $inherit = shift || 0;
my %gOpts;
$gOpts{inherit} = 1 if ( $inherit );
my $file = File::Spec->catfile ("t", "config", "12-use_sections.cfg");
my $cfg;
eval {
$cfg = Advanced::Config->new ($file, undef, \%gOpts);
dbug_ok (defined $cfg, "Advanced::Config object has been created! (inherit => $inherit)");
my $ldr = $cfg->load_config ();
dbug_ok (defined $ldr, "Advanced::Config object has been loaded into memory!");
};
if ( $@ ) {
unless (defined $cfg) {
dbug_ok (defined $cfg, "Advanced::Config object has been created! (inherit => $inherit)");
}
dbug_ok (0, "Advanced::Config object has been loaded into memory!");
DBUG_LEAVE (3);
}
DBUG_RETURN ($cfg);
}
# ==============================================------======================
# All tags & sections defined in the config files must be initialized below!
# The config file is: t/config/12-use_sections.cfg
# It's fairly complex based on how all it's sub-config files interact!
# NOTE: No tag may have undef as a value!
# That it can't happen in this module if a tag is defined!
# Undef means the tag doesn't exist instead!
sub init_validation_hashes
{
DBUG_ENTER_FUNC (@_);
# The name of the default section ...
my $default_name = Advanced::Config::DEFAULT_SECTION;
# ---------------------------------------------------
# Setting up for normal mode ...
# ---------------------------------------------------
# Tags in the default main section ...
my %main = ( "main_01" => "one",
"main_02" => "two",
"main_03" => "three",
"main_04" => "four",
"main_05" => "five",
"main_06" => "Crispy/Sweet",
"override_1" => "=ONE=",
"override_2" => "=TWO=",
"self" => $default_name
);
# Tags in Sections 01, 02 & 03 in normal mode ...
my %section_01n = ( "override_1" => "Help me One!",
"override_2" => "No help here One!",
"extra_1" => "Extra Help",
"extra_2" => "Extra Extra Help",
"self" => "section 01"
);
# Tags in Section 02 ...
my %section_02n = ( "override_1" => "Two vs One no fair! (ONE)",
"override_2" => "Two vs Two isn't fair either! (TWO)",
"extra_1" => "Crispy",
"self" => "section 02"
);
# Tags in Section 03 ...
my %section_03n = ( "override_1" => "Three to One odds are great!",
"override_2" => "Three to Two odds not so great!",
"extra_2" => "Sweet",
"self" => "section 03"
);
# ---------------------------------------------------
# Setting up for inherit mode ...
# ---------------------------------------------------
# Tags in Sections 01, 02 & 03 in inherit mode ...
my %section_01i = %section_01n;
my %section_02i = %section_02n;
my %section_03i = %section_03n;
# Inherit from the main section ...
foreach my $k ( keys %main ) {
$section_01i{$k} = $main{$k} unless ( exists $section_01i{$k} );
$section_02i{$k} = $main{$k} unless ( exists $section_02i{$k} );
$section_03i{$k} = $main{$k} unless ( exists $section_03i{$k} );
}
# Section => contents (tag/value pairs)
my %normal_cfg = ( $main{self} => \%main,
$section_01n{self} => \%section_01n,
$section_02n{self} => \%section_02n,
$section_03n{self} => \%section_03n
);
# Section => contents (tag/value pairs)
my %inherit_cfg = ( $main{self} => \%main,
$section_01i{self} => \%section_01i,
$section_02i{self} => \%section_02i,
$section_03i{self} => \%section_03i
);
DBUG_RETURN (\%normal_cfg, \%inherit_cfg);
}
t/15-validate_multi_source_cfg.t view on Meta::CPAN
DBUG_PRINT ("====", "%s", "="x50);
print_opts_hash ( "The Read Options", $ropts );
print_opts_hash ( "The Get Options", $gopts );
# Builds the hash to validate the config file against ...
my ($total, $validate) = init_validation_hash ( $ropts );
DBUG_PRINT ("----", "%s", "-"x50);
my @sections = $cfg->find_sections ();
my $cnt = @sections;
dbug_is ($cnt, $total, "The config file defines the correct number of sections! ($cnt)");
my $s;
foreach $s ( @sections ) {
dbug_ok ( exists $validate->{$s}, "Found section '$s' in the validaton hash!" );
}
foreach $s ( sort keys %{$validate} ) {
my $sect = $cfg->get_section ($s);
dbug_ok (1, "-"x30);
unless ( $sect ) {
dbug_ok (0, "Found section '$s' in the config file!");
next;
}
my @tag_list = $sect->find_tags ();
my $cnt1 = @tag_list;
my $cnt2 = keys %{$validate->{$s}};
dbug_is ($cnt1, $cnt2, "Section '$s' has the correct number of tag/value pairs! ($cnt1)");
# Validating the list of tags in the config file match what's in my validation hash.
$cnt = 0;
foreach my $t ( @tag_list ) {
unless ( exists $validate->{$s}->{$t} ) {
dbug_ok (0, "Tag \"$_\" exists in the validation hash!");
++$cnt;
}
}
dbug_is ($cnt, 0, "All tags were accounted for in the validation hash for section '$s'!");
# Validating that my hash matches what's in the config file ...
foreach my $t ( sort keys %{$validate->{$s}} ) {
my $val1 = $validate->{$s}->{$t};
my $val2 = $sect->get_value ( $t );
my $chk = (defined $val2) && ($val1 eq $val2);
$val2 = (defined $val2) ? $val2 : "";
dbug_ok ( $chk, "Validating tag \"$t\" in section \"$s\" matches config file. ($val2)" );
unless ( $chk ) {
DBUG_PRINT ("ERROR", "Value should have been: %s", $val1);
}
}
}
# Since I didn't count the test cases, must end my program
# with a call to this method. Can't do this in END anymore!
done_testing ();
DBUG_LEAVE (0);
}
# ==============================================------======================
# All tags & sections defined in the config files must be initialized below!
# The config file is: t/config/15-multi_source_01_main.cfg
# It's fairly complex based on how all it's sub-config files interact!
# NOTE: No tag may have undef as a value!
# That it can't happen in this module if a tag is defined!
# Undef means the tag doesn't exist instead!
sub init_validation_hash
{
DBUG_ENTER_FUNC (@_);
my $opts = shift;
# Tags in the main section ...
my %main = ( "main_01" => "Hello World!",
"hello" => "again!",
"main_02" => "What's up Doc?",
"main_03" => "I'm hunting wrabits!",
"main_04" => "Good bye cruel world!"
);
# Tags in the Common section ...
my %common = ( "common_01" => "Humpty Dumpty!",
"common_02" => "Sat on a wall!",
"common_03" => "He had a great fall!",
"common_04" => "They couldn't put humpty together again!"
);
# Tags in the Overwrite section ...
my %overwrite = ( "overwrite" => "From file 04!" );
# Common tags between different sections ...
my %first = ( "hello" => "1st!" );
my %second = ( "hello" => "2nd?" );
my %third = ( "hello" => "3rd." );
my %fourth = ( "hello" => "4th!?!" );
# Sedction names points to the tag/value pairs found in them.
my %sections = ( "main" => \%main,
"common" => \%common,
"overwrite" => \%overwrite,
"first" => \%first,
"second" => \%second,
"third" => \%third,
"fourth" => \%fourth,
);
my $total = keys %sections;
DBUG_RETURN ($total, \%sections);
}
t/20-validate_encrypt_decrypt.t view on Meta::CPAN
BEGIN { push (@INC, File::Spec->catdir (".", "t", "test-helper")); }
use helper1234;
my $fish;
# =================================================================
# Tests the encryption/decryption logic.
# =================================================================
# Assumptions about the config files made by this test program:
# If any assumtions are false, you will see test failures.
# 1) No tag appeears in multiple sections for this test.
# 2) All tags starting with "join" are assumed to reference
# encrypted variables/tags.
# =================================================================
BEGIN {
$fish = turn_fish_on_off_for_advanced_config ();
unlink ( $fish );
DBUG_ENTER_FUNC ();
t/20-validate_encrypt_decrypt.t view on Meta::CPAN
DBUG_ENTER_FUNC ();
# Don't do any tests in the END block ...
DBUG_VOID_RETURN ();
}
# =================================================================
my %decrypt_callback_tags;
my %encrypt_callback_tags;
sub my_security_callback
{
DBUG_ENTER_FUNC (@_);
my $mode = shift; # 0 = Decrypt / 1 = Encrypt
my $tag = shift;
my $value = shift;
my $file = shift;
my $workArea = shift;
if ( $mode == 0 ) {
# Decryption ...
t/20-validate_encrypt_decrypt.t view on Meta::CPAN
$value = "XX" . $value . "YY";
}
DBUG_RETURN ( $value );
}
sub my_source_callback
{
DBUG_ENTER_FUNC (@_);
my %opts = ( alias => "20-0-encrypt-decrypt.cfg",
encrypt_cb => \&my_security_callback );
DBUG_RETURN ( \%opts, undef );
}
# =================================================================
# Start of the main program!
# =================================================================
{
# Turn fish on ...
DBUG_PUSH ( $fish );
DBUG_ENTER_FUNC (@ARGV);
dbug_ok (1, "In the MAIN program ..."); # Test # 2 ...
run_all_tests ( "20-0-encrypt-decrypt.cfg", { encrypt_cb => \&my_security_callback } );
run_all_tests ( "21-0-encrypt-decrypt.cfg", { encrypt_cb => \&my_security_callback } );
run_all_tests ( "22-0-encrypt-decrypt.cfg", { assign => ":=:", quote_left => '|', quote_right => '|', encrypt_cb => \&my_security_callback } );
dbug_ok (1, "-"x30);
my %rOpts; $rOpts{source_cb} = \&my_source_callback;
# This file sources in one of the auto-encrypted files ...
my $alt_file = File::Spec->catfile ("t", "config", "25-0-encrypt-decrypt-src.cfg");
my $acfg = init_cfg_file ( $alt_file, \%rOpts );
run_alt_tests ($acfg, "aaa", "bBb", "CcC", "DDD", "zzZ");
t/20-validate_encrypt_decrypt.t view on Meta::CPAN
# Decrypting the file incorrectly ...
DBUG_PRINT ("====", "%s", "f"x50);
$status = $emptyCfg->decrypt_config_file ($encrypt_file, $fail_file, $rOpts);
dbug_is ($status, 1, "Bad Decryption Succeeded!");
my $fcfg = init_cfg_file ( $fail_file, $rOpts );
DBUG_PRINT ("====", "%s", "="x50);
my @sections = $cfg->find_sections ();
my $cnt = @sections;
dbug_ok ($cnt, "The config file has ${cnt} section(s) in it!");
my %data;
# Get the stats for the main file ...
foreach ( @sections ) {
my %parts;
my @tag_list = $cfg->get_section ($_)->find_tags ();
my $tcnt = @tag_list;
dbug_ok ( $tcnt, "Found ${tcnt} tags in section $_");
$parts{CNT} = $tcnt;
$parts{TAGS} = \@tag_list;
$data{$_} = \%parts;
# All variables begining with "join..." reference encrypted variables.
# So put in %save as well.
foreach my $t ( @tag_list ) {
$save{$t} = 1 if ( $t =~ m/^join/ );
}
}
t/20-validate_encrypt_decrypt.t view on Meta::CPAN
sub compare_cfg
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift; # The source config file.
my $dcfg = shift; # The config file to comare it to.
my $lbl = shift; # The label to use ...
my $data = shift; # The stats on the source cfg file.
my $fail = shift; # 1-Decrypt should fail. 0-Decrypt should succeed.
my $which = shift; # Which tags were decrypted!
my @sect = $dcfg->find_sections ();
my $cnt = keys %{$data};
my $dcnt = @sect;
dbug_ok (1, "-"x30);
dbug_is ($cnt, $dcnt, "The ${lbl} config file has the right number of sections.");
$cnt = 0;
foreach my $s ( @sect ) {
unless ( exists $data->{$s} ) {
dbug_ok (0, "Section '$s' exists in the original config file.");
next;
}
my @tag_list = $dcfg->get_section ($s)->find_tags ();
my $tcnt = @tag_list;
ok ( $tcnt == $data->{$s}->{CNT}, "Section '$s' in the ${lbl} cfg file has the right number of tags ($tcnt)" );
foreach my $t ( @tag_list ) {
my $stag = $cfg->get_section ($s)->get_value ($t);
my $dtag = $dcfg->get_section ($s)->get_value ($t);
unless ( $stag ) {
dbug_ok (0, "Tag \"${t}\" exists in both config files.");
} elsif ( ! $which->{$t} ) {
dbug_cmp_ok ( $stag, 'eq', $dtag, "Tag \"${t}\" has the same value in both config files! ($dtag)" );
} elsif ( $fail ) {
dbug_cmp_ok ( $stag, 'ne', $dtag, "Tag \"${t}\" had issues decrypting this value from the config file. ($dtag)" );
} else {
dbug_cmp_ok ( $stag, 'eq', $dtag, "Tag \"${t}\" has the same value in both config files. ($dtag)" );
}
}
t/20-validate_encrypt_decrypt.t view on Meta::CPAN
my %empty;
# Empty out the global hashes ...
%decrypt_callback_tags = %encrypt_callback_tags = %empty;
my $cfg;
eval {
if ( $rOpts ) {
$cfg = Advanced::Config->new ( $file, $rOpts );
} else {
$cfg = Advanced::Config->new ( $file, { encrypt_cb => \&my_security_callback } );
}
dbug_isa_ok ($cfg, 'Advanced::Config');
my $ldr = $cfg->load_config ();
dbug_ok (defined $ldr, "Advanced::Config object has been loaded into memory!");
};
if ( $@ ) {
unless (defined $cfg) {
dbug_isa_ok ($cfg, 'Advanced::Config');
}
dbug_ok (0, "Advanced::Config object has been loaded into memory!");
t/28-sensitive_tests.t view on Meta::CPAN
Advanced::Config::Options::make_it_sensitive ("1111", "zork", "22222");
my $file = File::Spec->catfile ("t", "config", "28-sensitive.cfg");
my $cfg1 = make_object ( $file );
my $cfg2 = make_object ( $file, "disable_variables" => 1 );
my $cfg3 = make_object ( $file, "disable_decryption" => 1 );
# Doesn't work after the config files are loaded ..
Advanced::Config::Options::make_it_sensitive ("pork");
my @sections = $cfg1->find_sections ();
my $cnt = @sections;
dbug_is ($cnt, 3, "All 3 sections were accounted for!");
my @tag_list = $cfg1->find_tags ();
$cnt = @tag_list;
# --------------------------------------------------------------
# Section # 1: Normal operation, validating the sensitive logic.
# All tags considered sensitive end in "_y" for this test.
# Or if a section name is sensitive everything in
# it is sensitive!
# --------------------------------------------------------------
foreach my $s ( @sections ) {
dbug_ok (1, "-"x50);
my $lCfg = $cfg1->get_section ( $s );
my @tags = $lCfg->find_tags ();
my $tlt = @tags;
my $sens = Advanced::Config::Options::should_we_hide_sensitive_data ( $s );
if ( $sens ) {
dbug_ok ( 1, "Processing sensitive section '$s'.");
} else {
dbug_ok ( 1, "Processing normal section '$s'.");
}
dbug_is ( $tlt, $cnt, "Found ${cnt} tags in this section.");
foreach my $t (@tags) {
my $ans = ($sens || ( $t =~ m/_y$/i )) ? 1 : 0;
my $chk = $lCfg->chk_if_sensitive ( $t );
my $v = $lCfg->get_value ($t);
if ( $ans ) {
dbug_is ( $chk, 1, "Tag '$t' is considered sensitive! ($v)" );
} else {
dbug_is ( $chk, 0, "Tag '$t' is NOT considered sensitive! ($v)" );
}
}
}
# --------------------------------------------------------------
# Section # 2: Now testing which tags have unexpanded variables ...
# Only tests tags listed in '00_has_variables'
# --------------------------------------------------------------
foreach my $s ( @sections ) {
dbug_ok (1, "="x50);
my $lCfg = $cfg2->get_section ( $s );
dbug_ok (1, "Disabled Variable test for section: " . $s);
# Get from "main" section, not individual sections
my $hash_ref2 = $cfg2->get_hash_values ( "00_has_variables" );
foreach my $t ( $lCfg->find_tags () ) {
my $v = $lCfg->get_value ($t);
my $bool = $lCfg->chk_if_still_uses_variables ($t);
my $ans = ( $v =~ m/[$][{][^}]+[}]/ ) ? 1 : 0; # Check for a variable definition.
my $agree = ($bool == $ans) ? 1 : 0;
if ( exists $hash_ref2->{$t} ) {
dbug_ok ( $agree && $bool, "Tag '$t' has unresolved variables in it! ($v)" );
} elsif ( $ans || $bool ) {
dbug_ok ( 0, "Tag '$t' has NO variables in it! ($v) [$ans, $bool]" );
}
}
}
# --------------------------------------------------------------
# Section # 3: Now testing which tags failed to decrypt!
# Only tests tags listed in '00_has_decryption'
# --------------------------------------------------------------
foreach my $s ( @sections ) {
dbug_ok (1, "~"x50);
my $lCfg = $cfg3->get_section ( $s );
dbug_ok (1, "Disabled Decryption test for section: " . $s);
# Get from "main" section, not individual sections
my $hash_ref3 = $cfg3->get_hash_values ( "00_has_decryption" );
foreach my $t ( $lCfg->find_tags () ) {
my $v = $lCfg->get_value ($t);
my $chk = $lCfg->chk_if_still_encrypted ($t);
my $bool = $lCfg->chk_if_still_uses_variables ($t);
my $ans = ( $v =~ m/[$][{][^}]+[}]/ ) ? 1 : 0; # Check for a variable definition.
if ( exists $hash_ref3->{$t} ) {
t/30-alt_symbols_cfg.t view on Meta::CPAN
my $main_cfg = initialize_config ( "10-simple.cfg" );
DBUG_PRINT ("====", "%s", "="x50);
$control_cfg = initialize_config ( "30-alt_symbol_control.cfg" );
DBUG_PRINT ("====", "%s", "="x50);
my $total = $control_cfg->get_value ("number_test_files");
dbug_like ($total, qr/^\d+$/, "Has a numeric value!");
my @sections = $control_cfg->find_sections ('[.]cfg$');
my $cnt = @sections;
dbug_is ( $cnt, $total, "Found the correct number of config files to work with. ($cnt vs $total)");
foreach my $c ( sort @sections ) {
dbug_ok (1, "-"x50);
my ($cfg, @stags) = initialize_each_config ( $control_cfg, $c );
next unless ( defined $cfg );
dbug_ok ($cfg->refresh_config (test_only=>1) ? 0 : 1,
"No refresh needed for the config file: " . basename ($cfg->filename()));
foreach my $r ( 0, 1, 2 ) {
if ( $cfg->refresh_config (force => $r) ) {
t/30-alt_symbols_cfg.t view on Meta::CPAN
# Finish loading the special case tests # 71 & 72
# so that they can emulate test # 70 ...
if ( $c =~ m/_71_empty/ ) {
local_merge_files ( $control_cfg, $cfg, 0 );
} elsif ( $c =~ m/_72_empty/ ) {
local_merge_files ( $control_cfg, $cfg, 1 );
}
if ( $#stags == -1 ) {
# Do a compare against the main section only ...
compare_config_files ( $main_cfg, $cfg, \%comment_tags );
} else {
# Do a compare against the specified section(s) in the new file ...
$cnt = 0;
foreach my $t ( sort @stags ) {
dbug_ok (1, "="x50) if ( $cnt > 0);
++$cnt;
# Are we looking in another section?
my $mode = ( $t =~ m/[.]/ ) ? 0 : 2;
# Look up the name of the section to use ...
my $sct = $cfg->get_value ($t, required => $mode);
$sct = $cfg->rule_3_section_lookup ($t) unless ($sct);
$sct = $cfg->get_value ($t) unless ($sct);
compare_config_files ( $main_cfg, $cfg, \%comment_tags, $sct );
}
}
} # End foreach $r ...
} # End foreach $c ...
dbug_ok (1, "-"x50);
# Since I didn't count the test cases, must end my program
# with a call to this method. Can't do tests in END anymore!
done_testing ();
DBUG_LEAVE (0);
}
# ====================================================================
# This is the source_cb callback function named in: 30-alt_symbol_control.cfg
# All it does is lookup the options to use from the
# appropriate section in the conig file. (global var)
sub ALTER_SOURCE_CALLBACK_OPTIONS
{
DBUG_ENTER_FUNC (@_);
my $file = shift;
my $custom = shift;
my $f = basename ($file);
DBUG_ENTER_BLOCK ("GRAB");
DBUG_PAUSE();
my ($ropts, $dopts, @section_tags) = grab_options ( $control_cfg, $f );
DBUG_VOID_RETURN ();
$ropts = print_opts_hash ( "Read Options for: $f", $ropts );
$dopts = print_opts_hash ( "Date Options for: $f", $dopts );
DBUG_RETURN ( $ropts, $dopts );
}
# ====================================================================
sub compare_config_files
{
DBUG_ENTER_FUNC (@_);
my $src_cfg = shift; # The original validated config file to compare against.
my $dst_cfg = shift; # The new config file to validate.
my $cmts = shift; # The tags with comment chars in their values!
my $sect = shift; # The section to change to.
my ( $cnt1, $cnt2 );
my @sections = $dst_cfg->find_sections ();
$cnt1 = @sections;
dbug_cmp_ok ($cnt1, '>', 0, "The config file has ${cnt1} section(s)!");
if ( $sect ) {
$dst_cfg = $dst_cfg->get_section ( $sect );
dbug_ok (defined $dst_cfg, "Validating against section \"${sect}\" in the config file ...");
return DBUG_VOID_RETURN () unless ( defined $dst_cfg );
} else {
dbug_ok (1, "Validating the config file ...");
}
my @src_list = $src_cfg->find_tags ();
my @dst_list = $dst_cfg->find_tags ();
$cnt1 = @src_list;
$cnt2 = @dst_list;
if ( $sect ) {
dbug_is ( $cnt1, $cnt2, "The source config file & section '$sect' have the same number of tags in them. ($cnt1 vs $cnt2)");
} else {
dbug_is ( $cnt1, $cnt2, "Both config files have the same number of tags in them. ($cnt1 vs $cnt2)");
}
my %list;
foreach my $tg ( @src_list ) {
$list{$tg} = 1;
my $src = $src_cfg->get_value ( $tg );
my $dst = $dst_cfg->get_value ( $tg );
my $same = ( $src eq $dst ) ? 1 : 0;
t/30-alt_symbols_cfg.t view on Meta::CPAN
# ====================================================================
# If using the special case of spaces separating the tag/value pair,
# will need to replace all "=" in the tag names to make them equivilant
# to the other config files.
sub fix_space_sep_issue
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift; # The config file to fix ...
foreach my $name ( $cfg->find_sections () ) {
my $s = $cfg->get_section ($name);
foreach my $t ( $s->find_tags ("=") ) {
my $new = $t;
$new =~ s/=/ /g;
$s->rename_tag ($t, $new);
}
}
DBUG_VOID_RETURN ();
}
t/30-alt_symbols_cfg.t view on Meta::CPAN
# By merging in the expected files ...
sub local_merge_files
{
DBUG_ENTER_FUNC (@_);
my $ctl_cfg = shift;
my $new_cfg = shift;
my $multiple = shift;
my $f1 = File::Spec->catfile ("t", "config", "30-alt_symbols_03.cfg");
my $f2 = File::Spec->catfile ("t", "config", "30-alt_symbols_04 multi section test.cfg");
my ($ropt1, $dopt1) = grab_options ($ctl_cfg, basename ($f1));
my ($ropt2, $dopt2) = grab_options ($ctl_cfg, basename ($f2));
# What to do with $dopt???
dbug_ok ($new_cfg->merge_config ($f1, $ropt1), "1st Merge is OK");
dbug_ok ($new_cfg->merge_config ($f2, $ropt2), "2nd Merge is OK");
if ( $multiple ) {
t/30-alt_symbols_cfg.t view on Meta::CPAN
# ====================================================================
# The generic config file loader ...
# ====================================================================
sub initialize_each_config
{
DBUG_ENTER_FUNC (@_);
my $ctrl_cfg = shift;
my $file = shift;
my @section_tags; # List of sections to compare against ...
my $ropts;
my $dopts;
($ropts, $dopts, @section_tags) = grab_options ( $ctrl_cfg, $file );
# Always die if we can't locate tags in this config file.
my %gopts = ( required => 2 );
my $cfg = initialize_config ( $file, $ropts, \%gopts, $dopts );
DBUG_RETURN ( $cfg, @section_tags );
}
# ====================================================================
# Grab the needed options ...
# ====================================================================
sub grab_options
{
DBUG_ENTER_FUNC (@_);
my $ctrl_cfg = shift;
my $file = shift;
my @section_tags;
$ctrl_cfg = $ctrl_cfg->get_section ($file);
dbug_ok ( defined $ctrl_cfg, "Processing config file: $file" );
unless ( defined $ctrl_cfg ) {
return DBUG_RETURN ( undef, undef, @section_tags );
}
# Get the "Read" & "Date" Options to use ...
my (%ropts, %dopts);
foreach my $tg ( $ctrl_cfg->find_tags () ) {
if ( $tg =~ m/^section_test_/i ) {
my $val = $ctrl_cfg->get_value ( $tg );
push ( @section_tags, $val );
} else {
my $ltg = lc ($tg);
if ( exists $default_ropts->{$ltg} ) {
$ropts{$ltg} = $ctrl_cfg->get_value ( $tg ) # Read
} elsif ( exists $default_dopts->{$ltg} ) {
$dopts{$ltg} = $ctrl_cfg->get_value ( $tg ) # Date
} else {
DBUG_PRINT ("INFO", "Skipping unknown tag (%s)", $tg);
}
}
}
DBUG_RETURN ( \%ropts, \%dopts, @section_tags );
}
t/35-improper_tests.t view on Meta::CPAN
# Verify that the refresh detects the change and dies!
eval {
my $r9 = $cfg9->refresh_config ();
dbug_ok (0, "Refresh Failed on 'pork'! ($r9)");
};
if ($@) {
dbug_ok (1, "Refresh Failed on 'pork'!");
}
DBUG_PRINT ("????", "?"x40);
my @sections = $cfg1->find_sections ();
my $cnt = @sections;
dbug_is ($cnt, 3, "All 3 sections were accounted for!");
my @tag_list = $cfg1->find_tags ();
$cnt = @tag_list;
foreach my $s ( @sections ) {
dbug_ok (1, "-"x50);
my $lCfg = $cfg1->get_section ( $s );
my @tags = $lCfg->find_tags ();
my $tlt = @tags;
my $sens = Advanced::Config::Options::should_we_hide_sensitive_data ( $s );
if ( $sens ) {
dbug_ok ( 1, "Processing sensitive section '$s'.");
} else {
dbug_ok ( 1, "Processing normal section '$s'.");
}
dbug_is ( $tlt, $cnt, "Found ${cnt} tags in this section.");
foreach my $t (@tags) {
my $ans = $sens || ( $t =~ m/_y$/i ) ? 1 : 0;
my $chk = $lCfg->chk_if_sensitive ( $t );
my $v = $lCfg->get_value ($t);
if ( $ans ) {
dbug_is ( $chk, 1, "Tag '$t' is considered sensitive! ($v)" );
} else {
dbug_is ( $chk, 0, "Tag '$t' is NOT considered sensitive! ($v)" );
}
}
last; # So only reports on the 1st section ... (so don't have to modify much code)
}
# --------------------------------------------------------------
# Section # 2: Now testing which tags have unexpanded variables ...
# --------------------------------------------------------------
foreach my $s ( @sections ) {
dbug_ok (1, "-"x50);
my $lCfg = $cfg2->get_section ( $s );
dbug_ok (1, "Disabled Variable test for section: " . $s);
my $hash_ref2 = $cfg2->get_hash_values ( "00_has_variables" );
foreach my $t ( $lCfg->find_tags () ) {
my $v = $lCfg->get_value ($t);
my $bool = $lCfg->chk_if_still_uses_variables ($t);
my $ans = ( $v =~ m/[$][{][^}]+[}]/ ) ? 1 : 0; # Check for a variable definition.
my $agree = ($bool == $ans) ? 1 : 0;
if ( exists $hash_ref2->{$t} ) {
dbug_ok ( $agree && $bool, "Tag '$t' has unresolved variables in it! ($v)" );
} elsif ( $ans || $bool ) {
dbug_ok ( 0, "Tag '$t' has NO variables in it! ($v) [$ans, $bool]" );
}
}
}
# --------------------------------------------------------------
# Section # 3: Now testing which tags failed to decrypt!
# --------------------------------------------------------------
foreach my $s ( @sections ) {
dbug_ok (1, "-"x50);
my $lCfg = $cfg3->get_section ( $s );
dbug_ok (1, "Disabled Decryption test for section: " . $s);
my $hash_ref3 = $cfg3->get_hash_values ( "00_has_decryption" );
foreach my $t ( $lCfg->find_tags () ) {
my $v = $lCfg->get_value ($t);
my $chk = $lCfg->chk_if_still_encrypted ($t);
my $bool = $lCfg->chk_if_still_uses_variables ($t);
my $ans = ( $v =~ m/[$][{][^}]+[}]/ ) ? 1 : 0; # Check for a variable definition.
my $agree = ($bool == $ans) ? 1 : 0;
t/40-validate-modifiers.t view on Meta::CPAN
print_opts_hash ( "The Get Options", $gopts );
# Builds the hash to validate the config file against ...
my ($total, $validate) = init_validation_hash ();
my $val = $cfg->get_value ( "msg" );
dbug_cmp_ok ( $val, 'eq', $validate->{msg}, "The test phrases are the same!");
DBUG_PRINT ("----", "%s", "-"x50);
my @sections = $cfg->find_sections ();
my $cnt = @sections;
dbug_is ($cnt, 1, "The config file doesn't define any sections!");
my @tag_list = $cfg->find_tags ();
$cnt = @tag_list;
dbug_is ($cnt, $total, "Found the expected number of tags in config file ($total)");
DBUG_PRINT ("----", "%s", "-"x50);
$cnt = 0;
foreach ( @tag_list ) {
unless ( exists $validate->{$_} ) {
t/50-validate-merge.t view on Meta::CPAN
use Sys::Hostname;
use Fred::Fish::DBUG 2.09 qw / on /;
use Fred::Fish::DBUG::Test 2.09;
# How to find the helper module ...
BEGIN { push (@INC, File::Spec->catdir (".", "t", "test-helper")); }
use helper1234;
my $fish;
# This program tests the default section override when merging multiple
# config files together.
# Only tests the expected counts of tags present. Not which ones or their values.
BEGIN {
$fish = turn_fish_on_off_for_advanced_config ();
unlink ( $fish );
DBUG_ENTER_FUNC ();
t/50-validate-merge.t view on Meta::CPAN
dbug_ok (1, "In the MAIN program ..."); # Test # 2 ...
my $file = File::Spec->catfile ("t", "config", "50-merge_a.cfg");
my %ropts;
# Load the same config file 3 different ways ...
$ropts{Croak} = -1;
my $cfg0 = init_config ( $file, \%ropts );
$ropts{source_file_section_lbl} = "ONE";
my $cfg1 = init_config ( $file, \%ropts );
$ropts{source_file_section_lbl} = "TWO";
my $cfg2 = init_config ( $file, \%ropts );
$ropts{source_file_section_lbl} = "THREE";
my $cfg3 = init_config ( $file, \%ropts );
# So can tell when the config files were loaded in fish ...
DBUG_PRINT ("====", "%s", "="x50);
foreach my $cfg ( $cfg0, $cfg1, $cfg2, $cfg3 ) {
my %expect;
my $lbl;
if ( $cfg == $cfg0 ) {
$expect{main} = 4;
$lbl = "default";
} elsif ( $cfg == $cfg1 ) {
$expect{'section a'} = 4;
$lbl = "one";
} elsif ( $cfg == $cfg2 ) {
$expect{'section a'} = 2;
$expect{'section b'} = 2;
$expect{'section c'} = 2;
$lbl = "two";
} else {
$expect{main} = 2;
$expect{'section b'} = 3;
$lbl = "three";
}
DBUG_PRINT ("FILE", "------ %s -------", $lbl);
my @sections = $cfg->find_sections ();
my $cnt = @sections;
dbug_is ($cnt, 5, "The config file defines 5 sections!");
foreach my $s ( @sections ) {
my @tag_list = $cfg->get_section($s)->find_tags ();
$cnt = @tag_list;
my $expect = $expect{$s} || 1;
my $lst = join ("', '", @tag_list);
dbug_is ($cnt, $expect, "Found $cnt tags in section \"$s\" ==> '$lst'.");
}
}
# Since I didn't count the test cases, must end my program
# with a call to this method. Can't do tests in END anymore!
done_testing ();
DBUG_LEAVE (0);
}
t/55-validate-strings.t view on Meta::CPAN
dbug_ok (1, "In the MAIN program ..."); # Test # 2 ...
my $miss = find_missing_entries ();
my $cfg = init_config ();
test_results ($cfg, $miss);
# Section "fix" ...
my $sect = "[ fix ]\n" . config_sh ();
my $res = $cfg->merge_string ( $sect );
dbug_ok ( $res, "The 'fix' string merge worked!");
my $sCfg = $cfg->get_section ( "fix" );
dbug_ok ( ref($sCfg) eq "Advanced::Config", "Section 'fix' exists!");
# Section "break" ...
$sect = "[ break ]\n" . config_sh ();
$res = $cfg->merge_string ( $sect );
dbug_ok ( $res, "The 'break' string merge worked!");
my $bCfg = $cfg->get_section ( "break" );
dbug_ok ( ref($bCfg) eq "Advanced::Config", "Section 'break' exists!");
# Modifying to prove modifying the string doesn't break refresh_config()!
$sect =~ s/ break / broken /;
dbug_ok (1, "Break changed to: " . substr ($sect,0,10));
test_results ($cfg, $miss);
test_results ($sCfg, $miss);
test_results ($bCfg, $miss);
DBUG_PRINT ("====", "%s", "="x50);
$res = $cfg->refresh_config ();
dbug_ok (! $res, "Refresh was skipped over.");
$res = $cfg->refresh_config ( "force" => 1 );
dbug_ok ($res, "Refresh was forced!");
$sCfg = $cfg->get_section ( "fix" );
dbug_ok ( ref($sCfg) eq "Advanced::Config", "Section 'fix' exists!");
$bCfg = $cfg->get_section ( "break" );
dbug_ok ( ref($bCfg) eq "Advanced::Config", "Section 'break' exists!");
test_results ($cfg, $miss);
test_results ($sCfg, $miss);
test_results ($bCfg, $miss);
# ----------------------------------------------------------
# Now lets test encrypting then decrypting a string ...
# ----------------------------------------------------------
dbug_ok ( 1, "-"x50 );
$sect = "section";
my $original = "abc = 'Help me!' # ENCRYPT you\n"
. "xyz = 'No way!' # ENCRYPT me\n"
. "[${sect}]\n"
. "lmn = 'no one' # ENCRYPT us\n"
. "no = never encrypt!\n"
;
my $alias = "STRING-IS-A-GO-go!";
# Defere the dbug_ok() calls until after they've been loaded!
my $str1 = $cfg->encrypt_string ($original, $alias);
my $str2 = $cfg->decrypt_string ($str1, $alias);
# ----------------------------------------------------------
# Now some more detailed comparisons of the results ...
# ----------------------------------------------------------
my $xCfg1 = init_config ( $original );
my $xCfg2 = init_config ( $str1, $alias ); # Decryption works ...
my $xCfg3 = init_config ( $str1 ); # Decryption fails ...
my $xCfg4 = init_config ( $str2 );
dbug_ok ((defined $str1 && $str1 ne $original), "Encrypting a string looks good!");
dbug_ok ((defined $str2 && $str2 ne $str1), "Decrypting a string looks good!");
my $sxCfg1 = $xCfg1->get_section ($sect);
my $sxCfg2 = $xCfg2->get_section ($sect);
my $sxCfg3 = $xCfg3->get_section ($sect);
my $sxCfg4 = $xCfg4->get_section ($sect);
dbug_ok ( defined $sxCfg1, "Section exists" );
dbug_ok ( defined $sxCfg2, "Section exists" );
dbug_ok ( defined $sxCfg3, "Section exists" );
dbug_ok ( defined $sxCfg4, "Section exists" );
# This is a lousy test ... Remove & update $original when detailed test available!
dbug_cmp_ok ( $str2, 'eq', $original, "Encrypting then decrypting produced the correct string!" );
dbug_ok ( test_obj ($xCfg1, $xCfg2, [ "abc", "xyz" ], [] ), "Compares main OK" );
dbug_ok ( test_obj ($sxCfg1, $sxCfg2, [ "lmn", "no" ], [] ), "Compares section OK" );
dbug_ok ( test_obj ($xCfg1, $xCfg3, [], [ "abc", "xyz" ] ), "Decrypts main Failed as expected" );
dbug_ok ( test_obj ($sxCfg1, $sxCfg3, [ "no" ], [ "lmn" ] ), "Decrypts section Failed as expected" );
dbug_ok ( test_obj ($xCfg1, $xCfg4, [ "abc", "xyz" ], [] ), "Decrypts main OK" );
dbug_ok ( test_obj ($sxCfg1, $sxCfg4, [ "lmn", "no" ], [] ), "Decrypts section OK" );
# ----------------------------------------------------------
# Does the toString () test cases ...
# ----------------------------------------------------------
dbug_ok ( 1, "-"x50 );
# Makes sure having comments in a tag's value doesn't cause us problems!
$xCfg1->set_value ("cmt1", '### Comments ###');
$xCfg1->set_value ("cmt2", '### "Comments" ###');
$xCfg1->set_value ("cmt3", "### 'Comments' ###");
$xCfg1->set_value ("cmt4", "### 'Comments" . '" ###');
my $str = $xCfg1->toString ();
my $zCfg1 = init_config ( $str );
my $szCfg1 = $zCfg1->get_section ($sect);
dbug_ok ( defined $szCfg1, "Section exists" );
dbug_ok ( defined $str, "toString() returned something!" );
dbug_ok ( test_obj ($xCfg1, $zCfg1, [ "abc", "xyz", "cmt1", "cmt2", "cmt3", "cmt4" ], [] ), "Compares main OK" );
dbug_ok ( test_obj ($sxCfg1, $szCfg1, [ "lmn", "no" ], [] ), "Compares section OK" );
# Mark all tags to be encrypted ...
$str = $xCfg1->toString (1);
dbug_ok ( defined $str, "toString(1) returned something!" );
$str2 = $xCfg1->encrypt_string ($str, $alias);
dbug_ok ( defined $str2, "encrypt_string() returned something!" );
my $flag = (defined $str && defined $str2) && $str ne $str2;
dbug_ok ( $flag, "The toString(1) results have been encrypted!");
my $zCfg2 = init_config ( $str2 );
my $szCfg2 = $zCfg2->get_section ($sect);
dbug_ok ( defined $szCfg2, "Section exists" );
my $zCfg3 = init_config ( $str2, $alias );
my $szCfg3 = $zCfg3->get_section ($sect);
dbug_ok ( defined $szCfg3, "Section exists" );
dbug_ok ( test_obj ($xCfg1, $zCfg2, [], [ "abc", "xyz", "cmt1", "cmt2", "cmt3", "cmt4" ] ), "Decrypts main Failed as expected" );
dbug_ok ( test_obj ($sxCfg1, $szCfg2, [], [ "lmn", "no" ] ), "Decrypts section Failed as expected" );
dbug_ok ( test_obj ($xCfg1, $zCfg3, [ "abc", "xyz", "cmt1", "cmt2", "cmt3", "cmt4" ], [] ), "Decrypts main OK" );
dbug_ok ( test_obj ($sxCfg1, $szCfg3, [ "lmn", "no" ], [] ), "Decrypts section OK" );
# ----------------------------------------------------------
# Does the toString () test using alternate symbols ...
# ----------------------------------------------------------
dbug_ok ( 1, "-"x50 );
$xCfg1->set_value ("cmt1", '//// Comments ///');
$xCfg1->set_value ("cmt2", '//// "Comments" ///');
$xCfg1->set_value ("cmt3", "//// 'Comments' ///");
$xCfg1->set_value ("cmt4", "//// 'Comments" . '" ///');
$str = $xCfg1->toString (1, "comment" => "//", "assign" => ":=:", "encrypt_lbl" => "Some Comments ...");
dbug_ok ( defined $str, "toString(2) returned something!" );
my $zCfg5 = init_config ( $str, $alias, 1);
my $szCfg5 = $zCfg5->get_section ($sect);
dbug_ok ( defined $szCfg5, "Section exists" );
dbug_ok ( test_obj ($xCfg1, $zCfg5, [ "abc", "xyz", "cmt1", "cmt2", "cmt3", "cmt4" ], [] ), "Compares alternate main OK" );
dbug_ok ( test_obj ($sxCfg1, $szCfg5, [ "lmn", "no" ], [] ), "Compares alternate section OK" );
# Since I didn't count the test cases, must end my program
# with a call to this method. Can't do tests in END anymore!
done_testing ();
DBUG_LEAVE (0);
}
# --------------------------------------------------
t/56-tohash.t view on Meta::CPAN
{
# Turn fish on ...
DBUG_PUSH ( $fish );
DBUG_ENTER_FUNC (@ARGV);
dbug_ok (1, "In the MAIN program ..."); # Test # 2 ...
dbug_ok (1, "------------------------------------------------");
my $cfg1 = init_config ("a = low level\nb=high level");
test_all_sections ( $cfg1, 0 );
dbug_ok (1, "------------------------------------------------");
my $cfg2 = init_config ("a = low level\nb=high level\npwd = Help!!!");
test_all_sections ( $cfg2, 0 );
test_all_sections ( $cfg2, 1 );
dbug_ok (1, "------------------------------------------------");
my $cfg3 = init_config ("[hello]\n a = low level\n b=high level\n pwd = Help!!!");
test_all_sections ( $cfg3, 0 );
test_all_sections ( $cfg3, 1 );
dbug_ok (1, "------------------------------------------------");
my $cfg4 = init_config ( "[alpha]\n 01 = low level\n 02=high level\n pwd03 = Help!!!\n" .
"[beta]\n 11 = low one\n 12=high two\n pwd13 = ???\n" .
"[omega]\n pwd23 = Ha! Ha! Ha!\n" .
"[zeta]\n"
);
test_all_sections ( $cfg4, 0 );
test_all_sections ( $cfg4, 1 );
# Since I didn't count the test cases, must end my program
# with a call to this method. Can't do tests in END anymore!
done_testing ();
DBUG_LEAVE (0);
}
# ====================================================================
sub test_all_sections
{
DBUG_ENTER_FUNC ( @_ );
my $cfg = shift;
my $sensitive = shift;
my $hashRef = $cfg->toHash ( $sensitive );
foreach my $s ( $cfg->find_sections (undef, 0) ) {
my $sect = $cfg->get_section ( $s, 1 );
dbug_ok ( 1, "Section '$s' exists in the Advanced::Config object!" );
my @tags = trim_if_sensitive ( $sect, $sensitive );
my $data = $hashRef->{$s}; # Get the proper sub-hash ...
if ( $#tags == -1 ) {
dbug_ok ( ! defined $data, "Section '$s' has no data in it!" );
} else {
dbug_ok ( defined $data, "Section '$s' has data in it!" );
test_section ( $sect, $data, @tags );
}
}
DBUG_VOID_RETURN ();
}
# ====================================================================
sub trim_if_sensitive
{
DBUG_ENTER_FUNC ( @_ );
t/56-tohash.t view on Meta::CPAN
push (@keep, $_) unless ( $cfg->chk_if_sensitive ($_, 0) );
}
} else {
@keep = @tags;
}
DBUG_RETURN ( @keep );
}
# ====================================================================
sub test_section
{
DBUG_ENTER_FUNC ( @_ );
my $sect = shift;
my $data = shift;
my @tags = @_;
my %found;
foreach my $tag ( sort @tags ) {
my $val = $sect->get_value ($tag) || "";
dbug_ok ( exists $data->{$tag} && $data->{$tag} eq $val,
"Tag '${tag}' exists in the hash with the correct value ($val)");
$found{$tag} = 1;
}
# Make sure there are no extra keys ...
foreach my $tag ( sort keys %{$data} ) {
unless ( exists $found{$tag} ) {
dbug_ok ( 0, "Tag '$tag' exists in the Advanced::Config object!" );
t/70-validate_date_vars.t view on Meta::CPAN
# ====================================================================
{
# Turn fish on ...
DBUG_PUSH ( $fish );
DBUG_ENTER_FUNC (@ARGV);
dbug_ok (1, "In the MAIN program ..."); # Test # 2 ...
my $now = time ();
my ($hr1, $min1, $sec1) = (localtime ($now))[2,1,0];
my ($hr2, $min2, $sec2) = (localtime ($now + 240))[2,1,0];
# If 4 minutes in the future is tomorrow ...
# Skip all tests so that the smoke testers won't complain!
if ( $hr1 > $hr2 ) {
dbug_ok (1, "Skipping all date tests. The current time is too close to midnight! ($hr1:$min1:$sec1, $hr2:$min2:$sec2)");
done_testing ();
DBUG_LEAVE (0);
}
my @cfgs;
DBUG_PRINT ("====", "%s", "="x50);
foreach my $opt ( {}, { date_sep => "/", date_order => 1 },
{ date_sep => ".", date_order => 2, month_type => 2 },
{ date_sep => "", date_order => 0, month_type => 0 },
{ date_sep => " ", date_order => 1, month_type => 1 }
t/70-validate_date_vars.t view on Meta::CPAN
{
DBUG_ENTER_FUNC (@_);
my $file = shift; # The file to source in.
my $custom = shift; # The private work area hash.
# Get the default options ...
my $dop = Advanced::Config::Options::get_date_opts ();
# Sleeping will cause failures, but was temporarily
# needed to prove comparing 1_timestamp & 2_timestamp worked!
# dbug_ok (1, "Sleeping for 4 seconds!");
# sleep (4);
DBUG_RETURN ( undef, $dop );
}
# ====================================================================
sub my_validation
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift; # The config file to validate ...
my $total = shift; # The number of keys in $validate.
my $validate = shift; # The hash to validate against ...
my @sections = $cfg->find_sections ();
my $cnt = @sections;
dbug_is ($cnt, 1, "The config file doesn't define any sections!");
my @tag_list = $cfg->find_tags ();
$cnt = @tag_list;
dbug_is ($cnt, $total, "Found the expected number of tags in config file ($total)");
DBUG_PRINT ("----", "%s", "-"x50);
$cnt = 0;
foreach ( @tag_list ) {
unless ( exists $validate->{$_} ) {
t/70-validate_date_vars.t view on Meta::CPAN
dbug_is ($cnt, 0, "All tags were accounted for in the validation hash!");
DBUG_PRINT ("----", "%s", "-"x50);
foreach ( sort keys %{$validate} ) {
my $val1 = $validate->{$_};
my $val2 = $cfg->get_value ( $_ );
my $val3 = (defined $val2) ? $val2 : "";
my $chk = (defined $val2) && $val1 eq $val2;
# If we're unlucky, the timestamps can be dozens of seconds off ...
my $ts = ( $_ =~ m/^[12]_timestamp$/ ) ? 1 : 0;
# if ($ts) { sleep(1); }
if ( $ts && $val2 && ! $chk ) {
my $diff = $val1 - $val3;
$chk = 1 if ( $diff <= 120 );
dbug_ok ( $chk, "Validating tag \"$_\" in config file is close enough. ($val3) [Diff: $diff sec(s)]" );
}
else {
dbug_ok ( $chk, "Validating tag \"$_\" matches config file. ($val3)" );
}
unless ( $chk ) {
DBUG_PRINT ("ERROR", "Value should have been: %s", $val1);
}
}
t/75-check_all_languages.t view on Meta::CPAN
# Stops on any error encountered.
# --------------------------------------------------------------------
sub compare_objects
{
DBUG_ENTER_FUNC (@_);
my $cfg_src = shift;
my $cfg_dst = shift;
DBUG_PAUSE () unless ( $run_as_developer );
my @src = $cfg_src->find_sections ();
my @dst = $cfg_src->find_sections ();
unless (dbug_is ( $#src, $#dst, "Both objects have the same number of sections in them!" )) {
return DBUG_RETURN (0);
}
my $stop = 0;
foreach (@src) {
my $sCfg1 = $cfg_src->get_section ( $_ );
my $sCfg2 = $cfg_dst->get_section ( $_ );
my $sts = ( $sCfg1 && $sCfg2 ) ? 1 : 0;
unless (dbug_ok ($sts, "Section '$_' exists in both objects!")) {
$stop = 1;
last;
}
my @tags1 = $sCfg1->find_tags ();
my @tags2 = $sCfg2->find_tags ();
unless (dbug_is ( $#tags1, $#tags2, "Both copies of section '$_' have the same number of tags in them!")) {
$stop = 1;
last;
}
foreach my $t (@tags1) {
my $val1 = $sCfg1->get_value ($t);
my $val2 = $sCfg2->get_value ($t);
$sts = ( defined $val2 && $val1 eq $val2 ) ? 1 : 0;
unless ( dbug_ok ($sts, "Tag '$t' in both objects have the same value ($val1) ($val2)" ) ) {
$stop = 1;
t/75-check_all_languages.t view on Meta::CPAN
# Validates that reading/writing to the config file doesn't introduce issues.
sub validate_MoY_MoYs
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift;
my $fatal = 0;
DBUG_PAUSE () unless ( $run_as_developer );
foreach ( $cfg->find_sections () ) {
my $sCfg = $cfg->get_section ( $_, 1 );
my $lang = $sCfg->get_value ("Language", {required => 0});
unless ( defined $lang ) {
dbug_ok (1, "Skipping section '${_}' due to no Language tag!");
next;
}
my %data = ( Language => $lang, Module => "Date::Language::${lang}" );
my ($MoY_ref, $MoYs_ref) = Advanced::Config::Date::_swap_lang_common ( \%data, 0, 1 );
foreach my $tag ( $sCfg->find_tags (qr /^MoY_/, 0) ) {
$fatal += test_array ($sCfg, "MoY", $lang, $tag, $MoY_ref );
}
t/75-check_all_languages.t view on Meta::CPAN
# --------------------------------------------------------------------
sub validate_dates
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift;
my $utf8_expected = shift;
DBUG_PAUSE () unless ( $run_as_developer );
foreach my $s ( $cfg->find_sections () ) {
my $sCfg = $cfg->get_section ( $s, 1 );
my $lang = $sCfg->get_value ("Language", {required => 0});
unless ( defined $lang ) {
dbug_ok (1, "Skipping section '$s' due to no Language tag!");
next;
}
my $tmp = $lang;
# $tmp = Advanced::Config::Date::swap_language ($lang);
if ( $tmp ne $lang ) {
dbug_ok (0, "Language was changed to ${lang}");
next;
}
dbug_ok (1, "Validating dates for language ${lang} ...");
t/75-check_all_languages.t view on Meta::CPAN
my $ok = ($val =~ m/^Found /) ? 1 : 0;
dbug_ok ($ok, "Found Weekday Tag ($tag): ${val}");
}
# Validate the date itself ...
foreach my $tag ( $sCfg->find_tags (qr /^[0-9]{4}-[0-9]{2}-[0-9]{2}$/, 0) ) {
my $val1 = $sCfg->get_value ($tag);
DBUG_PRINT ("UTF8", "utf8 flag (%d)", utf8::is_utf8($val1));
my $val2 = $sCfg->get_date ($tag, $lang, date_language_warn => 0);
if ( $val2 && $val2 eq $tag ) {
dbug_ok (1, "Found tag: ${tag} in section '${s}' for ${lang} --> ${val2} -- ${val1}");
} else {
dbug_ok (0, "Tag ${tag} in section '${s}' for ${lang} points to a valid date: ${val1}");
}
}
DBUG_PRINT ("----", "-------------------------------------------------");
}
DBUG_VOID_RETURN ();
}
# ====================================================================
# From here on down deals with creating the config file.
t/75-check_all_languages.t view on Meta::CPAN
print CONFIG "\n";
foreach ( 1..12 ) {
print CONFIG build_date (3, 1999, $_, $_ + 15, $l, $lang);
}
print CONFIG "\n";
}
print CONFIG "----------------------------------------------------------\n\n";
# These extra sections are for advanced checks ...
# Using variables and Encryption ...
my $cntr = 0;
foreach my $lang ( "Chinese", "Greek", "Russian" ) {
my $l = $all_languages->{$lang};
next unless ( defined $l );
next if ( $l->{wide} && ! $wide_flag );
++$cntr;
print CONFIG "[ ZZ Extra ${cntr} ]\n";
t/76-check_all_languages2.t view on Meta::CPAN
# Stops on any error encountered.
# --------------------------------------------------------------------
sub compare_objects
{
DBUG_ENTER_FUNC (@_);
my $cfg_src = shift;
my $cfg_dst = shift;
DBUG_PAUSE () unless ( $run_as_developer );
my @src = $cfg_src->find_sections ();
my @dst = $cfg_src->find_sections ();
unless (dbug_is ( $#src, $#dst, "Both objects have the same number of sections in them!" )) {
return DBUG_RETURN (0);
}
my $stop = 0;
foreach (@src) {
my $sCfg1 = $cfg_src->get_section ( $_ );
my $sCfg2 = $cfg_dst->get_section ( $_ );
my $sts = ( $sCfg1 && $sCfg2 ) ? 1 : 0;
unless (dbug_ok ($sts, "Section '$_' exists in both objects!")) {
$stop = 1;
last;
}
my @tags1 = $sCfg1->find_tags ();
my @tags2 = $sCfg2->find_tags ();
unless (dbug_is ( $#tags1, $#tags2, "Both copies of section '$_' have the same number of tags in them!")) {
$stop = 1;
last;
}
foreach my $t (@tags1) {
my $val1 = $sCfg1->get_value ($t);
my $val2 = $sCfg2->get_value ($t);
$sts = ( defined $val2 && $val1 eq $val2 ) ? 1 : 0;
unless ( dbug_ok ($sts, "Tag '$t' in both objects have the same value ($val1) ($val2)" ) ) {
$stop = 1;
t/76-check_all_languages2.t view on Meta::CPAN
sub validate_MoY_MoYs
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift;
my $lData = shift;
my $fatal = 0;
DBUG_PAUSE () unless ( $run_as_developer );
foreach ( $cfg->find_sections () ) {
my $sCfg = $cfg->get_section ( $_, 1 );
my $lang = $sCfg->get_value ("Language", {required => 0});
unless ( defined $lang ) {
dbug_ok (1, "Skipping section '${_}' due to no Language tag!");
next;
}
unless ( exists $lData->{$lang} ) {
dbug_ok (0, "No such language ${lang} to validate against!");
next;
}
my (%data, $MoY_ref, $MoYs_ref);
$data{Language} = $lang;
t/76-check_all_languages2.t view on Meta::CPAN
# --------------------------------------------------------------------
sub validate_dates
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift;
my $utf8_expected = shift;
DBUG_PAUSE () unless ( $run_as_developer );
foreach my $s ( $cfg->find_sections () ) {
my $sCfg = $cfg->get_section ( $s, 1 );
my $lang = $sCfg->get_value ("Language", {required => 0});
unless ( defined $lang ) {
dbug_ok (1, "Skipping section '$s' due to no Language tag!");
next;
}
my $tmp = $lang;
# $tmp = Advanced::Config::Date::swap_language ($lang);
if ( $tmp ne $lang ) {
dbug_ok (0, "Language was changed to ${lang}");
next;
}
dbug_ok (1, "Validating dates for language ${lang} ...");
t/76-check_all_languages2.t view on Meta::CPAN
my $ok = ($val =~ m/^Found /) ? 1 : 0;
dbug_ok ($ok, "Found Weekday Tag ($tag): ${val}");
}
# Validate the date itself ...
foreach my $tag ( $sCfg->find_tags (qr /^[0-9]{4}-[0-9]{2}-[0-9]{2}$/, 0) ) {
my $val1 = $sCfg->get_value ($tag);
DBUG_PRINT ("UTF8", "utf8 flag (%d)", utf8::is_utf8($val1));
my $val2 = $sCfg->get_date ($tag, $lang, date_language_warn => 1);
if ( $val2 && $val2 eq $tag ) {
dbug_ok (1, "Found tag: ${tag} in section '${s}' for ${lang} --> ${val2} -- ${val1}");
} else {
dbug_ok (0, "Tag ${tag} in section '${s}' for ${lang} points to a valid date: ${val1}");
}
}
DBUG_PRINT ("----", "-------------------------------------------------");
}
DBUG_VOID_RETURN ();
}
# ====================================================================
# From here on down deals with creating the config file.
t/76-check_all_languages2.t view on Meta::CPAN
print CONFIG "\n";
foreach ( 1..12 ) {
print CONFIG build_date (3, 1999, $_, $_ + 15, $l);
}
print CONFIG "\n";
}
print CONFIG "----------------------------------------------------------\n\n";
# These extra sections are for advanced checks ...
# Using variables and Encryption ...
my $cntr = 0;
foreach my $lang ( "Chinese", "Greek", "Russian" ) {
my $l = $all_languages->{$lang};
next unless ( defined $l );
next if ( $l->{wide} && ! $wide_flag );
++$cntr;
print CONFIG "[ ZZ Extra ${cntr} ]\n";
t/config/12-use_sections.cfg view on Meta::CPAN
# ==========================================================================
#
# Test Program : t/12-validate_sections.t
#
# This File : t/config/12-use_sections.cfg
#
# ==========================================================================
#
# This config file is for testing out using sections.
# Both in exclude & inherit modes.
#
# ==========================================================================
main_01 = one
main_02 = two
main_03 = three
override_1 = ONE
override_2 = TWO
self = ${section}
[ section 01 ]
override_1 = Help me One!
extra_1 = Extra Help
self = ${section}
[ section 02 ]
override_1 = Two vs One no fair! (${override_1}) # (ONE)
override_2 = Two vs Two isn't fair either! (${override_2}) # (TWO)
extra_1 = Crispy
self = ${section}
[ section 01 ]
override_2 = No help here One!
extra_2 = Extra ${extra_1} # Extra Extra Help
[ section 03 ]
override_1 = Three to One odds are great!
override_2 = Three to Two odds not so great!
extra_2 = Sweet
self = ${section}
[ main ]
main_04 = four
main_05 = five
override_1 = =ONE=
override_2 = =TWO=
main_06 = ${section 02.extra_1}/${section 03.extra_2} # Crispy/Sweet
t/config/15-multi_source_01_main.cfg view on Meta::CPAN
# files into a single Advanced::Config object.
#
# For this test all sourced in files use the same operators!
#
. 15-multi_source_02_first.cfg
main_01 = "Hello World!"
hello = again!
. 15-multi_source_03_second.cfg
[ common ]
common_01 = "Humpty Dumpty!"
[ overwrite ]
overwrite = "From file 01"
. 15-multi_source_04_third.cfg
[ first ]
t/config/15-multi_source_02_first.cfg view on Meta::CPAN
main_02 = "What's up Doc?"
[ common ]
common_02 = "Sat on a wall!"
[ overwrite ]
overwrite = "From file 02!"
[ second ]
hello = 2nd?
t/config/21-0-encrypt-decrypt.cfg view on Meta::CPAN
#
# This is just a sample config file that I'm using as a basis.
# It's validated by t/20-validate_encrypt_decrypt.t
#
# NOTE: All "join" tags reference encrypted variables!
# The above program assumes this is true!
#
# NOTE: Make sure the same tag doesn't appear in mupltiple sections.
# This will brake the test program!
#
# --------------------------------------------------------------
a = "A is for Apple!"
b = 'B is for Bat!' # A comment to ENCRYPT.
c='C is for Cat!' # Another comment to ENCRYPT
t/config/22-0-encrypt-decrypt.cfg view on Meta::CPAN
#
# This is just a sample config file that I'm using as a basis.
# It's validated by t/20-validate_encrypt_decrypt.t
#
# Using :=: as assignment
# and | as quotes
#
# NOTE: All "join" tags reference encrypted variables!
# The above program assumes this is true!
#
# NOTE: Make sure the same tag doesn't appear in mupltiple sections.
# This will brake the test program!
#
# --------------------------------------------------------------
a :=: |A is for Apple!|
b :=: |B is for Bat!| # A comment to ENCRYPT.
c:=:|C is for Cat!| # Another comment to ENCRYPT
( run in 1.625 second using v1.01-cache-2.11-cpan-39bf76dae61 )