lib/Memoize/t/tiefeatures.t

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