lib/Memoize/t/tiefeatures.t

   1 #!/usr/bin/perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7 use lib 'blib/lib';
   8 use Memoize 0.45 qw(memoize unmemoize);
   9 use Fcntl;
  10
  11 # print STDERR $INC{'Memoize.pm'}, "\n";
  12
  13 print "1..10\n";
  14
  15 # Test MERGE
  16 sub xx {
  17   wantarray();
  18 }
  19
  20 my $s = xx();
  21 print ((!$s) ? "ok 1\n" : "not ok 1\n");
  22 my ($a) = xx();
  23 print (($a) ? "ok 2\n" : "not ok 2\n");
  24 memoize 'xx', LIST_CACHE => MERGE;
  25 $s = xx();
  26 print ((!$s) ? "ok 3\n" : "not ok 3\n");
  27 ($a) = xx();  # Should return cached false value from previous invocation
  28 print ((!$a) ? "ok 4\n" : "not ok 4\n");
  29
  30
  31 # Test FAULT
  32 sub ns {}
  33 sub na {}
  34 memoize 'ns', SCALAR_CACHE => FAULT;
  35 memoize 'na', LIST_CACHE => FAULT;
  36 eval { my $s = ns() };  # Should fault
  37 print (($@) ?  "ok 5\n" : "not ok 5\n");
  38 eval { my ($a) = na() };  # Should fault
  39 print (($@) ?  "ok 6\n" : "not ok 6\n");
  40
  41
  42 # Test HASH
  43 my (%s, %l);
  44 sub nul {}
  45 memoize 'nul', SCALAR_CACHE => [HASH => \%s], LIST_CACHE => [HASH => \%l];
  46 nul('x');
  47 nul('y');
  48 print ((join '', sort keys %s) eq 'xy' ? "ok 7\n" : "not ok 7\n");
  49 print ((join '', sort keys %l) eq ''   ? "ok 8\n" : "not ok 8\n");
  50 () = nul('p');
  51 () = nul('q');
  52 print ((join '', sort keys %s) eq 'xy' ? "ok 9\n" : "not ok 9\n");
  53 print ((join '', sort keys %l) eq 'pq' ? "ok 10\n" : "not ok 10\n");
  54