1 /* builtin.c 2 * 3 * Copyright (C) 2021 by Paul Evans and others 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* This file contains the code that implements functions in perl's "builtin::" 11 * namespace 12 */ 13 14 #include "EXTERN.h" 15 #include "perl.h" 16 17 #include "XSUB.h" 18 19 struct BuiltinFuncDescriptor { 20 const char *name; 21 XSUBADDR_t xsub; 22 OP *(*checker)(pTHX_ OP *, GV *, SV *); 23 IV ckval; 24 }; 25 26 #define warn_experimental_builtin(name, prefix) S_warn_experimental_builtin(aTHX_ name, prefix) 27 static void S_warn_experimental_builtin(pTHX_ const char *name, bool prefix) 28 { 29 /* diag_listed_as: Built-in function '%s' is experimental */ 30 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BUILTIN), 31 "Built-in function '%s%s' is experimental", 32 prefix ? "builtin::" : "", name); 33 } 34 35 /* These three utilities might want to live elsewhere to be reused from other 36 * code sometime 37 */ 38 #define prepare_export_lexical() S_prepare_export_lexical(aTHX) 39 static void S_prepare_export_lexical(pTHX) 40 { 41 assert(PL_compcv); 42 43 /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */ 44 ENTER; 45 SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); 46 SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1]; 47 SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); 48 } 49 50 #define export_lexical(name, sv) S_export_lexical(aTHX_ name, sv) 51 static void S_export_lexical(pTHX_ SV *name, SV *sv) 52 { 53 PADOFFSET off = pad_add_name_sv(name, padadd_STATE, 0, 0); 54 SvREFCNT_dec(PL_curpad[off]); 55 PL_curpad[off] = SvREFCNT_inc(sv); 56 } 57 58 #define finish_export_lexical() S_finish_export_lexical(aTHX) 59 static void S_finish_export_lexical(pTHX) 60 { 61 intro_my(); 62 63 LEAVE; 64 } 65 66 67 XS(XS_builtin_true); 68 XS(XS_builtin_true) 69 { 70 dXSARGS; 71 warn_experimental_builtin("true", true); 72 if(items) 73 croak_xs_usage(cv, ""); 74 XSRETURN_YES; 75 } 76 77 XS(XS_builtin_false); 78 XS(XS_builtin_false) 79 { 80 dXSARGS; 81 warn_experimental_builtin("false", true); 82 if(items) 83 croak_xs_usage(cv, ""); 84 XSRETURN_NO; 85 } 86 87 enum { 88 BUILTIN_CONST_FALSE, 89 BUILTIN_CONST_TRUE, 90 }; 91 92 static OP *ck_builtin_const(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) 93 { 94 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj)); 95 96 warn_experimental_builtin(builtin->name, false); 97 98 SV *prototype = newSVpvs(""); 99 SAVEFREESV(prototype); 100 101 assert(entersubop->op_type == OP_ENTERSUB); 102 103 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); 104 105 SV *constval; 106 switch(builtin->ckval) { 107 case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break; 108 case BUILTIN_CONST_TRUE: constval = &PL_sv_yes; break; 109 default: 110 DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf, 111 builtin->ckval); 112 break; 113 } 114 115 op_free(entersubop); 116 117 return newSVOP(OP_CONST, 0, constval); 118 } 119 120 XS(XS_builtin_func1_scalar); 121 XS(XS_builtin_func1_scalar) 122 { 123 dXSARGS; 124 dXSI32; 125 126 warn_experimental_builtin(PL_op_name[ix], true); 127 128 if(items != 1) 129 croak_xs_usage(cv, "arg"); 130 131 switch(ix) { 132 case OP_IS_BOOL: 133 Perl_pp_is_bool(aTHX); 134 break; 135 136 case OP_IS_WEAK: 137 Perl_pp_is_weak(aTHX); 138 break; 139 140 case OP_BLESSED: 141 Perl_pp_blessed(aTHX); 142 break; 143 144 case OP_REFADDR: 145 Perl_pp_refaddr(aTHX); 146 break; 147 148 case OP_REFTYPE: 149 Perl_pp_reftype(aTHX); 150 break; 151 152 case OP_CEIL: 153 Perl_pp_ceil(aTHX); 154 break; 155 156 case OP_FLOOR: 157 Perl_pp_floor(aTHX); 158 break; 159 160 case OP_IS_TAINTED: 161 Perl_pp_is_tainted(aTHX); 162 break; 163 164 default: 165 Perl_die(aTHX_ "panic: unhandled opcode %" IVdf 166 " for xs_builtin_func1_scalar()", (IV) ix); 167 } 168 169 XSRETURN(1); 170 } 171 172 XS(XS_builtin_trim); 173 XS(XS_builtin_trim) 174 { 175 dXSARGS; 176 177 warn_experimental_builtin("trim", true); 178 179 if (items != 1) { 180 croak_xs_usage(cv, "arg"); 181 } 182 183 dTARGET; 184 SV *source = TOPs; 185 STRLEN len; 186 const U8 *start; 187 SV *dest; 188 189 SvGETMAGIC(source); 190 191 if (SvOK(source)) 192 start = (const U8*)SvPV_nomg_const(source, len); 193 else { 194 if (ckWARN(WARN_UNINITIALIZED)) 195 report_uninit(source); 196 start = (const U8*)""; 197 len = 0; 198 } 199 200 if (DO_UTF8(source)) { 201 const U8 *end = start + len; 202 203 /* Find the first non-space */ 204 while(len) { 205 STRLEN thislen; 206 if (!isSPACE_utf8_safe(start, end)) 207 break; 208 start += (thislen = UTF8SKIP(start)); 209 len -= thislen; 210 } 211 212 /* Find the final non-space */ 213 STRLEN thislen; 214 const U8 *cur_end = end; 215 while ((thislen = is_SPACE_utf8_safe_backwards(cur_end, start))) { 216 cur_end -= thislen; 217 } 218 len -= (end - cur_end); 219 } 220 else if (len) { 221 while(len) { 222 if (!isSPACE_L1(*start)) 223 break; 224 start++; 225 len--; 226 } 227 228 while(len) { 229 if (!isSPACE_L1(start[len-1])) 230 break; 231 len--; 232 } 233 } 234 235 dest = TARG; 236 237 if (SvPOK(dest) && (dest == source)) { 238 sv_chop(dest, (const char *)start); 239 SvCUR_set(dest, len); 240 } 241 else { 242 SvUPGRADE(dest, SVt_PV); 243 SvGROW(dest, len + 1); 244 245 Copy(start, SvPVX(dest), len, U8); 246 SvPVX(dest)[len] = '\0'; 247 SvPOK_on(dest); 248 SvCUR_set(dest, len); 249 250 if (DO_UTF8(source)) 251 SvUTF8_on(dest); 252 else 253 SvUTF8_off(dest); 254 255 if (SvTAINTED(source)) 256 SvTAINT(dest); 257 } 258 259 SvSETMAGIC(dest); 260 261 SETs(dest); 262 263 XSRETURN(1); 264 } 265 266 XS(XS_builtin_export_lexically); 267 XS(XS_builtin_export_lexically) 268 { 269 dXSARGS; 270 271 warn_experimental_builtin("export_lexically", true); 272 273 if(!PL_compcv) 274 Perl_croak(aTHX_ 275 "export_lexically can only be called at compile time"); 276 277 if(items % 2) 278 Perl_croak(aTHX_ "Odd number of elements in export_lexically"); 279 280 for(int i = 0; i < items; i += 2) { 281 SV *name = ST(i); 282 SV *ref = ST(i+1); 283 284 if(!SvROK(ref)) 285 /* diag_listed_as: Expected %s reference in export_lexically */ 286 Perl_croak(aTHX_ "Expected a reference in export_lexically"); 287 288 char sigil = SvPVX(name)[0]; 289 SV *rv = SvRV(ref); 290 291 const char *bad = NULL; 292 switch(sigil) { 293 default: 294 /* overwrites the pointer on the stack; but this is fine, the 295 * caller's value isn't modified */ 296 ST(i) = name = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(name))); 297 298 /* FALLTHROUGH */ 299 case '&': 300 if(SvTYPE(rv) != SVt_PVCV) 301 bad = "a CODE"; 302 break; 303 304 case '$': 305 /* Permit any of SVt_NULL to SVt_PVMG. Technically this also 306 * includes SVt_INVLIST but it isn't thought possible for pureperl 307 * code to ever manage to see one of those. */ 308 if(SvTYPE(rv) > SVt_PVMG) 309 bad = "a SCALAR"; 310 break; 311 312 case '@': 313 if(SvTYPE(rv) != SVt_PVAV) 314 bad = "an ARRAY"; 315 break; 316 317 case '%': 318 if(SvTYPE(rv) != SVt_PVHV) 319 bad = "a HASH"; 320 break; 321 } 322 323 if(bad) 324 Perl_croak(aTHX_ "Expected %s reference in export_lexically", bad); 325 } 326 327 prepare_export_lexical(); 328 329 for(int i = 0; i < items; i += 2) { 330 SV *name = ST(i); 331 SV *ref = ST(i+1); 332 333 export_lexical(name, SvRV(ref)); 334 } 335 336 finish_export_lexical(); 337 } 338 339 XS(XS_builtin_func1_void); 340 XS(XS_builtin_func1_void) 341 { 342 dXSARGS; 343 dXSI32; 344 345 warn_experimental_builtin(PL_op_name[ix], true); 346 347 if(items != 1) 348 croak_xs_usage(cv, "arg"); 349 350 switch(ix) { 351 case OP_WEAKEN: 352 Perl_pp_weaken(aTHX); 353 break; 354 355 case OP_UNWEAKEN: 356 Perl_pp_unweaken(aTHX); 357 break; 358 359 default: 360 Perl_die(aTHX_ "panic: unhandled opcode %" IVdf 361 " for xs_builtin_func1_void()", (IV) ix); 362 } 363 364 XSRETURN(0); 365 } 366 367 XS(XS_builtin_created_as_string) 368 { 369 dXSARGS; 370 371 if(items != 1) 372 croak_xs_usage(cv, "arg"); 373 374 SV *arg = ST(0); 375 SvGETMAGIC(arg); 376 377 /* SV was created as string if it has POK and isn't bool */ 378 ST(0) = boolSV(SvPOK(arg) && !SvIsBOOL(arg)); 379 XSRETURN(1); 380 } 381 382 XS(XS_builtin_created_as_number) 383 { 384 dXSARGS; 385 386 if(items != 1) 387 croak_xs_usage(cv, "arg"); 388 389 SV *arg = ST(0); 390 SvGETMAGIC(arg); 391 392 /* SV was created as number if it has NOK or IOK but not POK and is not bool */ 393 ST(0) = boolSV(SvNIOK(arg) && !SvPOK(arg) && !SvIsBOOL(arg)); 394 XSRETURN(1); 395 } 396 397 static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) 398 { 399 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj)); 400 401 warn_experimental_builtin(builtin->name, false); 402 403 SV *prototype = newSVpvs("$"); 404 SAVEFREESV(prototype); 405 406 assert(entersubop->op_type == OP_ENTERSUB); 407 408 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); 409 410 OPCODE opcode = builtin->ckval; 411 if(!opcode) 412 return entersubop; 413 414 OP *parent = entersubop, *pushop, *argop; 415 416 pushop = cUNOPx(entersubop)->op_first; 417 if (!OpHAS_SIBLING(pushop)) { 418 pushop = cUNOPx(pushop)->op_first; 419 } 420 421 argop = OpSIBLING(pushop); 422 423 if (!argop || !OpHAS_SIBLING(argop) || OpHAS_SIBLING(OpSIBLING(argop))) 424 return entersubop; 425 426 (void)op_sibling_splice(parent, pushop, 1, NULL); 427 428 U8 wantflags = entersubop->op_flags & OPf_WANT; 429 430 op_free(entersubop); 431 432 return newUNOP(opcode, wantflags, argop); 433 } 434 435 XS(XS_builtin_indexed) 436 { 437 dXSARGS; 438 439 switch(GIMME_V) { 440 case G_VOID: 441 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 442 "Useless use of %s in void context", "builtin::indexed"); 443 XSRETURN(0); 444 445 case G_SCALAR: 446 Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), 447 "Useless use of %s in scalar context", "builtin::indexed"); 448 ST(0) = sv_2mortal(newSViv(items * 2)); 449 XSRETURN(1); 450 451 case G_LIST: 452 break; 453 } 454 455 SSize_t retcount = items * 2; 456 EXTEND(SP, retcount); 457 458 /* Copy from [items-1] down to [0] so we don't have to make 459 * temporary copies */ 460 for(SSize_t index = items - 1; index >= 0; index--) { 461 /* Copy, not alias */ 462 ST(index * 2 + 1) = sv_mortalcopy(ST(index)); 463 ST(index * 2) = sv_2mortal(newSViv(index)); 464 } 465 466 XSRETURN(retcount); 467 } 468 469 static OP *ck_builtin_funcN(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) 470 { 471 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj)); 472 473 warn_experimental_builtin(builtin->name, false); 474 475 SV *prototype = newSVpvs("@"); 476 SAVEFREESV(prototype); 477 478 assert(entersubop->op_type == OP_ENTERSUB); 479 480 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); 481 return entersubop; 482 } 483 484 static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function"; 485 486 static const struct BuiltinFuncDescriptor builtins[] = { 487 /* constants */ 488 { "builtin::true", &XS_builtin_true, &ck_builtin_const, BUILTIN_CONST_TRUE }, 489 { "builtin::false", &XS_builtin_false, &ck_builtin_const, BUILTIN_CONST_FALSE }, 490 491 /* unary functions */ 492 { "builtin::is_bool", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL }, 493 { "builtin::weaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_WEAKEN }, 494 { "builtin::unweaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_UNWEAKEN }, 495 { "builtin::is_weak", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK }, 496 { "builtin::blessed", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED }, 497 { "builtin::refaddr", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR }, 498 { "builtin::reftype", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE }, 499 { "builtin::ceil", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL }, 500 { "builtin::floor", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR }, 501 { "builtin::is_tainted", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_TAINTED }, 502 { "builtin::trim", &XS_builtin_trim, &ck_builtin_func1, 0 }, 503 504 { "builtin::created_as_string", &XS_builtin_created_as_string, &ck_builtin_func1, 0 }, 505 { "builtin::created_as_number", &XS_builtin_created_as_number, &ck_builtin_func1, 0 }, 506 507 /* list functions */ 508 { "builtin::indexed", &XS_builtin_indexed, &ck_builtin_funcN, 0 }, 509 { "builtin::export_lexically", &XS_builtin_export_lexically, NULL, 0 }, 510 { 0 } 511 }; 512 513 XS(XS_builtin_import); 514 XS(XS_builtin_import) 515 { 516 dXSARGS; 517 518 if(!PL_compcv) 519 Perl_croak(aTHX_ 520 "builtin::import can only be called at compile time"); 521 522 prepare_export_lexical(); 523 524 for(int i = 1; i < items; i++) { 525 SV *sym = ST(i); 526 if(strEQ(SvPV_nolen(sym), "import")) 527 Perl_croak(aTHX_ builtin_not_recognised, sym); 528 529 SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym))); 530 SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym))); 531 532 CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0); 533 if(!cv) 534 Perl_croak(aTHX_ builtin_not_recognised, sym); 535 536 export_lexical(ampname, (SV *)cv); 537 } 538 539 finish_export_lexical(); 540 } 541 542 void 543 Perl_boot_core_builtin(pTHX) 544 { 545 I32 i; 546 for(i = 0; builtins[i].name; i++) { 547 const struct BuiltinFuncDescriptor *builtin = &builtins[i]; 548 549 const char *proto = NULL; 550 if(builtin->checker == &ck_builtin_const) 551 proto = ""; 552 else if(builtin->checker == &ck_builtin_func1) 553 proto = "$"; 554 555 CV *cv = newXS_flags(builtin->name, builtin->xsub, __FILE__, proto, 0); 556 XSANY.any_i32 = builtin->ckval; 557 558 if(builtin->checker) { 559 cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0); 560 } 561 } 562 563 newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0); 564 } 565 566 /* 567 * ex: set ts=8 sts=4 sw=4 et: 568 */ 569