lib/builtin.t

   1 #!./perl -T
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 use v5.36;
  10 no warnings 'experimental::builtin';
  11
  12 package FetchStoreCounter {
  13     sub TIESCALAR($class, @args) { bless \@args, $class }
  14
  15     sub FETCH($self)    { $self->[0]->$*++ }
  16     sub STORE($self, $) { $self->[1]->$*++ }
  17 }
  18
  19 # booleans
  20 {
  21     use builtin qw( true false is_bool );
  22
  23     ok(true, 'true is true');
  24     ok(!false, 'false is false');
  25
  26     ok(is_bool(true), 'true is bool');
  27     ok(is_bool(false), 'false is bool');
  28     ok(!is_bool(undef), 'undef is not bool');
  29     ok(!is_bool(1), '1 is not bool');
  30     ok(!is_bool(""), 'empty is not bool');
  31
  32     my $truevar  = (5 == 5);
  33     my $falsevar = (5 == 6);
  34
  35     ok(is_bool($truevar), '$truevar is bool');
  36     ok(is_bool($falsevar), '$falsevar is bool');
  37
  38     ok(is_bool(is_bool(true)), 'is_bool true is bool');
  39     ok(is_bool(is_bool(123)),  'is_bool false is bool');
  40
  41     # Invokes magic
  42
  43     tie my $tied, FetchStoreCounter => (\my $fetchcount, \my $storecount);
  44
  45     my $_dummy = is_bool($tied);
  46     is($fetchcount, 1, 'is_bool() invokes FETCH magic');
  47
  48     $tied = is_bool(false);
  49     is($storecount, 1, 'is_bool() invokes STORE magic');
  50
  51     is(prototype(\&builtin::is_bool), '$', 'is_bool prototype');
  52 }
  53
  54 # weakrefs
  55 {
  56     use builtin qw( is_weak weaken unweaken );
  57
  58     my $arr = [];
  59     my $ref = $arr;
  60
  61     ok(!is_weak($ref), 'ref is not weak initially');
  62
  63     weaken($ref);
  64     ok(is_weak($ref), 'ref is weak after weaken()');
  65
  66     unweaken($ref);
  67     ok(!is_weak($ref), 'ref is not weak after unweaken()');
  68
  69     weaken($ref);
  70     undef $arr;
  71     is($ref, undef, 'ref is now undef after arr is cleared');
  72
  73     is(prototype(\&builtin::weaken), '$', 'weaken prototype');
  74     is(prototype(\&builtin::unweaken), '$', 'unweaken prototype');
  75     is(prototype(\&builtin::is_weak), '$', 'is_weak prototype');
  76 }
  77
  78 # reference queries
  79 {
  80     use builtin qw( refaddr reftype blessed );
  81
  82     my $arr = [];
  83     my $obj = bless [], "Object";
  84
  85     is(refaddr($arr),        $arr+0, 'refaddr yields same as ref in numeric context');
  86     is(refaddr("not a ref"), undef,  'refaddr yields undef for non-reference');
  87
  88     is(reftype($arr),        "ARRAY", 'reftype yields type string');
  89     is(reftype($obj),        "ARRAY", 'reftype yields basic container type for blessed object');
  90     is(reftype("not a ref"), undef,   'reftype yields undef for non-reference');
  91
  92     is(blessed($arr), undef, 'blessed yields undef for non-object');
  93     is(blessed($obj), "Object", 'blessed yields package name for object');
  94
  95     # blessed() as a boolean
  96     is(blessed($obj) ? "YES" : "NO", "YES", 'blessed in boolean context still works');
  97
  98     # blessed() appears false as a boolean on package "0"
  99     is(blessed(bless [], "0") ? "YES" : "NO", "NO", 'blessed in boolean context handles "0" cornercase');
 100
 101     is(prototype(\&builtin::blessed), '$', 'blessed prototype');
 102     is(prototype(\&builtin::refaddr), '$', 'refaddr prototype');
 103     is(prototype(\&builtin::reftype), '$', 'reftype prototype');
 104 }
 105
 106 # created_as_...
 107 {
 108     use builtin qw( created_as_string created_as_number );
 109
 110     # some literal constants
 111     ok(!created_as_string(undef), 'undef created as !string');
 112     ok(!created_as_number(undef), 'undef created as !number');
 113
 114     ok( created_as_string("abc"), 'abc created as string');
 115     ok(!created_as_number("abc"), 'abc created as number');
 116
 117     ok(!created_as_string(123),   '123 created as !string');
 118     ok( created_as_number(123),   '123 created as !number');
 119
 120     ok(!created_as_string(1.23),   '1.23 created as !string');
 121     ok( created_as_number(1.23),   '1.23 created as !number');
 122
 123     ok(!created_as_string([]),    '[] created as !string');
 124     ok(!created_as_number([]),    '[] created as !number');
 125
 126     ok(!created_as_string(builtin::true), 'true created as !string');
 127     ok(!created_as_number(builtin::true), 'true created as !number');
 128
 129     ok(builtin::is_bool(created_as_string(0)), 'created_as_string returns bool');
 130     ok(builtin::is_bool(created_as_number(0)), 'created_as_number returns bool');
 131
 132     # variables
 133     my $just_pv = "def";
 134     ok( created_as_string($just_pv), 'def created as string');
 135     ok(!created_as_number($just_pv), 'def created as number');
 136
 137     my $just_iv = 456;
 138     ok(!created_as_string($just_iv), '456 created as string');
 139     ok( created_as_number($just_iv), '456 created as number');
 140
 141     my $just_nv = 4.56;
 142     ok(!created_as_string($just_nv), '456 created as string');
 143     ok( created_as_number($just_nv), '456 created as number');
 144
 145     # variables reused
 146     my $originally_pv = "1";
 147     my $pv_as_iv = $originally_pv + 0;
 148     ok( created_as_string($originally_pv), 'PV reused as IV created as string');
 149     ok(!created_as_number($originally_pv), 'PV reused as IV created as !number');
 150     ok(!created_as_string($pv_as_iv), 'New number from PV created as !string');
 151     ok( created_as_number($pv_as_iv), 'New number from PV created as number');
 152
 153     my $originally_iv = 1;
 154     my $iv_as_pv = "$originally_iv";
 155     ok(!created_as_string($originally_iv), 'IV reused as PV created as !string');
 156     ok( created_as_number($originally_iv), 'IV reused as PV created as number');
 157     ok( created_as_string($iv_as_pv), 'New string from IV created as string');
 158     ok(!created_as_number($iv_as_pv), 'New string from IV created as !number');
 159
 160     my $originally_nv = 1.1;
 161     my $nv_as_pv = "$originally_nv";
 162     ok(!created_as_string($originally_nv), 'NV reused as PV created as !string');
 163     ok( created_as_number($originally_nv), 'NV reused as PV created as number');
 164     ok( created_as_string($nv_as_pv), 'New string from NV created as string');
 165     ok(!created_as_number($nv_as_pv), 'New string from NV created as !number');
 166
 167     # magic
 168     local $1;
 169     "hello" =~ m/(.*)/;
 170     ok(created_as_string($1), 'magic string');
 171
 172     is(prototype(\&builtin::created_as_string), '$', 'created_as_string prototype');
 173     is(prototype(\&builtin::created_as_number), '$', 'created_as_number prototype');
 174 }
 175
 176 # ceil, floor
 177 {
 178     use builtin qw( ceil floor );
 179
 180     cmp_ok(ceil(1.5), '==', 2, 'ceil(1.5) == 2');
 181     cmp_ok(floor(1.5), '==', 1, 'floor(1.5) == 1');
 182
 183     # Invokes magic
 184
 185     tie my $tied, FetchStoreCounter => (\my $fetchcount, \my $storecount);
 186
 187     my $_dummy = ceil($tied);
 188     is($fetchcount, 1, 'ceil() invokes FETCH magic');
 189
 190     $tied = ceil(1.1);
 191     is($storecount, 1, 'ceil() TARG invokes STORE magic');
 192
 193     $fetchcount = $storecount = 0;
 194     tie $tied, FetchStoreCounter => (\$fetchcount, \$storecount);
 195
 196     $_dummy = floor($tied);
 197     is($fetchcount, 1, 'floor() invokes FETCH magic');
 198
 199     $tied = floor(1.1);
 200     is($storecount, 1, 'floor() TARG invokes STORE magic');
 201
 202     is(prototype(\&builtin::ceil), '$', 'ceil prototype');
 203     is(prototype(\&builtin::floor), '$', 'floor prototype');
 204 }
 205
 206 # imports are lexical; should not be visible here
 207 {
 208     my $ok = eval 'true()'; my $e = $@;
 209     ok(!$ok, 'true() not visible outside of lexical scope');
 210     like($e, qr/^Undefined subroutine &main::true called at /, 'failure from true() not visible');
 211 }
 212
 213 # lexical imports work fine in a variety of situations
 214 {
 215     sub regularfunc {
 216         use builtin 'true';
 217         return true;
 218     }
 219     ok(regularfunc(), 'true in regular sub');
 220
 221     my sub lexicalfunc {
 222         use builtin 'true';
 223         return true;
 224     }
 225     ok(lexicalfunc(), 'true in lexical sub');
 226
 227     my $coderef = sub {
 228         use builtin 'true';
 229         return true;
 230     };
 231     ok($coderef->(), 'true in anon sub');
 232
 233     sub recursefunc {
 234         use builtin 'true';
 235         return recursefunc() if @_;
 236         return true;
 237     }
 238     ok(recursefunc("rec"), 'true in self-recursive sub');
 239
 240     my $recursecoderef = sub {
 241         use feature 'current_sub';
 242         use builtin 'true';
 243         return __SUB__->() if @_;
 244         return true;
 245     };
 246     ok($recursecoderef->("rec"), 'true in self-recursive anon sub');
 247 }
 248
 249 {
 250     use builtin qw( true false );
 251
 252     my $val = true;
 253     cmp_ok($val, $_, !!1, "true is equivalent to !!1 by $_") for qw( eq == );
 254     cmp_ok($val, $_,  !0, "true is equivalent to  !0 by $_") for qw( eq == );
 255
 256     $val = false;
 257     cmp_ok($val, $_, !!0, "false is equivalent to !!0 by $_") for qw( eq == );
 258     cmp_ok($val, $_,  !1, "false is equivalent to  !1 by $_") for qw( eq == );
 259 }
 260
 261 # indexed
 262 {
 263     use builtin qw( indexed );
 264
 265     # We don't have Test::More's is_deeply here
 266
 267     ok(eq_array([indexed], [] ),
 268         'indexed on empty list');
 269
 270     ok(eq_array([indexed "A"], [0, "A"] ),
 271         'indexed on singleton list');
 272
 273     ok(eq_array([indexed "X" .. "Z"], [0, "X", 1, "Y", 2, "Z"] ),
 274         'indexed on 3-item list');
 275
 276     my @orig = (1..3);
 277     $_++ for indexed @orig;
 278     ok(eq_array(\@orig, [1 .. 3]), 'indexed copies values, does not alias');
 279
 280     {
 281         no warnings 'experimental::for_list';
 282
 283         my $ok = 1;
 284         foreach my ($len, $s) (indexed "", "x", "xx") {
 285             length($s) == $len or undef $ok;
 286         }
 287         ok($ok, 'indexed operates nicely with multivar foreach');
 288     }
 289
 290     {
 291         my %hash = indexed "a" .. "e";
 292         ok(eq_hash(\%hash, { 0 => "a", 1 => "b", 2 => "c", 3 => "d", 4 => "e" }),
 293             'indexed can be used to create hashes');
 294     }
 295
 296     {
 297         no warnings 'scalar';
 298
 299         my $count = indexed 'i', 'ii', 'iii', 'iv';
 300         is($count, 8, 'indexed in scalar context yields size of list it would return');
 301     }
 302 }
 303
 304 # Vanilla trim tests
 305 {
 306     use builtin qw( trim );
 307
 308     is(trim("    Hello world!   ")      , "Hello world!"  , 'trim spaces');
 309     is(trim("\tHello world!\t")         , "Hello world!"  , 'trim tabs');
 310     is(trim("\n\n\nHello\nworld!\n")    , "Hello\nworld!" , 'trim \n');
 311     is(trim("\t\n\n\nHello world!\n \t"), "Hello world!"  , 'trim all three');
 312     is(trim("Perl")                     , "Perl"          , 'trim nothing');
 313     is(trim('')                         , ""              , 'trim empty string');
 314
 315     is(prototype(\&builtin::trim), '$', 'trim prototype');
 316 }
 317
 318 TODO: {
 319     my $warn = '';
 320     local $SIG{__WARN__} = sub { $warn .= join "", @_; };
 321
 322     is(builtin::trim(undef), "", 'trim undef');
 323     like($warn    , qr/^Use of uninitialized value in subroutine entry at/,
 324          'trim undef triggers warning');
 325     local $main::TODO = "Currently uses generic value for the name of non-opcode builtins";
 326     like($warn    , qr/^Use of uninitialized value in trim at/,
 327          'trim undef triggers warning using actual name of builtin');
 328 }
 329
 330 # Fancier trim tests against a regexp and unicode
 331 {
 332     use builtin qw( trim );
 333     my $nbsp = chr utf8::unicode_to_native(0xA0);
 334
 335     is(trim("   \N{U+2603}       "), "\N{U+2603}", 'trim with unicode content');
 336     is(trim("\N{U+2029}foobar\x{2028} "), "foobar",
 337             'trim with unicode whitespace');
 338     is(trim("$nbsp foobar$nbsp    "), "foobar", 'trim with latin1 whitespace');
 339 }
 340
 341 # Test on a magical fetching variable
 342 {
 343     use builtin qw( trim );
 344
 345     my $str3 = "   Hello world!\t";
 346     $str3 =~ m/(.+Hello)/;
 347     is(trim($1), "Hello", "trim on a magical variable");
 348 }
 349
 350 # Inplace edit, my, our variables
 351 {
 352     use builtin qw( trim );
 353
 354     my $str4 = "\t\tHello world!\n\n";
 355     $str4 = trim($str4);
 356     is($str4, "Hello world!", "trim on an inplace variable");
 357
 358     our $str2 = "\t\nHello world!\t  ";
 359     is(trim($str2), "Hello world!", "trim on an our \$var");
 360 }
 361
 362 # is_tainted
 363 {
 364     use builtin qw( is_tainted );
 365
 366     is(is_tainted($0), !!${^TAINT}, "\$0 is tainted (if tainting is supported)");
 367     ok(!is_tainted($1), "\$1 isn't tainted");
 368
 369     # Invokes magic
 370     tie my $tied, FetchStoreCounter => (\my $fetchcount, \my $storecount);
 371
 372     my $_dummy = is_tainted($tied);
 373     is($fetchcount, 1, 'is_tainted() invokes FETCH magic');
 374
 375     $tied = is_tainted($0);
 376     is($storecount, 1, 'is_tainted() invokes STORE magic');
 377
 378     is(prototype(\&builtin::is_tainted), '$', 'is_tainted prototype');
 379 }
 380
 381 # Lexical export
 382 {
 383     my $name;
 384     BEGIN {
 385         use builtin qw( export_lexically );
 386
 387         $name = "message";
 388         export_lexically $name => sub { "Hello, world" };
 389     }
 390
 391     is(message(), "Hello, world", 'Lexically exported sub is callable');
 392     ok(!__PACKAGE__->can("message"), 'Exported sub is not visible via ->can');
 393
 394     is($name, "message", '$name argument was not modified by export_lexically');
 395
 396     our ( $scalar, @array, %hash );
 397     BEGIN {
 398         use builtin qw( export_lexically );
 399
 400         export_lexically
 401             '$SCALAR' => \$scalar,
 402             '@ARRAY'  => \@array,
 403             '%HASH'   => \%hash;
 404     }
 405
 406     $::scalar = "value";
 407     is($SCALAR, "value", 'Lexically exported scalar is accessible');
 408
 409     @::array = ('a' .. 'e');
 410     is(scalar @ARRAY, 5, 'Lexically exported array is accessible');
 411
 412     %::hash = (key => "val");
 413     is($HASH{key}, "val", 'Lexically exported hash is accessible');
 414 }
 415
 416 # vim: tabstop=4 shiftwidth=4 expandtab autoindent softtabstop=4
 417
 418 done_testing();