view release on metacpan or  search on metacpan

t/76-check_all_languages2.t  view on Meta::CPAN

             "Both normal objects are the same!" );
   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!" );

   # 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
{
   # DBUG_ENTER_FUNC (@_);
   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);

t/76-check_all_languages2.t  view on Meta::CPAN

            dbug_ok ($ok_tst, "${lang}: Force lowercase on MoYs[$_] ${ok_msg}.  ($lc2, $t) utf8($u1,$u2)");
            $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 ( $MoY, $DoM, $str );

   # The 4 digit years ...
   if ( $mode == 0 ) {
      $MoY = $def->{MoY}->[$month - 1];
      $DoM = $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 = $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,);
   }

   return ( $str );
}
# ====================================================================
# So uc() & lc() works agaisnt each key value ...
sub fix_key
{
   my $value = shift;

   my $has_spaces = 0;
   my $wide = ( $value =~ m/[^\x00-\xff]/ ) ? 1 : 0;  # Before ...

   unless ( $wide ) {
      utf8::encode ($value);
      utf8::decode ($value);

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

   $value = lc ($value);
   $has_spaces = 1   if ( $value =~ m/\s/ );

   return ( $value, $wide, $utf8, $has_spaces );
}

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

sub load_all_language_data
{
   DBUG_ENTER_FUNC (@_);

   my %lang_data;

   foreach my $mod ( @global_modules ) {
      my $module = "Date::Manip::Lang::${mod}";

      my ( $lang_wide, $lang_utf8 ) = ( 0, 0 );

      my $Language = eval "\$${module}::LangName";    # The proper name of this language.

      my $langData = eval "\$${module}::Language";    # A hash reference with the data!

      my %months;
      my %days;
      my %wdays;