view release on metacpan or  search on metacpan

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

      }

      foreach my $tag ( $sCfg->find_tags (qr /^uMoY_/, 0) ) {
         $fatal += test_array ($sCfg, "MoY-u", $lang, $tag, $MoY_ref );
      }

      foreach my $tag ( $sCfg->find_tags (qr /^uMoYs_/, 0) ) {
         $fatal += test_array ($sCfg, "MoYs-u", $lang, $tag, $MoYs_ref );
      }

      foreach my $tag ( $sCfg->find_tags (qr /^lMoY_/, 0) ) {
         $fatal += test_array ($sCfg, "MoY-l", $lang, $tag, $MoY_ref );
      }

      foreach my $tag ( $sCfg->find_tags (qr /^lMoYs_/, 0) ) {
         $fatal += test_array ($sCfg, "MoYs-l", $lang, $tag, $MoYs_ref );
      }
   }

   if ($fatal) {
      done_testing ();
      DBUG_LEAVE (11);
   }

   DBUG_VOID_RETURN ();
}

# --------------------------------------------------------------------
sub validate_dates
{
   DBUG_ENTER_FUNC (@_);
   my $cfg           = shift;
   my $utf8_expected = shift;

   DBUG_PAUSE ()  unless ( $run_as_developer );

   foreach my $s ( $cfg->find_sections () ) {
      my $sCfg = $cfg->get_section ( $s, 1 );
      my $lang = $sCfg->get_value ("Language", {required => 0});
      unless ( defined $lang ) {
         dbug_ok (1, "Skipping section '$s' due to no Language tag!");
         next;
      }

      my $tmp = $lang;
      # $tmp = Advanced::Config::Date::swap_language ($lang);
      if ( $tmp ne $lang ) {
         dbug_ok (0, "Language was changed to ${lang}");
         next;
      }
      dbug_ok (1, "Validating dates for language ${lang} ...");

      # Validate the weekdays ...
      my $wd = $sCfg->get_list_values ("WeekDays", qr/\s*,\s*/,  undef, {required => 1});
      my $cnt = @{$wd};
      $cnt = 7  if ( $cnt == 8 && $wd->[0] eq $wd->[-1] );
      dbug_is ( $cnt, 7, "Found 7 weekdays defined by tag 'WeekDays' ($cnt)" );

      foreach my $tag ( @{$wd} ) {
         my $val = $sCfg->get_value ($tag) || "";
         DBUG_PRINT ("UTF8", "utf8 flag (%d)", utf8::is_utf8($val));

         my $ok = ($val =~ m/^Found /) ? 1 : 0;
         dbug_ok ($ok, "Found Weekday Tag ($tag): ${val}");
      }

      # Validate the date itself ...
      foreach my $tag ( $sCfg->find_tags (qr /^[0-9]{4}-[0-9]{2}-[0-9]{2}$/, 0) ) {
         my $val1 = $sCfg->get_value ($tag);
         DBUG_PRINT ("UTF8", "utf8 flag (%d)", utf8::is_utf8($val1));
         my $val2 = $sCfg->get_date ($tag, $lang, date_language_warn => 0);
         if ( $val2 && $val2 eq $tag ) {
            dbug_ok (1, "Found tag: ${tag} in section '${s}' for ${lang} --> ${val2} -- ${val1}");
         } else {
            dbug_ok (0, "Tag ${tag} in section '${s}' for ${lang} points to a valid date: ${val1}");
         }
      }
      DBUG_PRINT ("----", "-------------------------------------------------");
   }

   DBUG_VOID_RETURN ();
}

# ====================================================================
# From here on down deals with creating the config file.
# ====================================================================
sub build_config_file
{
   DBUG_ENTER_FUNC (@_);
   my $all_languages = shift;
   my $wide_flag     = shift;

   my $file = $wide_flag ? $config_file_wide : $config_file_normal;

   unless ( open (CONFIG, ">", $file) ) {
      dbug_ok (0, "Creating the UTF-8 config file: $file");
      return DBUG_RETURN (0);
   }

   my $msg;
   if ( $wide_flag ) {
      dbug_ok (1, "Creating the UTF-8 config file: $file");
      binmode (CONFIG, "encoding(UTF-8)");   # Converts to wide-char / Unicode output.
      $msg = "This file was created using UTF-8 Encoding";
   } else {
      dbug_ok (1, "Creating the normal config file: $file");
      $msg = "This file was created without any special Encoding";
   }

   print CONFIG "\n";
   print CONFIG "# This is an auto-genearted config file.\n";
   print CONFIG "# Do not modify it by hand!\n\n";
   print CONFIG "# ${msg}\n\n";

   my $englishDoW = $all_languages->{English}->{DoW};

   foreach my $lang ( sort keys %{$all_languages} ) {
      my $l = $all_languages->{$lang};

      next  if ( $l->{wide} && ! $wide_flag );

      print CONFIG "[ $lang ]\n";
      print CONFIG "    Language = $lang\n";     # To preserve the case...
      print CONFIG "    Wide = $l->{wide}\n";
      print CONFIG "    WeekDays = ", join (",  ", @{$l->{DoW}}), "\n\n";

      foreach ( 0..6 ) {
         print CONFIG "    $l->{DoW}->[$_] = Found $englishDoW->[$_] in ${lang}  ($l->{DoW}->[$_])\n";
      }
      print CONFIG "\n";

      # ---------------------------
      # The 4 digit years ....
      # ---------------------------
      foreach ( 1..12 ) {
         print CONFIG build_date (0, 2018,  $_,  $_ + 1, $l, $lang);
      }
      print CONFIG "\n";

      foreach ( 1..12 ) {
         print CONFIG build_date (1, 2019,  $_,  $_ + 14, $l, $lang);
      }
      print CONFIG "\n";

      # ----------------------------------------------------------
      # The 2 digit years .... Use 199x years to avoid ambiguity
      # ----------------------------------------------------------
      foreach ( 1..12 ) {
         print CONFIG build_date (2, 1998,  $_,  $_ + 2, $l, $lang);
      }
      print CONFIG "\n";

      foreach ( 1..12 ) {
         print CONFIG build_date (3, 1999,  $_,  $_ + 15, $l, $lang);
      }
      print CONFIG "\n";
   }

   print CONFIG "----------------------------------------------------------\n\n";

   # These extra sections are for advanced checks ...
   # Using variables and Encryption ...
   my $cntr = 0;
   foreach my $lang ( "Chinese", "Greek", "Russian" ) {
      my $l = $all_languages->{$lang};

      next  unless ( defined $l );
      next  if ( $l->{wide} && ! $wide_flag );

      ++$cntr;
      print CONFIG "[ ZZ Extra ${cntr} ]\n";
      print CONFIG "    Language = \${$lang.Language}\n";
      print CONFIG "    Wide = \${$lang.Wide}\n";
      print CONFIG "    WeekDays = \${$lang.WeekDays}\n\n";

      foreach ( 0..6 ) {
         my $wd = $l->{DoW}->[$_];
         print CONFIG "    $wd = \${$lang.$wd}      # ENCRYPT\n";
      }
      print CONFIG "\n";

      foreach ( 1..12 ) {
         my $dt = sprintf ("%04d-%02d-%02d", 2018, $_, $_ + 1);
         print CONFIG "    ${dt} = \${$lang.$dt}      # ENCRYPT\n";
      }
      print CONFIG "\n";
      foreach ( 1..12 ) {
         my $dt = sprintf ("%04d-%02d-%02d", 2019, $_, $_ + 14);
         print CONFIG "    ${dt} = \${$lang.$dt}      # ENCRYPT\n";
      }
      print CONFIG "\n";
      foreach ( 1..12 ) {
         my $dt = sprintf ("%04d-%02d-%02d", 1998, $_, $_ + 2);
         print CONFIG "    ${dt} = \${$lang.$dt}      # ENCRYPT\n";
      }
      print CONFIG "\n";
      foreach ( 1..12 ) {
         my $dt = sprintf ("%04d-%02d-%02d", 1999, $_, $_ + 15);
         print CONFIG "    ${dt} = \${$lang.$dt}      # ENCRYPT\n";
      }
      print CONFIG "\n";
   }

   print CONFIG "----------------------------------------------------------\n\n";

   # So can validate we have no issues writing foreign languages to a
   # file and reading them back out again!
   foreach my $lang ( sort keys %{$all_languages} ) {
      my $l = $all_languages->{$lang};

      next  if ( $l->{wide} && ! $wide_flag );

      print CONFIG "[ $lang ]\n";
      foreach ( 0..11 ) {
         print CONFIG "MoY_${_} = $l->{MoY}->[$_]    # ENCRYPT\n";
      }
      print CONFIG "\n";
      foreach ( 0..11 ) {
         print CONFIG "MoYs_${_} = $l->{MoYs}->[$_]    # ENCRYPT\n";
      }
      print CONFIG "\n";

      # The status to use for the dbug_ok() tests in the following loop ...
      # Done this way so I can easily flip the switch to cause failed
      # tests during debugging this lc(uc(month)) issue!
      my $ok_tst = 1;
      my $ok_msg = $ok_tst ? "failed" : "worked";

      foreach ( 0..11 ) {
         my $uc1 = uc ($l->{MoY}->[$_]);
         my $uc2 = uc ($l->{MoYs}->[$_]);
         my $lc1 = lc ($l->{MoY}->[$_]);
         my $lc2 = lc ($l->{MoYs}->[$_]);

         # Search for upper case issues ...
         my ($p1, $p2, $p3, $p4) = ("", "", "", "");
         if ( uc($lc1) ne $uc1 ) {
            my $t = uc($lc1);
            my ($u1, $u2) = (utf8::is_utf8($uc1)||0, utf8::is_utf8($t)||0);
            dbug_ok ($ok_tst, "${lang}: Force uppercase on MoY[$_] ${ok_msg}.  ($uc1, $t) utf8($u1,$u2)");
            $p1 = " - Has problem? ($lang)";
            if ( $uc1 ne lc ($uc1) ) {
               dbug_ok ($ok_tst, "${lang}: Force uppercase on uc(uc(MoY[$_])) ${ok_msg}.\n");
            }
         }

         if ( uc($lc2) ne $uc2 ) {
            my $t = uc($lc2);
            my ($u1, $u2) = (utf8::is_utf8($uc2)||0, utf8::is_utf8($t)||0);
            dbug_ok ($ok_tst, "${lang}: Force uppercase on MoYs[$_] ${ok_msg}.  ($uc2, $t) utf8($u1,$u2)");
            $p2 = " - Has problem? ($lang)";
            if ( $uc2 ne lc ($uc2) ) {
               dbug_ok ($ok_tst, "${lang}: Force uppercase on uc(uc(MoYs[$_])) ${ok_msg}.\n");
            }
         }

         # Search for lower case issues ...
         if ( lc($uc1) ne $lc1 ) {
            my $t = lc($uc1);
            my ($u1, $u2) = (utf8::is_utf8($lc1)||0, utf8::is_utf8($t)||0);
            dbug_ok ($ok_tst, "${lang}: Force lowercase on MoY[$_] ${ok_msg}.  ($lc1, $t) utf8($u1,$u2)");
            $p3 = " - Has problem? ($lang)";
            if ( $lc1 ne lc ($lc1) ) {
               dbug_ok ($ok_tst, "${lang}: Force lowercase on lc(lc(MoY[$_])) ${ok_msg}.\n");
            }
         }

         if ( lc($uc2) ne $lc2 ) {
            my $t = lc($uc2);
            my ($u1, $u2) = (utf8::is_utf8($lc2)||0, utf8::is_utf8($t)||0);
            dbug_ok ($ok_tst, "${lang}: Force lowercase on MoYs[$_] ${ok_msg}.  ($lc2, $t) utf8($u1,$u2)");