lib/builtin.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 use strict;
  10 use warnings;
  11
  12 package FetchStoreCounter {
  13     sub new { my $class = shift; return bless [@_], $class }
  14     sub TIESCALAR { return shift->new(@_) }
  15     sub FETCH { ${shift->[0]}++ }
  16     sub STORE { ${shift->[1]}++ }
  17 }
  18
  19 # booleans
  20 {
  21     use builtin qw( true false isbool );
  22
  23     ok(true, 'true is true');
  24     ok(!false, 'false is false');
  25
  26     ok(isbool(true), 'true is bool');
  27     ok(isbool(false), 'false is bool');
  28     ok(!isbool(undef), 'undef is not bool');
  29     ok(!isbool(1), '1 is not bool');
  30     ok(!isbool(""), 'empty is not bool');
  31
  32     my $truevar  = (5 == 5);
  33     my $falsevar = (5 == 6);
  34
  35     ok(isbool($truevar), '$truevar is bool');
  36     ok(isbool($falsevar), '$falsevar is bool');
  37
  38     ok(isbool(isbool(true)), 'isbool true is bool');
  39     ok(isbool(isbool(123)),  'isbool false is bool');
  40
  41     # Invokes magic
  42
  43     tie my $tied, FetchStoreCounter => (\my $fetchcount, \my $storecount);
  44
  45     my $_dummy = isbool($tied);
  46     is($fetchcount, 1, 'isbool() invokes FETCH magic');
  47
  48     $tied = isbool(false);
  49     is($storecount, 1, 'isbool() TARG invokes STORE magic');
  50 }
  51
  52 # weakrefs
  53 {
  54     use builtin qw( isweak weaken unweaken );
  55
  56     my $arr = [];
  57     my $ref = $arr;
  58
  59     ok(!isweak($ref), 'ref is not weak initially');
  60
  61     weaken($ref);
  62     ok(isweak($ref), 'ref is weak after weaken()');
  63
  64     unweaken($ref);
  65     ok(!isweak($ref), 'ref is not weak after unweaken()');
  66
  67     weaken($ref);
  68     undef $arr;
  69     is($ref, undef, 'ref is now undef after arr is cleared');
  70 }
  71
  72 # reference queries
  73 {
  74     use builtin qw( refaddr reftype blessed );
  75
  76     my $arr = [];
  77     my $obj = bless [], "Object";
  78
  79     is(refaddr($arr),        $arr+0, 'refaddr yields same as ref in numeric context');
  80     is(refaddr("not a ref"), undef,  'refaddr yields undef for non-reference');
  81
  82     is(reftype($arr),        "ARRAY", 'reftype yields type string');
  83     is(reftype($obj),        "ARRAY", 'reftype yields basic container type for blessed object');
  84     is(reftype("not a ref"), undef,   'reftype yields undef for non-reference');
  85
  86     is(blessed($arr), undef, 'blessed yields undef for non-object');
  87     is(blessed($obj), "Object", 'blessed yields package name for object');
  88
  89     # blessed() as a boolean
  90     is(blessed($obj) ? "YES" : "NO", "YES", 'blessed in boolean context still works');
  91
  92     # blessed() appears false as a boolean on package "0"
  93     is(blessed(bless [], "0") ? "YES" : "NO", "NO", 'blessed in boolean context handles "0" cornercase');
  94 }
  95
  96 # imports are lexical; should not be visible here
  97 {
  98     my $ok = eval 'true()'; my $e = $@;
  99     ok(!$ok, 'true() not visible outside of lexical scope');
 100     like($e, qr/^Undefined subroutine &main::true called at /, 'failure from true() not visible');
 101 }
 102
 103 # lexical imports work fine in a variety of situations
 104 {
 105     sub regularfunc {
 106         use builtin 'true';
 107         return true;
 108     }
 109     ok(regularfunc(), 'true in regular sub');
 110
 111     my sub lexicalfunc {
 112         use builtin 'true';
 113         return true;
 114     }
 115     ok(lexicalfunc(), 'true in lexical sub');
 116
 117     my $coderef = sub {
 118         use builtin 'true';
 119         return true;
 120     };
 121     ok($coderef->(), 'true in anon sub');
 122
 123     sub recursefunc {
 124         use builtin 'true';
 125         return recursefunc() if @_;
 126         return true;
 127     }
 128     ok(recursefunc("rec"), 'true in self-recursive sub');
 129
 130     my $recursecoderef = sub {
 131         use feature 'current_sub';
 132         use builtin 'true';
 133         return __SUB__->() if @_;
 134         return true;
 135     };
 136     ok($recursecoderef->("rec"), 'true in self-recursive anon sub');
 137 }
 138
 139 {
 140     use builtin qw( true false );
 141
 142     my $val = true;
 143     cmp_ok($val, $_, !!1, "true is equivalent to !!1 by $_") for qw( eq == );
 144     cmp_ok($val, $_,  !0, "true is equivalent to  !0 by $_") for qw( eq == );
 145
 146     $val = false;
 147     cmp_ok($val, $_, !!0, "false is equivalent to !!0 by $_") for qw( eq == );
 148     cmp_ok($val, $_,  !1, "false is equivalent to  !1 by $_") for qw( eq == );
 149 }
 150
 151 done_testing();