view release on metacpan or  search on metacpan

t/13_to.t  view on Meta::CPAN

#!/usr/bin/perl
# 13_to.t
# Tests _make_filler(), get_eye_dir(), slurp_yerself()
# get_eye_properties(), get_eye_keywords(), find_eye_shapes()

use strict;
use Acme::EyeDrops qw(get_eye_dir
                      get_eye_shapes
                      get_eye_properties
                      get_eye_keywords
                      find_eye_shapes);

select(STDERR);$|=1;select(STDOUT);$|=1;  # autoflush

# --------------------------------------------------

sub build_file {
   my ($f, $d) = @_;
   local *F; open(F, '>'.$f) or die "open '$f': $!";
   print F $d or die "write '$f': $!"; close(F);
}

# --------------------------------------------------

my $tmpf = 'bill.tmp';

# --------------------------------------------------
# A valid property file should:
#  1) contain no "weird" chars.
#  2) no line should contain trailing spaces
#  3) be properly newline-terminated
#  4) contain no leading newlines
#  5) contain no trailing newlines
# test_one_propchars() below verifies that is
# the case for all .eyp shapes.
#  6) contain only valid properties
# Tested by get_prop_names()
#  7) contain only valid keywords
# Tested near the end via get_eye_keywords().
# --------------------------------------------------

my @eye_shapes = get_eye_shapes();
my $n_tests = @eye_shapes * 6;
$n_tests += 101;   # plus other tests

print "1..$n_tests\n";

# --------------------------------------------------

my $itest = 0;

# --------------------------------------------------

# Test _make_filler()
{
   my $fillv = '#';
   # This line is used in A::E pour_sightly().
   # Note: 11 is the length of, for example, $:='.'^'~';
   # Multiple of 6 because each filler contains 6 tokens:
   #   $:  =  '.'  ^  '~'  ;
   # Also, no single quoted string should contain " or ;
   # Oh, and $; variable is banned.
   # XXX: add tests for all these later.
   my @filler = Acme::EyeDrops::_make_filler(
                   ref($fillv) ? $fillv : [ '$:', '$~', '$^' ]);
   my $nfiller = @filler;
   $nfiller == 72 or print "not ";
   ++$itest; print "ok $itest - _make_filler 72 items (got $nfiller)\n";
   $nfiller % 6 == 0 or print "not ";
   ++$itest; print "ok $itest - _make_filler multiple of 6 (got $nfiller)\n";

   @filler = Acme::EyeDrops::_make_filler([ '$:', '$~', '$^', '$:', '$~' ]);
   $nfiller = @filler;
   $nfiller == 60 or print "not ";
   ++$itest; print "ok $itest - _make_filler 60 items (got $nfiller)\n";
   $nfiller % 6 == 0 or print "not ";
   ++$itest; print "ok $itest - _make_filler multiple of 6 (got $nfiller)\n";

   my $badfiller = [ '$:', '$~', '$^',
                     '$:', '$~', '$^',
                     '$:', '$~', '$^',
                     '$:', '$~', '$^',
                     '$:' ];
   eval { Acme::EyeDrops::_make_filler($badfiller) };
   $@ or print "not ";
   ++$itest; print "ok $itest - _make_filler, too many filler vars\n";
}

# -----------------------------------------------------------------------

sub test_one_propchars {
   my ($e, $s) = @_;
   $s =~ tr K-_:$@*&!%.;"'`()[]{},/\\ a-zA-Z0-9\nKKc and print "not ";
   ++$itest; print "ok $itest - $e valid chars\n";
   $s =~ / +$/m and print "not ";
   ++$itest; print "ok $itest - $e trailing spaces\n";
   substr($s, 0, 1) eq "\n" and print "not ";
   ++$itest; print "ok $itest - $e leading blank lines\n";
   substr($s, -1, 1) eq "\n" or print "not ";
   ++$itest; print "ok $itest - $e trailing blank lines\n";
   substr($s, -2, 1) eq "\n" and print "not ";
   ++$itest; print "ok $itest - $e properly newline terminated\n";
}

sub test_one_get_properties {
   my ($e, $pstr, $hexp) = @_;
   build_file($tmpf, $pstr);
   my $h = Acme::EyeDrops::_get_properties($tmpf);
   ref($h) eq 'HASH' or print "not ";
   ++$itest; print "ok $itest - _get_properties 1 $e\n";
   my @a = sort keys %$h; my @aexp = sort keys %$hexp;
   scalar(@a) == scalar(@aexp) or print "not ";
   ++$itest; print "ok $itest - _get_properties 2 $e\n";
   return unless @aexp;
   my $min = @a; $min = @aexp if @aexp < $min;
   for my $i (0 .. $min-1) {
      $a[$i] eq $aexp[$i] or print "not ";
      ++$itest; print "ok $itest - _get_properties 3 $e\n";
      $h->{$a[$i]} eq $hexp->{$aexp[$i]} or print "not ";
      ++$itest; print "ok $itest - _get_properties 4 $e\n";
   }
}

sub test_one_find_eye_shapes {
   my ($e, $s, $sexp) = @_;
   my @shapes = find_eye_shapes(@$s);
   scalar(@shapes) == scalar(@$sexp) or print "not ";
   ++$itest; print "ok $itest - find_eye_shapes 1 $e\n";
   return unless @$sexp;
   my $min = @shapes; $min = @$sexp if @$sexp < $min;
   for my $i (0 .. $min-1) {
      $shapes[$i] eq $sexp->[$i] or print "not ";
      ++$itest; print "ok $itest - find_eye_shapes 2 $e\n";
   }
}

sub test_one__find_eye_shapes {
   my ($e, $s, $sexp) = @_;
   my @shapes = Acme::EyeDrops::_find_eye_shapes('.', @$s);
   scalar(@shapes) == scalar(@$sexp) or print "not ";
   ++$itest; print "ok $itest - _find_eye_shapes 1 $e\n";
   return unless @$sexp;
   my $min = @shapes; $min = @$sexp if @$sexp < $min;
   for my $i (0 .. $min-1) {
      $shapes[$i] eq $sexp->[$i] or print "not ";
      ++$itest; print "ok $itest - _find_eye_shapes 2 $e\n";
   }
}

sub get_prop_names {
   my %h;
   for my $s (get_eye_shapes()) {
      my $p = get_eye_properties($s) or next;  # no properties
      my @k = keys(%{$p}) or next;
      for my $k (@k) { push(@{$h{$k}}, $s) }
   }
   return \%h;
}

# Hacked from _get_eye_shapes().
sub _get_eyp_shapes {
   my $d = shift; local *D;
   opendir(D, $d) or die "opendir '$d': $!";
   my @e = sort map(/(.+)\.eyp$/, readdir(D)); closedir(D); @e;
}

# -----------------------------------------------------------------------
# slurp_yerself() tests (primitive)

my $eyedrops_pm = Acme::EyeDrops::slurp_yerself();
my $elen = length($eyedrops_pm);
$elen > 50000 or print "not ";
++$itest; print "ok $itest - slurp_yerself length is $elen\n";
my $nlines = $eyedrops_pm =~ tr/\n//;
$nlines > 1000 or print "not ";
++$itest; print "ok $itest - slurp_yerself line count is $nlines\n";

# XXX: could add MD5 checksum test here.
# XXX: beware above test is fragile when testing auto-generated EyeDrops.pm
#      (as is done by 19_surrounds.t)

# -----------------------------------------------------------------------
# get_eye_dir() tests.

my $eyedir = get_eye_dir();
$eyedir or print "not ";
++$itest; print "ok $itest - get_eye_dir sane\n";
-d $eyedir or print "not ";
++$itest; print "ok $itest - get_eye_dir dir\n";
-f "$eyedir/camel.eye" or print "not ";
++$itest; print "ok $itest - get_eye_dir camel.eye\n";
# v1.50 added eye property (.eyp) files.
-f "$eyedir/camel.eyp" or print "not ";
++$itest; print "ok $itest - get_eye_dir camel.eyp\n";

# -----------------------------------------------------------------------
# Sanity check on all properties files.

{
   # Check that .eye files and .eyp files match.
   my @eyp_shapes = _get_eyp_shapes($eyedir);
   # print STDERR "# There are: " . scalar(@eyp_shapes) . " property files\n";
   scalar(@eye_shapes) == scalar(@eyp_shapes) or print "not ";
   ++$itest; print "ok $itest - num .eyp matches num .eye\n";
   for my $i (0 .. $#eye_shapes) {
      $eye_shapes[$i] eq $eyp_shapes[$i] or print "not ";
      ++$itest; print "ok $itest - '$eye_shapes[$i]' .eye matches .eyp\n";
   }
}

for my $e (@eye_shapes) {
   test_one_propchars($e,
      Acme::EyeDrops::_slurp_tfile($eyedir . '/' . $e . '.eyp'));
}

{
   # XXX: need to update test when update shape properties.
   my $h = get_prop_names();
   # for my $k (sort keys %{$h}) { print "k='$k' v='@{$h->{$k}}'\n" }
   ref($h) eq 'HASH' or print "not ";
   ++$itest; print "ok $itest - valid props, hash ref\n";
   my @skey = sort keys %{$h};
   my $nskey = @skey;
   print STDERR "# properties: @skey\n";
   $nskey == 6 or print "not ";
   ++$itest; print "ok $itest - valid props, number should be $nskey\n";
   for my $k ('author',
              'authorcpanid',
              'description',
              'keywords',
              'nick',
              'source') {
      shift(@skey) eq $k or print "not ";