Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Date.pm view on Meta::CPAN
# 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];
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/[.]/ );
}
# Now check if any RegExp wild cards in the value ...
foreach ( @lMoY, @lMoYs ) {
$issues{month_period} = 1 if ( $_ =~ m/[.]/ );
}
foreach ( @lDoW, @lDoWs ) {
$issues{dow_period} = 1 if ( $_ =~ m/[.]/ );
}
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 ...
{
lib/Advanced/Config/Date.pm view on Meta::CPAN
my $first_name = $langData->{month_name}->[$month_idx-1]->[0];
my $first_abb = $langData->{month_abb}->[$month_idx-1]->[0];
push ( @MoY, (_fix_key ($first_name, 1))[1] );
push ( @MoYs, (_fix_key ($first_abb, 1))[1] );
}
$issues{month_period} = $has_period;
$has_period = 0;
foreach my $day_idx (1..31) {
foreach my $day ( @{$langData->{nth}->[$day_idx-1]} ) {
my ($w, $k, $pi, $pe, $alt) = _fix_key ( $day );
$wide = 1 if ($w);
next if ( $pe && exists $days{$alt} && $days{$alt} == $day_idx );
$has_period = 1 if ( $pi || $pe );
$days{$k} = $day_idx;
}
my $first = $langData->{nth}->[$day_idx-1]->[0];
push ( @Dsuf, (_fix_key ($first, 1))[1] );
}
$issues{dsuf_period} = $has_period;
# Need Sunday to Saturday to be consistent with localime() & Date::Language.
# But this array is Monday to Sunday!
# So take advantage of -1 being last element in array to fix!
$has_period = 0;
foreach my $wd_idx (1..7) {
my $wd = $langData->{day_name}->[$wd_idx - 2]->[0];
my ($w, $k, $pi, $pe, $alt) = _fix_key ( $wd, 1 );
$wide = 1 if ($w);
push (@DoW, $k);
$wd = $langData->{day_abb}->[$wd_idx - 2]->[0];
($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;
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 );
my $alt = $value;
my ($has_internal_period, $has_ending_period) = (0, 0);
if ( $value =~ m/([.]?)[^.]*(.)$/ ) {
$has_internal_period = 1 if ($1 eq '.');
if ($2 eq '.') {
$has_ending_period = 1;
$alt =~ s/[.]$//;
}
}
return ($wide, lc $value, $has_internal_period, $has_ending_period, $alt);
}
# ==============================================================
# It's a mess since Date::Manip allows for aliases.
sub _select_language
{
DBUG_ENTER_FUNC ( @_ );
my $lang = shift;
my $warn_ok = shift;
my $allow_wide = shift;
my $k = lc ($lang);
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 );
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
foreach my $day ( 1..31 ) {
if ( $Dsuf_ref && defined $Dsuf_ref->[$day] ) {
my $key = $Dsuf_ref->[$day];
$Days{lc ($key)} = $day;
$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
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
There are too many valid date formats to list them all, especially when other
languages are added to the mix. But if you have one it doesn't support, open
a CPAN ticket and I'll see if I can quickly add it.
I<$order> tells the order to use for interpreting dates that are all digits.
It's forwarded to all internal calls to L<parse_6_digit_date> and
L<parse_8_digit_date>. So see those methods POD for more info on its meaning.
I<$allow_dl> is non-zero and L<Date::Language> is installed use it's method
B<str2time ()> to attempt the conversion only if nothing else worked.
If I<$enable_2_digit_years> is set to zero, it will not recognize any 2-digit
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;
DBUG_PRINT ("TST", "Matched Pattern (%s) Sep: %s Name: %s Dom: %s", join (",",@_), $s, $nm, $dm);
return (1);
}
# DEPRECIATED VERSION ...
sub parse_date_old
{
DBUG_ENTER_FUNC ( @_ );
my $in_date = shift; # A potential date in an unknown format ...
my $date_format_options = shift; # A comma separated list of ids ...
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 ...
# -------------------------------------------------------
foreach my $sep ( @seps ) {
if ( $in_date =~ m/(^|\D)(\d{4})(${sep})(\d{1,2})(${sep})(\d{1,2})(\D|$)/ ) {
( $year, $s1, $month, $s2, $day ) = ( $2, $3, $4, $5, $6 );
$fmt = "YYYY${s1}MM${s2}DD"; # ISO format
} elsif ( $in_date =~ m/(^|\D)(\d{1,2})(${sep})(\d{1,2})(${sep})(\d{4})(\D|$)/ ) {
( $month, $s1, $day, $s2, $year ) = ( $2, $3, $4, $5, $6 );
( $year, $month, $day ) = parse_8_digit_date ( sprintf ("%02d%02d%04d", $month, $day, $year),
$date_format_options, 1 );
( run in 0.520 second using v1.01-cache-2.11-cpan-140bd7fdf52 )