view release on metacpan or  search on metacpan

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

   dbug_ok (1, "----------------- UTF-8 Encrypted -------------------------");
   dbug_ok ( compare_objects ( $cfg2, $cfg4 ),
             "Both UTF-8 objects are the same!" );

   dbug_ok (1, "----------------- Regular Decrypted -----------------------");
   dbug_ok ( compare_objects ( $cfg1, $cfg5 ),
             "Both normal objects are the same!" );
   dbug_ok (1, "----------------- UTF-8 Decrypted -------------------------");
   dbug_ok ( compare_objects ( $cfg2, $cfg6 ),
             "Both UTF-8 objects are the same!" );
   dbug_ok (1, "---------------------- Done! ------------------------------");

   # Since I didn't count the test cases, must end my program
   # with a call to this method.  Can't do tests in END anymore!
   done_testing ();

   DBUG_LEAVE (0);
}

# --------------------------------------------------------------------
# Create a new Advanced::Config objact ...
# --------------------------------------------------------------------
sub build_new_object
{
   DBUG_ENTER_FUNC (@_);
   my $mode_utf8 = shift;     # 0 or 1.
   my $lbl       = shift;     # Initial, Encrypted or Decrypted
   my $pause     = shift;     # 0 or 1.
   my $file      = shift;

   my $cfg = Advanced::Config->new ( $file,
                                     { croak => 1,    use_utf8 => $mode_utf8,
                                       dbug_test_use_case_parse_override  => 1,
                                       dbug_test_use_case_hide_override   => 1,
                                       disable_variable_modifiers => 1 },
                                     { required => 0, date_enable_yy => 1 },
                                     { }
                                   );

   my $type = $mode_utf8 ? "UTF-8" : "normal";
   dbug_isa_ok ( $cfg, "Advanced::Config" );
   dbug_isa_ok ( pause_load ($cfg, $pause), "Advanced::Config" );

   DBUG_RETURN ( $cfg );
}

# --------------------------------------------------------------------
sub pause_load
{
   DBUG_ENTER_FUNC (@_);
   my $cfg   = shift;
   my $pause = shift;

   DBUG_PAUSE ()  if ( $pause );

   DBUG_RETURN ( $cfg->load_config () );
}

# --------------------------------------------------------------------
# Compares 2 Advanced::Config objects and verify they are the same!
# Stops on any error encountered.
# --------------------------------------------------------------------
sub compare_objects
{
   DBUG_ENTER_FUNC (@_);
   my $cfg_src = shift;
   my $cfg_dst = shift;

   DBUG_PAUSE ()  unless ( $run_as_developer );

   my @src = $cfg_src->find_sections ();
   my @dst = $cfg_src->find_sections ();
   unless (dbug_is ( $#src, $#dst, "Both objects have the same number of sections in them!" )) {
      return DBUG_RETURN (0);
   }

    my $stop = 0;
   foreach (@src) {
      my $sCfg1 = $cfg_src->get_section ( $_ );
      my $sCfg2 = $cfg_dst->get_section ( $_ );

      my $sts = ( $sCfg1 && $sCfg2 ) ? 1 : 0;
      unless (dbug_ok ($sts, "Section '$_' exists in both objects!")) {
         $stop = 1;
         last;
      }

      my @tags1 = $sCfg1->find_tags ();
      my @tags2 = $sCfg2->find_tags ();
      unless (dbug_is ( $#tags1, $#tags2, "Both copies of section '$_' have the same number of tags in them!")) {
         $stop = 1;
         last;
      }

      foreach my $t (@tags1) {
         my $val1 = $sCfg1->get_value ($t);
         my $val2 = $sCfg2->get_value ($t);
         $sts = ( defined $val2 && $val1 eq $val2 ) ? 1 : 0;
         unless ( dbug_ok ($sts, "Tag '$t' in both objects have the same value ($val1) ($val2)" ) ) {
            $stop = 1;
         }
      }
      last  if ( $stop );
   }

   DBUG_RETURN ( $stop ? 0 : 1 );
}

# --------------------------------------------------------------------
# Now onto validating we can read the config file we created ...
# --------------------------------------------------------------------
sub test_array
{
   my $cfg    = shift;
   my $lbl    = shift;
   my $lang   = shift;
   my $tag    = shift;
   my $months = shift;   # Ref to MoY or MoYs ...

   my ($bad, $good) = (0, 0);
   if ( $tag =~ m/^(.?)MoY.*_(\d+)$/ ) {

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

            $p4 = " - Has problem? ($lang)";
            if ( $lc2 ne lc ($lc2) ) {
               dbug_ok ($ok_tst, "${lang}: Force lowercase on lc(lc(MoYs[$_])) ${ok_msg}.\n");
            }
         }

         # Write to the config file ...
         print CONFIG sprintf ("uMoY_%d  = %s     # utf8 (%d)%s  %s\n",
                               $_, $uc1, utf8::is_utf8($uc1) || 0, $p1, "ENCRYPT");
         print CONFIG sprintf ("uMoYs_%d = %s     # utf8 (%d)%s  %s\n",
                               $_, $uc2, utf8::is_utf8($uc2) || 0, $p2, "ENCRYPT");
         print CONFIG sprintf ("lMoY_%d  = %s     # utf8 (%d)%s  %s\n",
                               $_, $lc1, utf8::is_utf8($lc1) || 0, $p3, "ENCRYPT");
         print CONFIG sprintf ("lMoYs_%d = %s     # utf8 (%d)%s  %s\n",
                               $_, $lc2, utf8::is_utf8($lc2) || 0, $p4, "ENCRYPT");
      }
      print CONFIG "\n";
   }

   close (CONFIG);

   DBUG_RETURN ( 1 );
}

# ====================================================================
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/ );
      }