view release on metacpan or  search on metacpan

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

   # 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
{
   DBUG_ENTER_FUNC ( @_ );
   my $cfg = shift;

   my ( $dir, $file, $get, $res );
   my $ok = 1;

   my @list = $cfg->find_tags ("^special_");

   foreach my $tag ( @list ) {
      my ($msg1, $msg2);

      $get  = $cfg->get_value ($tag);
      $dir  = $cfg->get_directory ($tag, undef, required => 0);
      $file = $cfg->get_filename ($tag, undef, required => 0);

      # Check what perl has to say about these files/dirs ...
      $msg1 = "Special file test (${get}): ";
      if ( -f $get ) {
         $res = ($file && ! $dir) ? 1 : 0;
         $msg2 = "it's a file!";
      } elsif ( -d $get ) {
         $res = (! $file && $dir) ? 1 : 0;
         $msg2 = "it's a directory!";
      } else {
         $res = (! $file && ! $dir) ? 1 : 0;
         $msg2 = "not a file or directory!";
      }

      dbug_ok ($res, ${msg1} . ${msg2});
      $ok = 0  unless ($res);
   }

   DBUG_RETURN ( $ok );
}

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

   my ($dir, $f, $bad, $ok, $r, $tag);

   # The individual directory tests ...
   $dir = $cfg->get_directory ("dir_1", "r");
   $r = dbug_ok ( $dir, "Found directory: ${dir}");
   $ok = $r;

   $dir = $cfg->get_directory ("dir_2", "rx");
   $r = dbug_ok ( $dir, "Found directory: ${dir}");
   $ok = 0  unless ( $r );

   $dir = $cfg->get_directory ("dir_3", "rwx");
   $r = dbug_ok ( $dir, "Found directory: ${dir}");
   $ok = 0  unless ( $r );

   $tag = "dir_bad_2";
   $dir = $cfg->get_directory ($tag, undef, required => 0);
   $f = $cfg->get_filename ($tag);
   $bad = $cfg->get_value ($tag);
   $r = dbug_ok ( ($f && ! $dir), "It's a file, not a directory: ${bad}" );
   $ok = 0  unless ( $r );

   # ---------------------------------------------------------
   # No-such dir, create dir, no-such dir tests ...
   # ---------------------------------------------------------
   $tag = "dir_bad_1";
   $dir = $cfg->get_directory ($tag, undef, required => 0);
   $f = $cfg->get_filename ($tag, undef, required => 0);
   $bad = $cfg->get_value ($tag);
   $r = dbug_ok ( (! $dir && ! $f), "No such file or directory: ${bad}" );
   $ok = 0  unless ( $r );

   mkdir ( $bad ) or die ("Can't create directory: ${bad}\n");
   $dir = $cfg->get_directory ($tag);
   $r = dbug_ok ( ($dir && ! $f), "The directory now exists! ${bad}" );