view release on metacpan or  search on metacpan

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

   $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;

   foreach (0..${cnt}) {
      next  unless ( $list_ref->[$_] =~ m/^([-+]?\d+)[.]\d+$/ );
      if ( $int_flag < 0 ) {
         $list_ref->[$_] = $1 + 0;       # Truncated
      } else {
         $list_ref->[$_] = sprintf ("%.0f", $list_ref->[$_]);
      }
   }

   DBUG_VOID_RETURN ();
}

# ====================================================================
# Assumes all passed tags only reference valid lists of numbers!
sub run_numeric_list_tests
{
   DBUG_ENTER_FUNC ( @_ );
   my $cfg       = shift;
   my $search    = shift;    # Which tags to search for.

   # Which tags use different separators ...
   my $exception = $cfg->_get_opt_args (@_);

   my @list = $cfg->find_tags ($search);

   my $ok = 1;
   foreach my $sort ( 0, 1, -1 ) {
      my $lbl = "unsorted";
      $lbl = "sorted"  if ( $sort == 1);
      $lbl = "reverse sorted"  if ( $sort == -1);

      foreach my $tag (@list) {
         my $split = $exception->{$tag};   # Usually undef ... (the split pattern)

         next  if ( defined $split && $split eq "bad" );

         my $test = $cfg->get_list_values ($tag, $split, $sort);
         my @round_test = @{$test};
         my @trunc_test = @{$test};
         truncate_or_round ( \@round_test,  1 );
         truncate_or_round ( \@trunc_test, -1 );

         my $nValue = $cfg->get_list_numeric ( $tag, $split, $sort );
         my $tValue = $cfg->get_list_integer ( $tag, 1, $split, $sort );
         my $rValue = $cfg->get_list_integer ( $tag, 0, $split, $sort );

         my $cnt = @{$test};
         my ($a, $b, $c);
         $a = dbug_ok ( compare_arrays ( 1, $test, $nValue ), "Tag ${tag}'s list of ${cnt} ${lbl} real numbers are the same!");
         $b = dbug_ok ( compare_arrays ( 1, \@round_test, $rValue ), "Tag ${tag}'s list of ${cnt} ${lbl} rounded integers are the same!");
         $c = dbug_ok ( compare_arrays ( 1, \@trunc_test, $tValue ), "Tag ${tag}'s list of ${cnt} ${lbl} truncated integers are the same!");
         $ok = 0  unless ($a && $b && $c);
      }
   }

   DBUG_RETURN ( $ok );
}

# ====================================================================
# Checks for special file/directory names to see if recognized!
# Behaviour may be different on different OS.

sub run_special_tests