view release on metacpan or  search on metacpan

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

            dbug_ok (0, "Tag ${tag}'s hash key ($k) has the right value!  ($val)");
            DBUG_PRINT ( "WARN", 'HASH $%s->{%s} = %s', $tag, $k, $v);
            $ok = 0;
         }
      }

      # Build the hash to test the merged hash against later on ...
      foreach ( @{$lst} ) {
         $expected{$_} = $val   unless ( exists $expected{$_} );
      }

      # Verify the merge hash has all these new entries ...
      foreach my $k ( @hlst ) {
         unless ( exists $merge{$k} ) {
            dbug_ok (0, "Tag ${tag}'s hash contained key ${k}");
            $ok = 0;
            next;
         }
         unless ( 1 <= $merge{$k} && $merge{$k} <= $val ) {
            dbug_ok (0, "Tag ${tag}'s hash value for key ${k} is between 1 and ${val} as expected!  ($merge{$k})");
            $ok = 0;
            next;
         }
      }

      foreach my $k ( keys %merge ) {
         next  if ( exists $hsh->{$k} );
         next  if ( 1 <= $merge{$k} && $merge{$k} < $val );
         my $max = $val - 1;
         dbug_ok (0, "The merge hash's value for key ${k} is between 1 and ${max} as expected!  ($merge{$k})");
         $ok = 0;
      }
   }    # foreach $tag loop ...

   # Validate the merge hash contents ...
   my @lst1 = sort { $a <=> $b } keys %expected;
   my @lst2 = sort { $a <=> $b } keys %merge;
   my $r = dbug_ok ( compare_arrays ( 0, \@lst1, \@lst2 ), "The merge hash has the correct keys!  (" . join (", ", @lst1) . ")" );
   unless ( $r ) {
      DBUG_PRINT ( "WARN", "The merge hash had these keys (%s)", join (", ", @lst2) );
      $ok = 0;
   } else {
      foreach ( @lst1 ) {
         if ( $expected{$_} ne $merge{$_} ) {
            dbug_ok (0, "The merge hash had the expected values!");
            $ok = 0;
            last;
         }
      }
   }

   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;

   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!");