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