Advanced-Config
view release on metacpan or search on metacpan
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
problems.
- Updated Makefille.PL to make DBUG v1.09 the minimum allowed version.
That's when DBUG supported writing Wide Chars to fish. It also allowed
me to simplify all t/*.t test programs logging by removing support
for obsolete features. The module itself will still work with DBUG
v1.03 or later as long as option 'use_utf8' isn't being used.
- t/00-basic.t - Fixed to enforce the same min version as Makefile.PL.
- helper1234.pm - Removed fixes for earlier DBUG versions. No longer
any need for a lot of conditional logic in test cases.
- t/*.t - Removed calls to helper methods removed from helper1234.pm
as no longer needed after DBUG min version upgraded.
- Created full_developer_test.pl.src to make things easier for a
full test of the module. Does a summary pass then a detailed pass.
- Created t/log_summary & t/log_details log dirs to hold the logs for
each pass. By default "make test" uses t/log_details.
- Modified all t/*.t to call turn_fish_on_off_for_advanced_config()
# Used to detect recursion ...
$control{RECURSION} = \%rec;
# Used to detect recursion ...
$control{MERGE} = \@lst;
# The count for sensitive entries ...
$control{SENSITIVE_CNT} = sensitive_cnt ();
# Assume not allowing utf8/Unicode/Wide Char dates ...
# Or inside the config file itself.
$control{ALLOW_UTF8} = 0;
# Controls the behaviour of this module.
# Only exists in the parent object.
$self->{CONTROL} = \%control;
my $key = $self->{SECTION_NAME} = DEFAULT_SECTION;
my %sections;
$self->{DATA} = \%data;
# Is the data all sensitive?
$self->{SENSITIVE_SECTION} = 0; # No for the default section ...
DBUG_RETURN ( $self );
}
# Only called by Advanced::Config::Reader::read_config() ...
# So not exposed in the POD!
# Didn't rely on read option 'use_utf8' since in many cases
# the option is misleading or just plain wrong!
sub _allow_utf8
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
# Tells calls to Advanced::Config::Options::apply_get_rules() that
# it's ok to use Wide Char Languages like Greek.
my $pcfg = $self->{PARENT} || $self;
$pcfg->{CONTROL}->{ALLOW_UTF8} = 1;
DBUG_VOID_RETURN ();
}
# 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 ...
$read_opts->{use_utf8} = ( $string =~ m/[^\x00-\xff]/ ) ? 1 : 0;
# Behaves diferently based on who calls us ...
my $c = (caller(1))[3] || "";
my $by = __PACKAGE__ . "::merge_string";
if ( $c eq $by ) {
# Manually merging in another string as a config file.
push (@{$self->{CONTROL}->{MERGE}}, $filename);
} else {
# Loading the original string ...
$self->_wipe_internal_data ( $filename );
lib/Advanced/Config/Date.pm view on Meta::CPAN
$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;
}
}
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
# ==============================================================
# So uc() & lc() works against all language values ...
sub _fix_key
{
my $value = shift;
my $keep_case = shift || 0;
my $wide = ( $value =~ m/[^\x00-\xff]/ ) ? 1 : 0; # Before ...
unless ( $wide ) {
utf8::encode ($value);
utf8::decode ($value);
# Now verify if any of the following makes it wide ...
if ( $value =~ m/[^\x00-\xff]/ ||
lc ($value) =~ m/[^\x00-\xff]/ ||
uc ($value) =~ m/[^\x00-\xff]/ ) {
$wide = 1;
}
}
$value = lc ($value) unless ( $keep_case );
lib/Advanced/Config/Date.pm view on Meta::CPAN
year date formats as valid. Set to a non-zero value to enable them.
=cut
# Check out Date::Parse for date examples to use to test this function out.
sub lcx
{
my $str = shift;
unless ( utf8::is_utf8 ($str) ) {
utf8::encode ($str);
utf8::decode ($str);
}
return (lc ($str));
}
sub _tst
{
my $s = shift;
my $nm = shift;
my $dm = shift;
lib/Advanced/Config/Options.pm view on Meta::CPAN
B<croak> - This controls what happens when a function hits an unexpected error
while parsing the config file. Set to B<0> to return an error code (default),
B<-1> to return an error code and print a warning to your screen, B<1> to call
die and terminate your program.
B<export> - Tells if we should export all tag/value pairs to perl's %ENV hash
or not. The default is B<0> for I<No>. Set to B<1> if you want this to happen.
But if set, it reverses the meaning of the B<export_lbl> option defined later
on.
B<use_utf8> - Defaults to B<0>. Set to B<1> if the config file was created
using utf8 encoding. (IE Unicode or Wide Characters.) Guessing this
setting wrong means the file will be unusable as a config file.
B<disable_quotes> - Defaults to B<0>. Set to B<1> if you want to disallow
the stripping of balanced quotes in your config files.
B<disable_variables> - Defaults to B<0>. Set to B<1> if you want to disable
variable expansion in your config files when they are loaded into memory.
B<disable_variable_modifiers> - Defaults to B<0>. Set to B<1> if you want to
disable this feature. See L<http://wiki.bash-hackers.org/syntax/pe> for more
lib/Advanced/Config/Options.pm view on Meta::CPAN
# ---------------------------------------------------------------------
DBUG_PRINT ("INFO", "Initializing the READ options global hash ...");
# Should always be set in the constructor ...
$default_read_opts{tag_case} = 0; # Case sensitive tags.
# The generic options ...
my %src_empty;
$default_read_opts{croak} = 0; # Don't croak by default.
$default_read_opts{export} = 0; # Don't export any tag/val pairs.
$default_read_opts{use_utf8} = 0; # Doesn't support utf8/Unicode/Wide Chars.
$default_read_opts{disable_quotes} = 0; # Don't disable balanced quotes.
$default_read_opts{disable_variables} = 0; # Don't disable variables!
$default_read_opts{disable_variable_modifiers} = 0; # Don't disable variable modifiers!
$default_read_opts{disable_decryption} = 0; # Don't disable decryption!
# $default_read_opts{enable_backquotes} = 0; # Don't allow random command execution.
$default_read_opts{trap_recursion} = 0; # Recursion is ignored, not fatal
$default_read_opts{source_cb} = __PACKAGE__->can ("_source_callback_stub");
$default_read_opts{source_cb_opts} = \%src_empty;
# The file parsing options ...
lib/Advanced/Config/Reader.pm view on Meta::CPAN
my $READ_CONFIG;
DBUG_PRINT ("INFO", "Opening the config file named: %s", $file);
unless ( open ($READ_CONFIG, "<", $file) ) {
return DBUG_RETURN ( croak_helper ($opts,
"Unable to open the config file.", 0) );
}
# Misuse of this option makes the config file unreadable ...
if ( $opts->{use_utf8} ) {
binmode ($READ_CONFIG, "encoding(UTF-8)");
$pcfg->_allow_utf8 (); # Tells get_date() that wide char languages are OK!
}
# Some common RegExp strings ... Done here to avoid asking repeatably ...
my $decrypt_str = convert_to_regexp_string ($opts->{decrypt_lbl});
my $encrypt_str = convert_to_regexp_string ($opts->{encrypt_lbl});
my $hide_str = convert_to_regexp_string ($opts->{hide_lbl});
my $sect_str = convert_to_regexp_string ($opts->{source_file_section_lbl});
my $export_str = convert_to_regexp_string ($opts->{export_lbl});
my ($lb, $rb) = ( convert_to_regexp_string ($opts->{section_left}),
lib/Advanced/Config/Reader.pm view on Meta::CPAN
}
DBUG_PRINT ("INFO", "Creating scratch file named: %s", $scratch);
unless ( open (NEW, ">", $scratch) ) {
close (ENCRYPT);
return DBUG_RETURN ( croak_helper ($rOpts,
"Unable to create the scratch config file.", 0) );
}
# Misuse of this option makes the config file unreadable ...
if ( $rOpts->{use_utf8} ) {
binmode (ENCRYPT, "encoding(UTF-8)");
binmode (NEW, "encoding(UTF-8)");
}
my $errMsg = "Unable to write to the scratch file.";
my $hide_section = 0;
my $count = 0;
while ( <ENCRYPT> ) {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
}
DBUG_PRINT ("INFO", "Creating scratch file named: %s", $scratch);
unless ( open (NEW, ">", $scratch) ) {
close (DECRYPT);
return DBUG_RETURN ( croak_helper ($rOpts,
"Unable to create the scratch config file.", 0) );
}
# Misuse of this option makes the config file unreadable ...
if ( $rOpts->{use_utf8} ) {
binmode (DECRYPT, "encoding(UTF-8)");
binmode (NEW, "encoding(UTF-8)");
}
my $errMsg = "Unable to write to the scratch file.";
my $hide_section = 0;
my $count = 0;
while ( <DECRYPT> ) {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
my $target = shift; # May be ascii or unicode ...
my $len = shift;
DBUG_MASK (0);
my $phrase;
unless ( $target =~ m/[^\x00-\xff]/ ) {
# Normal text ... (ascii)
$phrase = $target . pack ("C*", reverse (unpack ("C*", $target)));
} else {
# Unicode strings (utf8 / Wide Chars)
# Strip off the upper byte from each unicode char ...
my @ans = map { $_ % 0x100 } unpack ("U*", $target);
$phrase = pack ("C*", @ans) . pack ("C*", reverse (@ans));
}
my $key = $phrase;
while ( length ( $key ) < $len ) {
$key .= $phrase;
}
t/75-check_all_languages.t view on Meta::CPAN
# created those tools hadn't been created yet.
# ---------------------------------------------------------------------
# After the config file has been created it attempts to use the
# Config object to validate everything works.
# ---------------------------------------------------------------------
my $fish;
my $config_file_normal;
my $config_file_wide;
my @global_languages;
my @global_lang_use_utf8;
my $run_as_developer = 0;
BEGIN {
# The config file this program is to create!
$config_file_normal = File::Spec->catfile (dirname ($0), "config", "75-all_languages_normal.cfg");
$config_file_wide = File::Spec->catfile (dirname ($0), "config", "75-all_languages_wide.cfg");
unlink ( $config_file_normal, $config_file_wide );
$fish = turn_fish_on_off_for_advanced_config ();
unlink ( $fish );
DBUG_ENTER_FUNC ();
use_ok ("Advanced::Config");
DBUG_VOID_RETURN ();
# Turn fish on ...
DBUG_PUSH ( $fish, allow_utf8 => 1 );
$run_as_developer = $ENV{FULL_75_TEST} ? 1 : 0;
}
# Just proving it's a red herring.
sub uses_utf8_module
{
my $file = shift;
my $found = 0;
unless ( open (FH, "<", $file) ) {
dbug_ok (0, "Can't open the language file for reading: " . $file);
done_testing ();
DBUG_LEAVE (0);
}
while (<FH>) {
if ( $_ =~ m/^\s*use\s+utf8\s*;/ ) {
$found = 1;
last;
}
}
close (FH);
return ($found);
}
t/75-check_all_languages.t view on Meta::CPAN
my $lang_dir = $INC{$key};
$lang_dir = $INC{'Date/Language.pm'} unless ($lang_dir);
$lang_dir =~ s/[.]pm$//;
my $search = File::Spec->catdir ($lang_dir, "*.pm");
# Get's the list of languages supported.
foreach my $f ( bsd_glob ($search) ) {
my @dirs = File::Spec->splitdir ($f);
$dirs[-1] =~ s/[.]pm//;
push (@global_languages, $dirs[-1]);
push (@global_lang_use_utf8, uses_utf8_module ($f));
}
if ( $#global_languages == -1 ) {
dbug_ok (1, "No Date::Language::<lang> modules are installed. Skipping this test!");
done_testing ();
DBUG_LEAVE (0);
}
# Now load all those modules ...
foreach my $l ( @global_languages ) {
t/75-check_all_languages.t view on Meta::CPAN
DBUG_LEAVE (0);
}
# --------------------------------------------------------------------
# Create a new Advanced::Config objact ...
# --------------------------------------------------------------------
sub build_new_object
{
DBUG_ENTER_FUNC (@_);
my $mode_utf8 = shift; # 0 or 1.
my $lbl = shift; # Initial, Encrypted or Decrypted
my $pause = shift; # 0 or 1.
my $file = shift;
my $cfg = Advanced::Config->new ( $file,
{ croak => 1, use_utf8 => $mode_utf8,
dbug_test_use_case_parse_override => 1,
dbug_test_use_case_hide_override => 1,
disable_variable_modifiers => 1 },
{ required => 0, date_enable_yy => 1 },
{ }
);
my $type = $mode_utf8 ? "UTF-8" : "normal";
dbug_isa_ok ( $cfg, "Advanced::Config" );
dbug_isa_ok ( pause_load ($cfg, $pause), "Advanced::Config" );
DBUG_RETURN ( $cfg );
}
# --------------------------------------------------------------------
sub pause_load
{
DBUG_ENTER_FUNC (@_);
t/75-check_all_languages.t view on Meta::CPAN
$val1 = $cfg->get_value ($tag);
if ( $special eq "l" ) {
$val2 = lc ($months->[$idx]);
} elsif ( $special eq "u" ) {
$val2 = uc ($months->[$idx]);
} else {
$val2 = $months->[$idx];
}
if ( $val1 ne $val2 ) {
my ($u1, $u2) = (utf8::is_utf8($val1)||0, utf8::is_utf8($val2)||0);
dbug_ok (0, "Loaded ${lbl} [${idx}] ok! ($val1) vs ($val2) - utf8($u1 vs $u2)");
++$bad;
}
++$good;
} else {
++$bad
}
return ( $bad );
}
t/75-check_all_languages.t view on Meta::CPAN
}
DBUG_VOID_RETURN ();
}
# --------------------------------------------------------------------
sub validate_dates
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift;
my $utf8_expected = shift;
DBUG_PAUSE () unless ( $run_as_developer );
foreach my $s ( $cfg->find_sections () ) {
my $sCfg = $cfg->get_section ( $s, 1 );
my $lang = $sCfg->get_value ("Language", {required => 0});
unless ( defined $lang ) {
dbug_ok (1, "Skipping section '$s' due to no Language tag!");
next;
}
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 ("----", "-------------------------------------------------");
}
t/75-check_all_languages.t view on Meta::CPAN
foreach ( 0..11 ) {
my $uc1 = uc ($l->{MoY}->[$_]);
my $uc2 = uc ($l->{MoYs}->[$_]);
my $lc1 = lc ($l->{MoY}->[$_]);
my $lc2 = lc ($l->{MoYs}->[$_]);
# Search for upper case issues ...
my ($p1, $p2, $p3, $p4) = ("", "", "", "");
if ( uc($lc1) ne $uc1 ) {
my $t = uc($lc1);
my ($u1, $u2) = (utf8::is_utf8($uc1)||0, utf8::is_utf8($t)||0);
dbug_ok ($ok_tst, "${lang}: Force uppercase on MoY[$_] ${ok_msg}. ($uc1, $t) utf8($u1,$u2)");
$p1 = " - Has problem? ($lang)";
if ( $uc1 ne lc ($uc1) ) {
dbug_ok ($ok_tst, "${lang}: Force uppercase on uc(uc(MoY[$_])) ${ok_msg}.\n");
}
}
if ( uc($lc2) ne $uc2 ) {
my $t = uc($lc2);
my ($u1, $u2) = (utf8::is_utf8($uc2)||0, utf8::is_utf8($t)||0);
dbug_ok ($ok_tst, "${lang}: Force uppercase on MoYs[$_] ${ok_msg}. ($uc2, $t) utf8($u1,$u2)");
$p2 = " - Has problem? ($lang)";
if ( $uc2 ne lc ($uc2) ) {
dbug_ok ($ok_tst, "${lang}: Force uppercase on uc(uc(MoYs[$_])) ${ok_msg}.\n");
}
}
# Search for lower case issues ...
if ( lc($uc1) ne $lc1 ) {
my $t = lc($uc1);
my ($u1, $u2) = (utf8::is_utf8($lc1)||0, utf8::is_utf8($t)||0);
dbug_ok ($ok_tst, "${lang}: Force lowercase on MoY[$_] ${ok_msg}. ($lc1, $t) utf8($u1,$u2)");
$p3 = " - Has problem? ($lang)";
if ( $lc1 ne lc ($lc1) ) {
dbug_ok ($ok_tst, "${lang}: Force lowercase on lc(lc(MoY[$_])) ${ok_msg}.\n");
}
}
if ( lc($uc2) ne $lc2 ) {
my $t = lc($uc2);
my ($u1, $u2) = (utf8::is_utf8($lc2)||0, utf8::is_utf8($t)||0);
dbug_ok ($ok_tst, "${lang}: Force lowercase on MoYs[$_] ${ok_msg}. ($lc2, $t) utf8($u1,$u2)");
$p4 = " - Has problem? ($lang)";
if ( $lc2 ne lc ($lc2) ) {
dbug_ok ($ok_tst, "${lang}: Force lowercase on lc(lc(MoYs[$_])) ${ok_msg}.\n");
}
}
# Write to the config file ...
print CONFIG sprintf ("uMoY_%d = %s # utf8 (%d)%s %s\n",
$_, $uc1, utf8::is_utf8($uc1) || 0, $p1, "ENCRYPT");
print CONFIG sprintf ("uMoYs_%d = %s # utf8 (%d)%s %s\n",
$_, $uc2, utf8::is_utf8($uc2) || 0, $p2, "ENCRYPT");
print CONFIG sprintf ("lMoY_%d = %s # utf8 (%d)%s %s\n",
$_, $lc1, utf8::is_utf8($lc1) || 0, $p3, "ENCRYPT");
print CONFIG sprintf ("lMoYs_%d = %s # utf8 (%d)%s %s\n",
$_, $lc2, utf8::is_utf8($lc2) || 0, $p4, "ENCRYPT");
}
print CONFIG "\n";
}
close (CONFIG);
DBUG_RETURN ( 1 );
}
# ====================================================================
t/75-check_all_languages.t view on Meta::CPAN
# ====================================================================
sub load_all_language_data
{
DBUG_ENTER_FUNC (@_);
my %lang_data;
my $lidx = 0;
foreach my $lang ( @global_languages ) {
my $uses_utf8_mod = $global_lang_use_utf8[$lidx++];
my $module = "Date::Language::${lang}";
my ( $lang_wide, $lang_utf8 ) = ( 0, 0 );
# @Dsuf isn't always available for some modules.
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. (buggy)
my @lDoW = eval "\@${module}::DoW"; # The Day of Week.
my @lDoWs = eval "\@${module}::DoWs"; # The Day of Week Abbreviations.
my $has_spaces = 0;
# Fix so that uc() & lc() will always work on these 5 arrays ...
foreach (@lMoY, @lMoYs, @lDsuf, @lDoW, @lDoWs ) {
my $wide = utf8::is_utf8 ($_) || 0; # Before ...
unless ( $wide ) {
utf8::encode ($_);
utf8::decode ($_);
# Now determine if a common variant makes it wide ...
if ( $_ =~ m/[^\x00-\xff]/ ) {
$wide -= 1; # Now: -1
}
if ( lc ($_) =~ m/[^\x00-\xff]/ ) {
$wide -= 2; # Now: -2 or -3
}
if ( uc ($_) =~ m/[^\x00-\xff]/ ) {
$wide -= 4; # Now: -4, -5, -6 or -7 ...
}
}
my $utf8 = utf8::is_utf8 ($_) || 0; # After ...
$lang_wide = $lang_wide || $wide;
$lang_utf8 = $lang_utf8 || $utf8;
++$has_spaces if ( $_ =~ m/\s/ );
}
# So I can log my results ...
# And prove my assumptions are good!
my $test_ok = ( scalar (@lMoY) == 12 && scalar (@lMoYs) == 12 );
DBUG_PRINT ($test_ok ? "INFO" : "BAD",
"MoY: %d, MoYs: %d, Dsuf: %02d, DoW: %d, DoWs: %d, wide(%2d), utf8(%d), uses_utf8_mod(%s), spaces(%2d), Language: %s",
scalar (@lMoY), scalar (@lMoYs), scalar (@lDsuf), scalar (@lDoW), scalar (@lDoWs),
$lang_wide, $lang_utf8, $uses_utf8_mod ? "YES" : "no", $has_spaces, $lang);
if ( $test_ok ) {
my %data = ( MoY => \@lMoY, MoYs => \@lMoYs,
Dsuf => \@lDsuf,
DoW => \@lDoW, DoWs => \@lDoWs,
wide => $lang_wide, utf8 => $lang_utf8,
lang => $lang, spaces => $has_spaces,
used_utf8_mod => $uses_utf8_mod );
$lang_data{$lang} = \%data;
}
}
DBUG_RETURN (\%lang_data);
}
t/76-check_all_languages2.t view on Meta::CPAN
unlink ( $fish );
DBUG_ENTER_FUNC ();
use_ok ("Advanced::Config");
DBUG_VOID_RETURN ();
# Turn fish on ...
DBUG_PUSH ( $fish, allow_utf8 => 1 );
$run_as_developer = $ENV{FULL_75_TEST} ? 1 : 0;
}
BEGIN
{
DBUG_ENTER_FUNC ();
my $ver;
t/76-check_all_languages2.t view on Meta::CPAN
DBUG_LEAVE (0);
}
# --------------------------------------------------------------------
# Create a new Advanced::Config objact ...
# --------------------------------------------------------------------
sub build_new_object
{
DBUG_ENTER_FUNC (@_);
my $mode_utf8 = shift; # 0 or 1.
my $lbl = shift; # Initial, Encrypted or Decrypted
my $pause = shift; # 0 or 1.
my $file = shift;
my $cfg = Advanced::Config->new ( $file,
{ croak => 1, use_utf8 => $mode_utf8,
dbug_test_use_case_parse_override => 1,
dbug_test_use_case_hide_override => 1,
disable_variable_modifiers => 1 },
{ required => 0, date_enable_yy => 1 },
{ }
);
my $type = $mode_utf8 ? "UTF-8" : "normal";
dbug_isa_ok ( $cfg, "Advanced::Config" );
dbug_isa_ok ( pause_load ($cfg, $pause), "Advanced::Config" );
DBUG_RETURN ( $cfg );
}
# --------------------------------------------------------------------
sub pause_load
{
DBUG_ENTER_FUNC (@_);
t/76-check_all_languages2.t view on Meta::CPAN
$val1 = $cfg->get_value ($tag);
if ( $special eq "l" ) {
$val2 = lc ($months->[$idx]);
} elsif ( $special eq "u" ) {
$val2 = uc ($months->[$idx]);
} else {
$val2 = $months->[$idx];
}
if ( $val1 ne $val2 ) {
my ($u1, $u2) = (utf8::is_utf8($val1)||0, utf8::is_utf8($val2)||0);
dbug_ok (0, "Loaded ${lbl} [${idx}] for tag ($tag) ok! ($val1) vs ($val2) - utf8($u1 vs $u2)");
++$bad;
}
++$good;
} else {
++$bad
}
# DBUG_RETURN ( $bad );
return ( $bad );
}
t/76-check_all_languages2.t view on Meta::CPAN
}
DBUG_VOID_RETURN ();
}
# --------------------------------------------------------------------
sub validate_dates
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift;
my $utf8_expected = shift;
DBUG_PAUSE () unless ( $run_as_developer );
foreach my $s ( $cfg->find_sections () ) {
my $sCfg = $cfg->get_section ( $s, 1 );
my $lang = $sCfg->get_value ("Language", {required => 0});
unless ( defined $lang ) {
dbug_ok (1, "Skipping section '$s' due to no Language tag!");
next;
}
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 ("----", "-------------------------------------------------");
}
t/76-check_all_languages2.t view on Meta::CPAN
foreach ( 0..11 ) {
my $uc1 = uc ($l->{MoY}->[$_]);
my $uc2 = uc ($l->{MoYs}->[$_]);
my $lc1 = lc ($l->{MoY}->[$_]);
my $lc2 = lc ($l->{MoYs}->[$_]);
# Search for upper case issues ...
my ($p1, $p2, $p3, $p4) = ("", "", "", "");
if ( uc($lc1) ne $uc1 ) {
my $t = uc($lc1);
my ($u1, $u2) = (utf8::is_utf8($uc1)||0, utf8::is_utf8($t)||0);
dbug_ok ($ok_tst, "${lang}: Force uppercase on MoY[$_] ${ok_msg}. ($uc1, $t) utf8($u1,$u2)");
$p1 = " - Has problem? ($lang)";
if ( $uc1 ne lc ($uc1) ) {
dbug_ok ($ok_tst, "${lang}: Force uppercase on uc(uc(MoY[$_])) ${ok_msg}.\n");
}
}
if ( uc($lc2) ne $uc2 ) {
my $t = uc($lc2);
my ($u1, $u2) = (utf8::is_utf8($uc2)||0, utf8::is_utf8($t)||0);
dbug_ok ($ok_tst, "${lang}: Force uppercase on MoYs[$_] ${ok_msg}. ($uc2, $t) utf8($u1,$u2)");
$p2 = " - Has problem? ($lang)";
if ( $uc2 ne lc ($uc2) ) {
dbug_ok ($ok_tst, "${lang}: Force uppercase on uc(uc(MoYs[$_])) ${ok_msg}.\n");
}
}
# Search for lower case issues ...
if ( lc($uc1) ne $lc1 ) {
my $t = lc($uc1);
my ($u1, $u2) = (utf8::is_utf8($lc1)||0, utf8::is_utf8($t)||0);
dbug_ok ($ok_tst, "${lang}: Force lowercase on MoY[$_] ${ok_msg}. ($lc1, $t) utf8($u1,$u2)");
$p3 = " - Has problem? ($lang)";
if ( $lc1 ne lc ($lc1) ) {
dbug_ok ($ok_tst, "${lang}: Force lowercase on lc(lc(MoY[$_])) ${ok_msg}.\n");
}
}
if ( lc($uc2) ne $lc2 ) {
my $t = lc($uc2);
my ($u1, $u2) = (utf8::is_utf8($lc2)||0, utf8::is_utf8($t)||0);
dbug_ok ($ok_tst, "${lang}: Force lowercase on MoYs[$_] ${ok_msg}. ($lc2, $t) utf8($u1,$u2)");
$p4 = " - Has problem? ($lang)";
if ( $lc2 ne lc ($lc2) ) {
dbug_ok ($ok_tst, "${lang}: Force lowercase on lc(lc(MoYs[$_])) ${ok_msg}.\n");
}
}
# Write to the config file ...
print CONFIG sprintf ("uMoY_%d = %s # utf8 (%d)%s %s\n",
$_, $uc1, utf8::is_utf8($uc1) || 0, $p1, "ENCRYPT");
print CONFIG sprintf ("uMoYs_%d = %s # utf8 (%d)%s %s\n",
$_, $uc2, utf8::is_utf8($uc2) || 0, $p2, "ENCRYPT");
print CONFIG sprintf ("lMoY_%d = %s # utf8 (%d)%s %s\n",
$_, $lc1, utf8::is_utf8($lc1) || 0, $p3, "ENCRYPT");
print CONFIG sprintf ("lMoYs_%d = %s # utf8 (%d)%s %s\n",
$_, $lc2, utf8::is_utf8($lc2) || 0, $p4, "ENCRYPT");
}
print CONFIG "\n";
}
close (CONFIG);
DBUG_RETURN ( 1 );
}
# ====================================================================
t/76-check_all_languages2.t view on Meta::CPAN
# ====================================================================
# So uc() & lc() works agaisnt each key value ...
sub fix_key
{
my $value = shift;
my $has_spaces = 0;
my $wide = ( $value =~ m/[^\x00-\xff]/ ) ? 1 : 0; # Before ...
unless ( $wide ) {
utf8::encode ($value);
utf8::decode ($value);
# Now determine if a common variant makes it wide ...
if ( $value =~ m/[^\x00-\xff]/ ) {
$wide -= 1; # Now: -1
}
if ( lc ($value) =~ m/[^\x00-\xff]/ ) {
$wide -= 2; # Now: -2 or -3
}
if ( uc ($value) =~ m/[^\x00-\xff]/ ) {
$wide -= 4; # Now: -4, -5, -6 or -7 ...
}
}
my $utf8 = utf8::is_utf8 ($value) || 0; # After ...
$value = lc ($value);
$has_spaces = 1 if ( $value =~ m/\s/ );
return ( $value, $wide, $utf8, $has_spaces );
}
# ====================================================================
sub load_all_language_data
{
DBUG_ENTER_FUNC (@_);
my %lang_data;
foreach my $mod ( @global_modules ) {
my $module = "Date::Manip::Lang::${mod}";
my ( $lang_wide, $lang_utf8 ) = ( 0, 0 );
my $Language = eval "\$${module}::LangName"; # The proper name of this language.
my $langData = eval "\$${module}::Language"; # A hash reference with the data!
my %months;
my %days;
my %wdays;
# ------------------------------------------------------
# Used to validate the config files ...
# ------------------------------------------------------
my ($mon_spaces, $day_spaces, $wday_spaces) = (0, 0, 0);
foreach my $m (1..12) {
foreach my $name ( @{$langData->{month_name}->[$m-1]} ) {
my ($n, $before, $after, $spaces) = fix_key ($name);
$months{$n} = $m;
++$mon_spaces if ( $spaces );
$lang_wide = $lang_wide || $before;
$lang_utf8 = $lang_utf8 || $after;
}
foreach my $abb ( @{$langData->{month_abb}->[$m-1]} ) {
my ($a, $before, $after, $spaces) = fix_key ($abb);
$months{$a} = $m;
++$mon_spaces if ( $spaces );
$lang_wide = $lang_wide || $before;
$lang_utf8 = $lang_utf8 || $after;
}
}
foreach my $d (1..31) {
$days{$d} = $d; # Pure numbers are usually not in this hash list ...
foreach my $day ( @{$langData->{nth}->[$d-1]} ) {
my ($nth, $before, $after, $spaces) = fix_key ($day);
$days{$nth} = $d;
++$day_spaces if ( $spaces );
$lang_wide = $lang_wide || $before;
$lang_utf8 = $lang_utf8 || $after;
}
}
# Need Sunday(1) ... Saturday(7) ... since order from localtime() [wday: 0..6]
# But array is Monday(0) to Sunday(6).
# So take advantage of -1 being last element in array!
foreach my $d (1..7) {
foreach my $w ( @{$langData->{day_name}->[$d - 2]} ) {
my ($wd, $before, $after, $spaces) = fix_key ($w);
$wdays{$wd} = $d;
++$wday_spaces if ( $spaces );
$lang_wide = $lang_wide || $before;
$lang_utf8 = $lang_utf8 || $after;
};
foreach my $w ( @{$langData->{day_abb}->[$d - 2]} ) {
my ($wd, $before, $after, $spaces) = fix_key ($w);
$wdays{$wd} = $d;
++$wday_spaces if ( $spaces );
$lang_wide = $lang_wide || $before;
$lang_utf8 = $lang_utf8 || $after;
};
}
# ------------------------------------------------------
# Used to create the config files ...
# ------------------------------------------------------
my (@MoY, @MoYs, @Dsuf, @DoW, @DoWs);
foreach my $m (1..12) {
my $mon = $langData->{month_name}->[$m-1]->[0];
t/76-check_all_languages2.t view on Meta::CPAN
my ($wd, $before, $after, $spaces) = fix_key ($w);
push (@DoW, $wd);
$w = $langData->{day_abb}->[$d - 2]->[0]; # The 1st entry.
($wd, $before, $after, $spaces) = fix_key ($w);
push (@DoWs, $wd);
}
# So I can log my results ...
# And prove my assumptions are good!
DBUG_PRINT ("INFO", "MoY: %d, Dsuf: %02d, DoW: %d, wide(%2d), utf8(%d), spaces(%2d/%2d/%2d), Language: %s/%s",
scalar (keys %months), scalar (keys %days), scalar (keys %wdays), $lang_wide, $lang_utf8, $mon_spaces, $day_spaces, $wday_spaces, $mod, $Language);
my %data = ( hMoY => \%months, hDsuf => \%days, hDoW => \%wdays,
MoY => \@MoY, Dsuf => \@Dsuf, DoW => \@DoW,
MoYs => \@MoYs, DoWs => \@DoWs,
wide => $lang_wide, utf8 => $lang_utf8,
lang => $Language, module => $module,
spaces => $mon_spaces + $day_spaces );
# $lang_data{$mod} = \%data;
$lang_data{$Language} = \%data;
}
DBUG_RETURN (\%lang_data);
}
( run in 1.303 second using v1.01-cache-2.11-cpan-49f99fa48dc )