Advanced-Config
view release on metacpan or search on metacpan
beginning with an underscore is subject to change without notice.
- Date.pm - Major rewrite of parse_date() in advance of using Date::Manip as
an alternate source to getting foreign language support.
- Date.pm - Adding Date::Manip logic. Greatly expands the number of languages
and date formats allowed.
- t/76-check_all_languages2.t - Test case to support using Date::Manip.
1.07 2020-02-20 08:30:00
- Updated copyrights to 2020 on all files.
- Made some corrections to the README file.
- Reader.pm - Added an optional trim flag to expand_variables().
- Reader.pm - Fixed balanced quote bug in parse_line().
- Fixed t/60-recursion-test.t & 60-recursion-test.cfg to handle trim
properly.
- 40-validate-modifiers.cfg - Modified to highlight the parse_line()
balanced quote issue was fixed.
- Reader.pm - Fixed disable quotes bug by checking 1st in parse_line()
quote detection section.
- Config.pm - Changed section() to get_section(), depreciating section()
with a stub function that prints warning if used.
- Config.pm - Added create_section() and no longer exposed new_section()
in the POD. Also added new flag SENSITIVE_SECTION to tell if the section
name was sensitive to fix bug in _base_set() & set_value().
- Reader.pm - Fixed to use get_section() & create_section().
- Reader.pm - Fixed hide section bug in read_config().
- t/*.t - Fixed several test cases to use get_section().
- t/11-manual_build.t - Fixed to use create_section() and to also create
a sensitive section to verify masking words correctly for set_value().
- Options.pm - Fixed floating point numeric checks in apply_get_rules().
- 13-alt-get-tests.t & 13-alt-get-tests.cfg - fixed to allow 1. and .1
as valid numeric test values. Also added numeric flag to compare
arrays function. Also added additional floating point tests.
- Options.pm - Fixed sudo bug returning wrong user in _get_user_id().
- Config.pm - Fixed issue with print_special_vars() when called incorrectly.
- Options.pm - Made corrections to the POD.
- Date.pm - Fixed issue with lc/uc. IE: In German -- M RZ vs m rz
- Date.pm - Added wide char flag to _swap_common(), init_special_date_arrays()
and swap_language() to allow for wide char/utf8 support.
- New test case: t/75-check_all_languages.t
- Date.pm - Fixed a lot of minor bugs now that I have a test case that tests
all the languages defined by Date::Language & realized just how inconsistent
that module's language files really are. But I don't have a better source
for this data.
- Config.pm - Fixed bug in load_config & load_string where it was modifying
the default options instead of overriding them.
- Added new option use_utf8 to supports config files written in UTF-8 mode.
- Added new option to disable variable modifications when they cause
$value = $pcfg->{CONTROL}->{get_opts}->{$key};
}
}
}
return ( $value ); # The value to use ...
}
#######################################
=item $value = $cfg->get_integer ( $tag[, $rt_flag[, %override_get_opts]] );
This function looks up the requested B<tag>'s value and returns it if its an
integer. If the B<tag>'s value is a floating point number (ex 3.6), then the
value is either truncated or rounded up based on the setting of the I<rt_flag>.
If I<rt_flag> is set, it will perform truncation, so 3.6 becomes B<3>. If the
flag is B<undef> or zero, it does rounding, so 3.6 becomes B<4>. Meaning the
default is rounding.
Otherwise if the B<tag> doesn't exist or its value is not numeric it will
return B<undef> unless it's been marked as I<required>. In that case B<die>
may be called instead.
=cut
sub get_integer
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $rt_flag = shift; # 1 - truncate, 0 - rounding.
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Flag if we should use truncation (2) or rounding (1) if needed ...
local $opt_ref->{numeric} = $rt_flag ? 2 : 1;
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value );
}
#######################################
}
}
}
DBUG_RETURN ( \%my_hash );
}
#######################################
=item $array_ref = $cfg->get_list_integer ( $tag[, $rt_flag[, $pattern[, $sort[, %override_get_opts]]]] );
This is the list version of F<get_integer>. See that function for the meaning
of I<$rt_flag>. See F<get_list_values> for the meaning of I<$pattern> and
I<$sort>.
=cut
sub get_list_integer
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $rt_flag = shift; # 1 - truncate, 0 - rounding.
my $split_ptrn = shift; # The split pattern to use to call to split().
my $sort = shift; # The sort order.
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Tells us to split the tag's value up into an array ...
local $opt_ref->{split} = 1;
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
# Tells how to sort the resulting array ...
local $opt_ref->{sort} =
$self->_evaluate_hash_values ("sort", $opt_ref, $sort);
my $value = $self->get_integer ( $tag, $rt_flag, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
=item $array_ref = $cfg->get_list_numeric ( $tag[, $pattern[, $sort[, %override_get_opts]]] );
This is the list version of F<get_numeric>. See F<get_list_values> for the
If you provide I<%override_read_opts> it will use the information in that hash
to format the string. Otherwise it will use the defaults from B<new()>.
=cut
sub toString
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $encrypt_flag = shift;
my $read_opts = $self->_get_opt_args ( @_ ); # The override options ...
my $pcfg = $self->{PARENT} || $self;
my $rOpts = get_read_opts ($read_opts, $pcfg->{CONTROL}->{read_opts});
my $cmt = "";
if ( $encrypt_flag ) {
$cmt = " " . format_encrypt_cmt ( $rOpts );
}
my $line;
my $string = "";
my $cnt = 0;
foreach my $name ( $self->find_sections () ) {
my $cfg = $self->get_section ($name);
$line = format_section_line ($name, $rOpts);
$string .= "\n${line}\n";
=over
=item ($value, $status) = $cfg->lookup_one_variable ( $variable_name );
This method takes the given I<$variable_name> and returns it's value.
It returns I<undef> if the given variable doesn't exist. And the optional 2nd
return value tells us about the B<status> of the 1st return value.
If the B<status> is B<-1>, the returned value is still encrypted. If set to
B<1>, the value is considered sensitive. In all other cases this B<status> flag
is set to B<0>.
This method is frequently called internally if you define any variables inside
your config files when they are loaded into memory.
Variables in the config file are surrounded by anchors such as B<${>nameB<}>.
But it's passed as B<name> without any anchors when this method is called.
The precedence for looking up a variable's value to return is as follows:
# Silently disable calling "die" or "warn" on all get/set calls ...
local $pcfg->{CONTROL}->{get_opts}->{required} = -9876;
my $opts = $pcfg->{CONTROL}->{read_opts};
# Did we earlier request case insensitive tag lookups?
$var = lc ($var) if ( $opts->{tag_case} );
# The default return values ...
my ( $val, $mask_flag, $file, $encrypt_flag ) = ( undef, 0, "", 0 );
if ( $var =~ m/^shft(3+)$/i ) {
# 0. The special comment variable ... (Can't override)
$val = $1;
my $c = $opts->{comment}; # Usually a "#".
$val =~ s/3/${c}/g;
} else {
# 1. Look in the current section ...
( $val, $mask_flag, $file, $encrypt_flag ) = $self->_base_get2 ( $var );
# 2. Look in the parent section ... (if not already there)
if ( ! defined $val && $self != $pcfg ) {
( $val, $mask_flag, $file, $encrypt_flag ) = $pcfg->_base_get2 ( $var );
}
# 3. Look in the requested section(s) ...
if ( ! defined $val && $var =~ m/[.]/ ) {
($val, $mask_flag, $encrypt_flag) = $self->rule_3_section_lookup ( $var );
}
# 4. Look in the %ENV hash ...
if ( ! defined $val && defined $ENV{$var} ) {
$val = $ENV{$var};
$mask_flag = should_we_hide_sensitive_data ($var);
# Record so refresh logic will work when %ENV vars change.
$pcfg->{CONTROL}->{ENV}->{$var} = $val;
}
# 5. Look at the special Perl variables ... (now done as part of 6.)
# 6. Is it one of the predefined module variables ...
# Variables should either be all upper case or all lower case!
# But allowing for mixed case.
if ( ! defined $val ) {
$pcfg->{CONTROL}->{DATE_USED} = $rule;
}
}
}
}
# 8. Then it must be undefined ... (IE: an unknown variable)
}
# Mask the return value in fish ???
DBUG_MASK ( 0 ) if ( $mask_flag);
# Is the return value still encryped ???
$mask_flag = -1 if ( $encrypt_flag );
DBUG_RETURN ( $val, $mask_flag )
}
# ==============================================================
=item ($value, $sens, $encrypt) = $cfg->rule_3_section_lookup ( $variable_name );
When a variable has a period (B<.>) in it's name, it could mean that this
variable is referencing a tag from another section of the config file. So this
helper method to F<lookup_one_variable> exists to perform this complex check.
for tag "extra".
Here's another example with multiple B<.>'s in it's 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 ...
full_developer_test.pl.src view on Meta::CPAN
}
# --------------------------------------------------------------------------
# If not building the *.pl file, lets run the requested tests ...
# Each test will be run 2 times. Resetting the special environment
# variable between runs. The 2nd run is much slower than the 1st run.
# --------------------------------------------------------------------------
# Locate the "make" variant & then run ${make} ...
my $make = find_and_run_make ();
my ( $fail_summary_flag, $fail_detail_flag ) = ( 0, 0 );
if ( $fail_test_msg eq "BOTH" ) {
$fail_summary_flag = $fail_detail_flag = 1;
} elsif ( $fail_test_msg eq "DETAIL" ) {
$fail_detail_flag = 1;
} elsif ( $fail_test_msg eq "SUMMARY" ) {
$fail_summary_flag = 1;
}
if ( $one_test_prog ) {
run_specific_test ( $one_test_prog, $one_fish_base, $fail_summary_flag, $fail_detail_flag );
} else {
delete_old_fish_logs ();
run_all_tests ( $make, $fail_summary_flag, $fail_detail_flag ); # Does via "make test".
}
exit (0);
}
# ==============================================================================
# Start of the functions called ...
# ==============================================================================
# Run the test suite in both configurations ...
sub run_all_tests
{
my $make = shift;
my $summary_flag = shift;
my $details_flag = shift;
my ( $summary_msg, $detail_msg );
my $t0 = time ();
# Run the summary test ...
eval {
local $ENV{FAIL_TEST_99} = 1 if ( $summary_flag );
run_make_test ( $make, 1, MAX, "=", "Fred::Fish::DBUG::OFF, just high level logs generated. (fast)" );
};
if ( $@ ) {
$summary_msg = $@;
}
my $t1 = time ();
# Run the detailed test ...
eval {
local $ENV{FAIL_TEST_99} = 1 if ( $details_flag );
run_make_test ( $make, 0, MAX, "-", "Fred::Fish::DBUG::ON, providing detailed logging. (slow)" );
};
if ( $@ ) {
$detail_msg = $@;
}
my $t2 = time ();
print_status ( $summary_msg, $detail_msg );
printf "Pass 1: %.1f second(s)\n", ($t1 - $t0);
full_developer_test.pl.src view on Meta::CPAN
print "\n";
return;
}
# Run a test suite in the requested mode ...
sub run_make_test
{
my $make = shift; # Which make command to use.
my $off_flag = shift; # Which setting to use: 0, 1.
my $num_fish = shift; # The number of fish files to expect ...
my $sep_char = shift;
my $log_msg = shift;
my $mk = basename ($make);
printf ("\n%s\n", ${sep_char}x50);
print "Running '${mk} test' for ${log_msg} ...\n";
printf ("%s\n\n", ${sep_char}x50);
# Determine the test mode to use ...
$ENV{FISH_OFF_FLAG} = ${off_flag};
# Run the tests ...
my $res = system ("${make} test");
my $cnt = show_fish_logs ( ${off_flag} ? $fish_dir_summary : $fish_dir_details );
# Check out the results ...
if ( $res != 0 ) {
die ("Failed one or more test cases! FISH_OFF_FLAG == ${off_flag} (${log_msg}!)\n\n");
}
if ( $cnt != ${num_fish} ) {
die ("Failed final test case! FISH_OFF_FLAG == ${off_flag} (${log_msg}!)\n",
"Wrong number of fish logs generated! (${cnt} vs ${num_fish})\n\n");
}
return;
}
# Run a single test in both modes using "prove" ...
sub run_specific_test
{
my $prog = shift;
my $fish = shift; # The basename of the fish log file ...
my $summary_flag = shift;
my $details_flag = shift;
my $log_s = File::Spec->catfile ($fish_dir_summary, $fish);
my $log_d = File::Spec->catfile ($fish_dir_details, $fish);
# Delte both log files ...
unlink ( $log_s, $log_d );
my ( $summary_msg, $detail_msg );
my $prove = which_prove ( $prog );
# Run the summary test ...
eval {
local $ENV{FAIL_TEST_99} = 1 if ( $summary_flag );
run_that_test ( $prove, $prog, $log_s, 1, "=", "Fred::Fish::DBUG::OFF, just high level logs available. (fast)" );
};
if ( $@ ) {
$summary_msg = $@;
}
# Run the detailed test ...
eval {
local $ENV{FAIL_TEST_99} = 1 if ( $details_flag );
run_that_test ( $prove, $prog, $log_d, 0, "-", "Fred::Fish::DBUG, providing detailed logging. (slow)" );
};
if ( $@ ) {
$detail_msg = $@;
}
print_status ( $summary_msg, $detail_msg );
return;
}
sub run_that_test
{
my $prove = shift; # Prove or Perl binary to use.
my $prog = shift;
my $fish = shift;
my $off_flag = shift; # Which setting to use: 0, 1.
my $sep_char = shift;
my $log_msg = shift;
my $p = basename ($prove);
# Determine the test mode to use ...
$ENV{FISH_OFF_FLAG} = ${off_flag};
# Running the test via prove ...
printf ("\n%s\n", ${sep_char}x50);
print "Running '${p} -bv ${prog}' for ${log_msg} ...\n";
printf ("%s\n\n", ${sep_char}x50);
my $res = system ("${prove} -bv ${prog}");
if ( $res != 0 ) {
die ("Failed test case ($res)! FISH_OFF_FLAG == ${off_flag} (${log_msg}!)\n\n");
}
if ( -f $fish ) {
print "Found fish file: ${fish}\n";
} else {
print "No fish file found: ${fish}\n";
}
return;
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
# Always keep the keys in lower case.
# Using the values from Date::Language::English for initialization ...
# Hard coded here in case Date::Language wasn't installed ...
# These hashes get rebuilt each time swap_language() is
# successfully called!
# ========================================================================
# Used by parse_date ();
my %last_language_edit_flags;
# Variants for the month names & days of month ...
# We hard code the initialization in case neither
# language module is installed locally.
my %Months;
my %Days;
BEGIN {
# Variants for the month names ...
%Months = (
lib/Advanced/Config/Date.pm view on Meta::CPAN
'ten' => -10, 'eleven' => -11, 'twelve' => -12,
'thirteen' => -13, 'fourteen' => -14, 'fifteen' => -15,
'sixteen' => -16, 'seventeen' => -17, 'eighteen' => -18,
'nineteen' => -19, 'twenty' => -20, 'twenty-one' => -21,
'twenty-two' => -22, 'twenty-three' => -23, 'twenty-four' => -24,
'twenty-five' => -25, 'twenty-six' => -26, 'twenty-seven' => -27,
'twenty-eight' => -28, 'twenty-nine' => -29, 'thirty' => -30,
'thirty-one' => -31,
);
my $date_manip_installed_flag = keys %date_manip_installed_languages;
my $date_language_installed_flag = keys %date_language_installed_languages;
# Tells what to do about the negative values in the hashes ...
my $flip = $date_manip_installed_flag || (! $date_language_installed_flag);
$last_language_edit_flags{language} = "English";
$last_language_edit_flags{month_period} = 0;;
$last_language_edit_flags{dsuf_period} = 0;
$last_language_edit_flags{dow_period} = 0;;
foreach ( keys %Months ) {
next if ( $Months{$_} > 0 );
if ( $flip ) {
$Months{$_} = abs ($Months{$_});
} else {
delete $Months{$_};
}
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
foreach ( $num..31 ) {
my $idx = $_ - $num + 20 + $fix;
$lDsuf[$_] = $lDsuf[$idx];
DBUG_PRINT ("FIX", "lDsuf[%d] = lDsuf[%d] = %s (%s)",
$_, $idx, $lDsuf[$_], $lang);
}
}
# --------------------------------------------------
# Check if Unicode/Wide Chars were used ...
my $wide_flag = 0;
foreach ( @lMoY, @lMoYs, @lDsuf, @lDoW, @lDoWs ) {
# my $wide = utf8::is_utf8 ($_) || 0;
my $wide = ( $_ =~ m/[^\x00-\xff]/ ) || 0; # m/[^\x00-\x7f]/ doesn't completely work!
if ( $wide ) {
$wide_flag = 1; # Multi-byte chars detected!
} else {
# Fix so uc()/lc() work for languages like German.
utf8::encode ($_);
utf8::decode ($_); # Sets utf8 flag ...
# Are any of these common variants wide chars?
if ( $_ =~ m/[^\x00-\xff]/ ||
uc ($_) =~ m/[^\x00-\xff]/ ||
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
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 intalled, 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.
Languages like 'Greek' that rely on I<Wide Chars> require the I<$wide> flag set to
true. Otherwise that language is disabled. Using the I<use_ut8> option when
creating the Advanced::Config object causes the I<$wide> flag to be set to B<1>.
=cut
# NOTE: Sets the following global variables for use by parse_date() ...
# %last_language_edit_flags
# %Months
# %Days
sub swap_language
{
DBUG_ENTER_FUNC ( @_ );
my $lang = shift;
my $warn_ok = shift;
my $allow_wide = shift || 0;
if ( (! defined $lang) || lc($lang) eq lc($last_language_edit_flags{language}) ) {
return DBUG_RETURN ( $last_language_edit_flags{language} );
}
my ($manip_ref, $lang_ref) = _select_language ($lang, $warn_ok, $allow_wide);
unless ( $lang_ref || $manip_ref ) {
return DBUG_RETURN ( $last_language_edit_flags{language} );
}
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 ) {
lib/Advanced/Config/Date.pm view on Meta::CPAN
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};
}
unless ( $MoY_ref || $month_ref ) {
return DBUG_RETURN ( $last_language_edit_flags{language} );
}
DBUG_PRINT ("SWAP", "Swapping from '%s' to '%s'.",
$last_language_edit_flags{language}, $lang);
# ---------------------------------------------------------
foreach my $k ( keys %last_language_edit_flags ) {
$last_language_edit_flags{$k} = $issue1_ref->{$k} || $issue2_ref->{$k} || 0;
}
$last_language_edit_flags{language} = $lang;
# ---------------------------------------------------------
# Bug Alert: For some languges the following isn't true!
# lc(MoY) != lc(uc(lc(MoY)))
# So we have multiple lower case letters mapping to the
# same upper case letters#.
# ---------------------------------------------------------
# This happens for 3 languages for Date::Language.
# Chinese_GB, Greek & Russian_cp1251
# And one language for Date::Manip
lib/Advanced/Config/Date.pm view on Meta::CPAN
$Days{lc (uc (lc ($key)))} = $day; # Bug fix, but usually same.
}
}
# ---------------------------------------------------------
# Report the results ...
DBUG_PRINT ( "LANGUAGE", "%s\n%s\n%s",
join (", ", sort { $Months{$a} <=> $Months{$b} || $a cmp $b } keys %Months),
join (", ", sort { my ($x,$y) = ($a,$b); $x=~s/\D+//g; $y=~s/\D+//g; $x=0 if ($x eq ""); $y=0 if ($y eq ""); ($x<=>$y || $a cmp $b) } keys %Days),
join (", ", %last_language_edit_flags) );
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
lib/Advanced/Config/Date.pm view on Meta::CPAN
my $use_date_language_module = shift || 0;
my $allow_2_digit_years = shift || 0;
# The Month name pattern, ... [a-zA-Z] doesn't work for other languages.
my $name = "[^-\$\\s\\d.,|\\[\\]\\\\/{}()]";
# The Day of Month pattern ... (when not all digits are expected)
my $dom = "\\d{0,2}${name}*";
# Remove the requesed character from the month pattern ...
$name =~ s/\\s//g if ( $last_language_edit_flags{month_spaces} );
$name =~ s/[.]//g if ( $last_language_edit_flags{month_period} );
$name =~ s/-//g if ( $last_language_edit_flags{month_hyphin} );
$name .= '+'; # Terminate the name pattern.
# Remove the requesed character from the day of month pattern ...
$dom =~ s/\\s//g if ( $last_language_edit_flags{dsuf_spaces} );
$dom =~ s/[.]//g if ( $last_language_edit_flags{dsuf_period} );
$dom =~ s/-//g if ( $last_language_edit_flags{dsuf_hyphin} );
my ( $year, $month, $day );
my ( $s1, $s2 ) = ( "", "" );
my $fmt = "n/a";
# The 7 separators to cycle through to parse things correctly ...
my @seps = ( "-", "/", "[.]", ",", "\\s+", '\\\\', ":" );
# -------------------------------------------------------
# Let's start with the 4-digit year formats ...
lib/Advanced/Config/Date.pm view on Meta::CPAN
# Keep after my checks so that things are consistent when this module
# isn't installed. (No way to disable 2-digit year format here.)
# --------------------------------------------------------------------
if ( $use_date_language_module && ! defined $year ) {
unless ( _date_language_installed () ) {
DBUG_PRINT ("INFO", "Using Date::Language::str2time was requested, but it's not installed!");
} else {
DBUG_PRINT ("INFO", "Using Date::Language::str2time to attempt the parse!");
eval {
my $dl = Date::Language->new ( $last_language_edit_flags{language} );
my $t = $dl->str2time ( $in_date );
if ( defined $t ) {
($year, $month, $day) = (localtime ($t))[5,4,3];
$year += 1900;
$month += 1;
}
};
}
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
# --------------------------------------------------------------------
# If my parsing didn't work try using Date::Language if it's installed.
# Keep after my checks so that things are consistent when this module
# isn't installed. (No way to disable 2-digit year format here.)
# --------------------------------------------------------------------
if ( $use_date_language_module && (! $out_str) &&
_date_language_installed () ) {
DBUG_PRINT ("INFO", "Using Date::Language::str2time to attempt parsing!");
eval {
my $dl = Date::Language->new ( $last_language_edit_flags{language} );
my $t = $dl->str2time ( $in_date );
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);
}
};
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
my $month;
my $digits = 0;
my @lst = sort { length($b) <=> length($a) || $a cmp $b } keys %Months;
foreach my $m ( @lst ) {
# Ignore numeric keys, can't get the correct one from string ...
next if ( $m =~ m/^\d+$/ );
my $flag1 = ( $last_language_edit_flags{month_period} &&
$m =~ s/[.]/\\./g );
if ( $date_str =~ m/(${m})/ ) {
$month = $1;
$month =~ s/[.]/\\./g if ( $flag1 );
last;
}
}
# Allow any number between 1 and 12 ...
unless ( $month ) {
$month = "[1-9]|0[1-9]|1[0-2]";
$digits = 1;
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
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 ...
next if ( $dom =~ m/${all_digits}/ );
my $flag1 = ( $last_language_edit_flags{dsuf_period} &&
$dom =~ s/[.]/\\./g );
if ( $month_str ) {
# Makes sure dom doesn't match month name ...
$month_str =~ s/[.]/\\./g;
if ( $date_str =~ m/${month_str}.*(${dom})/ ||
$date_str =~ m/(${dom}).*${month_str}/ ) {
$day = $1;
$day =~ s/[.]/\\./g if ( $flag1 );
last;
}
# There is no month name to worry about ...
} elsif ( $date_str =~ m/(${dom})/ ) {
$day = $1;
$day =~ s/[.]/\\./g if ( $flag1 );
last;
}
}
# Allow any number between 1 and 31 ...
unless ( $day ) {
$day = "[1-9]|0[1-9]|[12][0-9]|3[01]";
$digits = 1;
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
I<$mode> tells how to return the various arrays:
1 - Abreviated month/weekday names in the requested language.
2 - Full month/weekday names in the requested language.
Any other value and it will return the numeric values. (default)
For @months, indexes are 0..11, with 0 representing January.
For @weekdays, indexes are 0..6, with 0 representing Sunday.
Languages like 'Greek' that rely on I<Wide Chars> require the I<$wide> flag set to
true. Otherwise that language is disabled.
=cut
sub init_special_date_arrays
{
DBUG_ENTER_FUNC ( @_ );
my $lang = shift;
my $mode = shift || 0; # Default to numeric arrays ...
my $warn_ok = shift || 0;
lib/Advanced/Config/Options.pm view on Meta::CPAN
=cut
sub change_special_date_vars
{
DBUG_ENTER_FUNC (@_);
my $timestamp = shift;
my $date_opts = shift;
my $dates = shift;
# Special flag for special handling ... (undocumented)
local $date_opts->{timestamp} = $timestamp;
# Forces all dates to use the specified date/time
set_special_date_vars ($date_opts, $dates);
DBUG_VOID_RETURN ();
}
# ==============================================================
# For formatting the full dates ...
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# Don't forget that any comment can include processing instructions!
# ------------------------------------------------------------------
# Go to the requested section ...
$cfg = $pcfg->get_section ( $section, 1 );
my ($tag, $value, $prefix, $t2) = _split_assign ( $opts, $ln );
# Don't export individually if doing a batch export ...
# If the export option is used, invert the meaning ...
my $export_flag = 0; # Assume not exporting this tag to %ENV ...
if ( $prefix ) {
$export_flag = $opts->{export} ? 0 : 1;
} elsif ( $cmt =~ m/(^|${lbl_sep})${export_str}(${lbl_sep}|$)/ ) {
$export_flag = $opts->{export} ? 0 : 1;
}
# Is the line info sensitive & should it be hidden/masked in fish ???
my $hide = 0;
if ( $hide_section{$section} ||
$cmt =~ m/(^|${lbl_sep})${encrypt_str}(${lbl_sep}|$)/ ||
$cmt =~ m/(^|${lbl_sep})${hide_str}(${lbl_sep}|$)/ ||
should_we_hide_sensitive_data ( $tag, 1 ) ) {
$hide = 1 unless ( $opts->{dbug_test_use_case_hide_override} );
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
$still_variables = ( $value =~ m/${lv}.+${rv}/ ) ? 1 : 0;
} elsif ( ! $still_encrypted ) {
($value, $hide) = expand_variables ( $cfg, $value, $file, $hide, ($lq ? 0 : 1) );
if ( $hide == -1 ) {
# $still_encrypted = $still_variables = 1;
$still_variables = 1; # Variable(s) points to encrypted data.
}
}
# Export one value to %ENV ... (once set, can't back it out again!)
$cfg->export_tag_value_to_ENV ( $tag, $value, $hide ) if ($export_flag);
# Add to the current section in the Advanced::Config object ...
$cfg->_base_set ($tag, $value, $file, $hide, $still_encrypted, $still_variables);
} # End while reading the config file ...
close ( $READ_CONFIG );
DBUG_RETURN (1);
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# Strip of leading & trailing spaces ...
$line =~ s/^\s+//;
$line =~ s/\s+$//;
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/^(['"])/ ) {
$l_quote = $r_quote = $1; # A ' or ". (Never both)
}
# User defined quotes ...
lib/Advanced/Config/Reader.pm view on Meta::CPAN
$var_line = $value;
}
# Comment still in value, but still haven't proved any quotes are balanced.
DBUG_PRINT ("DEBUG", "Tag (%s), Value (%s), Proposed Left (%s), Right (%s)",
$tag, $value, $l_quote, $r_quote);
my $cmts = "";
# Was the value in the tag/value pair starting with a left quote?
if ( $tv_pair_flag && $l_quote ne "" ) {
my ($q1, $val2, $q2);
# Now check if they were balanced ...
if ( $value =~ m/^(${l_quote})(.*)(${r_quote})(\s*${comment}.*$)/ ) {
($q1, $val2, $q2, $cmts) = ($1, $2, $3, $4); # Has a comment ...
} elsif ( $value =~ m/^(${l_quote})(.*)(${r_quote})\s*$/ ) {
($q1, $val2, $q2, $cmts) = ($1, $2, $3, ""); # Has no comment ...
}
# If balanced quotes were found ...
if ( $q1 ) {
# If the surrounding quotes don't have quotes inside them ...
# IE not malformed ...
unless ( $val2 =~ m/${l_quote}/ || $val2 =~ m/${r_quote}/ ) {
my $cmt2 = convert_to_regexp_string ($cmts);
$cmts =~ s/^\s*${comment}\s*//; # Remove comment symbol ...
$line =~ s/${cmt2}$// if ($cmt2 ne "" ); # Remove the comments ...
DBUG_PRINT ("LINE", "Balanced Quotes encountered for removal ...");
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, $l_quote, $r_quote);
}
}
}
# The Quotes weren't balanced, so they can no longer be removed from
# arround the value of what's returned!
$l_quote = $r_quote = "";
# ----------------------------------------------------------------------
# If no comments in the line, just return the trimmed string ...
# Both tests are needed due to custom comment/assign strings!
# ----------------------------------------------------------------------
if ( $line !~ m/${comment}/ ) {
DBUG_PRINT ("LINE", "Simply no comments to worry about ...");
return DBUG_RETURN ( $tv_pair_flag, $line, "", "", "" );
}
# Handles case where a comment char embedded in the assignment string.
if ( $tv_pair_flag && $value !~ m/${comment}/ ) {
DBUG_PRINT ("LINE", "Simply no comments in the value to worry about ...");
return DBUG_RETURN ( $tv_pair_flag, $line, "", "", "" );
}
# ----------------------------------------------------------------------
# If not protected by balanced quotes, verify the comment symbol detected
# isn't actually a variable modifier. Variables are allowed in most places
# in the config file, not just in tag/value pairs.
# ----------------------------------------------------------------------
# The left & right anchor points for variable substitution ...
my $lvar = convert_to_regexp_string ($opts->{variable_left}, 1);
lib/Advanced/Config/Reader.pm view on Meta::CPAN
push (@data, $var_line);
my $unbalanced_leading_var_anchor_with_comments = 0;
if ( $cmt_found && $parts[0] =~ m/(\s*${comment}\s*)(.*$)/ ) {
# parts[1] is parts[7] trimmed ... so join back together with untrimmed.
$cmts = $2 . $opts->{variable_left} . $parts[7]
. $opts->{variable_right} . $parts[2];
my $str = convert_to_regexp_string ( $1 . $cmts );
$line =~ s/${str}$//;
DBUG_PRINT ("LINE", "Variables encountered with variables in comment ...");
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
} elsif ( $count_var ) {
if ( $var_line =~ m/(\s*${comment}\s*)(.*)$/ ) {
$cmts = $2;
if ( $cmts =~ m/${has_no_cmt}/ ) {
$unbalanced_leading_var_anchor_with_comments = 1;
} else {
my $cmt2 = convert_to_regexp_string ($1 . $cmts);
$line =~ s/${cmt2}$//;
DBUG_PRINT ("LINE", "Variables encountered with constant comment ...");
}
} else {
$cmts = "";
DBUG_PRINT ("LINE", "Variables encountered without comments ...");
}
unless ( $unbalanced_leading_var_anchor_with_comments ) {
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
}
}
# ---------------------------------------------------------------------------
# Corrupted variable definition with variables in the comments ...
# Boy things are getting difficult to parse. Reverse the previous variable
# substitutions until the all variables in the comments are unexpanded again!
# Does a greedy RegExp to grab the 1st comment string encountered.
# ---------------------------------------------------------------------------
if ( $unbalanced_leading_var_anchor_with_comments ) {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
$cmts = $1;
last unless ( $cmts =~ m/${has_no_cmt}/ );
$cmts = "";
}
}
if ( $cmts ne "" ) {
my $cmt2 = convert_to_regexp_string ($cmts);
$line =~ s/\s*${comment}\s*${cmt2}$//;
DBUG_PRINT ("LINE", "Unbalanced var def encountered with var comments ...");
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
}
# If you get here, assume it's not a tag/value pair even if it is!
# I know I can no longer hope to parse it correctly without a test case.
# But I really don't think it's possible to get here anymore ...
warn ("Corrupted variable definition encountered. Can't split out the comment with variables in it correctly!\n");
return DBUG_RETURN ( 0, $line, "", "", "");
}
# ----------------------------------------------------------------------
# No variables, no balanced quotes ...
# But I still think there's a comment to remove!
# ----------------------------------------------------------------------
if ( $tv_pair_flag && $value =~ m/(\s*${comment}\s*)(.*)$/ ) {
$cmts = $2;
my $cmt2 = convert_to_regexp_string ($1 . $cmts);
$line =~ s/${cmt2}$//; # Remove the comment from the line.
DBUG_PRINT ("LINE", "Last ditch effort to remove the comment from the value ...");
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
}
$cmts = $line;
$line =~ s/\s*${comment}.*$//; # Strip off any comments ....
$cmts = substr ( $cmts, length ($line) ); # Grab the comments ...
$cmts =~ s/^\s*${comment}\s*//; # Remove comment symbol ...
DBUG_PRINT ("LINE", "Last ditch effort to remove the comment from the line ...");
DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
}
# ==============================================================
=item ($v[, $h]) = expand_variables ( $config, $string[, $file[, $sensitive[, trim]]] )
This function takes the provided I<$string> and expands any embedded variables
in this string similar to how it's handled by a Unix shell script.
lib/Advanced/Config/Reader.pm view on Meta::CPAN
all variables that don't contain encrypted data are resolved.
=cut
# ==============================================================
sub expand_variables
{
my $config = shift; # For the current section of config obj ...
my $value = shift; # The value to parse for variables ...
my $file = shift || ""; # The config file the value came from ...
my $mask_flag = shift || 0; # Hide/mask sensitive info written to fish?
my $trim_flag = shift || 0; # Tells if we should trim the result or not.
# Only mask ${value} if ${mask_flag} is true ...
DBUG_MASK_NEXT_FUNC_CALL (1) if ( $mask_flag );
DBUG_ENTER_FUNC ( $config, $value, $file, $mask_flag, $trim_flag, @_);
my $opts = $config->get_cfg_settings (); # The Read Options ...
my $pcfg = $config->get_section(); # Get the main/parent section to work with!
# Don't write to Fish if we're hiding any values ...
if ( $mask_flag ) {
DBUG_PAUSE ();
DBUG_MASK ( 0 );
}
# The 1st split of the value into it's component parts ...
my ($left, $tag, $right, $cmt_flag, $mod_tag, $mod_opt, $mod_val, $ot) =
parse_for_variables ( $value, 0, $opts );
# Any variables to substitute ???
unless ( defined $tag ) {
return DBUG_RETURN ( $value, $mask_flag ); # nope ...
}
my $output = $value;
my %encrypt_vars;
my $encrypt_cnt = 0;
my $encrypt_fmt = "_"x50 . "ENCRYPT_%02d" . "-"x50;
my ($lv, $rv) = ( convert_to_regexp_string ($opts->{variable_left}),
convert_to_regexp_string ($opts->{variable_right}) );
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# -----------------------------------------------------------------
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 ) {
$mask_flag = -1;
$val = sprintf ($encrypt_fmt, ++$encrypt_cnt);
# If the place holder contains variable anchors abort the substitutions.
last if ( $val =~ m/${lv}/ || $val =~ m/${rv}/ );
$encrypt_vars{$val} = $tag;
$do_mod_lookup = 0;
}
# Doing some accounting to make sure any sensitive data doesn't
# show up in the fish logs from now on.
if ( $mask && ! $mask_flag ) {
$mask_flag = 1;
DBUG_PAUSE ();
DBUG_MASK ( 0 );
}
if ( $do_mod_lookup ) {
my $m;
($val, $m) = apply_modifier ( $config, $val, $mod_tag, $mod_opt, $mod_val, $file );
if ( $m == -2 ) {
# The name of the variable changed & points to an encrypted value.
$val = $opts->{variable_left} . ${val} . $opts->{variable_right};
} elsif ( $m && ! $mask_flag ) {
$mask_flag = 1;
DBUG_PAUSE ();
DBUG_MASK ( 0 );
}
}
# Rebuild the output string so we can look for more variables ...
if ( defined $val ) {
$output = $left . $val . $right;
} else {
$output = $left . $right;
}
# Get the next variable to evaluate ...
($left, $tag, $right, $cmt_flag, $mod_tag, $mod_opt, $mod_val, $ot) =
parse_for_variables ( $output, 0, $opts );
} # End while ( defined $tag ) loop ...
# Restore all place holders back into the output string with the
# proper variable name. Have to assume still sensitive even if
# all the placeholders drop out. Since can't tell what else may
# have triggered it.
if ( $mask_flag == -1 ) {
$mask_flag = 1; # Mark sensitive ...
foreach ( keys %encrypt_vars ) {
my $val = $opts->{variable_left} . $encrypt_vars{$_} . $opts->{variable_right};
$mask_flag = -1 if ( $output =~ s/$_/$val/ );
}
}
# Did the variable substitution result in the need to trim things?
if ( $trim_flag ) {
$output =~ s/^\s+//;
$output =~ s/\s+$//;
}
DBUG_RETURN ( $output, $mask_flag );
}
# ==============================================================
=item ($v[, $s]) = apply_modifier ( $config, $value, $tag, $rule, $sub_rule, $file )
This is a helper method to F<expand_variables>. Not for public use.
This function takes the rule specified by I<$rule> and applies it against
lib/Advanced/Config/Reader.pm view on Meta::CPAN
DBUG_PRINT ("MOD",
"The modifier (%s) is overriding the variable with a default value!",
$mod_opt);
# Sub-string removal ...
} elsif ( $mod_opt eq "##" || $mod_opt eq "#" || # From beginning
$mod_opt eq "%%" || $mod_opt eq "%" ) { # From end
my $greedy = ( $mod_opt eq "##" || $mod_opt eq "%%" );
my $leading = ( $mod_opt eq "#" || $mod_opt eq "##" );
my $reverse_msg = ""; # Both the message & control flag ...
$output = $alt_val;
# Now replace shell script wildcards with their Perl equivalents.
# A RegExp can't do non-greedy replaces anchored to the end of string!
# So we need the reverse logic to do so.
my $regExpVal = convert_to_regexp_modifier ($mod_val);
$regExpVal =~ s/[?]/./g; # ? --> . (any one char)
if ( $greedy ) {
$regExpVal =~ s/[*]/.*/g; # * --> .* (zero or more greedy chars)
lib/Advanced/Config/Reader.pm view on Meta::CPAN
$mod_opt);
$output = $value;
}
DBUG_RETURN ( $output, $mask );
}
# ==============================================================
=item @ret[0..7] = parse_for_variables ( $value, $ignore_disable_flag, $rOpts )
This is a helper method to F<expand_variables> and B<parse_line>.
This method parses the I<$value> to see if any variables are defined in it
and returns the information about it. If there is more than one variable
present in the I<$value>, only the 1st variable/tag to evaluate is returned.
By default, a variable is the tag in the I<$value> between B<${> and B<}>, which
can be overriden 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.
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# : 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);
my $cmt_flg = 0;
my ($sub_tag, $sub_opr, $sub_val, $sub_extra);
if ( $opts->{disable_variables} && (! $disable_flag) ) {
DBUG_PRINT ("INFO", "Variable substitution has been disabled.");
return DBUG_RETURN ( $left, $tag, $right, $cmt_flg,
$sub_tag, $sub_opr, $sub_val, $otag );
}
my $lvar = convert_to_regexp_string ($opts->{variable_left}, 1);
my $rvar = convert_to_regexp_string ($opts->{variable_right}, 1);
# Break up the value into it's component parts. (Non-greedy RegExpr)
if ( $value =~ m/(^.*?)(${lvar})(.*?)(${rvar})(.*$)/ ) {
t/13-alt-get-tests.t view on Meta::CPAN
my $ok2_msg_prefix = "Tag ${tag}'s value";
DBUG_RETURN ( $guess, $real, $trunc, $round, $ok2_msg_prefix );
}
# ====================================================================
sub truncate_or_round
{
DBUG_ENTER_FUNC ( @_ );
my $list_ref = shift;
my $int_flag = shift; # Always 1 (round) or -1 (truncate)
my $cnt = @{$list_ref} - 1;
foreach (0..${cnt}) {
next unless ( $list_ref->[$_] =~ m/^([-+]?\d+)[.]\d+$/ );
if ( $int_flag < 0 ) {
$list_ref->[$_] = $1 + 0; # Truncated
} else {
$list_ref->[$_] = sprintf ("%.0f", $list_ref->[$_]);
}
}
DBUG_VOID_RETURN ();
}
# ====================================================================
t/55-validate-strings.t view on Meta::CPAN
dbug_ok ( test_obj ($xCfg1, $zCfg1, [ "abc", "xyz", "cmt1", "cmt2", "cmt3", "cmt4" ], [] ), "Compares main OK" );
dbug_ok ( test_obj ($sxCfg1, $szCfg1, [ "lmn", "no" ], [] ), "Compares section OK" );
# Mark all tags to be encrypted ...
$str = $xCfg1->toString (1);
dbug_ok ( defined $str, "toString(1) returned something!" );
$str2 = $xCfg1->encrypt_string ($str, $alias);
dbug_ok ( defined $str2, "encrypt_string() returned something!" );
my $flag = (defined $str && defined $str2) && $str ne $str2;
dbug_ok ( $flag, "The toString(1) results have been encrypted!");
my $zCfg2 = init_config ( $str2 );
my $szCfg2 = $zCfg2->get_section ($sect);
dbug_ok ( defined $szCfg2, "Section exists" );
my $zCfg3 = init_config ( $str2, $alias );
my $szCfg3 = $zCfg3->get_section ($sect);
dbug_ok ( defined $szCfg3, "Section exists" );
dbug_ok ( test_obj ($xCfg1, $zCfg2, [], [ "abc", "xyz", "cmt1", "cmt2", "cmt3", "cmt4" ] ), "Decrypts main Failed as expected" );
t/75-check_all_languages.t view on Meta::CPAN
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}");
}
# Validate the date itself ...
foreach my $tag ( $sCfg->find_tags (qr /^[0-9]{4}-[0-9]{2}-[0-9]{2}$/, 0) ) {
my $val1 = $sCfg->get_value ($tag);
DBUG_PRINT ("UTF8", "utf8 flag (%d)", utf8::is_utf8($val1));
my $val2 = $sCfg->get_date ($tag, $lang, date_language_warn => 0);
if ( $val2 && $val2 eq $tag ) {
dbug_ok (1, "Found tag: ${tag} in section '${s}' for ${lang} --> ${val2} -- ${val1}");
} else {
dbug_ok (0, "Tag ${tag} in section '${s}' for ${lang} points to a valid date: ${val1}");
}
}
DBUG_PRINT ("----", "-------------------------------------------------");
}
DBUG_VOID_RETURN ();
}
# ====================================================================
# From here on down deals with creating the config file.
# ====================================================================
sub build_config_file
{
DBUG_ENTER_FUNC (@_);
my $all_languages = shift;
my $wide_flag = shift;
my $file = $wide_flag ? $config_file_wide : $config_file_normal;
unless ( open (CONFIG, ">", $file) ) {
dbug_ok (0, "Creating the UTF-8 config file: $file");
return DBUG_RETURN (0);
}
my $msg;
if ( $wide_flag ) {
dbug_ok (1, "Creating the UTF-8 config file: $file");
binmode (CONFIG, "encoding(UTF-8)"); # Converts to wide-char / Unicode output.
$msg = "This file was created using UTF-8 Encoding";
} else {
dbug_ok (1, "Creating the normal config file: $file");
$msg = "This file was created without any special Encoding";
}
print CONFIG "\n";
print CONFIG "# This is an auto-genearted config file.\n";
print CONFIG "# Do not modify it by hand!\n\n";
print CONFIG "# ${msg}\n\n";
my $englishDoW = $all_languages->{English}->{DoW};
foreach my $lang ( sort keys %{$all_languages} ) {
my $l = $all_languages->{$lang};
next if ( $l->{wide} && ! $wide_flag );
print CONFIG "[ $lang ]\n";
print CONFIG " Language = $lang\n"; # To preserve the case...
print CONFIG " Wide = $l->{wide}\n";
print CONFIG " WeekDays = ", join (", ", @{$l->{DoW}}), "\n\n";
foreach ( 0..6 ) {
print CONFIG " $l->{DoW}->[$_] = Found $englishDoW->[$_] in ${lang} ($l->{DoW}->[$_])\n";
}
print CONFIG "\n";
t/75-check_all_languages.t view on Meta::CPAN
print CONFIG "----------------------------------------------------------\n\n";
# These extra sections are for advanced checks ...
# Using variables and Encryption ...
my $cntr = 0;
foreach my $lang ( "Chinese", "Greek", "Russian" ) {
my $l = $all_languages->{$lang};
next unless ( defined $l );
next if ( $l->{wide} && ! $wide_flag );
++$cntr;
print CONFIG "[ ZZ Extra ${cntr} ]\n";
print CONFIG " Language = \${$lang.Language}\n";
print CONFIG " Wide = \${$lang.Wide}\n";
print CONFIG " WeekDays = \${$lang.WeekDays}\n\n";
foreach ( 0..6 ) {
my $wd = $l->{DoW}->[$_];
print CONFIG " $wd = \${$lang.$wd} # ENCRYPT\n";
t/75-check_all_languages.t view on Meta::CPAN
print CONFIG "\n";
}
print CONFIG "----------------------------------------------------------\n\n";
# So can validate we have no issues writing foreign languages to a
# file and reading them back out again!
foreach my $lang ( sort keys %{$all_languages} ) {
my $l = $all_languages->{$lang};
next if ( $l->{wide} && ! $wide_flag );
print CONFIG "[ $lang ]\n";
foreach ( 0..11 ) {
print CONFIG "MoY_${_} = $l->{MoY}->[$_] # ENCRYPT\n";
}
print CONFIG "\n";
foreach ( 0..11 ) {
print CONFIG "MoYs_${_} = $l->{MoYs}->[$_] # ENCRYPT\n";
}
print CONFIG "\n";
t/76-check_all_languages2.t view on Meta::CPAN
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}");
}
# Validate the date itself ...
foreach my $tag ( $sCfg->find_tags (qr /^[0-9]{4}-[0-9]{2}-[0-9]{2}$/, 0) ) {
my $val1 = $sCfg->get_value ($tag);
DBUG_PRINT ("UTF8", "utf8 flag (%d)", utf8::is_utf8($val1));
my $val2 = $sCfg->get_date ($tag, $lang, date_language_warn => 1);
if ( $val2 && $val2 eq $tag ) {
dbug_ok (1, "Found tag: ${tag} in section '${s}' for ${lang} --> ${val2} -- ${val1}");
} else {
dbug_ok (0, "Tag ${tag} in section '${s}' for ${lang} points to a valid date: ${val1}");
}
}
DBUG_PRINT ("----", "-------------------------------------------------");
}
DBUG_VOID_RETURN ();
}
# ====================================================================
# From here on down deals with creating the config file.
# ====================================================================
sub build_config_file
{
DBUG_ENTER_FUNC (@_);
my $all_languages = shift;
my $wide_flag = shift;
my $file = $wide_flag ? $config_file_wide : $config_file_normal;
unless ( open (CONFIG, ">", $file) ) {
dbug_ok (0, "Creating the UTF-8 config file: $file");
return DBUG_RETURN (0);
}
my $msg;
if ( $wide_flag ) {
dbug_ok (1, "Creating the UTF-8 config file: $file");
binmode (CONFIG, "encoding(UTF-8)"); # Converts to wide-char / Unicode output.
$msg = "This file was created using UTF-8 Encoding";
} else {
dbug_ok (1, "Creating the normal config file: $file");
$msg = "This file was created without any special Encoding";
}
print CONFIG "\n";
print CONFIG "# This is an auto-genearted config file.\n";
print CONFIG "# Do not modify it by hand!\n\n";
print CONFIG "# ${msg}\n\n";
my $englishDoW = $all_languages->{English}->{DoW};
foreach my $lang ( sort keys %{$all_languages} ) {
my $l = $all_languages->{$lang};
next if ( $l->{wide} && ! $wide_flag );
print CONFIG "[ $lang ]\n";
print CONFIG " Language = $lang\n"; # To preserve the case...
print CONFIG " Wide = $l->{wide}\n";
print CONFIG " WeekDays = ", join (", ", @{$l->{DoW}}), "\n\n";
foreach ( 0..6 ) {
print CONFIG " $l->{DoW}->[$_] = Found $englishDoW->[$_] in ${lang} ($l->{DoW}->[$_])\n";
}
print CONFIG "\n";
t/76-check_all_languages2.t view on Meta::CPAN
print CONFIG "----------------------------------------------------------\n\n";
# These extra sections are for advanced checks ...
# Using variables and Encryption ...
my $cntr = 0;
foreach my $lang ( "Chinese", "Greek", "Russian" ) {
my $l = $all_languages->{$lang};
next unless ( defined $l );
next if ( $l->{wide} && ! $wide_flag );
++$cntr;
print CONFIG "[ ZZ Extra ${cntr} ]\n";
print CONFIG " Language = \${$lang.Language}\n";
print CONFIG " Wide = \${$lang.Wide}\n";
print CONFIG " WeekDays = \${$lang.WeekDays}\n\n";
foreach ( 0..6 ) {
my $wd = $l->{DoW}->[$_];
print CONFIG " $wd = \${$lang.$wd} # ENCRYPT\n";
t/76-check_all_languages2.t view on Meta::CPAN
print CONFIG "\n";
}
print CONFIG "----------------------------------------------------------\n\n";
# So can validate we have no issues writing foreign languages to a
# file and reading them back out again!
foreach my $lang ( sort keys %{$all_languages} ) {
my $l = $all_languages->{$lang};
next if ( $l->{wide} && ! $wide_flag );
print CONFIG "[ $lang ]\n";
foreach ( 0..11 ) {
print CONFIG "MoY_${_} = $l->{MoY}->[$_] # ENCRYPT\n";
}
print CONFIG "\n";
foreach ( 0..11 ) {
print CONFIG "MoYs_${_} = $l->{MoYs}->[$_] # ENCRYPT\n";
}
print CONFIG "\n";
( run in 2.158 seconds using v1.01-cache-2.11-cpan-94b05bcf43c )