Advanced-Config
view release on metacpan or search on metacpan
object you wish to work with. All it does is create an empty object for you to
reference and returns the C<Advanced::Config> object created. Once you
have this object reference you are good to go! You can either load an existing
config file into memory or dynamically build your own virtual config file or
even do a mixure of both!
=over
=item $cfg = Advanced::Config->new( [$filename[, \%read_opts[, \%get_opts[, \%date_var_opts]]]] );
It takes four arguments, any of which can be omitted or B<undef> during object
creation!
F<$filename> is the optional name of the config file to read in. It can be a
relative path. The absolute path to it will be calculated for you if a relative
path was given.
F<\%read_opts> is an optional hash reference that controls the default parsing
of the config file as it's being read into memory. Feel free to leave as
B<undef> if you're satisfied with this module's default behavior.
F<\%get_opts> is an optional hash reference that defines the default behavior
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:
# 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 );
$control{read_only} = 0; # not created via newDefineConfigRules().
$control{ConfigRuleObj} = undef; # not set by set_config_rules ().
my ( %dates, %empty, %mods, %ropts, %rec, @lst );
# Special Date Variables ...
set_special_date_vars ($control{date_opts}, \%dates);
$control{DATES} = \%dates;
$control{DATE_USED} = 0;
# Environment variables referenced ...
$control{ENV} = \%empty;
foreach my $g ( @get_list ) { $cfg->_base_set ( $g, $gOpts->{$g} ); }
foreach my $p ( @spec_list ) { $cfg->_base_set ( $p, $sOpts->{$p} ); }
# Load what's in the config file.
my $bool = $cfg->merge_config ();
# Validate that it built ok.
foreach my $s ( $cfg->find_sections () ) {
my $sect = $cfg->get_section ($s, 1);
my $name = $sect->section_name ();
my @tags = $sect->find_tags ( undef, 0 ); # Search current section only.
foreach my $t ( @tags ) {
my $cnt = (exists $rOpts->{$t} ? 1 : 0) +
(exists $gOpts->{$t} ? 1 : 0) +
(exists $sOpts->{$t} ? 1 : 0);
$cnt = 1 if ( $cnt == 0 && $name eq DEFAULT_SECTION && $extra{$t} );
$cnt = 1 if ( $cnt == 0 && $name ne "*" && $t eq "__order__" );
if ( $cnt == 0 ) {
die "Tag '$t' is not a valid option hash value in section $name!\n";
}
}
I<load_config> and will be forgotten afterwards. If you want these options
to persist between calls, set the option via the call to B<new()>. This
argument can be passed either by value or by reference. Either way will work.
See L<Advanced::Config::Options> for more details.
On success, it returns a reference to itself so that it can be initialized
separately or as a single unit.
Ex: $cfg = Advanced::Config->new(...)->load_config (...);
On failure it returns I<undef> or calls B<die> if option I<croak> is set!
WARNING: If basename(I<$filename>) is a symbolic link and your config file
contains encrypted data, please review the encryption options about special
considerations.
=cut
sub load_config
{
DBUG_ENTER_FUNC ( @_ );
my %none;
$new_opts = \%none;
} else {
$read_opts = {@_} if ( ref ($read_opts) ne "HASH" );
$new_opts = $read_opts;
}
$read_opts = get_read_opts ( $read_opts, $self->{CONTROL}->{read_opts} );
unless ( $filename ) {
my $msg = "You must provide a file name to load!";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
unless ( -f $filename ) {
my $msg = "No such file or it's unreadable! -- $filename";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
DBUG_PRINT ("READ", "Reading a config file into memory ... %s", $filename);
unless ( -f $filename && -r _ ) {
my $msg = "Your config file name doesn't exist or isn't readable.";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
# Behaves diferently based on who calls us ...
my $c = (caller(1))[3] || "";
my $by = __PACKAGE__ . "::merge_config";
my $by2 = __PACKAGE__ . "::_load_config_with_new_date_opts";
if ( $c eq $by ) {
# Manually merging in another config file.
push (@{$self->{CONTROL}->{MERGE}}, $filename);
} elsif ( $c eq $by2 ) {
$self->{CONTROL}->{REFRESH_READ_OPTIONS}->{$filename} = get_read_opts ($read_opts);
# So will auto-clear if die is called!
local $self->{CONTROL}->{RECURSION}->{$filename} = 1;
# Temp override of the default read options ...
local $self->{CONTROL}->{read_opts} = $read_opts;
unless ( read_config ( $filename, $self ) ) {
my $msg = "Reading the config file had serious issues!";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
DBUG_RETURN ( $self );
}
#######################################
=item $cfg = $cfg->load_string ( $string[, %override_read_opts] );
This method takes the passed I<$string> and treats it's value as the contents of
if ( $self->_chk_if_read_only () ) {
die "You may not override rules for object created by newDefineConfigRules ()\n";
}
# Get the read options ...
$read_opts = {@_} if ( ref ($read_opts) ne "HASH" );
$read_opts = get_read_opts ( $read_opts, $self->{CONTROL}->{read_opts} );
unless ( $string ) {
my $msg = "You must provide a string to use this method!";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
# The filename is a reference to the string passed to this method!
my $filename = \$string;
# If there's no alias provided, use a default value for it ...
# There is no filename to use for decryption purposes without it.
$read_opts->{alias} = "STRING" unless ( $read_opts->{alias} );
# Dynamically correct based on type of string ...
$self->{CONTROL}->{REFRESH_READ_OPTIONS}->{$filename} = get_read_opts ($read_opts);
# So will auto-clear if die is called!
local $self->{CONTROL}->{RECURSION}->{$filename} = 1;
# Temp override of the default read options ...
local $self->{CONTROL}->{read_opts} = $read_opts;
unless ( read_config ( $filename, $self ) ) {
my $msg = "Reading the config file had serious issues!";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
DBUG_RETURN ( $self );
}
#######################################
# No POD on purpose ...
# For use by Advanced::Config::Reader only.
# Purpose is to allow source_file() a way to modify the date options.
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;
my $get_opts = $pcfg->{CONTROL}->{get_opts};
$get_opts = get_get_opts ( $opts, $get_opts ) if ( $opts );
# Check if a case insensitive lookup was requested ...
my $t = ( $pcfg->{CONTROL}->{read_opts}->{tag_case} && $tag ) ? lc ($tag) : $tag;
# Check if we're overriding the required flag ...
my $req = $get_opts->{required};
local $get_opts->{required} = $disable_req ? 0 : $req;
# Returns a hash reference to a local copy of the tag's data ... (or undef)
# Handles the inherit option if used.
my $data_ref =apply_get_rules ( $tag, $self->{SECTION_NAME},
$self->{DATA}->{$t}, $pcfg->{DATA}->{$t},
$pcfg->{CONTROL}->{ALLOW_UTF8},
$get_opts );
return ( wantarray ? ($data_ref, $req) : $data_ref );
}
{
my $self = shift;
my $tag = shift;
my $opts = shift;
my ($data, $req) = $self->_base_get ( $tag, $opts, 0 );
if ( defined $data ) {
return ( $data->{VALUE}, $data->{MASK_IN_FISH}, $data->{FILE}, $data->{ENCRYPTED}, $data->{VARIABLE}, $req );
} else {
return ( undef, 0, "", 0, 0, $req ); # No such tag ...
}
}
# Private method ...
# Gets the requested tag date value from the current section.
# or treat the tag name as the date if the tag doesn't exist!
# Returns: All 5 of the hash members individually ... + required flag setting.
sub _base_get3_date_str
{
my $self = shift;
my $tag = shift;
my $opts = shift;
my $hyd_flg = shift; # Is it OK to return a HYD as HYD?
my $cvt_hyd_flg = shift; # Is it OK to convert a HYD into a date str?
if ($hyd_flg && $cvt_hyd_flg) {
local $opts->{required} = 1;
croak_helper ($opts, "Programming error! Can't set both hyd flags to true.", undef);
}
my ($data, $req);
{
local $opts->{date_active} = 0;
($data, $req) = $self->_base_get ( $tag, $opts, 1 ); # Does tag exist?
}
# If the tag doesn't exist, use $tag as a date string instead.
unless ( defined $data ) {
my $yr = _validate_date_str ($tag);
if ( defined $yr ) {
return ( $tag, 0, "", 0, 0, $req ); # We have a valid date string!
} elsif ( $hyd_flg && $tag =~ m/^[-]?\d+$/ ) {
return ( $tag, 0, "", 0, 0, $req ); # We have a valid HYD string!
} elsif ( $cvt_hyd_flg && $tag =~ m/^[-]?\d+$/ ) {
my $dt = convert_hyd_to_date_str ($tag);
return ( $dt, 0, "", 0, 0, $req ); # We have a valid date string!
} else {
local $opts->{required} = $req;
croak_helper ($opts, "No such tag ($tag), nor is it a date string.", undef);
return ( undef, 0, "", 0, 0, $req ); # No such tag/date ...
}
}
# The tag exists, then it must reference a date!
local $opts->{date_active} = 1;
($data, $req) = $self->_base_get ( $tag, $opts, 0 );
if ( defined $data ) {
return ( $data->{VALUE}, $data->{MASK_IN_FISH}, $data->{FILE}, $data->{ENCRYPTED}, $data->{VARIABLE}, $req );
} else {
return ( undef, 0, "", 0, 0, $req ); # Not a date ...
}
}
#######################################
=back
=head2 Accessing the contents of an Advanced::Config object.
These methods allow you to access the data loaded into this object.
They all look in the current section for the B<tag> and if the B<tag> couldn't
be found in this section and the I<inherit> option was also set, it will then
look in the parent/main section for the B<tag>. But if the I<inherit> option
wasn't set it wouldn't look there.
If the requested B<tag> couldn't be found, they return B<undef>. But if the
I<required> option was used, it may call B<die> instead!
But normally they just return the requested B<tag>'s value.
They all use F<%override_get_opts>, passed by value or by reference, as an
optional argument that overrides the default options provided in the call
to F<new()>. The I<inherit> and I<required> options discussed above are two
such options. In most cases this hash argument isn't needed. So leave it off
if you are happy with the current defaults!
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value );
}
#######################################
# A helper function to handle the various ways to find a hash as an argument!
# Handles all 3 cases.
# undef - No arguments
# hash ref - passed by reference
# something else - passed by value. (array)
sub _get_opt_args
{
my $self = shift; # Reference to the current section.
my $opt_ref = $_[0]; # May be undef, a hash ref, or start of a hash ...
# Convert the parameter array into a regular old hash reference ...
my %opts;
unless ( defined $opt_ref ) {
$opt_ref = \%opts;
} elsif ( ref ($opt_ref) ne "HASH" ) {
%opts = @_;
$opt_ref = \%opts;
}
return ( $opt_ref ); # The hash reference to use ...
}
#######################################
# Another helper function to help with evaluating which value to use ...
# Does a 4 step check.
# 1) Use the $value if provided.
# 2) If the key exists in the hash returned by _get_opt_args(), use it.
# 3) Look it up in the default "Get Options" set via call to new().
# 4) undef if all the above fail.
sub _evaluate_hash_values
{
my $self = shift; # References the current section.
my $key = shift; # The hash key to look up ...
my $ghash = shift; # A hash ref returned by _get_opt_args().
my $value = shift; # Use only if explicitly set ...
unless ( defined $value ) {
if ( defined $ghash && exists $ghash->{$key} ) {
#######################################
=item $value = $cfg->get_integer ( $tag[, $rt_flag[, %override_get_opts]] );
This function looks up the requested B<tag>'s value and returns it if its an
integer. If the B<tag>'s value is a floating point number (ex 3.6), then the
value is either truncated or rounded up based on the setting of the I<rt_flag>.
If I<rt_flag> is set, it will perform truncation, so 3.6 becomes B<3>. If the
flag is B<undef> or zero, it does rounding, so 3.6 becomes B<4>. Meaning the
default is rounding.
Otherwise if the B<tag> doesn't exist or its value is not numeric it will
return B<undef> unless it's been marked as I<required>. In that case B<die>
may be called instead.
=cut
sub get_integer
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $rt_flag = shift; # 1 - truncate, 0 - rounding.
}
#######################################
=item $value = $cfg->get_numeric ( $tag[, %override_get_opts] );
This function looks up the requested B<tag>'s value and returns it if its
value is numeric. Which means any valid integer or floating point number!
If the B<tag> doesn't exist or its value is not numeric it will return B<undef>
unless it's been marked as I<required>. In that case B<die> may be called
instead.
=cut
sub get_numeric
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value );
}
#######################################
=item $value = $cfg->get_boolean ( $tag[, %override_get_opts] );
Treats the B<tag>'s value as a boolean value and returns I<undef>,
B<0> or B<1>.
Sometimes you just want to allow for basically a true/false answer
without having to force a particular usage in the config file.
This function converts the B<tag>'s value accordingly.
So it handles pairs like: Yes/No, True/False, Good/Bad, Y/N, T/F, G/B, 1/0,
On/Off, etc. and converts them into a boolean value. This test is case
insensitive. It never returns what's actually in the config file.
#######################################
=item $date = $cfg->get_date ( $tag[, $language[, %override_get_opts]] );
This function looks up the requested B<tag>'s value and returns it if its
value contains a valid date. The returned value will always be in I<YYYY-MM-DD>
format no matter what format or language was actually used in the config file
for the date.
If the B<tag> doesn't exist or its value is not a date it will return B<undef>
unless it's been marked as I<required>. In that case B<die> may be called
instead.
If I<$language> is undefined, it will use the default language defined in the
call to I<new> for parsing the date. (B<English> if not overridden.) Otherwise
it must be a valid language defined by B<Date::Language>. If it's a wrong or
bad language, your date might not be recognized as valid.
Unlike most other B<get> options, when parsing the B<tag>'s value, it's not
looking to match the entire string. It's looking for a date portion inside the
value and ignores any miscellaneous information. There was just too many
semi-valid potential surrounding data to worry about parsing that info as well.
So B<Tues "January 3rd, 2017" at 6:00 PM> returns "2017-01-03".
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);
DBUG_MASK_NEXT_FUNC_CALL (-1);
}
return DBUG_RETURN (undef) unless (defined $value);
$value = calc_hundred_year_date ( $value );
DBUG_RETURN ( $value );
}
#######################################
=item $dow = $cfg->get_dow_date ( $tag[, $language[, $mode[, %override_get_opts]]] );
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);
DBUG_MASK_NEXT_FUNC_CALL (-1);
}
return DBUG_RETURN (undef) unless (defined $value);
$value = calc_day_of_week ( $value ); # 0 .. 6
if ($mode =~ m/^[12]$/) {
DBUG_MASK_NEXT_FUNC_CALL (-1) if ( $sensitive );
my ($m, $dow_ref) = init_special_date_arrays ($opt_ref->{date_language},
$mode, 0, 1);
$value = $dow_ref->[$value] if ( defined $dow_ref );
}
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);
DBUG_MASK_NEXT_FUNC_CALL (-1);
}
return DBUG_RETURN (undef) unless (defined $value);
$value = calc_day_of_year ( $value );
DBUG_RETURN ( $value );
}
#######################################
=item $newDate = $cfg->get_adjusted_date ( $tag, $adjYr, $adjMon[, $language[, %override_get_opts]] );
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];
if ( $sensitive ) {
DBUG_MASK (0);
DBUG_MASK_NEXT_FUNC_CALL (-1);
}
return DBUG_RETURN (undef) unless (defined $value);
$value = adjust_date_str ( $value, $adjYrs, $adjMons );
unless (defined $value) {
local $opt_ref->{required} = $required;
croak_helper ($opt_ref, "usage errror", undef);
}
DBUG_RETURN ( $value );
}
#######################################
=item $value = $cfg->get_filename ( $tag[, $access[, %override_get_opts]] );
Treats the B<tag>'s value as a filename. If the referenced file doesn't exist
it returns I<undef> instead, as if the B<tag> didn't exist.
B<access> defines the minimum access required. If that minimum access isn't
met it returns I<undef> instead, as if the B<tag> didn't exist. B<access>
may be I<undef> to just check for existence.
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
}
DBUG_RETURN ( $value );
}
#######################################
=item $value = $cfg->get_directory ( $tag[, $access[, %override_get_opts]] );
Treats the B<tag>'s value as a directory. If the referenced directory doesn't
exist it returns I<undef> instead, as if the B<tag> didn't exist.
B<access> defines the minimum access required. If that minimum access isn't met
it returns I<undef> instead, as if the B<tag> didn't exist. B<access> may be
I<undef> to just check for existence.
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
}
=back
=head2 Accessing the contents of an Advanced::Config object in LIST mode.
These methods allow you to access the data loaded into each B<tag> in list mode.
Splitting the B<tag>'s data up into arrays and hashes. Otherwise these
functions behave similarly to the one's above.
Each function asks for a I<pattern> used to split the B<tag>'s value into an
array of values. If the pattern is B<undef> it will use the default
I<split_pattern> specified during he call to F<new()>. Otherwise it can be
either a string or a RegEx. See Perl's I<split> function for more details.
After the value has been split, it will perform any requested validation and
most functions will return B<undef> if even one element in the list fails it's
edits. It was added as its own argument, instead of just relying on the
override option hash, since this option is probably the one that gets overridden
most often.
They also support the same I<inherit> and I<required> options described for the
scalar functions as well.
They also all allow 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()>. If you should use both option I<split_pattern> and the I<pattern>
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
# Tells how to sort the resulting array ...
local $opt_ref->{sort} =
$self->_evaluate_hash_values ("sort", $opt_ref, $sort);
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $hash_ref = $cfg->get_hash_values ( $tag[, $pattern[, $value[, \%merge[, %override_get_opts]]]] );
This method is a bit more complex than L<get_list_values>. Like that method it
splits up the B<tag>'s value into an array. But it then converts that array
into the keys of a hash whose value for each entry is set to I<value>.
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
# Tells how to sort the resulting array ...
local $opt_ref->{sort} =
$self->_evaluate_hash_values ("sort", $opt_ref, $sort);
my $value = $self->get_integer ( $tag, $rt_flag, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $array_ref = $cfg->get_list_numeric ( $tag[, $pattern[, $sort[, %override_get_opts]]] );
This is the list version of F<get_numeric>. See F<get_list_values> for the
meaning of I<$pattern> and I<$sort>.
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
# Tells how to sort the resulting array ...
local $opt_ref->{sort} =
$self->_evaluate_hash_values ("sort", $opt_ref, $sort);
my $value = $self->get_numeric ( $tag, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $array_ref = $cfg->get_list_boolean ( $tag[, $pattern[, %override_get_opts]] );
This is the list version of F<get_boolean>. See F<get_list_values> for the
meaning of I<$pattern>.
# Tells us to split the tag's value up into an array ...
local $opt_ref->{split} = 1;
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
my $value = $self->get_boolean ( $tag, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $array_ref = $cfg->get_list_date ( $tag, $pattern[, $language[, %override_get_opts]] );
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
$split_ptrn = $opt_ref->{split_pattern} unless ( defined $split_ptrn );
unless ( defined $split_ptrn ) {
my $msg = "Missing required \$pattern argument in call to get_list_date()!\n";
die ( $msg );
}
local $opt_ref->{split_pattern} = $split_ptrn;
my $value = $self->get_date ( $tag, $language, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=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} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
my $value = $self->get_filename ( $tag, $access, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $array_ref = $cfg->get_list_directory ( $tag[, $access[, $pattern[, %override_get_opts]]] );
This is the list version of F<get_directory>. See that function for the meaning
of I<$access>. See F<get_list_values> for the meaning of I<$pattern>.
=cut
sub get_list_directory
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $access = shift; # undef or contains "r", "w" and/or "x" ...
my $split_ptrn = shift; # The split pattern to use to call to split().
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Tells us to split the tag's value up into an array ...
local $opt_ref->{split} = 1;
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
my $value = $self->get_directory ( $tag, $access, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
# Private method ...
# Returns (Worked, Hide)
# Caller either wants both values or none of them.
# Should never write to fish ...
sub _base_set
{
if ( exists $self->{DATA}->{$tag} ) {
$hide = 1 if ( $self->{DATA}->{$tag}->{MASK_IN_FISH} );
} else {
my %data;
$self->{DATA}->{$tag} = \%data;
unless ( $hide ) {
$hide = 1 if ( should_we_hide_sensitive_data ($tag, 1) );
}
}
# The value must never be undefined!
$self->{DATA}->{$tag}->{VALUE} = (defined $value) ? $value : "";
# What file the tag was found in ...
$self->{DATA}->{$tag}->{FILE} = $file;
# Must it be hidden in the fish logs?
$self->{DATA}->{$tag}->{MASK_IN_FISH} = $hide;
# Is the value still encrypted?
$self->{DATA}->{$tag}->{ENCRYPTED} = $still_encrypted ? 1 : 0;
{
my $self = shift; # Reference to the current section of the object.
my $tag = shift; # The tag set to value ...
my $value = shift;
if ( $self->_chk_if_read_only () ) {
die ("You may not modify a rules config file!\n");
return (0);
}
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);
}
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;
DBUG_PRINT ("DBUG", "The section name is '%s'",
$self->{SECTIONS}->{$section}->{SECTION_NAME});
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
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 $name = shift;
if ( $self->_chk_if_read_only () ) {
die ("You may not modify a rules config file!\n");
return DBUG_RETURN (0);
}
# This test bypasses all the die logic in the special case constructor!
# That constructor is no longer exposed in the POD.
if ( $self->get_section ( $name ) ) {
return DBUG_RETURN (undef); # Name is already in use ...
}
DBUG_RETURN ( $self->new_section ( $self, $name ) );
}
#######################################
=back
=head2 Searching the contents of an Advanced::Config object.
This section deals with the methods available for searching for content within
your B<Advanced::Config> object.
=over
=item @list = $cfg->find_tags ( $pattern[, $override_inherit] );
It returns a list of all tags whose name contains the passed pattern.
If the pattern is B<undef> or the empty string, it will return all tags in
the current section. Otherwise it does a case insensitive comparison of the
pattern against each tag to see if it should be returned or not.
If I<override_inherit> is provided it overrides the current I<inherit> option's
setting. If B<undef> it uses the current I<inherit> setting. If I<inherit>
evaluates to true, it looks in the current section I<and> the main section for
a match. Otherwise it just looks in the current section.
The returned list of tags will be sorted in alphabetical order.
=cut
sub find_tags
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $pattern = shift;
my $inherit = shift; # undef, 0, or 1.
my @lst; # The list of tags found ...
my $pcfg = $self->{PARENT} || $self;
$inherit = $pcfg->{CONTROL}->{get_opts}->{inherit} unless (defined $inherit);
foreach my $tag ( sort keys %{$self->{DATA}} ) {
unless ( $pattern ) {
push (@lst, $tag);
DBUG_RETURN ( sort keys %res );
}
#######################################
=item @list = $cfg->find_values ( $pattern[, $override_inherit] );
It returns a list of all tags whose values contains the passed pattern.
If the pattern is B<undef> or the empty string, it will return all tags in
the current section. Otherwise it does a case insensitive comparison of the
pattern against each tag's value to see if it should be returned or not.
If I<override_inherit> is provided it overrides the current I<inherit> option's
setting. If B<undef> it uses the current I<inherit> setting. If I<inherit>
evaluates to true, it looks in the current section I<and> the main section for
a match. Otherwise it just looks in the current section.
The returned list of tags will be sorted in alphabetical order.
=cut
sub find_values
{
DBUG_ENTER_FUNC (@_);
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 (@_);
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 );
}
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 );
}
If the tag doesn't exist, or you called C<set_value> to create it, this function
will always return B<0> for that tag!
There are only two cases where it can ever return true (B<1>). The first case
is when you used the B<disable_variables> option. The second case is if you
used the B<disable_decryption> option and you had a variable that referenced
a tag that is still encrypted. But use of those two options should be rare.
If I<override_inherit> is provided it overrides the current I<inherit> option's
setting. If B<undef> it uses the current I<inherit> setting. If I<inherit>
evaluates to true, it looks in the current section I<and> the main section for
a match. Otherwise it just looks in the current section for the tag.
=cut
sub chk_if_still_uses_variables
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $inherit = shift; # undef, 0, or 1.
my $pcfg = $self->{PARENT} || $self;
$inherit = $pcfg->{CONTROL}->{get_opts}->{inherit} unless (defined $inherit);
local $pcfg->{CONTROL}->{get_opts}->{inherit} = $inherit;
my $bool = ($self->_base_get2 ( $tag ))[4];
DBUG_RETURN ( $bool );
}
my $line;
my $string = "";
my $cnt = 0;
foreach my $name ( $self->find_sections () ) {
my $cfg = $self->get_section ($name);
$line = format_section_line ($name, $rOpts);
$string .= "\n${line}\n";
++$cnt if ( should_we_hide_sensitive_data ( $name, 1 ) );
foreach my $tag ( $cfg->find_tags (undef, 0) ) {
++$cnt if ( $cfg->chk_if_sensitive ($tag, 0) );
$line = format_tag_value_line ($cfg, $tag, $rOpts);
$string .= " " . ${line} . ${cmt} . "\n";
}
}
# Mask the return value if anything seems sensitive.
DBUG_MASK (0) if ( $cnt > 0 );
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 );
}
$scratch = $file . ".$$.decrypted";
}
if ( $rOpts ) {
$rOpts = get_read_opts ($rOpts, $pcfg->{CONTROL}->{read_opts});
} else {
$rOpts = $pcfg->{CONTROL}->{read_opts};
}
if ( $msg ) {
return DBUG_RETURN ( croak_helper ( $rOpts, $msg, undef ) );
}
my $status = decrypt_config_file_details ($file, $scratch, $rOpts);
# Some type of error ... or nothing was decrypted ...
if ( $status == 0 || $status == -1 ) {
unlink ( $scratch );
# Replacing the original file ...
} elsif ( ! $newFile ) {
This method takes the passed I<$string> and treats its value as the contents of
a config file, comments and all. Modifying the I<$string> afterwards will not
affect things.
Since there is no filename to work with, it requires the I<$alias> to assist
with the encryption. And since it's required its passed as a separate argument
instead of being buried in the optional I<%rOpts> hash.
It takes the I<$string> and encrypts all tag/value pairs per the rules defined
by C<encrypt_config_file>. Once the contents of I$<string> has been encrypted,
the encrypted string is returned as I<$out_str>. It will return B<undef> on
failure.
You can tell if something was encrypted by comparing I<$string> to I<$out_str>.
=cut
sub encrypt_string
{
DBUG_MASK_NEXT_FUNC_CALL ( 2 ); # mask the alias.
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $string = shift; # The string to treat as a config file's contents.
my $alias = shift; # The alias to use during encryption ...
my $read_opts = $self->_get_opt_args ( @_ ); # The override options ...
unless ( $string ) {
my $msg = "You must provide a string to use this method!";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
unless ( $alias ) {
my $msg = "You must provide an alias to use this method!";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
# The filename is a reference to the string passed to this method!
my $scratch;
my $src_file = \$string;
my $dst_file = \$scratch;
# Put the alias into the read option hash ...
local $read_opts->{alias} = basename ($alias);
my $pcfg = $self->{PARENT} || $self;
my $rOpts = get_read_opts ($read_opts, $pcfg->{CONTROL}->{read_opts});
my $status = encrypt_config_file_details ($src_file, $dst_file, $rOpts);
$scratch = undef if ( $status == 0 );
DBUG_RETURN ( $scratch );
}
#######################################
=item $out_str = $cfg->decrypt_string ( $string, $alias[, \%rOpts] );
This method takes the passed I<$string> and treats its value as the contents of
an encrypted config file, comments and all. Modifying the I<$string> afterwards
will not affect things.
Since there is no filename to work with, it requires the I<$alias> to assist
with the decryption. And since it's required its passed as a separate argument
instead of being buried in the optional I<%rOpts> hash.
It takes the I<$string> and decrypts all tag/value pairs per the rules defined
by C<decrypt_config_file>. Once the contents of I$<string> has been decrypted,
the decrypted string is returned as I<$out_str>. It will return B<undef> on
failure.
You can tell if something was decrypted by comparing I<$string> to I<$out_str>.
=cut
sub decrypt_string
{
DBUG_MASK_NEXT_FUNC_CALL ( 2 ); # mask the alias.
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $string = shift; # The string to treat as a config file's contents.
my $alias = shift; # The alias to use during encryption ...
my $read_opts = $self->_get_opt_args ( @_ ); # The override options ...
unless ( $string ) {
my $msg = "You must provide a string to use this method!";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
unless ( $alias ) {
my $msg = "You must provide an alias to use this method!";
return DBUG_RETURN ( croak_helper ($read_opts, $msg, undef) );
}
# The filename is a reference to the string passed to this method!
my $scratch;
my $src_file = \$string;
my $dst_file = \$scratch;
# Put the alias into the read option hash ...
local $read_opts->{alias} = basename ($alias);
my $pcfg = $self->{PARENT} || $self;
my $rOpts = get_read_opts ($read_opts, $pcfg->{CONTROL}->{read_opts});
my $status = decrypt_config_file_details ($src_file, $dst_file, $rOpts);
$scratch = undef if ( $status == 0 );
DBUG_RETURN ( $scratch );
}
#######################################
=back
=head2 Handling Variables in your config file.
These methods are used to resolve variables defined in your config file when
it gets loaded into memory by this module. It is not intended for general use
except as an explanation on how variables work.
=over
=item ($value, $status) = $cfg->lookup_one_variable ( $variable_name );
This method takes the given I<$variable_name> and returns its value.
It returns I<undef> if the given variable doesn't exist. And the optional 2nd
return value tells us about the B<status> of the 1st return value.
If the B<status> is B<-1>, the returned value is still encrypted. If set to
B<1>, the value is considered sensitive. In all other cases this B<status> flag
is set to B<0>.
This method is frequently called internally if you define any variables inside
your config files when they are loaded into memory.
Variables in the config file are surrounded by anchors such as B<${>nameB<}>.
The precedence for looking up a variable's value to return is as follows:
0. Is it the special "shft3" variable or one of its variants?
1. Look for a tag of that same name previously defined in the current section.
2. If not defined there, look for the tag in the "main" section.
3. Special Case, see note below about periods in the variable name.
4. If not defined there, look for a value in the %ENV hash.
5. If not defined there, does it represent a special Perl variable?
6. If not defined there, is it a predefined Advanced::Config variable?
7. If not defined there, is it some predefined special date variable?
8. If not defined there, the result is undef.
If a variable was defined in the config file, it uses the tag's value when the
line gets parsed. But when you call this method in your code after the config
file has been loaded into memory, it uses the final value for that tag.
The special B<${>shft3B<}> variable is a way to insert comment chars into a
tag's value in the config file when you can't surround it with quotes. This
variable is always case insensitive and if you repeat the B<3> in the name, you
repeat the comment chars in the substitution.
# 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 );
if ( $rule != 0 ) {
if ( $pcfg->{CONTROL}->{DATE_USED} == 0 ) {
$pcfg->{CONTROL}->{DATE_USED} = $rule;
} elsif ( $pcfg->{CONTROL}->{DATE_USED} > $rule ) {
$pcfg->{CONTROL}->{DATE_USED} = $rule;
}
}
}
}
# 8. Then it must be undefined ... (IE: an unknown variable)
}
# Mask the return value in fish ???
DBUG_MASK ( 0 ) if ( $mask_flag);
# Is the return value still encryped ???
$mask_flag = -1 if ( $encrypt_flag );
DBUG_RETURN ( $val, $mask_flag )
}
helper method to F<lookup_one_variable> exists to perform this complex check.
For example, a variable called B<${>xxx.extraB<}> would look in Section "xxx"
for tag "extra".
Here's another example with multiple B<.>'s in its name this time. It would
look up variable B<${>one.two.threeB<}> in Section "one.two" for tag "three".
And if it didn't find it, it would next try Section "one" for tag "two.three".
If it found such a variable, it returns it's value. If it didn't find anything
it returns B<undef>. The optional 2nd and 3rd values tells you more about the
returned value.
I<$sens> is a flag that tells if the data value should be considered sensitive
or not.
I<$encrypt> is a flag that tells if the value still needs to be decrypted or
not.
=cut
sub rule_3_section_lookup
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $var_name = shift; # EX: abc.efg.xyz ...
my ( $val, $fish_mask, $f, $encrypted ) = ( undef, 0, "", 0 );
# If the variable name isn't named correctly ...
if ( $var_name !~ m/\./ ) {
return DBUG_RETURN ($val, $fish_mask, $encrypted);
}
# Silently disable calling "die" or "warn" on all get/set calls ...
my $pcfg = $self->{PARENT} || $self; # Get the main section ...
local $pcfg->{CONTROL}->{get_opts}->{required} = -9876;
# If it wasn't a hash reference, assume passed by value ...
if ( defined $date_opts && ref ($date_opts) eq "" ) {
my %data = @_;
$date_opts = \%data;
}
# -------------------------------------------------------------
# Start of real work ...
# -------------------------------------------------------------
my ($pcfg, $cmt, $la, $ra, $asgn) = (undef, '#', '${', '}', '=');
if ( $is_obj ) {
# Get the main/parent section to work against!
$pcfg = $self->{PARENT} || $self;
# Look in the Read Options hash for current settings ...
$cmt = $pcfg->{CONTROL}->{read_opts}->{comment};
$la = $pcfg->{CONTROL}->{read_opts}->{variable_left};
$ra = $pcfg->{CONTROL}->{read_opts}->{variable_right};
$asgn = $pcfg->{CONTROL}->{read_opts}->{assign};
}
full_developer_test.pl.src view on Meta::CPAN
if ( defined $cmd ) {
my $mk = basename ( $cmd );
print "\nRunning '${mk}' ...\n";
my $res = system ( $cmd );
if ( $res == 0 ) {
last; # The command is good!
} else {
print "Failed '${mk}'. Looking for the next make variant in the list.\n\n";
$cmd = undef;
}
}
}
unless ( defined $cmd ) {
die ("Can't locate a working 'make' program to run 'make test' with!\n");
}
print "Found: $cmd\n";
lib/Advanced/Config/Date.pm view on Meta::CPAN
}
DBUG_VOID_RETURN ();
}
# ==============================================================
# No POD on purpose ...
# Does some common logic for swap_language() & init_special_date_arrays().
# Requires knowledge of the internals to Date::Language::<language>
# in order to work.
# This method should avoid referencing any global variables!
# Returns: undef or the references to the 5 arrays!
sub _swap_lang_common
{
DBUG_ENTER_FUNC ( @_ );
my $lang_ref = shift;
my $warn_ok = shift;
my $allow_wide = shift || 0;
my $base = "Date::Language";
my $lang = $lang_ref->{Language};
my $module = $lang_ref->{Module};
my %issues;
# Check if the requested language module exists ...
{
local $SIG{__DIE__} = "";
my $sts = eval "require ${module}";
unless ( $sts ) {
_warn_msg ( $warn_ok, "${base} doesn't recognize '${lang}' as valid!" );
return DBUG_RETURN ( undef, undef, undef, undef, undef, \%issues );
}
}
# @Dsuf isn't always available for some modules & buggy for others.
my @lMoY = eval "\@${module}::MoY"; # The fully spelled out Months.
my @lMoYs = eval "\@${module}::MoYs"; # The legal Abbreviations.
my @lDsuf = eval "\@${module}::Dsuf"; # The suffix for the Day of Month.
my @lDoW = eval "\@${module}::DoW"; # The Day of Week.
my @lDoWs = eval "\@${module}::DoWs"; # The Day of Week Abbreviations.
# Detects Windows bug caused by case insensitive OS.
# Where the OS says the file exists, but it doesn't match the package name.
# Ex: Date::Language::Greek vs Date::Language::greek
if ( $#lMoY == -1 && $#lMoYs == -1 && $#lDsuf == -1 && $#lDoW == -1 && $#lDoWs == -1 ) {
_warn_msg ( $warn_ok, "${base} doesn't recognize '${lang}' as valid due to case!" );
return DBUG_RETURN ( undef, undef, undef, undef, undef, \%issues );
}
# Add the missing end of the month for quite a few Dsuf!
# Uses the suffixes from the 20's.
my $num = @lDsuf;
if ( $num > 29 ) {
my $fix = $num % 10;
foreach ( $num..31 ) {
my $idx = $_ - $num + 20 + $fix;
$lDsuf[$_] = $lDsuf[$idx];
lib/Advanced/Config/Date.pm view on Meta::CPAN
lc ($_) =~ m/[^\x00-\xff]/ ) {
$wide_flag = -1;
}
}
}
$lang_ref->{Wide} = $wide_flag;
if ( $wide_flag && ! $allow_wide ) {
_warn_msg ( $warn_ok, "'${lang}' uses Wide Chars. It's not currently enabled!" );
return DBUG_RETURN ( undef, undef, undef, undef, undef, \%issues );
}
# Put in the number before the suffix ... (ie: nd => 2nd, rd => 3rd)
# Many langages built this array incorrectly & shorted it.
foreach ( 0..31 ) {
last unless ( defined $lDsuf[$_] );
$lDsuf[$_] = $_ . $lDsuf[$_];
$issues{dsuf_period} = 1 if ($lDsuf[$_] =~ m/[.]/ );
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
DBUG_RETURN ( \@lMoY, \@lMoYs, \@lDsuf, \@lDoW, \@lDoWs, \%issues );
}
# ==============================================================
# No POD on purpose ...
# Does some common logic for swap_language() & init_special_date_arrays().
# Requires knowledge of the internals to Date::Manip::Lang::<language>
# in order to work.
# This method should avoid referencing any global variables!
# Returns: undef or the references to the 5 arrays!
# I would have broken it up ino multiple functions if not for the wide test!
sub _swap_manip_language_common
{
DBUG_ENTER_FUNC ( @_ );
my $lang_ref = shift;
my $warn_ok = shift;
my $allow_wide = shift || 0;
my $base = "Date::Manip";
my $lang = $lang_ref->{Language};
my $module = $lang_ref->{Module};
# Check if the requested language module exists ...
{
local $SIG{__DIE__} = "";
my $sts = eval "require ${module}";
unless ( $sts ) {
_warn_msg ( $warn_ok, "${base} doesn't recognize '${lang}' as valid!" );
return ( DBUG_RETURN ( undef, undef, undef, undef, undef, undef, undef, undef ) );
}
}
# Get the proper name of this language fom the module.
$lang_ref->{Language} = $lang = eval "\$${module}::LangName";
# Get the language data from the module.
my $langData = eval "\$${module}::Language"; # A hash reference with the data!
# The 3 return values used by swap_language () ...
lib/Advanced/Config/Date.pm view on Meta::CPAN
($w, $k, $pi, $pe, $alt) = _fix_key ( $wd, 1 );
$wide = 1 if ($w);
push (@DoWs, $k);
}
$issues{dow_period} = $has_period;
$lang_ref->{Wide} = $wide;
if ( $wide && ! $allow_wide ) {
_warn_msg ( $warn_ok, "'${lang}' uses Wide Chars. It's not currently enabled!" );
return ( DBUG_RETURN ( undef, undef, undef, undef, undef, undef, undef, undef ) );
}
DBUG_RETURN ( \%months, \%days, \%issues, \@MoY, \@MoYs, \@Dsuf, \@DoW, \@DoWs);
}
# ==============================================================
# So uc() & lc() works against all language values ...
sub _fix_key
{
my $value = shift;
lib/Advanced/Config/Date.pm view on Meta::CPAN
my $manip_ref = $date_manip_installed_languages{$k};
my $lang_ref = $date_language_installed_languages{$k};
if ( $manip_ref && ! $lang_ref ) {
$k = lc ($manip_ref->{Language});
$lang_ref = $date_language_installed_languages{$k};
}
unless ( $lang_ref || $manip_ref ) {
_warn_msg ( $warn_ok, "Language '$lang' does not exist! So can't swap to it!" );
return DBUG_RETURN ( undef, undef );
}
unless ( $allow_wide ) {
$manip_ref = undef if ( $manip_ref && $manip_ref->{Wide} );
$lang_ref = undef if ( $lang_ref && $lang_ref->{Wide} );
unless ( $lang_ref || $manip_ref ) {
_warn_msg ( $warn_ok, "Language '$lang' uses Wide Chars. It's not currently enabled!" );
return DBUG_RETURN ( undef, undef );
}
}
DBUG_RETURN ( $manip_ref, $lang_ref );
}
# ==============================================================
=item $lang = swap_language ( $language[, $give_warning[, $wide]] );
This method allows you to change the I<$language> used when this module parses
a date string if you have modules L<Date::Language> and/or L<Date::Manip>
installed. But if neither are installed, only dates in B<English> are
supported. If a language is defined in both places the results are merged.
It always returns the active language. So if I<$language> is B<undef> or
invalid, it will return the current language from before the call. But if the
language was successfully changed, it will return the new I<$language> instead.
Should the change fail and I<$give_warning> is set to a non-zero value, it will
write a warning to your screen telling you why it failed.
So assuming one of the language modules are installed, it asks it for the list
of months in the requested language. And once that list is retrieved only
months in that language are supported when parsing a date string.
lib/Advanced/Config/Date.pm view on Meta::CPAN
my ($month_ref, $day_ref, $issue1_ref);
if ( $manip_ref ) {
my $old = $manip_ref->{Language};
($month_ref, $day_ref, $issue1_ref) =
_swap_manip_language_common ($manip_ref, $warn_ok, $allow_wide );
$lang = $manip_ref->{Language};
if ( $old ne $lang && ! $lang_ref ) {
$lang_ref = $date_language_installed_languages{lc($lang)};
$lang_ref = undef if ($lang_ref && $lang_ref->{Wide} && ! $allow_wide);
}
}
my ($MoY_ref, $MoYs_ref, $Dsuf_ref, $issue2_ref);
if ( $lang_ref ) {
my ($unused_DoW_ref, $unused_DoWs_ref);
($MoY_ref, $MoYs_ref, $Dsuf_ref, $unused_DoW_ref, $unused_DoWs_ref, $issue2_ref) =
_swap_lang_common ( $lang_ref, $warn_ok, $allow_wide );
$lang = $lang_ref->{Language};
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
DBUG_RETURN ( $lang );
}
# ==============================================================
=item $date = parse_date ( $date_str, $order[, $allow_dl[, $enable_2_digit_years]] );
Passed a date in some unknown format, it does it's best to parse it and return
the date in S<YYYY-MM-DD> format if it's a valid date. It returns B<undef> if
it can't find a valid date within I<$date_str>.
The date can be surrounded by other information in the string that will be
ignored. So it will strip out just the date info in something like:
=over 4
Tues B<January 3rd, 2017> at 6:00 PM.
=back
lib/Advanced/Config/Date.pm view on Meta::CPAN
}
}
# Now let's validate the results ...
# Trim leading/trailing spaces ...
$day = $1 if ( $day =~ m/^\s*(.*)\s*$/ );
return DBUG_RETURN ( _check_if_good_date ($in_date, $year, $month, $day) );
}
DBUG_RETURN ( undef ); # Invalid date ...
}
sub parse_date
{
DBUG_ENTER_FUNC ( @_ );
my $in_date = shift; # A potential date in an unknown format ...
my $date_format_options = shift; # A comma separated list of fmt ids ...
my $use_date_language_module = shift || 0;
my $allow_2_digit_years = shift || 0;
$in_date = lcx ($in_date); # Make sure always in lower case ...
my ($month, $month_digits) = _find_month_in_string ( $in_date );
my ($dom, $dom_digits) = _find_day_of_month_in_string ( $in_date, $month_digits,
$month_digits ? undef : $month );
my $out_str;
if ( $month_digits && $dom_digits ) {
$out_str = _month_num_day_num ( $in_date, $month, $dom, $allow_2_digit_years, $date_format_options );
} elsif ( $month_digits ) {
$out_str = _month_num_day_str ( $in_date, $month, $dom, $allow_2_digit_years );
} elsif ( $dom_digits ) {
$out_str = _month_str_day_num ( $in_date, $month, $dom, $allow_2_digit_years, $date_format_options );
} else {
lib/Advanced/Config/Date.pm view on Meta::CPAN
if ( defined $t ) {
my ($year, $month, $day) = (localtime ($t))[5,4,3];
$year += 1900;
$month += 1;
$out_str = _check_if_good_date ($in_date, $year, $month, $day);
}
};
}
DBUG_RETURN ($out_str); # undef or the date in YYYY-MM-DD format.
}
# --------------------------------------------------------------
# No ambiguity here ... we have multiple text anchors ...
sub _month_str_day_str
{
DBUG_ENTER_FUNC ( @_ );
my $in_date = shift;
my $month_str = shift;
lib/Advanced/Config/Date.pm view on Meta::CPAN
($year, $s1, $month, $s2, $day ) = ( $2, $3, $4, $5, $6 ); # ISO format ...
}
$year = make_it_a_4_digit_year ( $year ) if (defined $year);
} # End if allowing 2-digit years ...
if ( defined $year ) {
return DBUG_RETURN ( _check_if_good_date ($in_date, $year, $month, $day) );
}
DBUG_RETURN ( undef );
}
# --------------------------------------------------------------
# With a month anchor still not too ambiguous.
sub _tst_4_YY
{
my $sep = shift;
my $res = ( $sep =~ m/\s\d{1,2}\s/ ) ? 0 : 1;
return ($res);
lib/Advanced/Config/Date.pm view on Meta::CPAN
} elsif ( $in_date =~ m/(^|[^:\d])(\d{2})([^:\d].*?)(${month_str})[.]?(.*?[^:\d])(${dom_num})($|[^:\d])/ ) {
($year, $s1, $month, $s2, $day ) = ( $2, $3, $4, $5, $6 );
$year = make_it_a_4_digit_year ( $year );
}
} # End if allowing 2-digit years ...
if ( defined $year ) {
return DBUG_RETURN ( _check_if_good_date ($in_date, $year, $month, $day) );
}
DBUG_RETURN ( undef );
}
# --------------------------------------------------------------
# Getting a bit more problematic ...
sub _month_num_day_str
{
DBUG_ENTER_FUNC ( @_ );
my $in_date = shift;
my $month_num = shift;
lib/Advanced/Config/Date.pm view on Meta::CPAN
($year, $s1, $month, $s2, $day ) = ( $2, $3, $4, $5, $6 ); # ISO format ...
}
$year = make_it_a_4_digit_year ( $year ) if (defined $year);
} # End if allowing 2-digit years ...
if ( defined $year ) {
return DBUG_RETURN ( _check_if_good_date ($in_date, $year, $month, $day) );
}
DBUG_RETURN ( undef );
}
# --------------------------------------------------------------
# A very ambiguous format ... and much, much messier!
sub _month_num_day_num
{
DBUG_ENTER_FUNC ( @_ );
my $in_date = shift;
my $month_num = shift;
lib/Advanced/Config/Date.pm view on Meta::CPAN
( $s1, $s2 ) = ( $3, $5 );
my $date = sprintf ("%02d%02d%02d", $2, $4, $6);
( $year, $month, $day ) = parse_6_digit_date ( $date, $date_format_options );
}
} # End if allowing 2-digit years ...
if ( defined $year ) {
return DBUG_RETURN ( _check_if_good_date ($in_date, $year, $month, $day) );
}
DBUG_RETURN ( undef );
}
# --------------------------------------------------------------
# Always returns date in ISO format if it's good!
# Or undef if a bad date!
sub _check_if_good_date
{
DBUG_ENTER_FUNC ( @_ );
my $in_str = shift;
my $year = shift;
my $month = shift;
my $day = shift;
# Strip off any leading zeros so we can use the hashes for validation ...
lib/Advanced/Config/Date.pm view on Meta::CPAN
$err_msg = "Just the month is bad.";
} else {
$err_msg = "Both the month and day are bad.";
}
unless ( $err_msg ) {
if ( 1 <= $day && $day <= $days_in_months[$month] ) {
; # It's a good date ...
} elsif ( $month == 2 && $day == 29 ) {
my $leap = _is_leap_year ($year);
$year = undef unless ( $leap );
} else {
$year = undef;
}
unless ( defined $year ) {
$err_msg = "The day of month is out of range.";
}
}
if ( $err_msg ) {
DBUG_PRINT ("ERROR", "'%s' was an invalid date!\n%s", $in_str, $err_msg);
DBUG_PRINT ("BAD", "%s-%s-%s", $year, $month, $day);
return ( DBUG_RETURN (undef) );
}
DBUG_RETURN ( sprintf ("%04d-%02d-%02d", $year, $month, $day) );
}
# --------------------------------------------------------------
sub _find_month_in_string
{
DBUG_ENTER_FUNC (@_);
my $date_str = shift;
lib/Advanced/Config/Date.pm view on Meta::CPAN
DBUG_RETURN ( $month, $digits ); # Suitable for use in a RegExpr.
}
# --------------------------------------------------------------
sub _find_day_of_month_in_string
{
DBUG_ENTER_FUNC (@_);
my $date_str = shift;
my $skip_period = shift; # Skip entries ending in '.' like 17.!
my $month_str = shift; # Will be undef if skip_period is true!
my $day;
my $digits = 0;
my @lst = sort { length($b) <=> length($a) || $a cmp $b } keys %Days;
my $all_digits = $skip_period ? "^\\d+[.]?\$" : "^\\d+\$";
foreach my $dom ( @lst ) {
# Ignore numeric keys, can't get the correct one from string ...
lib/Advanced/Config/Date.pm view on Meta::CPAN
only accept European dates.
It assumes its using the correct format when the date looks valid. It does this
by validating the B<MM> is between 1 and 12 and that the B<DD> is between 1 and
31. (Using the correct max for that month). And then assumes the year is
always valid.
If I<$skip> is a non-zero value it will skip over the B<ISO> format if it's
listed in I<$order>.
Returns 3 B<undef>'s if nothing looks good.
=cut
sub parse_8_digit_date
{
DBUG_ENTER_FUNC ( @_ );
my $date_str = shift;
my $order = shift;
my $skip_iso = shift || 0;
lib/Advanced/Config/Date.pm view on Meta::CPAN
finally the ISO format 3rd. You could also just say I<$order> is B<2> and
only accept European dates.
So if you use the wrong order, more than likely you'll get the wrong date!
It assumes its using the correct format when the date looks valid. It does this
by validating the B<MM> is between 1 and 12 and that the B<DD> is between 1 and
31. (Using the correct max for that month). And then assumes the year is
always valid.
Returns 3 B<undef>'s if nothing looks good.
It always returns the year as a 4-digit year!
=cut
sub parse_6_digit_date
{
DBUG_ENTER_FUNC ( @_ );
my $date_str = shift;
my $order = shift;
lib/Advanced/Config/Date.pm view on Meta::CPAN
my @week_days = ( "1", "2", "3", "4", "5", "6", "7" );
my $numbers = ($mode != 1 && $mode != 2 );
my ( $lang_ref, $manip_ref );
if ( defined $lang ) {
($manip_ref, $lang_ref) = _select_language ($lang, $warn_ok, $allow_wide);
unless ( $lang_ref || $manip_ref ) {
$lang = undef; # So it will enter the early out if block ...
}
}
if ( (! defined $lang) || lc($lang) eq lc($prev_array_lang) || $numbers ) {
if ( $mode == 1 ) {
@months = @gMoYs; # Abrevited month names ...
@week_days = @gDoWs; # Abrevited week names ...
} elsif ( $mode == 2 ) {
@months = @gMoY; # Full month names ...
@week_days = @gDoW; # Full week names ...
lib/Advanced/Config/Date.pm view on Meta::CPAN
my ($MoY_ref, $MoYs_ref, $Dsuf_ref, $DoW_ref, $DoWs_ref);
DBUG_PRINT ("INFO", "Manip: %s, Lang: %s", $manip_ref, $lang_ref);
if ( $manip_ref ) {
my ( $u1, $u2, $u3 ); # Unused placeholders.
($u1, $u2, $u3, $MoY_ref, $MoYs_ref, $Dsuf_ref, $DoW_ref, $DoWs_ref) =
_swap_manip_language_common ($manip_ref, $warn_ok, $allow_wide );
$lang = $manip_ref->{Language};
if ( $u1 ) {
$lang_ref = undef; # Skip lang_ref lookup if successsful ...
} else {
$lang_ref = $date_language_installed_languages{lc($lang)};
}
}
if ( $lang_ref ) {
($MoY_ref, $MoYs_ref, $Dsuf_ref, $DoW_ref, $DoWs_ref) =
_swap_lang_common ( $lang_ref, $warn_ok, $allow_wide );
$lang = $lang_ref->{Language};
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
DBUG_ENTER_FUNC ( @_ );
my $date_str = shift;
my ($year, $mon, $day);
if ( defined $date_str && $date_str =~ m/^(\d+)-(\d+)-(\d+)$/ ) {
($year, $mon, $day) = ($1, $2, $3);
my $leap = _is_leap_year ($year);
local $days_in_months[2] = $leap ? 29 : 28;
unless ( 1 <= $mon && $mon <= 12 &&
1 <= $day && $day <= $days_in_months[$mon] ) {
return DBUG_RETURN ( undef, undef, undef );
}
} else {
return DBUG_RETURN ( undef, undef, undef );
}
DBUG_RETURN ( $year, $mon, $day );
}
# ==============================================================
=item $bool = is_leap_year ( $year );
Returns B<1> if I<$year> is a Leap Year, else B<0> if it isn't.
lib/Advanced/Config/Date.pm view on Meta::CPAN
B<1899-12-31>. (Which is HYD B<0>.) It should be compatible with DB2's data
type of the same name. Something like this function is needed if you wish to be
able to do date math.
For example:
1 : 2026-01-01 - 2025-12-30 = 2 days.
2 : 2025-12-31 + 10 = 2026-01-10.
2 : 2025-12-31 - 2 = 2025-12-29.
If the given date string is invalid it will return B<undef>.
=cut
sub calc_hundred_year_date
{
DBUG_ENTER_FUNC ( @_ );
my $date_str = shift;
# Validate the input date.
my ($end_year, $month, $day) = _validate_date_str ($date_str);
unless (defined $end_year) {
return DBUG_RETURN ( undef );
}
my $hyd = 0;
my $start_year = 1899;
if ( $end_year > $start_year ) {
for (my $year = $start_year + 1; $year < $end_year; ++$year) {
my $leap = _is_leap_year ($year);
$hyd += $leap ? 366 : 365;
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
DBUG_RETURN ($hyd);
}
# ==============================================================
=item $dow = calc_day_of_week ( $date_str );
Takes a date string in B<YYYY-MM-DD> format and returns the day of the week it
falls on. It returns a value between B<0> and B<6> for Sunday to Saturday.
If the given date is invalid it will return B<undef>.
=item $dow = calc_day_of_week ( $hyd );
It takes an integer as a Hundred Year Date and returns the day of the week it
falls on. It returns a value between B<0> and B<6> for Sunday to Saturday.
If the given hyd is not an integer it will return B<undef>.
=cut
sub calc_day_of_week
{
DBUG_ENTER_FUNC ( @_ );
my $date_str = shift; # or a HYD ...
my $hyd;
if ( defined $date_str && $date_str =~ m/^[-]?\d+$/ ) {
$hyd = $date_str;
} else {
$hyd = calc_hundred_year_date ( $date_str );
}
unless (defined $hyd) {
return DBUG_RETURN ( undef );
}
my $start_dow = 0; # $hyd 0, 1899-12-31, falls on a Sunday.
my $dow = ($hyd + $start_dow) % 7;
DBUG_RETURN ($dow);
}
# ==============================================================
=item $date_str = convert_hyd_to_date_str ( $hyd );
It takes an integer as a Hundred Year Date and converts it into a date string
in the format of B<YYYY-MM-DD> and returns it.
If the given hyd is not an integer it will return B<undef>.
=cut
sub convert_hyd_to_date_str
{
DBUG_ENTER_FUNC ( @_ );
my $target_hyd = shift;
unless ( defined $target_hyd && $target_hyd =~ m/^[-]?\d+$/ ) {
return DBUG_RETURN ( undef );
}
my $date_str;
my $start_year = 1899; # HYD of 0 is 1899-12-31
my $hyd_total = 0;
my $days = 0;
my ($leap, $year);
if ( $target_hyd > 0 ) {
for ($year = $start_year + 1; 1==1; ++$year) {
lib/Advanced/Config/Date.pm view on Meta::CPAN
# ==============================================================
=item $doy = calc_day_of_year ( $date_str[, $remainder_flag] );
Takes a date string in B<YYYY-MM-DD> format and returns the number of days since
the begining of the year. With January 1st being day B<1>.
If the remainder_flag is set to a no-zero value, it returns the number of days
left in the year. With December 31st being B<0>.
If the given date is invalid it will return B<undef>.
=cut
sub calc_day_of_year
{
DBUG_ENTER_FUNC ( @_ );
my $date_str = shift;
my $remainder_flag = shift || 0;
# Validate the input date.
my ($year, $month, $day) = _validate_date_str ($date_str);
unless (defined $year) {
return DBUG_RETURN ( undef );
}
my $leap = _is_leap_year ($year);
local $days_in_months[2] = $leap ? 29 : 28;
my $doy = 0;
for (my $m = 0; $m < $month; ++$m) {
$doy += $days_in_months[$m];
}
$doy += $day;
lib/Advanced/Config/Date.pm view on Meta::CPAN
=item $date_str = adjust_date_str ( $date_str, $years, $months );
Takes a date string in B<YYYY-MM-DD> format and adjusts it by the given number
of months and years. It returns the new date in B<YYYY-MM-Dd> format.
It does its best to preserve the day of month, but if it would exceed the number
of days in a month, it will truncate to the end of month. Not round to the next
month.
Returns I<undef> if passed bad arguments.
=cut
sub adjust_date_str
{
DBUG_ENTER_FUNC ( @_ );
my $date_str = shift;
my $adj_years = shift || 0;
my $adj_months = shift || 0;
# Validate the input date.
my ($year, $month, $day) = _validate_date_str ($date_str);
unless (defined $year &&
$adj_years =~ m/^[-]?\d+$/ && $adj_months =~ m/^[-]?\d+$/) {
return DBUG_RETURN ( undef );
}
# Adjust by month ...
if ( $adj_months >= 0 ) {
foreach (1..${adj_months}) {
if ( $month == 12 ) {
$month = 1;
++$adj_years;
} else {
++$month;
lib/Advanced/Config/Examples.pm view on Meta::CPAN
# See I'm referencing variables defined in simple.cfg!
tag1 = ${tag1} ${tag3} ${tag1} # tag1 now equals: "xyz l m n xyz".
tag 6 = abc = 7 # "tag 6" now contains: "abc = 7".
tag 6 = ${TAG1} # "tag 6" is now: 123
messy = "I have a # in my value" # See comment symbol in the value.
# A neat little trick ...
# Implements: a = $ENV{test} ? "TRUE" : "FALSE";
a = ${test:+TRUE} # Set to TRUE if $ENV{test} is set, else undef
a = ${a:-FALSE} # Set to FALSE if ${a} is undef, else set to ${a}.
# Does variables within variables ...
# Implements: b = $ENV{test} ? $y : $z;
y = YES
z = NO
b = ${test:+${y}} # Set to ${y} if $ENV{test} is set, else undef
b = ${b:-${z}} # Set to ${z} if ${b} is undef, else set to ${b}.
# So (a,b) = (TRUE,YES) or (FALSE,NO).
# How about testing for a specific value for $ENV{test}? This can be
# done in a limited way.
message_abc = I know my abc's.
message_123 = I know my 123's
message_hello = Hello World!
msg = ${message_${test}:-Unknown Message.}
lib/Advanced/Config/Options.pm view on Meta::CPAN
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.
Also note that some I<Read> options have B<left> and B<right> variants. These
options are used in pairs and both must anchor the target in order for the rule
to be applied to it. These start/end anchors can be set to the same string or
different strings. Your choice.
lib/Advanced/Config/Options.pm view on Meta::CPAN
$file --> The file being sourced in.
$cbOpts --> A hash reference containing values needed by your callback
function to decide what options are required to source in the
requested file. You may update the contents of this hash to
preserve info between calls. This module will "never" examine
the contents of this hash!
$rOpts --> A reference to the "Read Options" hash used to parse the file
you want to source in. Returns "undef" if the options don't
change. The returned options override what's currently in use by
"load_config" when loading the current file.
$dOpts --> A reference to the "Date Formatting Options" hash used to tell how
to format the special date variables. Returns "undef" if the
options don't change. The returned options override what's
currently in use by "load_config" when loading the current file.
NOTE: This callback option is disabled if you use another config file to tell
how to parse the current config file.
=back
=head2 Parse Read Options
lib/Advanced/Config/Options.pm view on Meta::CPAN
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.
B<split_pattern> - Defaults to B<qr /\s+/>. The pattern to use when splitting
a tag's value into an array via perl's C<split> function. It can be a string
or a regular expression. For example to split on a comma separated string
you could do: B<qr /\s*,\s*/>.
lib/Advanced/Config/Options.pm view on Meta::CPAN
DBUG_RETURN ($user);
}
# ==============================================================
# A stub of the source callback function ...
sub _source_callback_stub
{
DBUG_ENTER_FUNC ( @_ );
my $file = shift;
my $opts = shift;
DBUG_RETURN ( undef, undef );
}
# ==============================================================
# A stub of the encryption/decryption callback function ...
sub _encryption_callback_stub
{
DBUG_MASK_NEXT_FUNC_CALL (2); # Mask $value!
DBUG_ENTER_FUNC ( @_ );
my $mode = shift;
lib/Advanced/Config/Options.pm view on Meta::CPAN
}
# ==============================================================
# Initialize the global hashes with their default values ...
BEGIN
{
DBUG_ENTER_FUNC ();
# ---------------------------------------------------------------------
# Make sure no hash value is undef !!!
# ---------------------------------------------------------------------
# You can only add to this list, you can't remove anything from it!
# See should_we_hide_sensitive_data () on how this list is used.
DBUG_PRINT ("INFO", "Initializing the tag patterns to hide from fish ...");
push ( @hide_from_fish, "password" );
push ( @hide_from_fish, "pass" );
push ( @hide_from_fish, "pwd" );
# ---------------------------------------------------------------------
lib/Advanced/Config/Options.pm view on Meta::CPAN
$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.
$default_get_opts{date_enable_yy} = 0; # 1-Enable 0-Disable using 2 digit years in a date!
$default_get_opts{date_format} = 3; # Hints are 0 to 8.
lib/Advanced/Config/Options.pm view on Meta::CPAN
$no_spaces_allowed = 0;
} else {
$val =~ s/^\s+//;
$val =~ s/\s+$//;
}
} else {
if ( defined $defaults->{$k} ) {
warn "Option '$k' has no defined value. Override ignored.\n";
} else {
$result{$k} = undef;
}
next;
}
# Making sure never undef for easier comparisons later on ...
my $expect = ( defined $defaults->{$k} ) ? $defaults->{$k} : "";
# -------------------------------------
# Is this a call back reference ...
# -------------------------------------
if ( ref ( $expect ) eq "CODE" ) {
my $call;
if ( ref ($val) eq "CODE" ) {
$call = $val;
} elsif ( ref ($val) eq "") {
lib/Advanced/Config/Options.pm view on Meta::CPAN
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
lib/Advanced/Config/Options.pm view on Meta::CPAN
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;
unless ( $get_opts->{split} ) {
lib/Advanced/Config/Options.pm view on Meta::CPAN
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 _ );
$valid = 0 if ( ($get_opts->{filename} & 4) && ! -w _ );
$valid = 0 if ( ($get_opts->{filename} & 8) && ! -x _ );
unless ( $valid ) {
return DBUG_RETURN ( croak_helper ( $get_opts,
"Tag ${tag} doesn't reference a valid filename or it doesn't have the requested permissions! ($v)",
undef ) );
}
}
# -------------------------------------------------------------------
# Are we referencing a directory?
if ( $get_opts->{directory} ) {
my $valid = 1; # Assume it's a directory ...
$valid = 0 unless ( -d $v );
$valid = 0 if ( ($get_opts->{directory} & 2) && ! -r _ );
$valid = 0 if ( ($get_opts->{directory} & 4) && ! -w _ );
$valid = 0 if ( ($get_opts->{directory} & 8) && ! -x _ );
unless ( $valid ) {
return DBUG_RETURN ( croak_helper ( $get_opts,
"Tag ${tag} doesn't reference a valid directory or it doesn't have the requested permissions! ($v)",
undef ) );
}
}
# -------------------------------------------------------------------
# If not splitting after all, save any changes ... (keep last in loop)
if ( (! $get_opts->{split}) && $old ne $v ) {
$result{VALUE} = $v;
}
} # End foreach @vals loop ...
lib/Advanced/Config/Reader.pm view on Meta::CPAN
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 $ruleObj = $cfg->_get_rule_object (); # Is there a rule config file?
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);
my ( $rOpts, $sdOpts );
if ( $ruleObj ) {
# Get the Read & Date options from the correct section in rule config file
my $ruleSect = $ruleObj->_get_rule_section ($new_file);
( $rOpts, $sdOpts ) = ( $ruleSect->_get_rules_from_cfg () )[0,2];
} else {
# The Current Read Options ...
$rOpts = $cfg->get_cfg_settings ();
lib/Advanced/Config/Reader.pm view on Meta::CPAN
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 );
lib/Advanced/Config/Reader.pm view on Meta::CPAN
my $default_quotes = using_default_quotes ( $opts );
my $comment = convert_to_regexp_string ($opts->{comment}, 1);
my ($tag, $value) = _split_assign ( $opts, $line, 1 );
my ($l_quote, $r_quote, $tv_pair_flag) = ("", "", 0);
my $var_line = $line;
unless ( defined $tag && defined $value ) {
$tag = $value = undef; # It's not a tag/value pair ...
} elsif ( $tag eq "" || $tag =~ m/${comment}/ ) {
$tag = $value = undef; # It's not a valid tag ...
} else {
# It looks like a tag/value pair to me ...
$tv_pair_flag = 1;
if ( $opts->{disable_quotes} ) {
; # Don't do anything ...
} elsif ( $default_quotes ) {
if ( $value =~ m/^(['"])/ ) {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
my ($lv, $rv) = ( convert_to_regexp_string ($opts->{variable_left}),
convert_to_regexp_string ($opts->{variable_right}) );
# While there are still variables to process ...
while ( defined $tag ) {
my ( $val, $mask );
my $do_mod_lookup = 0; # Very rarely set to true ...
# ${tag} and ${mod_tag} will never have the same value ...
# ${mod_tag} will amost always be undefinded.
# If both are defined, we'll almost always end up using ${mod_tag} as
# the real variable to expand! But we check to be sure 1st.
( $val, $mask ) = $config->lookup_one_variable ( $tag );
# It's extreemly rare to have this "if statement" evalate to true ...
if ( (! defined $val) && defined $mod_tag ) {
( $val, $mask ) = $config->lookup_one_variable ( $mod_tag );
# -----------------------------------------------------------------
# If we're using variable modifiers, it doesn't matter if the
# varible exists or not. The modifier gets evaluated!
# So checking if the undefined $mod_tag needs to be masked or not ...
# -----------------------------------------------------------------
unless ( defined $val ) {
$mask = should_we_hide_sensitive_data ( $mod_tag );
}
$do_mod_lookup = 1; # Yes, apply the modifiers!
}
# Use a place holder if the variable references data that is still encrypted.
if ( $mask == -1 ) {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
if ( $mod_opt eq ":=" || $mod_opt eq "=" ) {
# The variable either doesn't exist or it resolved to "".
# This variant rule says to also set the variable to this value!
$cfg->_base_set ( $mod_tag, $output, $file );
} elsif ( $mod_opt eq ":?" || $mod_opt eq "?" ) {
# In shell scripts, ":?" would cause your script to die with the
# default value as the error message if your var had no value.
# Repeating that logic here.
my $msg = "Encounterd undefined variable ($mod_tag) using shell modifier ${mod_opt}";
$msg .= " in config file: " . basename ($file) if ( $file ne "" );
DBUG_PRINT ("MOD", $msg);
die ( basename ($0) . ": ${mod_tag}: ${output}.\n" );
}
DBUG_PRINT ("MOD",
"The modifier (%s) is overriding the variable with a default value!",
$mod_opt);
# Sub-string removal ...
lib/Advanced/Config/Reader.pm view on Meta::CPAN
By default, a variable is the tag in the I<$value> between B<${> and B<}>, which
can be overridden with other anchor patterns. See L<Advanced::Config::Options>
for more details on this.
If you've configured the module to ignore variables, it will never find any.
Unless you also set I<$ignore_disable_flag> to a non-zero value.
Returns B<8> values. ( $left, $tag, $right, $cmt, $sub_tag, $sub_opr, $sub_val,
$otag )
All B<8> values will be I<undef> if no variables were found in I<$value>.
Otherwise it returns at least the 1st four values. Where I<$tag> is the
variable that needs to be looked up. And the caller can join things back
together as "B<$left . $look_up_value . $right>" after the variable substitution
is done and before this method is called again to locate additional variables in
the resulting new I<$value>.
The 4th value I<$cmt>, will be true/false based on if B<$left> has a comment
symbol in it! This flag only has meaning to B<parse_line>. And is terribly
misleading to other users.
Should the I<$tag> definition have one of the supported shell script variable
modifiers embedded inside it, then the I<$tag> will be parsed and the 3 B<sub_*>
return values will be calculated as well. See
L<http://wiki.bash-hackers.org/syntax/pe> for more details. Most of the
modifiers listed there are supported except for those dealing with arrays.
See I<apply_modifier> for applying these rules against the returned I<$tag>.
Other modifier rules may be added upon request.
These 3 B<sub_*> return values will always be I<undef> should the variable
left/right anchors be overridden with the same value. Or if no modifiers
are detected in the tag's name.
If you've configured the module to be case insensitive (option B<tag_case>),
then both I<$tag> and I<$sub_tag> will be shifted to lower case for case
insensitive variable lookups.
Finally there is an 8th return value, I<$otag>, that contains the original
I<$tag> value before it was edited. Needed by F<parse_line> logic.
=cut
# WARNING: If (${lvar} == ${rvar}), nested variables are not supported.
# : And neither are variable modifiers. (The sub_* return values.)
# : So evaluate tags left to right.
# : If (${lvar} != ${rvar}), nested variables are supported.
# : So evaluate inner most tags first. And then left to right.
#
# RETURNS: 8 values. ( $left, $tag, $right, $cmt, $sub_tag, $sub_opr, $sub_val, $otag )
# : The 3 sub_* vars are usually undef.
# : But when set, all 3 sub_* vars are set! And $tag != $sub_tag.
#
# NOTE 1 : If the 3 sub_* vars are populated, you'd get something like this
# : for the tag & sub_* vars.
# : tag : "abc:-Default Value" - the ${...} was removed.
# : sub_tag : "abc" - the ${...} & modifier were removed.
# : sub_opr : ":-"
# : sub_val : "Default Value"
# : So if the "tag" exists as a variable, the sub_* values are ignored.
# : But if "tag" doesn't exist as a variable, then we apply the
# : sub_* rules!
#
# NOTE 2 : If the sub_* vars undef, you'd get something like this without any
# : modifiers.
# : tag : tag - the ${...} was removed.
#
# NOTE 3 : For some alternate variable anchors, the sub_* vars will almost
# : always be undef. Since the code base won't allow you to redefine
# : these modifiers when they conflict with the variable anchors.
sub parse_for_variables
{
DBUG_ENTER_FUNC ( @_ );
my $value = shift;
my $disable_flag = shift;
my $opts = shift;
my ($left, $s1, $tag, $s2, $right, $otag);
t/09-basic_date.t view on Meta::CPAN
"1899-12-31" => [ 0, 0, 365 ], # Special case.
# Start of -hyd tests
"1899-12-30" => [ -1, 6, 364 ],
"1899-11-30" => [ -31, 4, 334 ],
# Leap Year tests -hyd
"1820-02-28" => [ -29161, 1, 59 ],
"1820-02-29" => [ -29160, 2, 60 ],
"1820-03-01" => [ -29159, 3, 61 ],
# "1821-02-29" => [ undef, undef, undef ], # Bad Leap Year
# A year's worth of edge cases: -hyd
"1822-12-31" => [ -28124, 2, 365 ],
"1823-01-01" => [ -28123, 3, 1 ],
"1823-01-31" => [ -28093, 5, 31 ],
"1823-02-01" => [ -28092, 6, 32 ],
"1823-02-28" => [ -28065, 5, 59 ],
"1823-03-01" => [ -28064, 6, 60 ],
"1823-03-31" => [ -28034, 1, 90 ],
"1823-04-01" => [ -28033, 2, 91 ],
t/09-basic_date.t view on Meta::CPAN
# Start of +hyd tests
"1900-01-01" => [ 1, 1, 1 ],
"1900-12-31" => [ 365, 1, 365 ],
"2013-06-04" => [ 41428, 2, 155 ],
# Leap Year tests +hyd
"2020-02-28" => [ 43888, 5, 59 ],
"2020-02-29" => [ 43889, 6, 60 ],
"2020-03-01" => [ 43890, 0, 61 ],
# "2021-02-29" => [ undef, undef, undef ], # Bad Leap Year
# A year's worth of edge cases: +hyd
"2022-12-31" => [ 44925, 6, 365 ],
"2023-01-01" => [ 44926, 0, 1 ],
"2023-01-31" => [ 44956, 2, 31 ],
"2023-02-01" => [ 44957, 3, 32 ],
"2023-02-28" => [ 44984, 2, 59 ],
"2023-03-01" => [ 44985, 3, 60 ],
"2023-03-31" => [ 45015, 5, 90 ],
"2023-04-01" => [ 45016, 6, 91 ],
t/10-validate_simple_cfg.t view on Meta::CPAN
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;
my $sep = "";
t/11-manual_build.t view on Meta::CPAN
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\"!");
}
t/12-validate_sections.t view on Meta::CPAN
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;
t/13-alt-get-tests.t view on Meta::CPAN
DBUG_PUSH ( $fish );
DBUG_ENTER_FUNC (@ARGV);
dbug_ok (1, "In the MAIN program ..."); # Test # 2 ...
my $file = File::Spec->catfile ("t", "config", "13-alt-get-tests.cfg");
my $cfg;
eval {
my %gOpt = ( "required" => 2 );
$cfg = Advanced::Config->new ($file, undef, \%gOpt);
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_ok (defined $cfg, "Advanced::Config object has been created!");
}
dbug_ok (0, "Advanced::Config object has been loaded into memory!");
DBUG_LEAVE (3);
t/13-alt-get-tests.t view on Meta::CPAN
{
DBUG_ENTER_FUNC ( @_ );
my $cfg = shift;
my $ok = 1; # Assume all tests pass ...
my %merge;
my $val = 0;
my %expected;
foreach my $tag ( "int_one", "int_two", "int_three", "int_four", "int_two" ) {
my $ptrn = ($tag eq "int_three") ? qr /\s*[|]\s*/ : undef;
# This tag's value is a list of integers ...
my $lst = $cfg->get_list_values ($tag, $ptrn, 1);
my $hsh = $cfg->get_hash_values ($tag, $ptrn, ++$val, \%merge);
my @hlst = sort { $a <=> $b } keys %{$hsh};
# Verify the returned hash referene has the correct key list ...
my $r = dbug_ok ( compare_arrays ( 0, $lst, \@hlst ), "Tag ${tag}'s breakup into a hash was correct! (" . join (", ", @{$lst}) . ")" );
unless ( $r ) {
DBUG_PRINT ( "WARN", "get_hash_values() returned (%s) as it's keys.", join (", ", @hlst) );
t/13-alt-get-tests.t view on Meta::CPAN
my @list = $cfg->find_tags ($search);
my $ok = 1;
foreach my $sort ( 0, 1, -1 ) {
my $lbl = "unsorted";
$lbl = "sorted" if ( $sort == 1);
$lbl = "reverse sorted" if ( $sort == -1);
foreach my $tag (@list) {
my $split = $exception->{$tag}; # Usually undef ... (the split pattern)
next if ( defined $split && $split eq "bad" );
my $test = $cfg->get_list_values ($tag, $split, $sort);
my @round_test = @{$test};
my @trunc_test = @{$test};
truncate_or_round ( \@round_test, 1 );
truncate_or_round ( \@trunc_test, -1 );
my $nValue = $cfg->get_list_numeric ( $tag, $split, $sort );
t/13-alt-get-tests.t view on Meta::CPAN
my ( $dir, $file, $get, $res );
my $ok = 1;
my @list = $cfg->find_tags ("^special_");
foreach my $tag ( @list ) {
my ($msg1, $msg2);
$get = $cfg->get_value ($tag);
$dir = $cfg->get_directory ($tag, undef, required => 0);
$file = $cfg->get_filename ($tag, undef, required => 0);
# Check what perl has to say about these files/dirs ...
$msg1 = "Special file test (${get}): ";
if ( -f $get ) {
$res = ($file && ! $dir) ? 1 : 0;
$msg2 = "it's a file!";
} elsif ( -d $get ) {
$res = (! $file && $dir) ? 1 : 0;
$msg2 = "it's a directory!";
} else {
t/13-alt-get-tests.t view on Meta::CPAN
$dir = $cfg->get_directory ("dir_2", "rx");
$r = dbug_ok ( $dir, "Found directory: ${dir}");
$ok = 0 unless ( $r );
$dir = $cfg->get_directory ("dir_3", "rwx");
$r = dbug_ok ( $dir, "Found directory: ${dir}");
$ok = 0 unless ( $r );
$tag = "dir_bad_2";
$dir = $cfg->get_directory ($tag, undef, required => 0);
$f = $cfg->get_filename ($tag);
$bad = $cfg->get_value ($tag);
$r = dbug_ok ( ($f && ! $dir), "It's a file, not a directory: ${bad}" );
$ok = 0 unless ( $r );
# ---------------------------------------------------------
# No-such dir, create dir, no-such dir tests ...
# ---------------------------------------------------------
$tag = "dir_bad_1";
$dir = $cfg->get_directory ($tag, undef, required => 0);
$f = $cfg->get_filename ($tag, undef, required => 0);
$bad = $cfg->get_value ($tag);
$r = dbug_ok ( (! $dir && ! $f), "No such file or directory: ${bad}" );
$ok = 0 unless ( $r );
mkdir ( $bad ) or die ("Can't create directory: ${bad}\n");
$dir = $cfg->get_directory ($tag);
$r = dbug_ok ( ($dir && ! $f), "The directory now exists! ${bad}" );
$ok = 0 unless ( $r );
rmdir ( $bad );
$dir = $cfg->get_directory ($tag, undef, required => 0);
$r = dbug_ok ( (! $dir && ! $f), "No such file or directory again: ${bad}" );
$ok = 0 unless ( $r );
# ---------------------------------------------------------
# The list tests ...
$tag = "dir_list_1";
my $lst = $cfg->get_list_directory ($tag, "r");
my $ref = $cfg->get_list_values ($tag);
$r = dbug_ok ( compare_arrays ( 0, $ref, $lst ), "The directory arrays are the same!" );
$ok = 0 unless ( $r );
$tag = "dir_list_2";
$lst = $cfg->get_list_directory ($tag, undef, undef, required => 0);
$r = dbug_ok ( (! $lst), "The list of directories contains one or more bad entries!" );
$ok = 0 unless ( $r );
DBUG_RETURN ( $ok );
}
# ====================================================================
sub run_file_tests
{
DBUG_ENTER_FUNC ( @_ );
t/13-alt-get-tests.t view on Meta::CPAN
# The individual file tests ...
$file = $cfg->get_filename ("file_1");
$r = dbug_ok ( $file, "Found file: ${file}");
$ok = $r;
$file = $cfg->get_filename ("file_2");
$r = dbug_ok ( $file, "Found file: ${file}");
$ok = 0 unless ( $r );
$tag = "file_bad_2";
$file = $cfg->get_filename ($tag, undef, required => 0);
$bad = $cfg->get_value ($tag);
$d = $cfg->get_directory ($tag);
$r = dbug_ok ( ($d && ! $file), "It's a directory, not a file: ${bad}");
$ok = 0 unless ( $r );
# ---------------------------------------------------------
# No-such file, create file, no-such file tests ...
# ---------------------------------------------------------
$tag = "file_bad_1";
$file = $cfg->get_filename ($tag, undef, required => 0);
$bad = $cfg->get_value ($tag);
$d = $cfg->get_directory ($tag, undef, required => 0);
$r = dbug_ok ( (! $file && ! $d), "No such file or directory: ${bad}");
$ok = 0 unless ( $r );
open (FILE, ">", $bad) or die ("Can't create file: $bad\n");
close (FILE);
$file = $cfg->get_filename ($tag);
$r = dbug_ok ( ($file && ! $d), "The file now exists! ${bad}");
$ok = 0 unless ( $r );
unlink ( $bad );
$file = $cfg->get_filename ($tag, undef, required => 0);
$r = dbug_ok ( (! $file && ! $d), "No such file or directory again: ${bad}");
$ok = 0 unless ( $r );
# ---------------------------------------------------------
# The list tests ...
$tag = "file_list_1";
my $ref = $cfg->get_list_values ($tag);
my $lst = $cfg->get_list_filename ($tag);
$r = dbug_ok ( compare_arrays ( 0, $ref, $lst ), "The file list arrays are the same!" );
$ok = 0 unless ( $r );
$tag = "file_list_2";
$lst = $cfg->get_list_filename ($tag, undef, undef, required => 0);
$r = dbug_ok ( (! $lst), "The list of files contains one or more bad entries!" );
$ok = 0 unless ( $r );
DBUG_RETURN ( $ok );
}
# ====================================================================
# Builds the boolean array to validate against!
sub run_boolean_tests
t/13-alt-get-tests.t view on Meta::CPAN
}
# ====================================================================
# Assumes run_date_tests() passes it's get_test() tests.
# Also assumes the extensive tests in t/09-basic_date.t passes.
# So it's OK to perform minimal testing here!
sub run_alt_date_tests
{
DBUG_ENTER_FUNC ( @_ );
my $cfg = Advanced::Config->new (undef, undef, { "required" => 0, "date_language" => "English" }, undef );
$cfg->set_value ("2024-01-01", "Jan 1, 1900");
$cfg->set_value ("2024-01-02", "not date");
$cfg->set_value ("10", "Jan 1, 1900");
$cfg->set_value ("11", "not a date");
$cfg->set_value ("one", "Jan 1, 1900");
$cfg->set_value ("two", "not a date");
my $ok = 1; # assumes all tests pass.
my ($ans, $sts, $tag);
t/13-alt-get-tests.t view on Meta::CPAN
# All tags reference the same date ...
foreach $tag ( "2024-01-01", "10", "one" ) {
$ans = $cfg->get_hyd_date ($tag);
$sts = dbug_cmp_ok ($ans, "==", 1, "hyd test for tag $tag");
$ok = 0 unless ($sts);
$ans = $cfg->get_dow_date ($tag);
$sts = dbug_cmp_ok ($ans, "==", 1, "dow test for tag $tag (Monday)");
$ok = 0 unless ($sts);
$ans = $cfg->get_dow_date ($tag, undef, 2);
$sts = dbug_cmp_ok ($ans, "eq", "Monday", "dow test for tag $tag (Monday)");
$ok = 0 unless ($sts);
$ans = $cfg->get_dow_date ($tag, undef, 1);
$sts = dbug_cmp_ok (uc($ans), "eq", "MON", "dow test for tag $tag (Mon)");
$ok = 0 unless ($sts);
$ans = $cfg->get_doy_date ($tag);
$sts = dbug_cmp_ok ($ans, "==", 1, "doy test for tag $tag");
$ok = 0 unless ($sts);
$ans = $cfg->get_adjusted_date ($tag, 1, 2);
$sts = dbug_cmp_ok ($ans, "eq", "1901-03-01", "adjusted test for tag $tag");
$ok = 0 unless ($sts);
}
# All tags reference the same non-date value ...
foreach $tag ( "2024-01-02", "11", "two" ) {
$ans = $cfg->get_hyd_date ($tag);
$sts = dbug_is ($ans, undef, "hyd test for non-date tag $tag");
$ok = 0 unless ($sts);
$ans = $cfg->get_dow_date ($tag);
$sts = dbug_is ($ans, undef, "dow test for non-date tag $tag (n/a)");
$ok = 0 unless ($sts);
$ans = $cfg->get_doy_date ($tag);
$sts = dbug_is ($ans, undef, "doy test for non-date tag $tag");
$ok = 0 unless ($sts);
$ans = $cfg->get_adjusted_date ($tag, 1, 2);
$sts = dbug_is ($ans, undef, "adjusted test for non-date tag $tag");
$ok = 0 unless ($sts);
}
# The given date doesn't exist as a tag ...
$tag = "1900-01-03";
$ans = $cfg->get_hyd_date ($tag);
$sts = dbug_cmp_ok ($ans, "==", 3, "hyd test for non-tag $tag");
$ok = 0 unless ($sts);
t/13-alt-get-tests.t view on Meta::CPAN
$ok = 0 unless ($sts);
$ans = $cfg->get_adjusted_date ($tag, 1, 2);
$sts = dbug_cmp_ok ($ans, "eq", "1901-03-03", "adjusted test for non-tag $tag");
$ok = 0 unless ($sts);
# The given hyd doesn't exist as a tag ...
$tag = "3"; # 1900-01-03
$ans = $cfg->get_hyd_date ($tag);
$sts = dbug_is ($ans, undef, "hyd test for HYD $tag");
$ok = 0 unless ($sts);
$ans = $cfg->get_dow_date ($tag);
$sts = dbug_cmp_ok ($ans, "==", 3, "dow test for HYD $tag (Wednsday)");
$ok = 0 unless ($sts);
$ans = $cfg->get_doy_date ($tag);
$sts = dbug_is ($ans, undef, "doy test for HYD $tag");
$ok = 0 unless ($sts);
$ans = $cfg->get_adjusted_date ($tag, 1, 2);
$sts = dbug_cmp_ok ($ans, "eq", "1901-03-03", "adjusted test for HYD $tag");
$ok = 0 unless ($sts);
DBUG_RETURN ( $ok );
}
t/13-alt-get-tests.t view on Meta::CPAN
my $prediction;
if ( $tag =~ m/^date_\d+_(\d{4}-\d{2}-\d{2})$/ ) {
$prediction = $1; # The resulting date ...
} elsif ( $tag =~ m/^date_\d+_bad$/ ) {
$prediction = ""; # Invalid Date ...
} else {
die ("Improperly formatted date tag: $tag (<name>_<test-number>_<YYYY-MM-DD>) or (<name>_<test-number>_bad)\n");
}
my $raw = $cfg->get_value ( $tag );
my $ans = $cfg->get_date ( $tag, undef, \%opt );
my $chk;
if ( $prediction ) {
$chk = ($prediction eq $ans);
} else {
$chk = (! defined $ans);
}
$r = dbug_ok ( $chk, "Tag ${tag} correctly evaluated '${raw}' to '${prediction}'");
unless ( $r ) {
t/13-alt-get-tests.t view on Meta::CPAN
next unless ( $prediction );
push ( @answers, $prediction ); # In YYYY-MM-DD format ...
$dates .= ${sep} . ${raw};
$sep = " | ";
}
# Build a list of date values we can split and evaluate ...
my $tag = "test_date_list";
$cfg->set_value ( $tag, $dates );
my $lst = $cfg->get_list_date ( $tag, qr/\s*[|]\s*/, undef, \%opt );
my $res = join (", ", @answers);
$res = substr ($res, 0, 40) . "...";
$r = dbug_ok ( defined $lst && compare_arrays ( 0, \@answers, $lst ), "The date arrays are the same! ($res)" );
$ok = 0 unless ( $r );
$cfg->set_value ( $tag, $dates . ${sep} . "Bad-Date" );
$lst = $cfg->get_list_date ( $tag, qr/\s*[|]\s*/, undef, \%opt );
$res = $cfg->get_value ( $tag );
$r = dbug_ok ( (! defined $lst), "The date array had a bad date in it! (... | Bad-Date)" );
$ok = 0 unless ( $r );
DBUG_RETURN ( $ok );
}
# ====================================================================
# Checks if two arrays are identical!
t/15-validate_multi_source_cfg.t view on Meta::CPAN
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!",
t/20-validate_encrypt_decrypt.t view on Meta::CPAN
}
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);
t/20-validate_encrypt_decrypt.t view on Meta::CPAN
sub run_all_tests
{
DBUG_ENTER_FUNC (@_);
my $alias = shift;
my $rOpts = shift;
dbug_ok (1, "x"x50);
dbug_ok (1, "?"x10 . " $alias " . "?"x10);
# my $emptyCfg = Advanced::Config->new (undef, { assign => "?", quote_left => 'x', quote_right => 'x' } );
my $emptyCfg = Advanced::Config->new (undef, $rOpts);
dbug_isa_ok ($emptyCfg, 'Advanced::Config');
# Options to use in decrypting an encrypted file ...
my %aOpts;
%aOpts = %{$rOpts} if ( defined $rOpts );
$aOpts{alias} = $alias;
my ($orig_file, $encrypt_file, $file_decrypt, $fail_file);
$orig_file = $encrypt_file = $file_decrypt = $fail_file =
t/30-alt_symbols_cfg.t view on Meta::CPAN
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);
t/35-improper_tests.t view on Meta::CPAN
}
sub make_object
{
DBUG_ENTER_FUNC ( @_ );
my $file = shift;
my %rOpts = @_;
my $cfg;
eval {
$cfg = Advanced::Config->new ( undef, \%rOpts, { required => 1 } );
dbug_isa_ok ($cfg, 'Advanced::Config');
my $ldr = $cfg->merge_config ( $file );
dbug_ok (defined $ldr, "Advanced::Config object has been loaded into memory via merge!");
};
if ( $@ ) {
unless (defined $cfg) {
dbug_isa_ok ($cfg, 'Advanced::Config');
}
dbug_ok (0, "Advanced::Config object has been loaded into memory via merge!");
DBUG_LEAVE (3);
t/40-validate-modifiers.t view on Meta::CPAN
# 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/40-validate-modifiers.cfg
# NOTE: No tag may have undef as a value!
# That 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 $Msg = "Be liberal in what you accept, and conservative in what you send.";
my $aMsg = "liberal in what you accept, and conservative in what you send.";
my $bMsg = "send.";
t/55-validate-strings.t view on Meta::CPAN
}
}
# Only prints out errors. Otherwise over 1,000 tests printed out.
foreach ( @lst1 ) {
unless ( exists $val2{$_} ) {
dbug_ok ( 0, "Tag $_ exists in the string config file!");
next;
}
# Some Config values are undefined ...
unless ( defined $Config{$_} ) {
if ( $val2{$_} ne "undef" ) {
dbug_ok ( 0, "Tag $_ is set to 'undef'. ($val2{$_})");
}
next;
}
if ( $Config{$_} ne $val2{$_} ) {
dbug_ok ( 0, "Tag $_ is set to the proper value ($Config{$_} vs $val2{$_})" );
next;
}
}
t/55-validate-strings.t view on Meta::CPAN
my ($tag, $value) = split ("=", $_, 2);
$value = $1 if ( $value =~ m/^'(.*)'$/ );
$found{$tag} = $value; # Without quotes!
}
# Now determine which are missing from the string ...
my $cnt = 0;
my %missing;
foreach ( sort keys %Config ) {
next if ( exists $found{$_} );
$missing{$_} = (defined $Config{$_}) ? $Config{$_} : "undef";
DBUG_PRINT ("MISSING", "Found missing tag: %s\n<%s>", $_, $missing{$_});
++$cnt;
}
dbug_ok ( 1, "There were $cnt missing entries in the Config String.");
DBUG_RETURN ( \%missing );
}
# ====================================================================
t/55-validate-strings.t view on Meta::CPAN
# Commented out on purpose ...
# $rOpts{encrypt_lbl} = "Some Comments ...";
}
# Did we override the read options to use with the string?
my %oOpts;
$oOpts{alias} = $alias if ( $alias );
eval {
$cfg = Advanced::Config->new (undef, \%rOpts, \%gOpts, \%dOpts);
dbug_isa_ok ($cfg, 'Advanced::Config');
my $ldr = $cfg->load_string ( $in_string, \%oOpts );
dbug_ok (defined $ldr, "Advanced::Config contents have been loaded into memory!");
};
if ( $@ ) {
unless (defined $cfg) {
dbug_isa_ok ($cfg, 'Advanced::Config');
}
dbug_ok (0, "Advanced::Config contents have been loaded into memory!");
DBUG_LEAVE (3);
t/56-tohash.t view on Meta::CPAN
# ====================================================================
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!" );
t/56-tohash.t view on Meta::CPAN
DBUG_VOID_RETURN ();
}
# ====================================================================
sub trim_if_sensitive
{
DBUG_ENTER_FUNC ( @_ );
my $cfg = shift;
my $sensitive = shift;
my @tags = $cfg->find_tags ( undef, 0 );
my @keep;
if ( $sensitive ) {
foreach ( @tags ) {
push (@keep, $_) unless ( $cfg->chk_if_sensitive ($_, 0) );
}
} else {
@keep = @tags;
}
t/56-tohash.t view on Meta::CPAN
my $cfg;
my ( %rOpts, %gOpts, %dOpts );
$rOpts{Croak} = 1; # Call die on error.
$gOpts{Required} = 1; # Call die if the tag doesn't exist.
# Did we override the read options to use with the string?
my %oOpts;
eval {
$cfg = Advanced::Config->new (undef, \%rOpts, \%gOpts, \%dOpts);
dbug_isa_ok ($cfg, 'Advanced::Config');
my $ldr = $cfg->load_string ( $in_string, \%oOpts );
dbug_ok (defined $ldr, "Advanced::Config contents have been loaded into memory!");
};
if ( $@ ) {
unless (defined $cfg) {
dbug_isa_ok ($cfg, 'Advanced::Config');
}
dbug_ok (0, "Advanced::Config contents have been loaded into memory!");
DBUG_LEAVE (3);
t/70-validate_date_vars.t view on Meta::CPAN
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 }
) {
my $cfg = my_load_config ( 1, "70-date-validation.cfg", undef, undef, $opt );
push (@cfgs, $cfg);
}
# Sourcing in files with same/different date formats for the special date vars ...
my $cfg = my_load_config ( 1, "70-date-validation_2.cfg" );
push (@cfgs, $cfg);
# So I can dynamically change the date format used ...
my $my_cb = \&ALTER_SOURCE_CALLBACK_OPTIONS;
$cfg = my_load_config ( 0, "70-date-validation_2.cfg",
{ source_cb => $my_cb },
undef, { date_sep => "~", date_order => 2, month_type => 2 } );
push (@cfgs, $cfg);
DBUG_PRINT ("====", "%s", "="x50);
foreach my $cfg (@cfgs) {
my $dopts = ($cfg->get_cfg_settings ())[2]; # The Date options ...
dbug_ok (1, "--------- sep = '$dopts->{date_sep}' ------------------------------");
my (%dates, %date2, $alt_date);
print_opts_hash ( "The Date Options", $dopts );
t/70-validate_date_vars.t view on Meta::CPAN
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 ...
t/75-check_all_languages.t view on Meta::CPAN
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} ...");
# Validate the weekdays ...
my $wd = $sCfg->get_list_values ("WeekDays", qr/\s*,\s*/, undef, {required => 1});
my $cnt = @{$wd};
$cnt = 7 if ( $cnt == 8 && $wd->[0] eq $wd->[-1] );
dbug_is ( $cnt, 7, "Found 7 weekdays defined by tag 'WeekDays' ($cnt)" );
foreach my $tag ( @{$wd} ) {
my $val = $sCfg->get_value ($tag) || "";
DBUG_PRINT ("UTF8", "utf8 flag (%d)", utf8::is_utf8($val));
my $ok = ($val =~ m/^Found /) ? 1 : 0;
dbug_ok ($ok, "Found Weekday Tag ($tag): ${val}");
t/76-check_all_languages2.t view on Meta::CPAN
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} ...");
# Validate the weekdays ...
my $wd = $sCfg->get_list_values ("WeekDays", qr/\s*,\s*/, undef, {required => 1});
my $cnt = @{$wd};
$cnt = 7 if ( $cnt == 8 && $wd->[0] eq $wd->[-1] );
dbug_is ( $cnt, 7, "Found 7 weekdays defined by tag 'WeekDays' ($cnt)" );
foreach my $tag ( @{$wd} ) {
my $val = $sCfg->get_value ($tag) || "";
DBUG_PRINT ("UTF8", "utf8 flag (%d)", utf8::is_utf8($val));
my $ok = ($val =~ m/^Found /) ? 1 : 0;
dbug_ok ($ok, "Found Weekday Tag ($tag): ${val}");
t/config/10-simple.cfg view on Meta::CPAN
number 2 = '${one} ${two} ${three}'
number 3 = ${one} ${two} ${three}
# All 3 evaluate to the same value again ...
number 6 = "${one} ${two} ${three}" # A comment ...
number 5 = '${one} ${two} ${three}' # A comment ...
number 4 = ${one} ${two} ${three} # A comment ...
number 8 = ${number 1}
rule8 missing = ${undefined} # Returns "" as it's value.
# Testing the special variables ... (Rule 0)
shft3 = "zzzzzzzzz" # Line should be ignored!
cmt = ${shft3}
cmt2 = ${shft33}
cmt3 = ${shft333}
# Look up these 3 special perl variables ... (Rule 5)
rule5_pid = ${$} # Different per test ...
t/config/30-alt_symbols_01.cfg view on Meta::CPAN
number 2 == ^$[one] $[two] $[three]^
number 3 == $[one] $[two] $[three]
: All 3 evaluate to the same value again ...
number 6 == ^$[one] $[two] $[three]^ : A comment ...
number 5 == ^$[one] $[two] $[three]^ : A comment ...
number 4 == $[one] $[two] $[three] : A comment ...
number 8 == $[number 1]
rule8 missing == $[undefined] : Returns ^^ as it^s value.
: Testing the special variables ... (Rule 0)
shft3 == ^zzzzzzzzz^ : Line should be ignored!
cmt == $[shft3]
cmt2 == $[shft33]
cmt3 == $[shft333]
: Look up these 3 special perl variables ... (Rule 5)
rule5_pid == $[$] : Different per test ...
t/config/30-alt_symbols_02.cfg view on Meta::CPAN
number 2 == <%one% %two% %three%>
number 3 == %one% %two% %three%
= All 3 evaluate to the same value again ...
number 6 == <%one% %two% %three%> = A comment ...
number 5 == <%one% %two% %three%> = A comment ...
number 4 == %one% %two% %three% = A comment ...
number 8 == %number 1%
rule8 missing == %undefined% = Returns <> as it>s value.
= Testing the special variables ... (Rule 0)
shft3 == <zzzzzzzzz> = Line should be ignored!
cmt == %shft3%
cmt2 == %shft33%
cmt3 == %shft333%
= Look up these 3 special perl variables ... (Rule 5)
rule5_pid == %$% = Different per test ...
t/config/30-alt_symbols_03.cfg view on Meta::CPAN
number 2 := @$[one] $[two] $[three]@
number 3 := $[one] $[two] $[three]
? All 3 evaluate to the same value again ...
number 6 := @$[one] $[two] $[three]@ ? A comment ...
number 5 := @$[one] $[two] $[three]@ ? A comment ...
number 4 := $[one] $[two] $[three] ? A comment ...
number 8 := $[number 1]
rule8 missing := $[undefined] ? Returns @@ as it@s value.
? Testing the special variables ... (Rule 0)
shft3 := @zzzzzzzzz@ ? Line should be ignored!
cmt := $[shft3]
cmt2 := $[shft33]
cmt3 := $[shft333]
? Look up these 3 special perl variables ... (Rule 5)
rule5_pid := $[$] ? Different per test ...
t/config/30-alt_symbols_04 multi section test.cfg view on Meta::CPAN
number 2 ~ '$<one> $<two> $<three>'
number 3 ~ $<one> $<two> $<three>
CMT: All 3 evaluate to the same value again ...
number 6 ~ '$<one> $<two> $<three>' CMT: A comment ...
number 5 ~ '$<one> $<two> $<three>' CMT: A comment ...
number 4 ~ $<one> $<two> $<three> CMT: A comment ...
number 8 ~ $<number 1>
rule8 missing ~ $<undefined> CMT: Returns '' as it's value.
CMT: Testing the special variables ... (Rule 0)
shft3 ~ 'zzzzzzzzz' CMT: Line should be ignored!
cmt ~ $<shft3>
cmt2 ~ $<shft33>
cmt3 ~ $<shft333>
CMT: Look up these 3 special perl variables ... (Rule 5)
rule5_pid ~ $<$> CMT: Different per test ...
t/config/30-alt_symbols_05 space assign.cfg view on Meta::CPAN
number=2 ^$[one] $[two] $[three]^
number=3 $[one] $[two] $[three]
: All 3 evaluate to the same value again ...
number=6 ^$[one] $[two] $[three]^ : A comment ...
number=5 ^$[one] $[two] $[three]^ : A comment ...
number=4 $[one] $[two] $[three] : A comment ...
number=8 $[number=1]
rule8=missing $[undefined] : Returns ^^ as it^s value.
: Testing the special variables ... (Rule 0)
shft3 ^zzzzzzzzz^ : Line should be ignored!
cmt $[shft3]
cmt2 $[shft33]
cmt3 $[shft333]
: Look up these 3 special perl variables ... (Rule 5)
rule5_pid $[$] : Different per test ...
t/config/30-alt_symbols_80_overlap.cfg view on Meta::CPAN
number 2 = '${duplicate.number 2}'
number 3 = ${duplicate.number 3}
number 6 = "${duplicate.number 6}" # A comment ...
number 5 = '${duplicate.number 5}' # A comment ...
number 4 = ${duplicate.number 4} # A comment ...
number 8 = ${number 1}
# --------------------------------------------------------------
[ main ]
rule8 missing = ${undefined} # Returns "" as it's value.
# Testing the special variables ... (Rule 0)
shft3 = "zzzzzzzzz" # Line should be ignored!
cmt = ${shft3}
cmt2 = ${shft33}
cmt3 = ${shft333}
[ duplicate ]
rule8 missing = ${undefined} # Returns "" as it's value.
shft3 = "zzzzzzzzz" # Line should be ignored!
cmt = ${shft3}
cmt2 = ${shft33}
cmt3 = ${shft333}
[ variable ]
rule8 missing = ${undefined} # Returns "" as it's value.
shft3 = "zzzzzzzzz" # Line should be ignored!
cmt = ${shft3}
cmt2 = ${shft33}
cmt3 = ${shft333}
# --------------------------------------------------------------
[ main ]
# Look up these 3 special perl variables ... (Rule 5)
rule5_pid = ${$} # Different per test ...
t/test-helper/helper1234.pm view on Meta::CPAN
@EXPORT_OK = qw( );
BEGIN
{
}
END
{
}
# Uses 2 ENV vars so that the meaning of undefined %ENV var can be easily
# changed for deciding what to do with the real %ENV var ...
sub turn_fish_on_off_for_advanced_config
{
DBUG_ENTER_FUNC(@_);
# Get the name of the fish file to return ...
my $fish = $0;
$fish =~ s/[.]t$//;
$fish =~ s/[.]pl$//;
$fish .= ".fish.txt";
t/test-helper/helper1234.pm view on Meta::CPAN
delete ( $ENV{$fish_tag} );
$msg = "Fish has been disabled for Advanced::Config ...";
$fish = File::Spec->catfile (dirname ($fish), "log_summary", basename ($fish));
}
DBUG_PRINT ("INFO", "\n%s\n ", $msg);
DBUG_RETURN ( $fish );
}
# Returns the hash if not empty or undef.
sub print_opts_hash
{
DBUG_ENTER_FUNC(@_);
my $lbl = shift;
my $opts = shift;
my $cnt = 0;
foreach ( sort keys %{$opts} ) {
DBUG_PRINT ("OPTS", "%s ==> %s", $_, $opts->{$_});
++$cnt;
}
DBUG_RETURN ( $cnt ? $opts : undef );
}
# ============================================================
#required if module is included w/ require command;
1;
( run in 3.800 seconds using v1.01-cache-2.11-cpan-d80b1682f3f )