t/lib/u-reftype.t

   1 BEGIN {
   2         chdir 't' if -d 't';
   3         @INC = '../lib';
   4         require Config; import Config;
   5         if ($Config{extensions} !~ /\bList\/Util\b/) {
   6             print "1..0 # Skip: List::Util was not built\n";
   7             exit 0;
   8         }
   9 }
  10
  11 use Scalar::Util qw(reftype);
  12 use vars qw($t $y $x *F);
  13 use Symbol qw(gensym);
  14
  15 # Ensure we do not trigger and tied methods
  16 tie *F, 'MyTie';
  17
  18 @test = (
  19  [ undef, 1],
  20  [ undef, 'A'],
  21  [ HASH => {} ],
  22  [ ARRAY => [] ],
  23  [ SCALAR => \$t ],
  24  [ REF    => \(\$t) ],
  25  [ GLOB   => \*F ],
  26  [ GLOB   => gensym ],
  27  [ CODE   => sub {} ],
  28 # [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN
  29 );
  30
  31 print "1..", @test*4, "\n";
  32
  33 my $i = 1;
  34 foreach $test (@test) {
  35   my($type,$what) = @$test;
  36   my $pack;
  37   foreach $pack (undef,"ABC","0",undef) {
  38     print "# $what\n";
  39     my $res = reftype($what);
  40     printf "# %s - %s\n", map { defined($_) ? $_ : 'undef' } $type,$res;
  41     print "not " if $type ? $res ne $type : defined($res);
  42     bless $what, $pack if $type && defined $pack;
  43     print "ok ",$i++,"\n";
  44   }
  45 }
  46
  47 package MyTie;
  48
  49 sub TIEHANDLE { bless {} }
  50 sub DESTROY {}
  51
  52 sub AUTOLOAD {
  53   warn "$AUTOLOAD called";
  54   exit 1; # May be in an eval
  55 }