view release on metacpan or  search on metacpan

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

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

   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.

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

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

# ==============================================================