view release on metacpan or  search on metacpan

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

   eval {
      local $SIG{__DIE__} = "";
      require Date::Manip::Lang::index;
      Date::Manip::Lang::index->import ();

      foreach my $k ( sort keys %Date::Manip::Lang::index::Lang ) {
         my $mod = $Date::Manip::Lang::index::Lang{$k};
         my $lang = ( $k eq $mod ) ? ucfirst ($mod) : $mod;
         my $module = "Date::Manip::Lang::${mod}";

         my %data = ( Language => $lang,    # A guess that's wrong sometimes
                      Module   => $module );
         $date_manip_installed_languages{lc ($k)} = \%data;
      }
   };

   # -------------------------------------------------------------
   # Proves sometimes the module name is different from the
   # real language name.
   # -------------------------------------------------------------
   # foreach my $k ( sort keys %date_manip_installed_languages ) {

t/13-alt-get-tests.t  view on Meta::CPAN

   DBUG_RETURN ( $ok );
}

# ====================================================================
sub run_numeric_tests
{
   DBUG_ENTER_FUNC ( @_ );
   my $cfg = shift;

   my ($guess, $real, $trunc, $round, $lbl);
   my $ans;
   my $ok = 1;

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "int_one" );
   $ans = 0;
   if ( $real && $trunc && $round && $guess ) {
      $ans = 1  if ( $real == $trunc && $trunc == $round && $trunc == $guess );
   }
   dbug_ok ( $ans, "${lbl} references a valid integer! ($guess)" );
   $ok = 0  unless ($ans);

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "int_two" );
   $ans = ( (! $real) && (! $trunc) && (! $round) && $guess ) ? 1 : 0;
   dbug_ok ( $ans, "${lbl} is not a single number! ($guess)" );
   $ok = 0  unless ($ans);

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "real_one" );
   $ans = ( $guess && $real && $guess == $real && $trunc && $round && $trunc == $round ) ? 1 : 0;
   dbug_ok ( $ans, "${lbl} is a floating point number, not an integer! ($guess)" );
   $ok = 0  unless ($ans);

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "bad_real_one" );
   $ans = ( $guess && (! $real) && (! $trunc) && (! $round) ) ? 1 : 0;
   dbug_ok ( $ans, "${lbl} is not numeric! ($guess)" );
   $ok = 0  unless ($ans);

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "real_1" );
   $ans = ( $guess && $real && $guess == $real && (defined $round && defined $trunc) && $round == $trunc ) ? 1 : 0;
   dbug_ok ( $ans, "${lbl} is a valid floating point number. ($guess) [$round]");
   $ok = 0  unless ($ans);

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "real_2");
   $ans = ( $guess && (defined $real) && (defined $round ) && (defined $trunc) ) ? 1 : 0;
   dbug_ok ( $ans, "${lbl} is a valid floating point number.  Now allows the leading digit to be missing. ($guess)" );
   $ok = 0  unless ($ans);

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "real_3" );
   $ans = ( $guess && (defined $real) && (defined $round ) && (defined $trunc) ) ? 1 : 0;
   dbug_ok ( $ans, "${lbl} is a valid floating point number.  Now allows the trailing digit to be missing. ($guess)" );
   $ok = 0  unless ($ans);

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "realb_4" );
   $ans = ( $guess && (! defined $real) && (! defined $round ) && (! defined $trunc) ) ? 1 : 0;
   dbug_ok ( $ans, "${lbl} is not a valid floating point number. ($guess)" );
   $ok = 0  unless ($ans);

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "realb_5" );
   $ans = ( $guess && (! defined $real) && (! defined $round ) && (! defined $trunc) ) ? 1 : 0;
   dbug_ok ( $ans, "${lbl} is not a valid floating point number. ($guess)" );
   $ok = 0  unless ($ans);

   ($guess, $real, $trunc, $round, $lbl) = get_all_numeric_values ( $cfg, "realb_6" );
   $ans = ( $guess && (! defined $real) && (! defined $round ) && (! defined $trunc) ) ? 1 : 0;
   dbug_ok ( $ans, "${lbl} is not a valid floating point number. ($guess)" );
   $ok = 0  unless ($ans);

# dbug_ok (0, "No get_list_numeric() tests ...");  return DBUG_RETURN (0);

   # The list tests ...
   $ok = 0  unless (run_numeric_list_tests ($cfg, "^int_",  "int_three"  => qr/\s*[|]\s*/));
   $ok = 0  unless (run_numeric_list_tests ($cfg, "^real_", "real_three" => qr/\s*[?]\s*/, "real_2" => "bad", "real_3" => "bad"));

   DBUG_RETURN ( $ok );
}

# ====================================================================
sub get_all_numeric_values
{
   DBUG_ENTER_FUNC ( @_ );
   my $cfg = shift;
   my $tag = shift;

   my ( $guess, $real, $trunc, $round );

   $guess = $cfg->get_value ($tag);                       # Always works!
   $real  = $cfg->get_numeric ($tag,    required => 0);   # Real number
   $trunc = $cfg->get_integer ($tag, 1, required => 0);   # Integer (truncating)
   $round = $cfg->get_integer ($tag, 0, required => 0);   # Integer (rounding)

   my $ok2_msg_prefix = "Tag ${tag}'s value";

   DBUG_RETURN ( $guess, $real, $trunc, $round, $ok2_msg_prefix );
}

# ====================================================================
sub truncate_or_round
{
   DBUG_ENTER_FUNC ( @_ );
   my $list_ref = shift;
   my $int_flag = shift;   # Always 1 (round) or -1 (truncate)

   my $cnt = @{$list_ref} - 1;