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 XS(XS_builtin_true); 36 XS(XS_builtin_true) 37 { 38 dXSARGS; 39 warn_experimental_builtin("true", true); 40 if(items) 41 croak_xs_usage(cv, ""); 42 XSRETURN_YES; 43 } 44 45 XS(XS_builtin_false); 46 XS(XS_builtin_false) 47 { 48 dXSARGS; 49 warn_experimental_builtin("false", true); 50 if(items) 51 croak_xs_usage(cv, ""); 52 XSRETURN_NO; 53 } 54 55 enum { 56 BUILTIN_CONST_FALSE, 57 BUILTIN_CONST_TRUE, 58 }; 59 60 static OP *ck_builtin_const(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) 61 { 62 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj)); 63 64 warn_experimental_builtin(builtin->name, false); 65 66 SV *prototype = newSVpvs(""); 67 SAVEFREESV(prototype); 68 69 assert(entersubop->op_type == OP_ENTERSUB); 70 71 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); 72 73 SV *constval; 74 switch(builtin->ckval) { 75 case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break; 76 case BUILTIN_CONST_TRUE: constval = &PL_sv_yes; break; 77 default: 78 DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf, 79 builtin->ckval); 80 break; 81 } 82 83 op_free(entersubop); 84 85 return newSVOP(OP_CONST, 0, constval); 86 } 87 88 XS(XS_builtin_func1_scalar); 89 XS(XS_builtin_func1_scalar) 90 { 91 dXSARGS; 92 dXSI32; 93 94 warn_experimental_builtin(PL_op_name[ix], true); 95 96 if(items != 1) 97 croak_xs_usage(cv, "arg"); 98 99 switch(ix) { 100 case OP_IS_BOOL: 101 Perl_pp_is_bool(aTHX); 102 break; 103 104 case OP_IS_WEAK: 105 Perl_pp_is_weak(aTHX); 106 break; 107 108 case OP_BLESSED: 109 Perl_pp_blessed(aTHX); 110 break; 111 112 case OP_REFADDR: 113 Perl_pp_refaddr(aTHX); 114 break; 115 116 case OP_REFTYPE: 117 Perl_pp_reftype(aTHX); 118 break; 119 120 case OP_CEIL: 121 Perl_pp_ceil(aTHX); 122 break; 123 124 case OP_FLOOR: 125 Perl_pp_floor(aTHX); 126 break; 127 128 default: 129 Perl_die(aTHX_ "panic: unhandled opcode %" IVdf 130 " for xs_builtin_func1_scalar()", (IV) ix); 131 } 132 133 XSRETURN(1); 134 } 135 136 XS(XS_builtin_trim); 137 XS(XS_builtin_trim) 138 { 139 dXSARGS; 140 141 warn_experimental_builtin("trim", true); 142 143 if (items != 1) { 144 croak_xs_usage(cv, "arg"); 145 } 146 147 dTARGET; 148 SV *source = TOPs; 149 STRLEN len; 150 const U8 *start; 151 SV *dest; 152 153 SvGETMAGIC(source); 154 155 if (SvOK(source)) 156 start = (const U8*)SvPV_nomg_const(source, len); 157 else { 158 if (ckWARN(WARN_UNINITIALIZED)) 159 report_uninit(source); 160 start = (const U8*)""; 161 len = 0; 162 } 163 164 if (DO_UTF8(source)) { 165 const U8 *end = start + len; 166 167 /* Find the first non-space */ 168 while(len) { 169 STRLEN thislen; 170 if (!isSPACE_utf8_safe(start, end)) 171 break; 172 start += (thislen = UTF8SKIP(start)); 173 len -= thislen; 174 } 175 176 /* Find the final non-space */ 177 STRLEN thislen; 178 const U8 *cur_end = end; 179 while ((thislen = is_SPACE_utf8_safe_backwards(cur_end, start))) { 180 cur_end -= thislen; 181 } 182 len -= (end - cur_end); 183 } 184 else if (len) { 185 while(len) { 186 if (!isSPACE_L1(*start)) 187 break; 188 start++; 189 len--; 190 } 191 192 while(len) { 193 if (!isSPACE_L1(start[len-1])) 194 break; 195 len--; 196 } 197 } 198 199 dest = TARG; 200 201 if (SvPOK(dest) && (dest == source)) { 202 sv_chop(dest, (const char *)start); 203 SvCUR_set(dest, len); 204 } 205 else { 206 SvUPGRADE(dest, SVt_PV); 207 SvGROW(dest, len + 1); 208 209 Copy(start, SvPVX(dest), len, U8); 210 SvPVX(dest)[len] = '\0'; 211 SvPOK_on(dest); 212 SvCUR_set(dest, len); 213 214 if (DO_UTF8(source)) 215 SvUTF8_on(dest); 216 else 217 SvUTF8_off(dest); 218 219 if (SvTAINTED(source)) 220 SvTAINT(dest); 221 } 222 223 SvSETMAGIC(dest); 224 225 SETs(dest); 226 227 XSRETURN(1); 228 } 229 230 XS(XS_builtin_func1_void); 231 XS(XS_builtin_func1_void) 232 { 233 dXSARGS; 234 dXSI32; 235 236 warn_experimental_builtin(PL_op_name[ix], true); 237 238 if(items != 1) 239 croak_xs_usage(cv, "arg"); 240 241 switch(ix) { 242 case OP_WEAKEN: 243 Perl_pp_weaken(aTHX); 244 break; 245 246 case OP_UNWEAKEN: 247 Perl_pp_unweaken(aTHX); 248 break; 249 250 default: 251 Perl_die(aTHX_ "panic: unhandled opcode %" IVdf 252 " for xs_builtin_func1_void()", (IV) ix); 253 } 254 255 XSRETURN(0); 256 } 257 258 XS(XS_builtin_created_as_string) 259 { 260 dXSARGS; 261 262 if(items != 1) 263 croak_xs_usage(cv, "arg"); 264 265 SV *arg = ST(0); 266 SvGETMAGIC(arg); 267 268 /* SV was created as string if it has POK and isn't bool */ 269 ST(0) = boolSV(SvPOK(arg) && !SvIsBOOL(arg)); 270 XSRETURN(1); 271 } 272 273 XS(XS_builtin_created_as_number) 274 { 275 dXSARGS; 276 277 if(items != 1) 278 croak_xs_usage(cv, "arg"); 279 280 SV *arg = ST(0); 281 SvGETMAGIC(arg); 282 283 /* SV was created as number if it has NOK or IOK but not POK and is not bool */ 284 ST(0) = boolSV(SvNIOK(arg) && !SvPOK(arg) && !SvIsBOOL(arg)); 285 XSRETURN(1); 286 } 287 288 static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) 289 { 290 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj)); 291 292 warn_experimental_builtin(builtin->name, false); 293 294 SV *prototype = newSVpvs("$"); 295 SAVEFREESV(prototype); 296 297 assert(entersubop->op_type == OP_ENTERSUB); 298 299 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); 300 301 OPCODE opcode = builtin->ckval; 302 if(!opcode) 303 return entersubop; 304 305 OP *parent = entersubop, *pushop, *argop; 306 307 pushop = cUNOPx(entersubop)->op_first; 308 if (!OpHAS_SIBLING(pushop)) { 309 pushop = cUNOPx(pushop)->op_first; 310 } 311 312 argop = OpSIBLING(pushop); 313 314 if (!argop || !OpHAS_SIBLING(argop) || OpHAS_SIBLING(OpSIBLING(argop))) 315 return entersubop; 316 317 (void)op_sibling_splice(parent, pushop, 1, NULL); 318 319 U8 wantflags = entersubop->op_flags & OPf_WANT; 320 321 op_free(entersubop); 322 323 return newUNOP(opcode, wantflags, argop); 324 } 325 326 XS(XS_builtin_indexed) 327 { 328 dXSARGS; 329 330 switch(GIMME_V) { 331 case G_VOID: 332 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 333 "Useless use of %s in void context", "builtin::indexed"); 334 XSRETURN(0); 335 336 case G_SCALAR: 337 Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), 338 "Useless use of %s in scalar context", "builtin::indexed"); 339 ST(0) = sv_2mortal(newSViv(items * 2)); 340 XSRETURN(1); 341 342 case G_LIST: 343 break; 344 } 345 346 SSize_t retcount = items * 2; 347 EXTEND(SP, retcount); 348 349 /* Copy from [items-1] down to [0] so we don't have to make 350 * temporary copies */ 351 for(SSize_t index = items - 1; index >= 0; index--) { 352 /* Copy, not alias */ 353 ST(index * 2 + 1) = sv_mortalcopy(ST(index)); 354 ST(index * 2) = sv_2mortal(newSViv(index)); 355 } 356 357 XSRETURN(retcount); 358 } 359 360 static OP *ck_builtin_funcN(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) 361 { 362 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj)); 363 364 warn_experimental_builtin(builtin->name, false); 365 366 SV *prototype = newSVpvs("@"); 367 SAVEFREESV(prototype); 368 369 assert(entersubop->op_type == OP_ENTERSUB); 370 371 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); 372 return entersubop; 373 } 374 375 static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function"; 376 377 static const struct BuiltinFuncDescriptor builtins[] = { 378 /* constants */ 379 { "builtin::true", &XS_builtin_true, &ck_builtin_const, BUILTIN_CONST_TRUE }, 380 { "builtin::false", &XS_builtin_false, &ck_builtin_const, BUILTIN_CONST_FALSE }, 381 382 /* unary functions */ 383 { "builtin::is_bool", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL }, 384 { "builtin::weaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_WEAKEN }, 385 { "builtin::unweaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_UNWEAKEN }, 386 { "builtin::is_weak", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK }, 387 { "builtin::blessed", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED }, 388 { "builtin::refaddr", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR }, 389 { "builtin::reftype", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE }, 390 { "builtin::ceil", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL }, 391 { "builtin::floor", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR }, 392 { "builtin::trim", &XS_builtin_trim, NULL, 0 }, 393 394 { "builtin::created_as_string", &XS_builtin_created_as_string, &ck_builtin_func1, 0 }, 395 { "builtin::created_as_number", &XS_builtin_created_as_number, &ck_builtin_func1, 0 }, 396 397 /* list functions */ 398 { "builtin::indexed", &XS_builtin_indexed, &ck_builtin_funcN, 0 }, 399 { 0 } 400 }; 401 402 XS(XS_builtin_import); 403 XS(XS_builtin_import) 404 { 405 dXSARGS; 406 407 if(!PL_compcv) 408 Perl_croak(aTHX_ 409 "builtin::import can only be called at compile time"); 410 411 /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */ 412 ENTER; 413 SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); 414 SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1]; 415 SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); 416 417 for(int i = 1; i < items; i++) { 418 SV *sym = ST(i); 419 if(strEQ(SvPV_nolen(sym), "import")) 420 Perl_croak(aTHX_ builtin_not_recognised, sym); 421 422 SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym))); 423 SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym))); 424 425 CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0); 426 if(!cv) 427 Perl_croak(aTHX_ builtin_not_recognised, sym); 428 429 PADOFFSET off = pad_add_name_sv(ampname, padadd_STATE, 0, 0); 430 SvREFCNT_dec(PL_curpad[off]); 431 PL_curpad[off] = SvREFCNT_inc(cv); 432 } 433 434 intro_my(); 435 436 LEAVE; 437 } 438 439 void 440 Perl_boot_core_builtin(pTHX) 441 { 442 I32 i; 443 for(i = 0; builtins[i].name; i++) { 444 const struct BuiltinFuncDescriptor *builtin = &builtins[i]; 445 446 const char *proto = NULL; 447 if(builtin->checker == &ck_builtin_const) 448 proto = ""; 449 else if(builtin->checker == &ck_builtin_func1) 450 proto = "$"; 451 452 CV *cv = newXS_flags(builtin->name, builtin->xsub, __FILE__, proto, 0); 453 XSANY.any_i32 = builtin->ckval; 454 455 if(builtin->checker) { 456 cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0); 457 } 458 } 459 460 newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0); 461 } 462 463 /* 464 * ex: set ts=8 sts=4 sw=4 et: 465 */ 466