view release on metacpan or  search on metacpan

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

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

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

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

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

            }

            if ( $d <= $max ) {
               ( $year, $month, $day ) = ( $y, $m, $d );
               last;
            }
         }
      }
   }

   DBUG_RETURN ( $year, $month, $day );
}


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

=item (\@months, \@weekdays) = init_special_date_arrays ( $lang[, $mode[, $wok[, $wide]]] );

Prefers getting the date names from I<Date::Manip::Lang::${lang}> for the
I<Advanced::Config> special date variables.  But if the language isn't supported
by that module it tries I<Date::Language::${lang}> instead.  This is because
the 1st module is more consistent.

If the I<$lang> doesn't exist, then it returns the arrays for the last valid
language.

If I<$wok> is set to a non-zero value, it will print warnings to your screen if
there were issues in changing the language used.

I<$mode> tells how to return the various arrays:

   1 - Abbreviated month/weekday names in the requested language.
   2 - Full month/weekday names in the requested language.
   Any other value and it will return the numeric values. (default)

For @months, indexes are 0..11, with 0 representing January.

For @weekdays, indexes are 0..6, with 0 representing Sunday.

Languages like 'Greek' that rely on I<Wide Chars> require the I<$wide> flag set to
true.   Otherwise that language is disabled.

=cut

sub init_special_date_arrays
{
   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 ...