1#!./perl -T 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8 9use v5.36; 10no warnings 'experimental::builtin'; 11 12package 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 318TODO: { 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 418done_testing(); 419