| 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 | XS(XS_builtin_true); |
| 27 | XS(XS_builtin_true) |
| 28 | { |
| 29 | dXSARGS; |
| 30 | if(items) |
| 31 | croak_xs_usage(cv, ""); |
| 32 | XSRETURN_YES; |
| 33 | } |
| 34 | |
| 35 | XS(XS_builtin_false); |
| 36 | XS(XS_builtin_false) |
| 37 | { |
| 38 | dXSARGS; |
| 39 | if(items) |
| 40 | croak_xs_usage(cv, ""); |
| 41 | XSRETURN_NO; |
| 42 | } |
| 43 | |
| 44 | enum { |
| 45 | BUILTIN_CONST_FALSE, |
| 46 | BUILTIN_CONST_TRUE, |
| 47 | }; |
| 48 | |
| 49 | static OP *ck_builtin_const(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) |
| 50 | { |
| 51 | const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj)); |
| 52 | |
| 53 | SV *prototype = newSVpvs(""); |
| 54 | SAVEFREESV(prototype); |
| 55 | |
| 56 | assert(entersubop->op_type == OP_ENTERSUB); |
| 57 | |
| 58 | entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); |
| 59 | |
| 60 | SV *constval; |
| 61 | switch(builtin->ckval) { |
| 62 | case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break; |
| 63 | case BUILTIN_CONST_TRUE: constval = &PL_sv_yes; break; |
| 64 | default: |
| 65 | DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf, builtin->ckval); |
| 66 | break; |
| 67 | } |
| 68 | |
| 69 | op_free(entersubop); |
| 70 | |
| 71 | return newSVOP(OP_CONST, 0, constval); |
| 72 | } |
| 73 | |
| 74 | enum { |
| 75 | BUILTIN_FUNC1_ISBOOL = 1, |
| 76 | }; |
| 77 | |
| 78 | XS(XS_builtin_func1); |
| 79 | XS(XS_builtin_func1) |
| 80 | { |
| 81 | dXSARGS; |
| 82 | dXSI32; |
| 83 | |
| 84 | if(items != 1) |
| 85 | croak_xs_usage(cv, "arg"); |
| 86 | |
| 87 | switch(ix) { |
| 88 | case BUILTIN_FUNC1_ISBOOL: |
| 89 | Perl_pp_isbool(aTHX); |
| 90 | break; |
| 91 | |
| 92 | default: |
| 93 | Perl_die(aTHX_ "panic: unhandled ix value %d for xs_builtin_func1()", ix); |
| 94 | } |
| 95 | |
| 96 | XSRETURN(1); |
| 97 | } |
| 98 | |
| 99 | static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) |
| 100 | { |
| 101 | const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj)); |
| 102 | |
| 103 | SV *prototype = newSVpvs("$"); |
| 104 | SAVEFREESV(prototype); |
| 105 | |
| 106 | assert(entersubop->op_type == OP_ENTERSUB); |
| 107 | |
| 108 | entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); |
| 109 | |
| 110 | OP *parent = entersubop, *pushop, *argop; |
| 111 | |
| 112 | pushop = cUNOPx(entersubop)->op_first; |
| 113 | if (!OpHAS_SIBLING(pushop)) { |
| 114 | pushop = cUNOPx(pushop)->op_first; |
| 115 | } |
| 116 | |
| 117 | argop = OpSIBLING(pushop); |
| 118 | |
| 119 | if (!argop || !OpHAS_SIBLING(argop) || OpHAS_SIBLING(OpSIBLING(argop))) |
| 120 | return entersubop; |
| 121 | |
| 122 | (void)op_sibling_splice(parent, pushop, 1, NULL); |
| 123 | |
| 124 | U8 wantflags = entersubop->op_flags & OPf_WANT; |
| 125 | |
| 126 | op_free(entersubop); |
| 127 | |
| 128 | OPCODE opcode; |
| 129 | switch(builtin->ckval) { |
| 130 | case BUILTIN_FUNC1_ISBOOL: opcode = OP_ISBOOL; break; |
| 131 | default: |
| 132 | DIE(aTHX_ "panic: unhandled ckval value %" IVdf " for ck_builtin_func1()", builtin->ckval); |
| 133 | } |
| 134 | |
| 135 | return newUNOP(opcode, wantflags, argop); |
| 136 | } |
| 137 | |
| 138 | static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function"; |
| 139 | |
| 140 | static const struct BuiltinFuncDescriptor builtins[] = { |
| 141 | /* constants */ |
| 142 | { "builtin::true", &XS_builtin_true, &ck_builtin_const, BUILTIN_CONST_TRUE }, |
| 143 | { "builtin::false", &XS_builtin_false, &ck_builtin_const, BUILTIN_CONST_FALSE }, |
| 144 | |
| 145 | /* unary functions */ |
| 146 | { "builtin::isbool", &XS_builtin_func1, &ck_builtin_func1, BUILTIN_FUNC1_ISBOOL }, |
| 147 | { 0 } |
| 148 | }; |
| 149 | |
| 150 | XS(XS_builtin_import); |
| 151 | XS(XS_builtin_import) |
| 152 | { |
| 153 | dXSARGS; |
| 154 | |
| 155 | if(!PL_compcv) |
| 156 | Perl_croak(aTHX_ |
| 157 | "builtin::import can only be called at compiletime"); |
| 158 | |
| 159 | /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */ |
| 160 | ENTER; |
| 161 | SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); |
| 162 | SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1]; |
| 163 | SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); |
| 164 | |
| 165 | for(int i = 1; i < items; i++) { |
| 166 | SV *sym = ST(i); |
| 167 | if(strEQ(SvPV_nolen(sym), "import")) |
| 168 | Perl_croak(aTHX_ builtin_not_recognised, sym); |
| 169 | |
| 170 | SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym))); |
| 171 | SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym))); |
| 172 | |
| 173 | CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0); |
| 174 | if(!cv) |
| 175 | Perl_croak(aTHX_ builtin_not_recognised, sym); |
| 176 | |
| 177 | PADOFFSET off = pad_add_name_sv(ampname, padadd_STATE, 0, 0); |
| 178 | SvREFCNT_dec(PL_curpad[off]); |
| 179 | PL_curpad[off] = SvREFCNT_inc(cv); |
| 180 | } |
| 181 | |
| 182 | intro_my(); |
| 183 | |
| 184 | LEAVE; |
| 185 | } |
| 186 | |
| 187 | void |
| 188 | Perl_boot_core_builtin(pTHX) |
| 189 | { |
| 190 | I32 i; |
| 191 | for(i = 0; builtins[i].name; i++) { |
| 192 | const struct BuiltinFuncDescriptor *builtin = &builtins[i]; |
| 193 | |
| 194 | const char *proto = NULL; |
| 195 | if(builtin->checker == &ck_builtin_const) |
| 196 | proto = ""; |
| 197 | else if(builtin->checker == &ck_builtin_func1) |
| 198 | proto = "$"; |
| 199 | |
| 200 | CV *cv = newXS_flags(builtin->name, builtin->xsub, __FILE__, proto, 0); |
| 201 | XSANY.any_i32 = builtin->ckval; |
| 202 | |
| 203 | if(builtin->checker) { |
| 204 | cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0); |
| 205 | } |
| 206 | } |
| 207 | |
| 208 | newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0); |
| 209 | } |
| 210 | |
| 211 | /* |
| 212 | * ex: set ts=8 sts=4 sw=4 et: |
| 213 | */ |