Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Date.pm view on Meta::CPAN
'twenty-fifth' => -25, 'twenty-sixth' => -26, 'twenty-seventh' => -27,
'twenty-eighth' => -28, 'twenty-ninth' => -29, 'thirtieth' => -30,
'thirty-first' => -31,
# From Date::Manip::Lang::english::Language->{nth} arrays ...
'one' => -1, 'two' => -2, 'three' => -3,
'four' => -4, 'five' => -5, 'six' => -6,
'seven' => -7, 'eight' => -8, 'nine' => -9,
'ten' => -10, 'eleven' => -11, 'twelve' => -12,
'thirteen' => -13, 'fourteen' => -14, 'fifteen' => -15,
'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{$_};
}
}
foreach ( keys %Days ) {
next if ( $Days{$_} > 0 );
if ( $flip ) {
$Days{$_} = abs ($Days{$_});
} else {
delete $Days{$_};
}
}
}
# How many days per month ... (non-leap year)
# ---------------------> J F M A M J J A S O N D
my @days_in_months = ( 0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
# Updated by: init_special_date_arrays() ...
# May be for a different language than the above hashes ...
my $prev_array_lang = "English";
my @gMoY = qw ( January February March April May June
July August September October November December );
my @gMoYs = map { uc (substr($_,0,3)) } @gMoY;
my @gDsuf = sort { my ($x,$y) = ($a,$b); $x=~s/\D+$//; $y=~s/\D+$//; $x<=>$y } grep (/^\d+\D+$/, keys %Days, "0th");
my @gDoW = qw( Sunday Monday Tuesday Wednesday Thursday Friday Saturday );
my @gDoWs = map { uc (substr($_,0,3)) } @gDoW;
# ==============================================================
# Not in pod on purpose. Only added to simplify test cases.
sub _date_language_installed
{
return ( scalar (keys %date_language_installed_languages) );
}
# ==============================================================
# Not in pod on purpose. Only added to simplify test cases.
sub _date_manip_installed
{
return ( scalar (keys %date_manip_installed_languages) );
}
# ==============================================================
=item @languages = get_languages ( );
This module returns a sorted list of languages supported by this module
for the parsing of date strings.
If neither L<Date::Language> and/or L<Date::Manip> are installed, only
I<English> is supported and you'll be unable to swap languages.
Both modules are used since each language module supports a different
set of languages with a lot of overlap between them.
Also L<Date::Manip> supports common aliases for some languages. These
aliases appear in lower case. When these aliases are used by
swap_language, it returns the real underlying language instead of
the alias.
=cut
sub get_languages
{
DBUG_ENTER_FUNC ( @_ );
my %languages;
# For Date::Language ... (straight forward)
foreach my $k1 ( keys %date_language_installed_languages ) {
my $lang = $date_language_installed_languages{$k1}->{Language};
$languages{$lang} = 1;
}
# For Date::Manip ... (a bit messy)
# Messy since we can't verify the language without 1st loading it!
foreach my $k1 ( keys %date_manip_installed_languages ) {
my $lang = $date_manip_installed_languages{$k1}->{Language};
my $k2 = ($k1 eq lc($lang)) ? $lang : $k1;
$languages{$k2} = 1;
}
if ( scalar ( keys %languages ) == 0 ) {
$languages{English} = 1;
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
# 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 ) {
$lang_ref = $date_language_installed_languages{lc($lang)};
$lang_ref = undef if ($lang_ref && $lang_ref->{Wide} && ! $allow_wide);
}
}
my ($MoY_ref, $MoYs_ref, $Dsuf_ref, $issue2_ref);
if ( $lang_ref ) {
my ($unused_DoW_ref, $unused_DoWs_ref);
($MoY_ref, $MoYs_ref, $Dsuf_ref, $unused_DoW_ref, $unused_DoWs_ref, $issue2_ref) =
_swap_lang_common ( $lang_ref, $warn_ok, $allow_wide );
$lang = $lang_ref->{Language};
}
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
# Turkish
# ---------------------------------------------------------
my %empty;
%Months = %Days = %empty;
# ---------------------------------------------------------
# Put in the common numeric values into the hashes ...
my $cnt;
foreach $cnt ( 1..12 ) {
$Months{$cnt} = $cnt;
}
foreach my $day ( 1..31 ) {
$Days{$day} = $day;
}
# ---------------------------------------------------------
# Merge in the Date::Manip::Lang::<language> values ...
foreach my $mon ( keys %{$month_ref} ) {
$Months{$mon} = $month_ref->{$mon};
$Months{lc (uc (lc ($mon)))} = $Months{$mon}; # Bug fix, but usually same.
}
foreach my $day ( keys %{$day_ref} ) {
$Days{$day} = $day_ref->{$day};
$Days{lc (uc (lc ($day)))} = $Days{$day}; # Bug fix, but usually same.
}
# ---------------------------------------------------------
# Merge in the Date::Language::<language> values ...
$cnt = 1;
foreach my $mon ( @{$MoY_ref} ) {
$Months{lc ($mon)} = $cnt;
$Months{lc (uc (lc ($mon)))} = $cnt; # Bug fix, but usually same.
++$cnt;
}
$cnt = 1;
foreach my $mon ( @{$MoYs_ref} ) {
$Months{lc ($mon)} = $cnt;
$Months{lc (uc (lc ($mon)))} = $cnt; # Bug fix, but usually same.
++$cnt;
}
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.
}
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
{
DBUG_ENTER_FUNC ( @_ );
my $lang = shift;
my $mode = shift || 0; # Default to numeric arrays ...
my $warn_ok = shift || 0;
my $allow_wide = shift || 0;
my @months = ( "01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12" );
my @week_days = ( "1", "2", "3", "4", "5", "6", "7" );
my $numbers = ($mode != 1 && $mode != 2 );
my ( $lang_ref, $manip_ref );
if ( defined $lang ) {
($manip_ref, $lang_ref) = _select_language ($lang, $warn_ok, $allow_wide);
unless ( $lang_ref || $manip_ref ) {
$lang = undef; # So it will enter the early out if block ...
}
}
if ( (! defined $lang) || lc($lang) eq lc($prev_array_lang) || $numbers ) {
if ( $mode == 1 ) {
@months = @gMoYs; # Abrevited month names ...
@week_days = @gDoWs; # Abrevited week names ...
} elsif ( $mode == 2 ) {
@months = @gMoY; # Full month names ...
@week_days = @gDoW; # Full week names ...
}
return DBUG_RETURN ( \@months, \@week_days );
}
my ($MoY_ref, $MoYs_ref, $Dsuf_ref, $DoW_ref, $DoWs_ref);
DBUG_PRINT ("INFO", "Manip: %s, Lang: %s", $manip_ref, $lang_ref);
if ( $manip_ref ) {
my ( $u1, $u2, $u3 ); # Unused placeholders.
($u1, $u2, $u3, $MoY_ref, $MoYs_ref, $Dsuf_ref, $DoW_ref, $DoWs_ref) =
_swap_manip_language_common ($manip_ref, $warn_ok, $allow_wide );
$lang = $manip_ref->{Language};
if ( $u1 ) {
$lang_ref = undef; # Skip lang_ref lookup if successsful ...
} else {
$lang_ref = $date_language_installed_languages{lc($lang)};
}
}
if ( $lang_ref ) {
($MoY_ref, $MoYs_ref, $Dsuf_ref, $DoW_ref, $DoWs_ref) =
_swap_lang_common ( $lang_ref, $warn_ok, $allow_wide );
$lang = $lang_ref->{Language};
}
# If the new language was valid, update the global variables ...
if ( $MoY_ref ) {
$prev_array_lang = $lang;
@gMoY = @{$MoY_ref};
@gMoYs = map { uc($_) } @{$MoYs_ref};
@gDoW = @{$DoW_ref};
@gDoWs = map { uc($_) } @{$DoWs_ref};
@gDsuf = @{$Dsuf_ref};
DBUG_PRINT ( "LANGUAGE", "%s\n%s\n%s\n%s\n%s",
join (", ", @gMoY), join (", ", @gMoYs),
join (", ", @gDoW), join (", ", @gDoWs),
join (", ", @gDsuf)
);
}
# Numeric handled earlier ...
if ( $mode == 1 ) {
@months = @gMoYs; # Abrevited month names ...
@week_days = @gDoWs; # Abrevited week names ...
} elsif ( $mode == 2 ) {
@months = @gMoY; # Full month names ...
@week_days = @gDoW; # Full week names ...
}
DBUG_RETURN ( \@months, \@week_days );
}
# ==============================================================
sub _is_leap_year
{
my $year = shift;
my $leap = ($year % 4 == 0) && ($year % 100 != 0 || $year % 400 == 0);
return ($leap ? 1 : 0);
}
# ==============================================================
# Validate the input date.
sub _validate_date_str
{
DBUG_ENTER_FUNC ( @_ );
my $date_str = shift;
my ($year, $mon, $day);
if ( defined $date_str && $date_str =~ m/^(\d+)-(\d+)-(\d+)$/ ) {
($year, $mon, $day) = ($1, $2, $3);
my $leap = _is_leap_year ($year);
local $days_in_months[2] = $leap ? 29 : 28;
unless ( 1 <= $mon && $mon <= 12 &&
1 <= $day && $day <= $days_in_months[$mon] ) {
return DBUG_RETURN ( undef, undef, undef );
}
} else {
return DBUG_RETURN ( undef, undef, undef );
}
DBUG_RETURN ( $year, $mon, $day );
}
# ==============================================================
=item $bool = is_leap_year ( $year );
Returns B<1> if I<$year> is a Leap Year, else B<0> if it isn't.
( run in 0.636 second using v1.01-cache-2.11-cpan-13bb782fe5a )