builtin.c

   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  */