view release on metacpan or  search on metacpan

t/75-check_all_languages.t  view on Meta::CPAN

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use File::Basename;
use File::Spec;
use File::Glob qw (bsd_glob);
use Fred::Fish::DBUG 2.09 qw ( on );
use Fred::Fish::DBUG::Test 2.09;

# How to find the helper module ...
BEGIN { push (@INC, File::Spec->catdir (".", "t", "test-helper")); }
use helper1234;

# ---------------------------------------------------------------------
# Automatically creates a config file with all Date::Languages in use.
# It doesn't use the tools Advanced::Config has to give me more
# direct control on how the config file is created.  Also when originally
# created those tools hadn't been created yet.
# ---------------------------------------------------------------------
# After the config file has been created it attempts to use the
# Config object to validate everything works.
# ---------------------------------------------------------------------

my $fish;
my $config_file_normal;
my $config_file_wide;
my @global_languages;
my @global_lang_use_utf8;
my $run_as_developer = 0;

BEGIN {
   # The config file this program is to create!
   $config_file_normal = File::Spec->catfile (dirname ($0), "config", "75-all_languages_normal.cfg");
   $config_file_wide   = File::Spec->catfile (dirname ($0), "config", "75-all_languages_wide.cfg");
   unlink ( $config_file_normal, $config_file_wide );

   $fish = turn_fish_on_off_for_advanced_config ();

   unlink ( $fish );

   DBUG_ENTER_FUNC ();

   use_ok ("Advanced::Config");

   DBUG_VOID_RETURN ();

   # Turn fish on ...
   DBUG_PUSH ( $fish, allow_utf8 => 1 );

   $run_as_developer = $ENV{FULL_75_TEST} ? 1 : 0;
}

# Just proving it's a red herring.
sub uses_utf8_module
{
   my $file  = shift;

   my $found = 0;
   unless ( open (FH, "<", $file) ) {
      dbug_ok (0, "Can't open the language file for reading: " . $file);
      done_testing ();
      DBUG_LEAVE (0);
   }

   while (<FH>) {
      if ( $_ =~ m/^\s*use\s+utf8\s*;/ ) {
         $found = 1;
         last;
      }
   }

   close (FH);

   return ($found);
}

BEGIN
{
   DBUG_ENTER_FUNC ();

   eval {
      require Date::Language;
      Date::Language->import ();
   };
   if ($@) {
      dbug_ok (1, "Date::Language is not installed.  Skipping this test!");
      done_testing ();
      DBUG_LEAVE (0);
   }

   # Lookup where to find the Language modules ...
   my $key = File::Spec->catfile ("Date", "Language") . ".pm";
   my $lang_dir = $INC{$key};
   $lang_dir = $INC{'Date/Language.pm'}   unless ($lang_dir);
   $lang_dir =~ s/[.]pm$//;
   my $search = File::Spec->catdir ($lang_dir, "*.pm");

   # Get's the list of languages supported.
   foreach my $f ( bsd_glob ($search) ) {
      my @dirs = File::Spec->splitdir ($f);
      $dirs[-1] =~ s/[.]pm//;
      push (@global_languages, $dirs[-1]);
      push (@global_lang_use_utf8, uses_utf8_module ($f));
   }

   if ( $#global_languages == -1 ) {
      dbug_ok (1, "No Date::Language::<lang> modules are installed.  Skipping this test!");
      done_testing ();
      DBUG_LEAVE (0);
   }

   # Now load all those modules ...
   foreach my $l ( @global_languages ) {
      my $module = "Date::Language::${l}";
      use_ok ($module);
   }

   DBUG_VOID_RETURN ();
}

END {
   DBUG_ENTER_FUNC ();
   # Don't do any tests in the END block ...
   DBUG_VOID_RETURN ();
}

sub my_warn
{
   my $msg = shift;
   chomp ($msg);
   unless ( $msg =~ m/^Wide character in print/ ) {
      dbug_ok (0, "Warning encountered - $msg");
   }
}

sub my_die
{
   my $msg = $_[0];
   chomp ($msg);
   dbug_ok (0, "Die encountered - $msg");
   done_testing ();
   die ( $_[0] );
}

# ====================================================================
# Start of the main program!
# ====================================================================
{
   DBUG_ENTER_FUNC (@ARGV);

   $SIG{__WARN__} = \&my_warn;
   $SIG{__DIE__}  = \&my_die;

   dbug_ok (1, "In the MAIN program ...");  # Test # 2 ...

   my $language_data = load_all_language_data ();
   my $cnt = keys %{$language_data};
   dbug_ok (1, "Loaded ${cnt} languages ...");

   dbug_ok (1, "----------------- Building the cfg files ------------------");

   unless ( dbug_ok ( build_config_file ( $language_data, 0 ),
                     "The normal config file was successfully built!" ) ) {
      done_testing ();
      DBUG_LEAVE (3);
   }

   unless ( dbug_ok ( build_config_file ( $language_data, 1 ),
                     "The UTF8 config file was successfully built!" ) ) {
      done_testing ();
      DBUG_LEAVE (3);
   }

t/75-check_all_languages.t  view on Meta::CPAN

}

# ====================================================================
sub build_date
{
   my $mode  = shift;    # 0, 1, 2, 3
   my $year  = shift;    # YYYY
   my $month = shift;    # 1..12
   my $day   = shift;    # 1..31
   my $def   = shift;
   my $lang  = shift;

   my ( $MoY, $DoM, $str );

   # The 4 digit years ...
   if ( $mode == 0 ) {
      $MoY = $def->{MoY}->[$month - 1];
      $DoM = $day . ( $def->{Dsuf}->[$day] || "" );
      $str = sprintf ("    %04d-%02d-%02d = %s %s, %04d      # ENCRYPT\n",
                      $year, $month, $day, $MoY, $DoM, $year);

   } elsif ( $mode == 1 ) {
      $MoY = $def->{MoYs}->[$month - 1];
      $str = sprintf ("    %04d-%02d-%02d = %04d-%s-%02d      # ENCRYPT -- %s   %s\n",
                      $year, $month, $day, $year, uc($MoY), $day, lc(uc($MoY)), $MoY);

   # The 2 digit years ... (be careful, don't use ambiguous dates!)
   } elsif ( $mode == 2 ) {
      $MoY = uc ($def->{MoY}->[$month - 1]);
      $DoM = $day . uc ( $def->{Dsuf}->[$day] || "" );
      $str = sprintf ("    %04d-%02d-%02d = %s %s, %02d      # ENCRYPT\n",
                      $year, $month, $day, $MoY, $DoM, $year % 100);

   } elsif ( $mode == 3 ) {
      $MoY = lc (uc ($def->{MoYs}->[$month - 1]));
      $str = sprintf ("    %04d-%02d-%02d = %02d-%s-%02d      # ENCRYPT\n",
                      $year, $month, $day, $day, $MoY, $year % 100);

   # The error case that should never happen ....
   } else {
      $str = sprintf ("    %04d-%02d-%02d = Programming errror!",
                      $year, $month, $day,);
   }

   # Only happens with bad language definitions ...
   unless ( $MoY ) {
      DBUG_PRINT ("ERROR", "MoY is null for '%s'.  mode: %d\n%s", $lang, $mode, $str);
   }

   return ( $str );
}

# ====================================================================
sub load_all_language_data
{
   DBUG_ENTER_FUNC (@_);

   my %lang_data;

   my $lidx = 0;
   foreach my $lang ( @global_languages ) {
      my $uses_utf8_mod = $global_lang_use_utf8[$lidx++];

      my $module = "Date::Language::${lang}";
      my ( $lang_wide, $lang_utf8 ) = ( 0, 0 );

      # @Dsuf isn't always available for some modules.
      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. (buggy)
      my @lDoW  = eval "\@${module}::DoW";     # The Day of Week.
      my @lDoWs = eval "\@${module}::DoWs";    # The Day of Week Abbreviations.
      my $has_spaces = 0;

      # Fix so that uc() & lc() will always work on these 5 arrays ...
      foreach (@lMoY, @lMoYs, @lDsuf, @lDoW, @lDoWs ) {
         my $wide = utf8::is_utf8 ($_) || 0;   # Before ...
         unless ( $wide ) {
            utf8::encode ($_);
            utf8::decode ($_);

            # Now determine if a common variant makes it wide ...
            if ( $_ =~  m/[^\x00-\xff]/ ) {
               $wide -= 1;     # Now: -1
            }
            if ( lc ($_) =~  m/[^\x00-\xff]/ ) {
               $wide -= 2;     # Now: -2 or -3
            }
            if ( uc ($_) =~  m/[^\x00-\xff]/ ) {
               $wide -= 4;     # Now: -4, -5, -6 or -7 ...
            }
         }
         my $utf8 = utf8::is_utf8 ($_) || 0;   # After ...

         $lang_wide = $lang_wide || $wide;
         $lang_utf8 = $lang_utf8 || $utf8;
         ++$has_spaces   if ( $_ =~ m/\s/ );
      }

      # So I can log my results ...
      # And prove my assumptions are good!
      my $test_ok = ( scalar (@lMoY) == 12 && scalar (@lMoYs) == 12 );

      DBUG_PRINT ($test_ok ? "INFO" : "BAD",
                  "MoY: %d, MoYs: %d, Dsuf: %02d, DoW: %d, DoWs: %d, wide(%2d), utf8(%d), uses_utf8_mod(%s), spaces(%2d), Language: %s",
                  scalar (@lMoY), scalar (@lMoYs), scalar (@lDsuf), scalar (@lDoW), scalar (@lDoWs),
                  $lang_wide, $lang_utf8, $uses_utf8_mod ? "YES" : "no", $has_spaces, $lang);

      if ( $test_ok ) {
         my %data = ( MoY  => \@lMoY,      MoYs   => \@lMoYs,
                      Dsuf => \@lDsuf,
                      DoW  => \@lDoW,      DoWs   => \@lDoWs,
                      wide => $lang_wide,  utf8   => $lang_utf8,
                      lang => $lang,       spaces => $has_spaces,
                      used_utf8_mod => $uses_utf8_mod );

         $lang_data{$lang} = \%data;
      }
   }

   DBUG_RETURN (\%lang_data);
}