Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Date.pm view on Meta::CPAN
# Find out where it's installed
my $loc = $INC{"Date/Language.pm"};
$loc =~ s/[.]pm$//;
my $search = File::Spec->catfile ($loc, "*.pm");
# Get's the list of languages supported.
foreach my $f ( bsd_glob ($search) ) {
my $module = (File::Spec->splitdir( $f ))[-1];
$module =~ s/[.]pm$//;
my %data = ( Language => $module,
Module => "Date::Language::${module}" );
$date_language_installed_languages{lc($module)} = \%data;
}
};
}
# ========================================================================
# Detects if the optional Date::Manip module is available ...
# If it's not installed, you'll be unable to swap languages using it!
BEGIN
{
eval {
local $SIG{__DIE__} = "";
require Date::Manip::Lang::index;
Date::Manip::Lang::index->import ();
foreach my $k ( sort keys %Date::Manip::Lang::index::Lang ) {
my $mod = $Date::Manip::Lang::index::Lang{$k};
my $lang = ( $k eq $mod ) ? ucfirst ($mod) : $mod;
my $module = "Date::Manip::Lang::${mod}";
my %data = ( Language => $lang, # A guess that's wrong sometimes
Module => $module );
$date_manip_installed_languages{lc ($k)} = \%data;
}
};
# -------------------------------------------------------------
# Proves sometimes the module name is different from the
# real language name.
# -------------------------------------------------------------
# foreach my $k ( sort keys %date_manip_installed_languages ) {
# printf STDERR ("Key (%s) Language (%s)\n", $k, $date_manip_installed_languages{$k}->{Language});
# }
}
# ========================================================================
# Hashes used to help validate/parse dates with ...
# 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 = (
# The USA Months spelled out ...
# Built from the @Date::Language::English::MoY array ...
"january" => 1, "february" => 2, "march" => 3,
"april" => 4, "may" => 5, "june" => 6,
"july" => 7, "august" => 8, "september" => 9,
"october" => 10, "november" => 11, "december" => 12,
# The USA Months using 3 char abreviations ("may" not repeated!)
# Built from the @Date::Language::English::MoYs array ...
"jan" => 1, "feb" => 2, "mar" => 3, "apr" => 4,
"jun" => 6, "jul" => 7, "aug" => 8,
"sep" => 9, "oct" => 10, "nov" => 11, "dec" => 12,
# Months as a numeric value. If all digits, leading zeros will
# be removed before it's used as a key.
"1" => 1, "2" => 2, "3" => 3, "4" => 4, "5" => 5, "6" => 6,
"7" => 7, "8" => 8, "9" => 9, "10" => 10, "11" => 11, "12" => 12
);
# variants for days of the month ...
%Days = (
"1" => 1, "2" => 2, "3" => 3, "4" => 4, "5" => 5,
"6" => 6, "7" => 7, "8" => 8, "9" => 9, "10" => 10,
"11" => 11, "12" => 12, "13" => 13, "14" => 14, "15" => 15,
"16" => 16, "17" => 17, "18" => 18, "19" => 19, "20" => 20,
"21" => 21, "22" => 22, "23" => 23, "24" => 24, "25" => 25,
"26" => 26, "27" => 27, "28" => 28, "29" => 29, "30" => 30,
"31" => 31,
# Built from the optional @Date::Language::English::Dsuf array ...
"1st" => 1, "2nd" => 2, "3rd" => 3, "4th" => 4, "5th" => 5,
"6th" => 6, "7th" => 7, "8th" => 8, "9th" => 9, "10th" => 10,
"11th" => 11, "12th" => 12, "13th" => 13, "14th" => 14, "15th" => 15,
"16th" => 16, "17th" => 17, "18th" => 18, "19th" => 19, "20th" => 20,
"21st" => 21, "22nd" => 22, "23rd" => 23, "24th" => 24, "25th" => 25,
"26th" => 26, "27th" => 27, "28th" => 28, "29th" => 29, "30th" => 30,
"31st" => 31,
# From Date::Manip::Lang::english::Language->{nth} arrays ...
'first' => -1, 'second' => -2, 'third' => -3,
'fourth' => -4, 'fifth' => -5, 'sixth' => -6,
'seventh' => -7, 'eighth' => -8, 'ninth' => -9,
'tenth' => -10, 'eleventh' => -11, 'twelfth' => -12,
'thirteenth' => -13, 'fourteenth' => -14, 'fifteenth' => -15,
'sixteenth' => -16, 'seventeenth' => -17, 'eighteenth' => -18,
'nineteenth' => -19, 'twentieth' => -20, 'twenty-first' => -21,
'twenty-second' => -22, 'twenty-third' => -23, 'twenty-fourth' => -24,
'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.
lib/Advanced/Config/Date.pm view on Meta::CPAN
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 );
}
# ==============================================================
=item $lang = swap_language ( $language[, $give_warning[, $wide]] );
This method allows you to change the I<$language> used when this module parses
a date string if you have modules L<Date::Language> and/or L<Date::Manip>
installed. But if neither are installed, only dates in B<English> are
supported. If a language is defined in both places the results are merged.
It always returns the active language. So if I<$language> is B<undef> or
invalid, it will return the current language from before the call. But if the
language was successfully changed, it will return the new I<$language> instead.
Should the change fail and I<$give_warning> is set to a non-zero value, it will
write a warning to your screen telling you why it failed.
So assuming one of the language modules are installed, it asks it for the list
of months in the requested language. And once that list is retrieved only
months in that language are supported when parsing a date string.
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 ) {
$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.
}
}
# ---------------------------------------------------------
# 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 );
$fmt = "MM${s1}DD${s2}YYYY"; # European or American format (ambiguous?)
# ------------------------------------------------------------------------------------------
} elsif ( $in_date =~ m/(^|\D)(\d{1,2})(${sep})(${name})[.]?(${sep})(\d{4})(\D|$)/ &&
exists $Months{lcx($4)} ) {
( $day, $s1, $month, $s2, $year ) = ( $2, $3, $4, $5, $6 );
$fmt = "DD${s1}Month${s2}YYYY";
} elsif ( $in_date =~ m/(^|\D)(\d{4})(${sep})(${name})[.]?(${sep})(\d{1,2})(\D|$)/ &&
exists $Months{lcx($4)} ) {
( $year, $s1, $month, $s2, $day ) = ( $2, $3, $4, $5, $6 );
$fmt = "YYYY${s1}Month${s2}DD";
} elsif ( $in_date =~ m/(^|\s)(${name})(${sep})(\d{1,2})(${sep})(\d{4})(\D|$)/ &&
exists $Months{lcx($2)} ) {
( $month, $s1, $day, $s2, $year ) = ( $2, $3, $4, $5, $6 );
$fmt = "Month${s1}DD${s2}YYYY";
# ------------------------------------------------------------------------------------------
} elsif ( $in_date =~ m/(^|\s)(${dom})(${sep})(${name})[.]?(${sep})(\d{4})(\D|$)/ &&
exists $Months{lcx($4)} &&
exists $Days{lcx($2)} ) {
( $day, $s1, $month, $s2, $year ) = ( $2, $3, $4, $5, $6 );
$fmt = "Day${s1}Month${s2}YYYY"; # European format
} elsif ( $in_date =~ m/(^|\D)(\d{4})(${sep})(${name})[.]?(${sep})(${dom})(\s|$)/ &&
exists $Months{lcx($4)} &&
exists $Days{lcx($6)} ) {
( $year, $s1, $month, $s2, $day ) = ( $2, $3, $4, $5, $6 );
$fmt = "YYYY${s1}Month${s2}Day"; # ISO format
} elsif ( $in_date =~ m/(^|\s)(${name})(${sep})(${dom})(${sep})(\d{4})(\D|$)/ &&
exists $Months{lcx($2)} &&
exists $Days{lcx($4)} ) {
( $month, $s1, $day, $s2, $year ) = ( $2, $3, $4, $5, $6 );
$fmt = "Month${s1}Day${s2}YYYY"; # American format
}
last if ( defined $year );
}
lib/Advanced/Config/Date.pm view on Meta::CPAN
# ------------------------------------------------------------------------------------------
} elsif ( $in_date =~ m/(^|\s)(${name})[.]?(${sep})(${dom})(${sep})(\d{1,2})([^:\d]|$)/ &&
_tst( $sep, $name, $dom, $2, $4, $6 ) &&
exists $Months{lcx($2)} &&
exists $Days{lcx($4)} ) {
( $month, $s1, $day, $s2, $year ) = ( $2, $3, $4, $5, $6 );
$year = make_it_a_4_digit_year ( $year );
$fmt = "Month${s1}Day${s2}YY"; # American format
} elsif ( $in_date =~ m/(^|\s)(${dom})(${sep})(${name})[.]?(${sep})(\d{1,2})([^:\d]|$)/ &&
_tst( $sep, $name, $dom, $2, $4, $6 ) &&
exists $Months{lcx($4)} &&
exists $Days{lcx($2)} ) {
( $day, $s1, $month, $s2, $year ) = ( $2, $3, $4, $5, $6 );
$year = make_it_a_4_digit_year ( $year );
$fmt = "Day${s1}Month${s2}YY"; # European format
} elsif ( $in_date =~ m/(^|\D)(\d{1,2})(${sep})(${name})[.]?(${sep})(${dom})(\s|$)/ &&
_tst( $sep, $name, $dom, $2, $4, $6 ) &&
exists $Months{lcx($4)} &&
exists $Days{lcx($6)} ) {
( $year, $s1, $month, $s2, $day ) = ( $2, $3, $4, $5, $6 );
$year = make_it_a_4_digit_year ( $year );
$fmt = "YY${s1}Month${s2}Day"; # ISO format
}
last if ( defined $year );
}
if ( defined $year ) {
; # No more formatting tests needed ...
# "Month Day, YY" or "Month Day YY"
} elsif ( $in_date =~ m/(${name})[.\s]\s*(${dom})[,\s]\s*(\d{2})(\D|$)/ &&
_tst( "\\s", $name, $dom, $1, $2, $3 ) &&
exists $Months{lcx($1)} ) {
( $month, $day ) = ( $1, $2 );
$year = make_it_a_4_digit_year ( $3 );
$fmt = "Month Day, YY";
# As a string of 6 digits.
} elsif ( $in_date =~ m/(^|\D)(\d{6})(\D|$)/ ) {
($year, $month, $day) = parse_6_digit_date ( $2, $date_format_options );
$fmt = "YYMMDD";
}
} # End if its a 2-digit year ...
# --------------------------------------------------------------------
# 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 && ! 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;
}
};
}
}
# --------------------------------------------------------------------
# We're done with parsing things. Now let's validate the results!
# --------------------------------------------------------------------
if ( ! defined $year ) {
DBUG_PRINT ("ERROR", "No such date format is supported: %s", $in_date);
# Else we're using a known date format ...
} else {
DBUG_PRINT ("FORMAT", "%s ==> %s ==> (Y:%s, M:%s, D:%s, Sep:%s)",
$fmt, $in_date, $year, $month, $day, $s1);
# It's not a valid date if the separaters are different ...
# Shouldn't be possible any more unless it's spaces.
# (Hence we die if it happens)
if ( $s1 ne $s2 ) {
unless ( $s1 =~ m/^\s*$/ && $s2 =~ m/^\s*$/ ) {
die ("BUG: Separators are different ($s1 vs $s2)\n");
}
}
# Now let's validate the results ...
# Trim leading/trailing spaces ...
$day = $1 if ( $day =~ m/^\s*(.*)\s*$/ );
return DBUG_RETURN ( _check_if_good_date ($in_date, $year, $month, $day) );
}
DBUG_RETURN ( undef ); # Invalid date ...
}
sub parse_date
{
DBUG_ENTER_FUNC ( @_ );
my $in_date = shift; # A potential date in an unknown format ...
my $date_format_options = shift; # A comma separated list of fmt ids ...
my $use_date_language_module = shift || 0;
my $allow_2_digit_years = shift || 0;
$in_date = lcx ($in_date); # Make sure always in lower case ...
my ($month, $month_digits) = _find_month_in_string ( $in_date );
my ($dom, $dom_digits) = _find_day_of_month_in_string ( $in_date, $month_digits,
$month_digits ? undef : $month );
my $out_str;
if ( $month_digits && $dom_digits ) {
$out_str = _month_num_day_num ( $in_date, $month, $dom, $allow_2_digit_years, $date_format_options );
} elsif ( $month_digits ) {
$out_str = _month_num_day_str ( $in_date, $month, $dom, $allow_2_digit_years );
} elsif ( $dom_digits ) {
$out_str = _month_str_day_num ( $in_date, $month, $dom, $allow_2_digit_years, $date_format_options );
} else {
$out_str = _month_str_day_str ( $in_date, $month, $dom, $allow_2_digit_years );
}
# --------------------------------------------------------------------
# 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);
}
};
}
DBUG_RETURN ($out_str); # undef or the date in YYYY-MM-DD format.
}
# --------------------------------------------------------------
# No ambiguity here ... we have multiple text anchors ...
sub _month_str_day_str
{
DBUG_ENTER_FUNC ( @_ );
my $in_date = shift;
my $month_str = shift;
my $dom_str = shift;
my $allow_2_digit_years = shift;
my ($year, $s1, $month, $s2, $day );
if ( $in_date =~ m/(^|\D)(${month_str})[.]?(.*?\D)(${dom_str})(.*?\D)(\d{4})($|\D)/ ) {
($month, $s1, $day, $s2, $year ) = ( $2, $3, $4, $5, $6 ); # American format ...
} elsif ($in_date =~ m/(^|\D)(${dom_str})(.+?)(${month_str})[.]?(.*?\D)(\d{4})($|\D)/ ) {
($day, $s1, $month, $s2, $year ) = ( $2, $3, $4, $5, $6 ); # European format ...
} elsif ( $in_date =~ m/(^|\D)(\d{4})(\D.*?)(${month_str})[.]?(.*?\D)(${dom_str})($|\D)/ ) {
($year, $s1, $month, $s2, $day ) = ( $2, $3, $4, $5, $6 ); # ISO format ...
}
if ( $allow_2_digit_years && ! defined $year ) {
if ( $in_date =~ m/(^|\D)(${month_str})[.]?(.*?\D)(${dom_str})(.*?[^:\d])(\d{2})($|[^:\d])/ ) {
($month, $s1, $day, $s2, $year ) = ( $2, $3, $4, $5, $6 ); # American format ...
} elsif ($in_date =~ m/(^|\D)(${dom_str})(.+?)(${month_str})[.]?(.*?[^:\d])(\d{2})($|[^:\d])/ ) {
($day, $s1, $month, $s2, $year ) = ( $2, $3, $4, $5, $6 ); # European format ...
} elsif ( $in_date =~ m/(^|[^:\d])(\d{2})([^:\d].*?)(${month_str})[.]?(.*?\D)(${dom_str})($|\D)/ ) {
($year, $s1, $month, $s2, $day ) = ( $2, $3, $4, $5, $6 ); # ISO format ...
}
$year = make_it_a_4_digit_year ( $year ) if (defined $year);
} # End if allowing 2-digit years ...
if ( defined $year ) {
return DBUG_RETURN ( _check_if_good_date ($in_date, $year, $month, $day) );
}
DBUG_RETURN ( undef );
}
# --------------------------------------------------------------
# With a month anchor still not too ambiguous.
lib/Advanced/Config/Date.pm view on Meta::CPAN
my $day = shift;
# Strip off any leading zeros so we can use the hashes for validation ...
$month =~ s/^0+//;
$day =~ s/^0+//;
# Standardize it ... (with digits only!)
$month = $Months{lcx($month)};
$day = $Days{lcx($day)};
# Helpfull when dealing with foreign languages.
my $err_msg;
if ( defined $month && defined $day ) {
; # Good date!
} elsif ( defined $month ) {
$err_msg = "Just the day of month is bad.";
} elsif ( defined $day ) {
$err_msg = "Just the month is bad.";
} else {
$err_msg = "Both the month and day are bad.";
}
unless ( $err_msg ) {
if ( 1 <= $day && $day <= $days_in_months[$month] ) {
; # It's a good date ...
} elsif ( $month == 2 && $day == 29 ) {
my $leap = _is_leap_year ($year);
$year = undef unless ( $leap );
} else {
$year = undef;
}
unless ( defined $year ) {
$err_msg = "The day of month is out of range.";
}
}
if ( $err_msg ) {
DBUG_PRINT ("ERROR", "'%s' was an invalid date!\n%s", $in_str, $err_msg);
DBUG_PRINT ("BAD", "%s-%s-%s", $year, $month, $day);
return ( DBUG_RETURN (undef) );
}
DBUG_RETURN ( sprintf ("%04d-%02d-%02d", $year, $month, $day) );
}
# --------------------------------------------------------------
sub _find_month_in_string
{
DBUG_ENTER_FUNC (@_);
my $date_str = shift;
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;
}
DBUG_RETURN ( $month, $digits ); # Suitable for use in a RegExpr.
}
# --------------------------------------------------------------
sub _find_day_of_month_in_string
{
DBUG_ENTER_FUNC (@_);
my $date_str = shift;
my $skip_period = shift; # Skip entries ending in '.' like 17.!
my $month_str = shift; # Will be undef if skip_period is true!
my $day;
my $digits = 0;
my @lst = sort { length($b) <=> length($a) || $a cmp $b } keys %Days;
my $all_digits = $skip_period ? "^\\d+[.]?\$" : "^\\d+\$";
foreach my $dom ( @lst ) {
# Ignore numeric keys, can't get the correct one from string ...
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;
}
DBUG_RETURN ( $day, $digits ); # Suitable for use in a RegExpr.
}
# ==============================================================
=item adjust_future_cutoff ( $num_years );
Changes the cutoff future date from B<30> years to I<$num_years>.
Set to B<0> to disable years in the future!
This affects all L<Advanced::Config> objects, not just the current one.
=cut
sub adjust_future_cutoff
{
DBUG_ENTER_FUNC ( @_ );
my $years = shift;
if ( defined $years && $years =~ m/^\d+$/ ) {
$global_cutoff_date = shift;
}
DBUG_VOID_RETURN ();
}
# ==============================================================
=item $year = make_it_a_4_digit_year ( $two_digit_year );
Used whenever this module needs to convert a two-digit year into a four-digit
year.
( run in 1.374 second using v1.01-cache-2.11-cpan-140bd7fdf52 )