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 #define PERL_IN_BUILTIN_C
16 #include "perl.h"
17
18 #include "XSUB.h"
19
20 /* copied from op.c */
21 #define SHORTVER(maj,min) (((maj) << 8) | (min))
22
23 struct BuiltinFuncDescriptor {
24 const char *name;
25 U16 since_ver;
26 XSUBADDR_t xsub;
27 OP *(*checker)(pTHX_ OP *, GV *, SV *);
28 IV ckval;
29 bool is_experimental;
30 };
31
32 #define warn_experimental_builtin(name) S_warn_experimental_builtin(aTHX_ name)
S_warn_experimental_builtin(pTHX_ const char * name)33 static void S_warn_experimental_builtin(pTHX_ const char *name)
34 {
35 /* diag_listed_as: Built-in function '%s' is experimental */
36 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BUILTIN),
37 "Built-in function 'builtin::%s' is experimental", name);
38 }
39
40 /* These three utilities might want to live elsewhere to be reused from other
41 * code sometime
42 */
43 void
Perl_prepare_export_lexical(pTHX)44 Perl_prepare_export_lexical(pTHX)
45 {
46 assert(PL_compcv);
47
48 /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */
49 ENTER;
50 SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
51 SAVECOMPPAD();
52 PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1];
53 PL_curpad = PadARRAY(PL_comppad);
54 }
55
56 #define export_lexical(name, sv) S_export_lexical(aTHX_ name, sv)
S_export_lexical(pTHX_ SV * name,SV * sv)57 static void S_export_lexical(pTHX_ SV *name, SV *sv)
58 {
59 PADOFFSET off = pad_add_name_sv(name, padadd_STATE, 0, 0);
60 SvREFCNT_dec(PL_curpad[off]);
61 PL_curpad[off] = SvREFCNT_inc(sv);
62 }
63
64 void
Perl_finish_export_lexical(pTHX)65 Perl_finish_export_lexical(pTHX)
66 {
67 intro_my();
68
69 LEAVE;
70 }
71
72
73 XS(XS_builtin_true);
XS(XS_builtin_true)74 XS(XS_builtin_true)
75 {
76 dXSARGS;
77 if(items)
78 croak_xs_usage(cv, "");
79 EXTEND(SP, 1);
80 XSRETURN_YES;
81 }
82
83 XS(XS_builtin_false);
XS(XS_builtin_false)84 XS(XS_builtin_false)
85 {
86 dXSARGS;
87 if(items)
88 croak_xs_usage(cv, "");
89 EXTEND(SP, 1);
90 XSRETURN_NO;
91 }
92
93 XS(XS_builtin_inf);
XS(XS_builtin_inf)94 XS(XS_builtin_inf)
95 {
96 dXSARGS;
97 if(items)
98 croak_xs_usage(cv, "");
99 EXTEND(SP, 1);
100 XSRETURN_NV(NV_INF);
101 }
102
103 XS(XS_builtin_nan);
XS(XS_builtin_nan)104 XS(XS_builtin_nan)
105 {
106 dXSARGS;
107 if(items)
108 croak_xs_usage(cv, "");
109 EXTEND(SP, 1);
110 XSRETURN_NV(NV_NAN);
111 }
112
113 enum {
114 BUILTIN_CONST_FALSE,
115 BUILTIN_CONST_TRUE,
116 BUILTIN_CONST_INF,
117 BUILTIN_CONST_NAN,
118 };
119
ck_builtin_const(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)120 static OP *ck_builtin_const(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
121 {
122 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));
123
124 if(builtin->is_experimental)
125 warn_experimental_builtin(builtin->name);
126
127 SV *prototype = newSVpvs("");
128 SAVEFREESV(prototype);
129
130 assert(entersubop->op_type == OP_ENTERSUB);
131
132 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
133
134 SV *constval;
135 switch(builtin->ckval) {
136 case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break;
137 case BUILTIN_CONST_TRUE: constval = &PL_sv_yes; break;
138 case BUILTIN_CONST_INF: constval = newSVnv(NV_INF); break;
139 case BUILTIN_CONST_NAN: constval = newSVnv(NV_NAN); break;
140 default:
141 DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf,
142 builtin->ckval);
143 break;
144 }
145
146 op_free(entersubop);
147
148 return newSVOP(OP_CONST, 0, constval);
149 }
150
151 XS(XS_builtin_func1_scalar);
XS(XS_builtin_func1_scalar)152 XS(XS_builtin_func1_scalar)
153 {
154 dXSARGS;
155 dXSI32;
156
157 if(items != 1)
158 croak_xs_usage(cv, "arg");
159
160 switch(ix) {
161 case OP_IS_BOOL:
162 warn_experimental_builtin(PL_op_name[ix]);
163 Perl_pp_is_bool(aTHX);
164 break;
165
166 case OP_IS_WEAK:
167 Perl_pp_is_weak(aTHX);
168 break;
169
170 case OP_BLESSED:
171 Perl_pp_blessed(aTHX);
172 break;
173
174 case OP_REFADDR:
175 Perl_pp_refaddr(aTHX);
176 break;
177
178 case OP_REFTYPE:
179 Perl_pp_reftype(aTHX);
180 break;
181
182 case OP_CEIL:
183 Perl_pp_ceil(aTHX);
184 break;
185
186 case OP_FLOOR:
187 Perl_pp_floor(aTHX);
188 break;
189
190 case OP_IS_TAINTED:
191 Perl_pp_is_tainted(aTHX);
192 break;
193
194 case OP_STRINGIFY:
195 {
196 /* we could only call pp_stringify if we're sure there is a TARG
197 and if the XSUB is called from call_sv() or goto it may not
198 have one.
199 */
200 dXSTARG;
201 sv_copypv(TARG, *PL_stack_sp);
202 SvSETMAGIC(TARG);
203 rpp_replace_1_1_NN(TARG);
204 }
205 break;
206
207 default:
208 Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
209 " for xs_builtin_func1_scalar()", (IV) ix);
210 }
211
212 XSRETURN(1);
213 }
214
215 XS(XS_builtin_trim);
XS(XS_builtin_trim)216 XS(XS_builtin_trim)
217 {
218 dXSARGS;
219
220 if (items != 1) {
221 croak_xs_usage(cv, "arg");
222 }
223
224 dXSTARG;
225 SV *source = TOPs;
226 STRLEN len;
227 const U8 *start;
228 SV *dest;
229
230 SvGETMAGIC(source);
231
232 if (SvOK(source))
233 start = (const U8*)SvPV_nomg_const(source, len);
234 else {
235 if (ckWARN(WARN_UNINITIALIZED))
236 report_uninit(source);
237 start = (const U8*)"";
238 len = 0;
239 }
240
241 if (DO_UTF8(source)) {
242 const U8 *end = start + len;
243
244 /* Find the first non-space */
245 while(len) {
246 STRLEN thislen;
247 if (!isSPACE_utf8_safe(start, end))
248 break;
249 start += (thislen = UTF8SKIP(start));
250 len -= thislen;
251 }
252
253 /* Find the final non-space */
254 STRLEN thislen;
255 const U8 *cur_end = end;
256 while ((thislen = is_SPACE_utf8_safe_backwards(cur_end, start))) {
257 cur_end -= thislen;
258 }
259 len -= (end - cur_end);
260 }
261 else if (len) {
262 while(len) {
263 if (!isSPACE_L1(*start))
264 break;
265 start++;
266 len--;
267 }
268
269 while(len) {
270 if (!isSPACE_L1(start[len-1]))
271 break;
272 len--;
273 }
274 }
275
276 dest = TARG;
277
278 if (SvPOK(dest) && (dest == source)) {
279 sv_chop(dest, (const char *)start);
280 SvCUR_set(dest, len);
281 }
282 else {
283 SvUPGRADE(dest, SVt_PV);
284 SvGROW(dest, len + 1);
285
286 Copy(start, SvPVX(dest), len, U8);
287 SvPVX(dest)[len] = '\0';
288 SvPOK_on(dest);
289 SvCUR_set(dest, len);
290
291 if (DO_UTF8(source))
292 SvUTF8_on(dest);
293 else
294 SvUTF8_off(dest);
295
296 if (SvTAINTED(source))
297 SvTAINT(dest);
298 }
299
300 SvSETMAGIC(dest);
301
302 SETs(dest);
303
304 XSRETURN(1);
305 }
306
307 XS(XS_builtin_export_lexically);
XS(XS_builtin_export_lexically)308 XS(XS_builtin_export_lexically)
309 {
310 dXSARGS;
311
312 warn_experimental_builtin("export_lexically");
313
314 if(!PL_compcv)
315 Perl_croak(aTHX_
316 "export_lexically can only be called at compile time");
317
318 if(items % 2)
319 Perl_croak(aTHX_ "Odd number of elements in export_lexically");
320
321 for(int i = 0; i < items; i += 2) {
322 SV *name = ST(i);
323 SV *ref = ST(i+1);
324
325 if(!SvROK(ref))
326 /* diag_listed_as: Expected %s reference in export_lexically */
327 Perl_croak(aTHX_ "Expected a reference in export_lexically");
328
329 char sigil = SvPVX(name)[0];
330 SV *rv = SvRV(ref);
331
332 const char *bad = NULL;
333 switch(sigil) {
334 default:
335 /* overwrites the pointer on the stack; but this is fine, the
336 * caller's value isn't modified */
337 ST(i) = name = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(name)));
338
339 /* FALLTHROUGH */
340 case '&':
341 if(SvTYPE(rv) != SVt_PVCV)
342 bad = "a CODE";
343 break;
344
345 case '$':
346 /* Permit any of SVt_NULL to SVt_PVMG. Technically this also
347 * includes SVt_INVLIST but it isn't thought possible for pureperl
348 * code to ever manage to see one of those. */
349 if(SvTYPE(rv) > SVt_PVMG)
350 bad = "a SCALAR";
351 break;
352
353 case '@':
354 if(SvTYPE(rv) != SVt_PVAV)
355 bad = "an ARRAY";
356 break;
357
358 case '%':
359 if(SvTYPE(rv) != SVt_PVHV)
360 bad = "a HASH";
361 break;
362 }
363
364 if(bad)
365 Perl_croak(aTHX_ "Expected %s reference in export_lexically", bad);
366 }
367
368 prepare_export_lexical();
369
370 for(int i = 0; i < items; i += 2) {
371 SV *name = ST(i);
372 SV *ref = ST(i+1);
373
374 export_lexical(name, SvRV(ref));
375 }
376
377 finish_export_lexical();
378 }
379
380 XS(XS_builtin_func1_void);
XS(XS_builtin_func1_void)381 XS(XS_builtin_func1_void)
382 {
383 dXSARGS;
384 dXSI32;
385
386 if(items != 1)
387 croak_xs_usage(cv, "arg");
388
389 switch(ix) {
390 case OP_WEAKEN:
391 Perl_pp_weaken(aTHX);
392 break;
393
394 case OP_UNWEAKEN:
395 Perl_pp_unweaken(aTHX);
396 break;
397
398 default:
399 Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
400 " for xs_builtin_func1_void()", (IV) ix);
401 }
402
403 XSRETURN(0);
404 }
405
XS(XS_builtin_created_as_string)406 XS(XS_builtin_created_as_string)
407 {
408 dXSARGS;
409
410 if(items != 1)
411 croak_xs_usage(cv, "arg");
412
413 SV *arg = ST(0);
414 SvGETMAGIC(arg);
415
416 /* SV was created as string if it has POK and isn't bool */
417 ST(0) = boolSV(SvPOK(arg) && !SvIsBOOL(arg));
418 XSRETURN(1);
419 }
420
XS(XS_builtin_created_as_number)421 XS(XS_builtin_created_as_number)
422 {
423 dXSARGS;
424
425 if(items != 1)
426 croak_xs_usage(cv, "arg");
427
428 SV *arg = ST(0);
429 SvGETMAGIC(arg);
430
431 /* SV was created as number if it has NOK or IOK but not POK and is not bool */
432 ST(0) = boolSV(SvNIOK(arg) && !SvPOK(arg) && !SvIsBOOL(arg));
433 XSRETURN(1);
434 }
435
ck_builtin_func1(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)436 static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
437 {
438 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));
439
440 if(builtin->is_experimental)
441 warn_experimental_builtin(builtin->name);
442
443 SV *prototype = newSVpvs("$");
444 SAVEFREESV(prototype);
445
446 assert(entersubop->op_type == OP_ENTERSUB);
447
448 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
449
450 OPCODE opcode = builtin->ckval;
451 if(!opcode)
452 return entersubop;
453
454 OP *parent = entersubop, *pushop, *argop;
455
456 pushop = cUNOPx(entersubop)->op_first;
457 if (!OpHAS_SIBLING(pushop)) {
458 pushop = cUNOPx(pushop)->op_first;
459 }
460
461 argop = OpSIBLING(pushop);
462
463 if (!argop || !OpHAS_SIBLING(argop) || OpHAS_SIBLING(OpSIBLING(argop)))
464 return entersubop;
465
466 (void)op_sibling_splice(parent, pushop, 1, NULL);
467
468 U8 wantflags = entersubop->op_flags & OPf_WANT;
469
470 op_free(entersubop);
471
472 if(opcode == OP_STRINGIFY)
473 /* Even though pp_stringify only looks at TOPs and conceptually works
474 * on a single argument, it happens to be a LISTOP. I've no idea why
475 */
476 return newLISTOPn(opcode, wantflags,
477 argop,
478 NULL);
479 else {
480 OP * const op = newUNOP(opcode, wantflags, argop);
481
482 /* since these pp funcs can be called from XS, and XS may be called
483 without a normal ENTERSUB, we need to indicate to them that a targ
484 has been allocated.
485 */
486 if (op->op_targ)
487 op->op_private |= OPpENTERSUB_HASTARG;
488
489 return op;
490 }
491 }
492
XS(XS_builtin_indexed)493 XS(XS_builtin_indexed)
494 {
495 dXSARGS;
496
497 switch(GIMME_V) {
498 case G_VOID:
499 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
500 "Useless use of %s in void context", "builtin::indexed");
501 XSRETURN(0);
502
503 case G_SCALAR:
504 Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR),
505 "Useless use of %s in scalar context", "builtin::indexed");
506 ST(0) = sv_2mortal(newSViv(items * 2));
507 XSRETURN(1);
508
509 case G_LIST:
510 break;
511 }
512
513 SSize_t retcount = items * 2;
514 EXTEND(SP, retcount);
515
516 /* Copy from [items-1] down to [0] so we don't have to make
517 * temporary copies */
518 for(SSize_t index = items - 1; index >= 0; index--) {
519 /* Copy, not alias */
520 ST(index * 2 + 1) = sv_mortalcopy(ST(index));
521 ST(index * 2) = sv_2mortal(newSViv(index));
522 }
523
524 XSRETURN(retcount);
525 }
526
527 XS(XS_builtin_load_module);
XS(XS_builtin_load_module)528 XS(XS_builtin_load_module)
529 {
530 dXSARGS;
531 if (items != 1)
532 croak_xs_usage(cv, "arg");
533 SV *module_name = newSVsv(ST(0));
534 if (!SvPOK(module_name)) {
535 SvREFCNT_dec(module_name);
536 croak_xs_usage(cv, "defined string");
537 }
538 load_module(PERL_LOADMOD_NOIMPORT, module_name, NULL, NULL);
539 /* The loaded module's name is left intentionally on the stack for the
540 * caller's benefit, and becomes load_module's return value. */
541 XSRETURN(1);
542 }
543
544 /* These pp_ funcs all need to use dXSTARG */
545
PP(pp_refaddr)546 PP(pp_refaddr)
547 {
548 dXSTARG;
549 SV *arg = *PL_stack_sp;
550
551 SvGETMAGIC(arg);
552
553 if(SvROK(arg))
554 sv_setuv_mg(TARG, PTR2UV(SvRV(arg)));
555 else
556 sv_setsv(TARG, &PL_sv_undef);
557
558 rpp_replace_1_1_NN(TARG);
559 return NORMAL;
560 }
561
PP(pp_reftype)562 PP(pp_reftype)
563 {
564 dXSTARG;
565 SV *arg = *PL_stack_sp;
566
567 SvGETMAGIC(arg);
568
569 if(SvROK(arg))
570 sv_setpv_mg(TARG, sv_reftype(SvRV(arg), FALSE));
571 else
572 sv_setsv(TARG, &PL_sv_undef);
573
574 rpp_replace_1_1_NN(TARG);
575 return NORMAL;
576 }
577
PP(pp_ceil)578 PP(pp_ceil)
579 {
580 dXSTARG;
581 TARGn(Perl_ceil(SvNVx(*PL_stack_sp)), 1);
582 rpp_replace_1_1_NN(TARG);
583 return NORMAL;
584 }
585
PP(pp_floor)586 PP(pp_floor)
587 {
588 dXSTARG;
589 TARGn(Perl_floor(SvNVx(*PL_stack_sp)), 1);
590 rpp_replace_1_1_NN(TARG);
591 return NORMAL;
592 }
593
ck_builtin_funcN(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)594 static OP *ck_builtin_funcN(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
595 {
596 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));
597
598 if(builtin->is_experimental)
599 warn_experimental_builtin(builtin->name);
600
601 SV *prototype = newSVpvs("@");
602 SAVEFREESV(prototype);
603
604 assert(entersubop->op_type == OP_ENTERSUB);
605
606 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
607 return entersubop;
608 }
609
610 static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function";
611
612 #define NO_BUNDLE SHORTVER(255,255)
613
614 static const struct BuiltinFuncDescriptor builtins[] = {
615 /* constants */
616 { "true", SHORTVER(5,39), &XS_builtin_true, &ck_builtin_const, BUILTIN_CONST_TRUE, false },
617 { "false", SHORTVER(5,39), &XS_builtin_false, &ck_builtin_const, BUILTIN_CONST_FALSE, false },
618 { "inf", NO_BUNDLE, &XS_builtin_inf, &ck_builtin_const, BUILTIN_CONST_INF, true },
619 { "nan", NO_BUNDLE, &XS_builtin_nan, &ck_builtin_const, BUILTIN_CONST_NAN, true },
620
621 /* unary functions */
622 { "is_bool", NO_BUNDLE, &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL, true },
623 { "weaken", SHORTVER(5,39), &XS_builtin_func1_void, &ck_builtin_func1, OP_WEAKEN, false },
624 { "unweaken", SHORTVER(5,39), &XS_builtin_func1_void, &ck_builtin_func1, OP_UNWEAKEN, false },
625 { "is_weak", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK, false },
626 { "blessed", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED, false },
627 { "refaddr", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR, false },
628 { "reftype", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE, false },
629 { "ceil", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL, false },
630 { "floor", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR, false },
631 { "is_tainted", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_TAINTED, false },
632 { "trim", SHORTVER(5,39), &XS_builtin_trim, &ck_builtin_func1, 0, false },
633 { "stringify", NO_BUNDLE, &XS_builtin_func1_scalar, &ck_builtin_func1, OP_STRINGIFY, true },
634
635 { "created_as_string", NO_BUNDLE, &XS_builtin_created_as_string, &ck_builtin_func1, 0, true },
636 { "created_as_number", NO_BUNDLE, &XS_builtin_created_as_number, &ck_builtin_func1, 0, true },
637
638 { "load_module", NO_BUNDLE, &XS_builtin_load_module, &ck_builtin_func1, 0, true },
639
640 /* list functions */
641 { "indexed", SHORTVER(5,39), &XS_builtin_indexed, &ck_builtin_funcN, 0, false },
642 { "export_lexically", NO_BUNDLE, &XS_builtin_export_lexically, NULL, 0, true },
643
644 { NULL, 0, NULL, NULL, 0, false }
645 };
646
S_parse_version(const char * vstr,const char * vend,UV * vmajor,UV * vminor)647 static bool S_parse_version(const char *vstr, const char *vend, UV *vmajor, UV *vminor)
648 {
649 /* Parse a string like "5.35" to yield 5 and 35. Ignores an optional
650 * trailing third component e.g. "5.35.7". Returns false on parse errors.
651 */
652
653 const char *end = vend;
654 if (!grok_atoUV(vstr, vmajor, &end))
655 return FALSE;
656
657 vstr = end;
658 if (*vstr++ != '.')
659 return FALSE;
660
661 end = vend;
662 if (!grok_atoUV(vstr, vminor, &end))
663 return FALSE;
664
665 if(*vminor > 255)
666 return FALSE;
667
668 vstr = end;
669
670 if(vstr[0] == '.') {
671 vstr++;
672
673 UV _dummy;
674 if(!grok_atoUV(vstr, &_dummy, &end))
675 return FALSE;
676 if(_dummy > 255)
677 return FALSE;
678
679 vstr = end;
680 }
681
682 if(vstr != vend)
683 return FALSE;
684
685 return TRUE;
686 }
687
688 #define import_sym(sym) S_import_sym(aTHX_ sym)
S_import_sym(pTHX_ SV * sym)689 static void S_import_sym(pTHX_ SV *sym)
690 {
691 SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym)));
692 SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym)));
693
694 CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0);
695 if(!cv)
696 Perl_croak(aTHX_ builtin_not_recognised, sym);
697
698 export_lexical(ampname, (SV *)cv);
699 }
700
701 #define cv_is_builtin(cv) S_cv_is_builtin(aTHX_ cv)
S_cv_is_builtin(pTHX_ CV * cv)702 static bool S_cv_is_builtin(pTHX_ CV *cv)
703 {
704 char *file = CvFILE(cv);
705 return file && strEQ(file, __FILE__);
706 }
707
708 void
Perl_import_builtin_bundle(pTHX_ U16 ver)709 Perl_import_builtin_bundle(pTHX_ U16 ver)
710 {
711 SV *ampname = sv_newmortal();
712
713 for(int i = 0; builtins[i].name; i++) {
714 sv_setpvf(ampname, "&%s", builtins[i].name);
715
716 bool want = (builtins[i].since_ver <= ver);
717
718 bool got = false;
719 PADOFFSET off = pad_findmy_sv(ampname, 0);
720 CV *cv;
721 if(off != NOT_IN_PAD &&
722 SvTYPE((cv = (CV *)PL_curpad[off])) == SVt_PVCV &&
723 cv_is_builtin(cv))
724 got = true;
725
726 if(!got && want) {
727 import_sym(newSVpvn_flags(builtins[i].name, strlen(builtins[i].name), SVs_TEMP));
728 }
729 }
730 }
731
732 XS(XS_builtin_import);
XS(XS_builtin_import)733 XS(XS_builtin_import)
734 {
735 dXSARGS;
736
737 if(!PL_compcv)
738 Perl_croak(aTHX_
739 "builtin::import can only be called at compile time");
740
741 prepare_export_lexical();
742
743 for(int i = 1; i < items; i++) {
744 SV *sym = ST(i);
745 STRLEN symlen;
746 const char *sympv = SvPV(sym, symlen);
747 if(strEQ(sympv, "import"))
748 Perl_croak(aTHX_ builtin_not_recognised, sym);
749
750 if(sympv[0] == ':') {
751 UV vmajor, vminor;
752 if(!S_parse_version(sympv + 1, sympv + symlen, &vmajor, &vminor))
753 Perl_croak(aTHX_ "Invalid version bundle %" SVf_QUOTEDPREFIX, sym);
754
755 U16 want_ver = SHORTVER(vmajor, vminor);
756
757 if(want_ver < SHORTVER(5,39) ||
758 /* round up devel version to next major release; e.g. 5.39 => 5.40 */
759 want_ver > SHORTVER(PERL_REVISION, PERL_VERSION + (PERL_VERSION % 2)))
760 Perl_croak(aTHX_ "Builtin version bundle \"%s\" is not supported by Perl " PERL_VERSION_STRING,
761 sympv);
762
763 import_builtin_bundle(want_ver);
764
765 continue;
766 }
767
768 import_sym(sym);
769 }
770
771 finish_export_lexical();
772 }
773
774 void
Perl_boot_core_builtin(pTHX)775 Perl_boot_core_builtin(pTHX)
776 {
777 I32 i;
778 for(i = 0; builtins[i].name; i++) {
779 const struct BuiltinFuncDescriptor *builtin = &builtins[i];
780
781 const char *proto = NULL;
782 if(builtin->checker == &ck_builtin_const)
783 proto = "";
784 else if(builtin->checker == &ck_builtin_func1)
785 proto = "$";
786 else if(builtin->checker == &ck_builtin_funcN)
787 proto = "@";
788
789 SV *name = newSVpvs_flags("builtin::", SVs_TEMP);
790 sv_catpv(name, builtin->name);
791 CV *cv = newXS_flags(SvPV_nolen(name), builtin->xsub, __FILE__, proto, 0);
792 XSANY.any_i32 = builtin->ckval;
793
794 if ( builtin->xsub == &XS_builtin_func1_void
795 || builtin->xsub == &XS_builtin_func1_scalar)
796 {
797 /* these XS functions just call out to the relevant pp()
798 * functions, so they must operate with a reference-counted
799 * stack if the pp() do too.
800 */
801 CvXS_RCSTACK_on(cv);
802 }
803
804 if(builtin->checker) {
805 cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0);
806 }
807 }
808
809 newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0);
810 }
811
812 /*
813 * ex: set ts=8 sts=4 sw=4 et:
814 */
815