view release on metacpan or  search on metacpan

lib/Advanced/Config/Date.pm  view on Meta::CPAN

###
###  Copyright (c) 2018 - 2026 Curtis Leach.  All rights reserved.
###
###  Module: Advanced::Config::Date

=head1 NAME

Advanced::Config::Date - Module for parsing dates for L<Advanced::Config>.

=head1 SYNOPSIS

 use Advanced::Config::Date;
 or 
 require Advanced::Config::Date;

=head1 DESCRIPTION

F<Advanced::Config::Date> is a helper module to L<Advanced::Config>.  So it
should be very rare to directly call any methods defined by this module.  But
it's perfectly OK to use this module directly if you wish.

It's main job is to handle parsing dates passed in various formats and languages
while returning it in the standardized format of: S<YYYY-MM-DD>.  Hiding all the
messy logic of how to interpret any given date string.

=head1 MULTI-LANGUAGE SUPPORT

By default this module only supports parsing B<English> language dates.

But if you have the I<Date::Language> and/or I<Date::Manip>  modules installed
you can ask for it to use another language supported by either of these modules
instead.

You have to explicitly allow languages that require the use of I<Wide Chars>.
Otherwise they are not supported.

If a language is defined in both modules, it will merge the data together.
Since both modules sometimes give extra information that can be useful in
parsing a date..

=head1 FOUR-DIGIT VS TWO-DIGIT YEARS IN A DATE

This module will accept both 4-digit and 2-digit years in the dates it parses.
But two-digit years are inherently ambiguous if you aren't given the expected
format up front.  So 2-digit years generate more unreliability in the parsing
of any dates by this module.

So when used by the L<Advanced::Config> module, that module gives you the
ability to turn two-digit years on or off.  This is done via the B<Get Option>
"B<date_enable_yy>" which defaults to 0, B<not> allowing two-digit years.

To help resolve ambiguity with numeric dates, there is an option "B<date_format>"
that tells the L<Advanced::Config> how to parse these dates.  See the order
argument for I<parse_6_digit_date()> and I<parse_8_digit_date()> for how this
is done.

Finally if you use "B<date_dl_conversion>" and module L<Date::Language> is
installed, it will enhance parse_date() with that module's str2time() parser.
So if this option was used, it doesn't make much sense to disable 2-digit years.
Since we can't turn off 2-digit year support for str2time().

See L<Advanced::Config::Options> for more options telling how that module
controls how L<Advanced::Config> uses this module for parsing dates.

Those options have no effect if you are calling these methods directly.

=head1 FUNCTIONS

=over 4

=cut 

package Advanced::Config::Date;

use strict;
use warnings;

use File::Spec;
use File::Glob qw (bsd_glob);

use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
use Exporter;

use Fred::Fish::DBUG 2.09 qw / on_if_set  ADVANCED_CONFIG_FISH /;

lib/Advanced/Config/Date.pm  view on Meta::CPAN

=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;
   }

   DBUG_RETURN ( sort keys %languages );
}

# ==============================================================
# Done this way to the warning goes to fish no matter what.
sub _warn_msg
{
   DBUG_ENTER_FUNC ( @_ );
   my $ok = shift;
   my $msg = shift;
   if ( $ok ) {
      warn "==> ${msg}\n";
   }
   DBUG_VOID_RETURN ();
}

# ==============================================================
# No POD on purpose ...
# Does some common logic for swap_language() & init_special_date_arrays().
# 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 ...
   {
      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, undef, undef, undef ) );
      }
   }

   # Get the proper name of this language fom the module.
   $lang_ref->{Language} = $lang = eval "\$${module}::LangName";

   # Get the language data from the module.
   my $langData = eval "\$${module}::Language";    # A hash reference with the data!

   # The 3 return values used by swap_language () ...
   my (%months, %days, %issues);

   # The 5 return values used by init_special_date_arrays()
   my ( @MoY, @MoYs, @Dsuf, @DoW, @DoWs);

   my $wide = 0;
   my $has_period = 0;
   foreach my $month_idx (1..12) {
      foreach my $name ( @{$langData->{month_name}->[$month_idx-1]} ) {
         my ($w, $k, $pi, $pe, $alt) = _fix_key ( $name );
         $wide = 1  if ($w);
         next  if ( $pe && exists $months{$alt} && $months{$alt} == $month_idx );
         $has_period = 1  if ( $pi || $pe );
         $months{$k} = $month_idx;
      }
      foreach my $abb ( @{$langData->{month_abb}->[$month_idx-1]} ) {
         my ($w, $k, $pi, $pe, $alt) = _fix_key ( $abb );
         $wide = 1  if ($w);
         next  if ( $pe && exists $months{$alt} && $months{$alt} == $month_idx );
         $has_period = 1  if ( $pi || $pe );
         $months{$k} = $month_idx;
      }

      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] );