1256a93a4Safresh1 /* builtin.c
2256a93a4Safresh1 *
3256a93a4Safresh1 * Copyright (C) 2021 by Paul Evans and others
4256a93a4Safresh1 *
5256a93a4Safresh1 * You may distribute under the terms of either the GNU General Public
6256a93a4Safresh1 * License or the Artistic License, as specified in the README file.
7256a93a4Safresh1 *
8256a93a4Safresh1 */
9256a93a4Safresh1
10256a93a4Safresh1 /* This file contains the code that implements functions in perl's "builtin::"
11256a93a4Safresh1 * namespace
12256a93a4Safresh1 */
13256a93a4Safresh1
14256a93a4Safresh1 #include "EXTERN.h"
15256a93a4Safresh1 #include "perl.h"
16256a93a4Safresh1
17256a93a4Safresh1 #include "XSUB.h"
18256a93a4Safresh1
19256a93a4Safresh1 struct BuiltinFuncDescriptor {
20256a93a4Safresh1 const char *name;
21256a93a4Safresh1 XSUBADDR_t xsub;
22256a93a4Safresh1 OP *(*checker)(pTHX_ OP *, GV *, SV *);
23256a93a4Safresh1 IV ckval;
24256a93a4Safresh1 };
25256a93a4Safresh1
26256a93a4Safresh1 #define warn_experimental_builtin(name, prefix) S_warn_experimental_builtin(aTHX_ name, prefix)
S_warn_experimental_builtin(pTHX_ const char * name,bool prefix)27256a93a4Safresh1 static void S_warn_experimental_builtin(pTHX_ const char *name, bool prefix)
28256a93a4Safresh1 {
29256a93a4Safresh1 /* diag_listed_as: Built-in function '%s' is experimental */
30256a93a4Safresh1 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BUILTIN),
31256a93a4Safresh1 "Built-in function '%s%s' is experimental",
32256a93a4Safresh1 prefix ? "builtin::" : "", name);
33256a93a4Safresh1 }
34256a93a4Safresh1
35*f2a19305Safresh1 /* These three utilities might want to live elsewhere to be reused from other
36*f2a19305Safresh1 * code sometime
37*f2a19305Safresh1 */
38*f2a19305Safresh1 #define prepare_export_lexical() S_prepare_export_lexical(aTHX)
S_prepare_export_lexical(pTHX)39*f2a19305Safresh1 static void S_prepare_export_lexical(pTHX)
40*f2a19305Safresh1 {
41*f2a19305Safresh1 assert(PL_compcv);
42*f2a19305Safresh1
43*f2a19305Safresh1 /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */
44*f2a19305Safresh1 ENTER;
45*f2a19305Safresh1 SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
46*f2a19305Safresh1 SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1];
47*f2a19305Safresh1 SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad);
48*f2a19305Safresh1 }
49*f2a19305Safresh1
50*f2a19305Safresh1 #define export_lexical(name, sv) S_export_lexical(aTHX_ name, sv)
S_export_lexical(pTHX_ SV * name,SV * sv)51*f2a19305Safresh1 static void S_export_lexical(pTHX_ SV *name, SV *sv)
52*f2a19305Safresh1 {
53*f2a19305Safresh1 PADOFFSET off = pad_add_name_sv(name, padadd_STATE, 0, 0);
54*f2a19305Safresh1 SvREFCNT_dec(PL_curpad[off]);
55*f2a19305Safresh1 PL_curpad[off] = SvREFCNT_inc(sv);
56*f2a19305Safresh1 }
57*f2a19305Safresh1
58*f2a19305Safresh1 #define finish_export_lexical() S_finish_export_lexical(aTHX)
S_finish_export_lexical(pTHX)59*f2a19305Safresh1 static void S_finish_export_lexical(pTHX)
60*f2a19305Safresh1 {
61*f2a19305Safresh1 intro_my();
62*f2a19305Safresh1
63*f2a19305Safresh1 LEAVE;
64*f2a19305Safresh1 }
65*f2a19305Safresh1
66*f2a19305Safresh1
67256a93a4Safresh1 XS(XS_builtin_true);
XS(XS_builtin_true)68256a93a4Safresh1 XS(XS_builtin_true)
69256a93a4Safresh1 {
70256a93a4Safresh1 dXSARGS;
71256a93a4Safresh1 warn_experimental_builtin("true", true);
72256a93a4Safresh1 if(items)
73256a93a4Safresh1 croak_xs_usage(cv, "");
74256a93a4Safresh1 XSRETURN_YES;
75256a93a4Safresh1 }
76256a93a4Safresh1
77256a93a4Safresh1 XS(XS_builtin_false);
XS(XS_builtin_false)78256a93a4Safresh1 XS(XS_builtin_false)
79256a93a4Safresh1 {
80256a93a4Safresh1 dXSARGS;
81256a93a4Safresh1 warn_experimental_builtin("false", true);
82256a93a4Safresh1 if(items)
83256a93a4Safresh1 croak_xs_usage(cv, "");
84256a93a4Safresh1 XSRETURN_NO;
85256a93a4Safresh1 }
86256a93a4Safresh1
87256a93a4Safresh1 enum {
88256a93a4Safresh1 BUILTIN_CONST_FALSE,
89256a93a4Safresh1 BUILTIN_CONST_TRUE,
90256a93a4Safresh1 };
91256a93a4Safresh1
ck_builtin_const(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)92256a93a4Safresh1 static OP *ck_builtin_const(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
93256a93a4Safresh1 {
94256a93a4Safresh1 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));
95256a93a4Safresh1
96256a93a4Safresh1 warn_experimental_builtin(builtin->name, false);
97256a93a4Safresh1
98256a93a4Safresh1 SV *prototype = newSVpvs("");
99256a93a4Safresh1 SAVEFREESV(prototype);
100256a93a4Safresh1
101256a93a4Safresh1 assert(entersubop->op_type == OP_ENTERSUB);
102256a93a4Safresh1
103256a93a4Safresh1 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
104256a93a4Safresh1
105256a93a4Safresh1 SV *constval;
106256a93a4Safresh1 switch(builtin->ckval) {
107256a93a4Safresh1 case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break;
108256a93a4Safresh1 case BUILTIN_CONST_TRUE: constval = &PL_sv_yes; break;
109256a93a4Safresh1 default:
110256a93a4Safresh1 DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf,
111256a93a4Safresh1 builtin->ckval);
112256a93a4Safresh1 break;
113256a93a4Safresh1 }
114256a93a4Safresh1
115256a93a4Safresh1 op_free(entersubop);
116256a93a4Safresh1
117256a93a4Safresh1 return newSVOP(OP_CONST, 0, constval);
118256a93a4Safresh1 }
119256a93a4Safresh1
120256a93a4Safresh1 XS(XS_builtin_func1_scalar);
XS(XS_builtin_func1_scalar)121256a93a4Safresh1 XS(XS_builtin_func1_scalar)
122256a93a4Safresh1 {
123256a93a4Safresh1 dXSARGS;
124256a93a4Safresh1 dXSI32;
125256a93a4Safresh1
126256a93a4Safresh1 warn_experimental_builtin(PL_op_name[ix], true);
127256a93a4Safresh1
128256a93a4Safresh1 if(items != 1)
129256a93a4Safresh1 croak_xs_usage(cv, "arg");
130256a93a4Safresh1
131256a93a4Safresh1 switch(ix) {
132256a93a4Safresh1 case OP_IS_BOOL:
133256a93a4Safresh1 Perl_pp_is_bool(aTHX);
134256a93a4Safresh1 break;
135256a93a4Safresh1
136256a93a4Safresh1 case OP_IS_WEAK:
137256a93a4Safresh1 Perl_pp_is_weak(aTHX);
138256a93a4Safresh1 break;
139256a93a4Safresh1
140256a93a4Safresh1 case OP_BLESSED:
141256a93a4Safresh1 Perl_pp_blessed(aTHX);
142256a93a4Safresh1 break;
143256a93a4Safresh1
144256a93a4Safresh1 case OP_REFADDR:
145256a93a4Safresh1 Perl_pp_refaddr(aTHX);
146256a93a4Safresh1 break;
147256a93a4Safresh1
148256a93a4Safresh1 case OP_REFTYPE:
149256a93a4Safresh1 Perl_pp_reftype(aTHX);
150256a93a4Safresh1 break;
151256a93a4Safresh1
152256a93a4Safresh1 case OP_CEIL:
153256a93a4Safresh1 Perl_pp_ceil(aTHX);
154256a93a4Safresh1 break;
155256a93a4Safresh1
156256a93a4Safresh1 case OP_FLOOR:
157256a93a4Safresh1 Perl_pp_floor(aTHX);
158256a93a4Safresh1 break;
159256a93a4Safresh1
160*f2a19305Safresh1 case OP_IS_TAINTED:
161*f2a19305Safresh1 Perl_pp_is_tainted(aTHX);
162*f2a19305Safresh1 break;
163*f2a19305Safresh1
164256a93a4Safresh1 default:
165256a93a4Safresh1 Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
166256a93a4Safresh1 " for xs_builtin_func1_scalar()", (IV) ix);
167256a93a4Safresh1 }
168256a93a4Safresh1
169256a93a4Safresh1 XSRETURN(1);
170256a93a4Safresh1 }
171256a93a4Safresh1
172256a93a4Safresh1 XS(XS_builtin_trim);
XS(XS_builtin_trim)173256a93a4Safresh1 XS(XS_builtin_trim)
174256a93a4Safresh1 {
175256a93a4Safresh1 dXSARGS;
176256a93a4Safresh1
177256a93a4Safresh1 warn_experimental_builtin("trim", true);
178256a93a4Safresh1
179256a93a4Safresh1 if (items != 1) {
180256a93a4Safresh1 croak_xs_usage(cv, "arg");
181256a93a4Safresh1 }
182256a93a4Safresh1
183256a93a4Safresh1 dTARGET;
184256a93a4Safresh1 SV *source = TOPs;
185256a93a4Safresh1 STRLEN len;
186256a93a4Safresh1 const U8 *start;
187256a93a4Safresh1 SV *dest;
188256a93a4Safresh1
189256a93a4Safresh1 SvGETMAGIC(source);
190256a93a4Safresh1
191256a93a4Safresh1 if (SvOK(source))
192256a93a4Safresh1 start = (const U8*)SvPV_nomg_const(source, len);
193256a93a4Safresh1 else {
194256a93a4Safresh1 if (ckWARN(WARN_UNINITIALIZED))
195256a93a4Safresh1 report_uninit(source);
196256a93a4Safresh1 start = (const U8*)"";
197256a93a4Safresh1 len = 0;
198256a93a4Safresh1 }
199256a93a4Safresh1
200256a93a4Safresh1 if (DO_UTF8(source)) {
201256a93a4Safresh1 const U8 *end = start + len;
202256a93a4Safresh1
203256a93a4Safresh1 /* Find the first non-space */
204256a93a4Safresh1 while(len) {
205256a93a4Safresh1 STRLEN thislen;
206256a93a4Safresh1 if (!isSPACE_utf8_safe(start, end))
207256a93a4Safresh1 break;
208256a93a4Safresh1 start += (thislen = UTF8SKIP(start));
209256a93a4Safresh1 len -= thislen;
210256a93a4Safresh1 }
211256a93a4Safresh1
212256a93a4Safresh1 /* Find the final non-space */
213256a93a4Safresh1 STRLEN thislen;
214256a93a4Safresh1 const U8 *cur_end = end;
215256a93a4Safresh1 while ((thislen = is_SPACE_utf8_safe_backwards(cur_end, start))) {
216256a93a4Safresh1 cur_end -= thislen;
217256a93a4Safresh1 }
218256a93a4Safresh1 len -= (end - cur_end);
219256a93a4Safresh1 }
220256a93a4Safresh1 else if (len) {
221256a93a4Safresh1 while(len) {
222256a93a4Safresh1 if (!isSPACE_L1(*start))
223256a93a4Safresh1 break;
224256a93a4Safresh1 start++;
225256a93a4Safresh1 len--;
226256a93a4Safresh1 }
227256a93a4Safresh1
228256a93a4Safresh1 while(len) {
229256a93a4Safresh1 if (!isSPACE_L1(start[len-1]))
230256a93a4Safresh1 break;
231256a93a4Safresh1 len--;
232256a93a4Safresh1 }
233256a93a4Safresh1 }
234256a93a4Safresh1
235256a93a4Safresh1 dest = TARG;
236256a93a4Safresh1
237256a93a4Safresh1 if (SvPOK(dest) && (dest == source)) {
238256a93a4Safresh1 sv_chop(dest, (const char *)start);
239256a93a4Safresh1 SvCUR_set(dest, len);
240256a93a4Safresh1 }
241256a93a4Safresh1 else {
242256a93a4Safresh1 SvUPGRADE(dest, SVt_PV);
243256a93a4Safresh1 SvGROW(dest, len + 1);
244256a93a4Safresh1
245256a93a4Safresh1 Copy(start, SvPVX(dest), len, U8);
246256a93a4Safresh1 SvPVX(dest)[len] = '\0';
247256a93a4Safresh1 SvPOK_on(dest);
248256a93a4Safresh1 SvCUR_set(dest, len);
249256a93a4Safresh1
250256a93a4Safresh1 if (DO_UTF8(source))
251256a93a4Safresh1 SvUTF8_on(dest);
252256a93a4Safresh1 else
253256a93a4Safresh1 SvUTF8_off(dest);
254256a93a4Safresh1
255256a93a4Safresh1 if (SvTAINTED(source))
256256a93a4Safresh1 SvTAINT(dest);
257256a93a4Safresh1 }
258256a93a4Safresh1
259256a93a4Safresh1 SvSETMAGIC(dest);
260256a93a4Safresh1
261256a93a4Safresh1 SETs(dest);
262256a93a4Safresh1
263256a93a4Safresh1 XSRETURN(1);
264256a93a4Safresh1 }
265256a93a4Safresh1
266*f2a19305Safresh1 XS(XS_builtin_export_lexically);
XS(XS_builtin_export_lexically)267*f2a19305Safresh1 XS(XS_builtin_export_lexically)
268*f2a19305Safresh1 {
269*f2a19305Safresh1 dXSARGS;
270*f2a19305Safresh1
271*f2a19305Safresh1 warn_experimental_builtin("export_lexically", true);
272*f2a19305Safresh1
273*f2a19305Safresh1 if(!PL_compcv)
274*f2a19305Safresh1 Perl_croak(aTHX_
275*f2a19305Safresh1 "export_lexically can only be called at compile time");
276*f2a19305Safresh1
277*f2a19305Safresh1 if(items % 2)
278*f2a19305Safresh1 Perl_croak(aTHX_ "Odd number of elements in export_lexically");
279*f2a19305Safresh1
280*f2a19305Safresh1 for(int i = 0; i < items; i += 2) {
281*f2a19305Safresh1 SV *name = ST(i);
282*f2a19305Safresh1 SV *ref = ST(i+1);
283*f2a19305Safresh1
284*f2a19305Safresh1 if(!SvROK(ref))
285*f2a19305Safresh1 /* diag_listed_as: Expected %s reference in export_lexically */
286*f2a19305Safresh1 Perl_croak(aTHX_ "Expected a reference in export_lexically");
287*f2a19305Safresh1
288*f2a19305Safresh1 char sigil = SvPVX(name)[0];
289*f2a19305Safresh1 SV *rv = SvRV(ref);
290*f2a19305Safresh1
291*f2a19305Safresh1 const char *bad = NULL;
292*f2a19305Safresh1 switch(sigil) {
293*f2a19305Safresh1 default:
294*f2a19305Safresh1 /* overwrites the pointer on the stack; but this is fine, the
295*f2a19305Safresh1 * caller's value isn't modified */
296*f2a19305Safresh1 ST(i) = name = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(name)));
297*f2a19305Safresh1
298*f2a19305Safresh1 /* FALLTHROUGH */
299*f2a19305Safresh1 case '&':
300*f2a19305Safresh1 if(SvTYPE(rv) != SVt_PVCV)
301*f2a19305Safresh1 bad = "a CODE";
302*f2a19305Safresh1 break;
303*f2a19305Safresh1
304*f2a19305Safresh1 case '$':
305*f2a19305Safresh1 /* Permit any of SVt_NULL to SVt_PVMG. Technically this also
306*f2a19305Safresh1 * includes SVt_INVLIST but it isn't thought possible for pureperl
307*f2a19305Safresh1 * code to ever manage to see one of those. */
308*f2a19305Safresh1 if(SvTYPE(rv) > SVt_PVMG)
309*f2a19305Safresh1 bad = "a SCALAR";
310*f2a19305Safresh1 break;
311*f2a19305Safresh1
312*f2a19305Safresh1 case '@':
313*f2a19305Safresh1 if(SvTYPE(rv) != SVt_PVAV)
314*f2a19305Safresh1 bad = "an ARRAY";
315*f2a19305Safresh1 break;
316*f2a19305Safresh1
317*f2a19305Safresh1 case '%':
318*f2a19305Safresh1 if(SvTYPE(rv) != SVt_PVHV)
319*f2a19305Safresh1 bad = "a HASH";
320*f2a19305Safresh1 break;
321*f2a19305Safresh1 }
322*f2a19305Safresh1
323*f2a19305Safresh1 if(bad)
324*f2a19305Safresh1 Perl_croak(aTHX_ "Expected %s reference in export_lexically", bad);
325*f2a19305Safresh1 }
326*f2a19305Safresh1
327*f2a19305Safresh1 prepare_export_lexical();
328*f2a19305Safresh1
329*f2a19305Safresh1 for(int i = 0; i < items; i += 2) {
330*f2a19305Safresh1 SV *name = ST(i);
331*f2a19305Safresh1 SV *ref = ST(i+1);
332*f2a19305Safresh1
333*f2a19305Safresh1 export_lexical(name, SvRV(ref));
334*f2a19305Safresh1 }
335*f2a19305Safresh1
336*f2a19305Safresh1 finish_export_lexical();
337*f2a19305Safresh1 }
338*f2a19305Safresh1
339256a93a4Safresh1 XS(XS_builtin_func1_void);
XS(XS_builtin_func1_void)340256a93a4Safresh1 XS(XS_builtin_func1_void)
341256a93a4Safresh1 {
342256a93a4Safresh1 dXSARGS;
343256a93a4Safresh1 dXSI32;
344256a93a4Safresh1
345256a93a4Safresh1 warn_experimental_builtin(PL_op_name[ix], true);
346256a93a4Safresh1
347256a93a4Safresh1 if(items != 1)
348256a93a4Safresh1 croak_xs_usage(cv, "arg");
349256a93a4Safresh1
350256a93a4Safresh1 switch(ix) {
351256a93a4Safresh1 case OP_WEAKEN:
352256a93a4Safresh1 Perl_pp_weaken(aTHX);
353256a93a4Safresh1 break;
354256a93a4Safresh1
355256a93a4Safresh1 case OP_UNWEAKEN:
356256a93a4Safresh1 Perl_pp_unweaken(aTHX);
357256a93a4Safresh1 break;
358256a93a4Safresh1
359256a93a4Safresh1 default:
360256a93a4Safresh1 Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
361256a93a4Safresh1 " for xs_builtin_func1_void()", (IV) ix);
362256a93a4Safresh1 }
363256a93a4Safresh1
364256a93a4Safresh1 XSRETURN(0);
365256a93a4Safresh1 }
366256a93a4Safresh1
XS(XS_builtin_created_as_string)367256a93a4Safresh1 XS(XS_builtin_created_as_string)
368256a93a4Safresh1 {
369256a93a4Safresh1 dXSARGS;
370256a93a4Safresh1
371256a93a4Safresh1 if(items != 1)
372256a93a4Safresh1 croak_xs_usage(cv, "arg");
373256a93a4Safresh1
374256a93a4Safresh1 SV *arg = ST(0);
375256a93a4Safresh1 SvGETMAGIC(arg);
376256a93a4Safresh1
377256a93a4Safresh1 /* SV was created as string if it has POK and isn't bool */
378256a93a4Safresh1 ST(0) = boolSV(SvPOK(arg) && !SvIsBOOL(arg));
379256a93a4Safresh1 XSRETURN(1);
380256a93a4Safresh1 }
381256a93a4Safresh1
XS(XS_builtin_created_as_number)382256a93a4Safresh1 XS(XS_builtin_created_as_number)
383256a93a4Safresh1 {
384256a93a4Safresh1 dXSARGS;
385256a93a4Safresh1
386256a93a4Safresh1 if(items != 1)
387256a93a4Safresh1 croak_xs_usage(cv, "arg");
388256a93a4Safresh1
389256a93a4Safresh1 SV *arg = ST(0);
390256a93a4Safresh1 SvGETMAGIC(arg);
391256a93a4Safresh1
392256a93a4Safresh1 /* SV was created as number if it has NOK or IOK but not POK and is not bool */
393256a93a4Safresh1 ST(0) = boolSV(SvNIOK(arg) && !SvPOK(arg) && !SvIsBOOL(arg));
394256a93a4Safresh1 XSRETURN(1);
395256a93a4Safresh1 }
396256a93a4Safresh1
ck_builtin_func1(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)397256a93a4Safresh1 static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
398256a93a4Safresh1 {
399256a93a4Safresh1 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));
400256a93a4Safresh1
401256a93a4Safresh1 warn_experimental_builtin(builtin->name, false);
402256a93a4Safresh1
403256a93a4Safresh1 SV *prototype = newSVpvs("$");
404256a93a4Safresh1 SAVEFREESV(prototype);
405256a93a4Safresh1
406256a93a4Safresh1 assert(entersubop->op_type == OP_ENTERSUB);
407256a93a4Safresh1
408256a93a4Safresh1 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
409256a93a4Safresh1
410256a93a4Safresh1 OPCODE opcode = builtin->ckval;
411256a93a4Safresh1 if(!opcode)
412256a93a4Safresh1 return entersubop;
413256a93a4Safresh1
414256a93a4Safresh1 OP *parent = entersubop, *pushop, *argop;
415256a93a4Safresh1
416256a93a4Safresh1 pushop = cUNOPx(entersubop)->op_first;
417256a93a4Safresh1 if (!OpHAS_SIBLING(pushop)) {
418256a93a4Safresh1 pushop = cUNOPx(pushop)->op_first;
419256a93a4Safresh1 }
420256a93a4Safresh1
421256a93a4Safresh1 argop = OpSIBLING(pushop);
422256a93a4Safresh1
423256a93a4Safresh1 if (!argop || !OpHAS_SIBLING(argop) || OpHAS_SIBLING(OpSIBLING(argop)))
424256a93a4Safresh1 return entersubop;
425256a93a4Safresh1
426256a93a4Safresh1 (void)op_sibling_splice(parent, pushop, 1, NULL);
427256a93a4Safresh1
428256a93a4Safresh1 U8 wantflags = entersubop->op_flags & OPf_WANT;
429256a93a4Safresh1
430256a93a4Safresh1 op_free(entersubop);
431256a93a4Safresh1
432256a93a4Safresh1 return newUNOP(opcode, wantflags, argop);
433256a93a4Safresh1 }
434256a93a4Safresh1
XS(XS_builtin_indexed)435256a93a4Safresh1 XS(XS_builtin_indexed)
436256a93a4Safresh1 {
437256a93a4Safresh1 dXSARGS;
438256a93a4Safresh1
439256a93a4Safresh1 switch(GIMME_V) {
440256a93a4Safresh1 case G_VOID:
441256a93a4Safresh1 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
442256a93a4Safresh1 "Useless use of %s in void context", "builtin::indexed");
443256a93a4Safresh1 XSRETURN(0);
444256a93a4Safresh1
445256a93a4Safresh1 case G_SCALAR:
446256a93a4Safresh1 Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR),
447256a93a4Safresh1 "Useless use of %s in scalar context", "builtin::indexed");
448256a93a4Safresh1 ST(0) = sv_2mortal(newSViv(items * 2));
449256a93a4Safresh1 XSRETURN(1);
450256a93a4Safresh1
451256a93a4Safresh1 case G_LIST:
452256a93a4Safresh1 break;
453256a93a4Safresh1 }
454256a93a4Safresh1
455256a93a4Safresh1 SSize_t retcount = items * 2;
456256a93a4Safresh1 EXTEND(SP, retcount);
457256a93a4Safresh1
458256a93a4Safresh1 /* Copy from [items-1] down to [0] so we don't have to make
459256a93a4Safresh1 * temporary copies */
460256a93a4Safresh1 for(SSize_t index = items - 1; index >= 0; index--) {
461256a93a4Safresh1 /* Copy, not alias */
462256a93a4Safresh1 ST(index * 2 + 1) = sv_mortalcopy(ST(index));
463256a93a4Safresh1 ST(index * 2) = sv_2mortal(newSViv(index));
464256a93a4Safresh1 }
465256a93a4Safresh1
466256a93a4Safresh1 XSRETURN(retcount);
467256a93a4Safresh1 }
468256a93a4Safresh1
ck_builtin_funcN(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)469256a93a4Safresh1 static OP *ck_builtin_funcN(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
470256a93a4Safresh1 {
471256a93a4Safresh1 const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));
472256a93a4Safresh1
473256a93a4Safresh1 warn_experimental_builtin(builtin->name, false);
474256a93a4Safresh1
475256a93a4Safresh1 SV *prototype = newSVpvs("@");
476256a93a4Safresh1 SAVEFREESV(prototype);
477256a93a4Safresh1
478256a93a4Safresh1 assert(entersubop->op_type == OP_ENTERSUB);
479256a93a4Safresh1
480256a93a4Safresh1 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
481256a93a4Safresh1 return entersubop;
482256a93a4Safresh1 }
483256a93a4Safresh1
484256a93a4Safresh1 static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function";
485256a93a4Safresh1
486256a93a4Safresh1 static const struct BuiltinFuncDescriptor builtins[] = {
487256a93a4Safresh1 /* constants */
488256a93a4Safresh1 { "builtin::true", &XS_builtin_true, &ck_builtin_const, BUILTIN_CONST_TRUE },
489256a93a4Safresh1 { "builtin::false", &XS_builtin_false, &ck_builtin_const, BUILTIN_CONST_FALSE },
490256a93a4Safresh1
491256a93a4Safresh1 /* unary functions */
492256a93a4Safresh1 { "builtin::is_bool", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL },
493256a93a4Safresh1 { "builtin::weaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_WEAKEN },
494256a93a4Safresh1 { "builtin::unweaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_UNWEAKEN },
495256a93a4Safresh1 { "builtin::is_weak", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK },
496256a93a4Safresh1 { "builtin::blessed", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED },
497256a93a4Safresh1 { "builtin::refaddr", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR },
498256a93a4Safresh1 { "builtin::reftype", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE },
499256a93a4Safresh1 { "builtin::ceil", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL },
500256a93a4Safresh1 { "builtin::floor", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR },
501*f2a19305Safresh1 { "builtin::is_tainted", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_TAINTED },
502*f2a19305Safresh1 { "builtin::trim", &XS_builtin_trim, &ck_builtin_func1, 0 },
503256a93a4Safresh1
504256a93a4Safresh1 { "builtin::created_as_string", &XS_builtin_created_as_string, &ck_builtin_func1, 0 },
505256a93a4Safresh1 { "builtin::created_as_number", &XS_builtin_created_as_number, &ck_builtin_func1, 0 },
506256a93a4Safresh1
507256a93a4Safresh1 /* list functions */
508256a93a4Safresh1 { "builtin::indexed", &XS_builtin_indexed, &ck_builtin_funcN, 0 },
509*f2a19305Safresh1 { "builtin::export_lexically", &XS_builtin_export_lexically, NULL, 0 },
510256a93a4Safresh1 { 0 }
511256a93a4Safresh1 };
512256a93a4Safresh1
513256a93a4Safresh1 XS(XS_builtin_import);
XS(XS_builtin_import)514256a93a4Safresh1 XS(XS_builtin_import)
515256a93a4Safresh1 {
516256a93a4Safresh1 dXSARGS;
517256a93a4Safresh1
518256a93a4Safresh1 if(!PL_compcv)
519256a93a4Safresh1 Perl_croak(aTHX_
520256a93a4Safresh1 "builtin::import can only be called at compile time");
521256a93a4Safresh1
522*f2a19305Safresh1 prepare_export_lexical();
523256a93a4Safresh1
524256a93a4Safresh1 for(int i = 1; i < items; i++) {
525256a93a4Safresh1 SV *sym = ST(i);
526256a93a4Safresh1 if(strEQ(SvPV_nolen(sym), "import"))
527256a93a4Safresh1 Perl_croak(aTHX_ builtin_not_recognised, sym);
528256a93a4Safresh1
529256a93a4Safresh1 SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym)));
530256a93a4Safresh1 SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym)));
531256a93a4Safresh1
532256a93a4Safresh1 CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0);
533256a93a4Safresh1 if(!cv)
534256a93a4Safresh1 Perl_croak(aTHX_ builtin_not_recognised, sym);
535256a93a4Safresh1
536*f2a19305Safresh1 export_lexical(ampname, (SV *)cv);
537256a93a4Safresh1 }
538256a93a4Safresh1
539*f2a19305Safresh1 finish_export_lexical();
540256a93a4Safresh1 }
541256a93a4Safresh1
542256a93a4Safresh1 void
Perl_boot_core_builtin(pTHX)543256a93a4Safresh1 Perl_boot_core_builtin(pTHX)
544256a93a4Safresh1 {
545256a93a4Safresh1 I32 i;
546256a93a4Safresh1 for(i = 0; builtins[i].name; i++) {
547256a93a4Safresh1 const struct BuiltinFuncDescriptor *builtin = &builtins[i];
548256a93a4Safresh1
549256a93a4Safresh1 const char *proto = NULL;
550256a93a4Safresh1 if(builtin->checker == &ck_builtin_const)
551256a93a4Safresh1 proto = "";
552256a93a4Safresh1 else if(builtin->checker == &ck_builtin_func1)
553256a93a4Safresh1 proto = "$";
554256a93a4Safresh1
555256a93a4Safresh1 CV *cv = newXS_flags(builtin->name, builtin->xsub, __FILE__, proto, 0);
556256a93a4Safresh1 XSANY.any_i32 = builtin->ckval;
557256a93a4Safresh1
558256a93a4Safresh1 if(builtin->checker) {
559256a93a4Safresh1 cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0);
560256a93a4Safresh1 }
561256a93a4Safresh1 }
562256a93a4Safresh1
563256a93a4Safresh1 newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0);
564256a93a4Safresh1 }
565256a93a4Safresh1
566256a93a4Safresh1 /*
567256a93a4Safresh1 * ex: set ts=8 sts=4 sw=4 et:
568256a93a4Safresh1 */
569