1 #line 2 "universal.c"
2 /* universal.c
3 *
4 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
5 * 2005, 2006, 2007, 2008 by Larry Wall and others
6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
10 */
11
12 /*
13 * '"The roots of those mountains must be roots indeed; there must be
14 * great secrets buried there which have not been discovered since the
15 * beginning."' --Gandalf, relating Gollum's history
16 *
17 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
18 */
19
20 /* This file contains the code that implements the functions in Perl's
21 * UNIVERSAL package, such as UNIVERSAL->can().
22 *
23 * It is also used to store XS functions that need to be present in
24 * miniperl for a lack of a better place to put them. It might be
25 * clever to move them to separate XS files which would then be pulled
26 * in by some to-be-written build process.
27 */
28
29 #include "EXTERN.h"
30 #define PERL_IN_UNIVERSAL_C
31 #include "perl.h"
32
33 #if defined(USE_PERLIO)
34 #include "perliol.h" /* For the PERLIO_F_XXX */
35 #endif
36
37 /*
38 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
39 * The main guts of traverse_isa was actually copied from gv_fetchmeth
40 */
41
42 #define PERL_ARGS_ASSERT_ISA_LOOKUP \
43 assert(stash); \
44 assert(namesv || name)
45
46
47 STATIC bool
S_isa_lookup(pTHX_ HV * stash,SV * namesv,const char * name,STRLEN len,U32 flags)48 S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 flags)
49 {
50 const struct mro_meta *const meta = HvMROMETA(stash);
51 HV *isa = meta->isa;
52 const HV *our_stash;
53
54 PERL_ARGS_ASSERT_ISA_LOOKUP;
55
56 if (!isa) {
57 (void)mro_get_linear_isa(stash);
58 isa = meta->isa;
59 }
60
61 if (hv_common(isa, namesv, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
62 HV_FETCH_ISEXISTS, NULL, 0)) {
63 /* Direct name lookup worked. */
64 return TRUE;
65 }
66
67 /* A stash/class can go by many names (ie. User == main::User), so
68 we use the HvENAME in the stash itself, which is canonical, falling
69 back to HvNAME if necessary. */
70 our_stash = gv_stashsvpvn_cached(namesv, name, len, flags);
71
72 if (our_stash) {
73 HEK *canon_name = HvENAME_HEK(our_stash);
74 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
75 assert(canon_name);
76 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
77 HEK_FLAGS(canon_name),
78 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
79 return TRUE;
80 }
81 }
82
83 return FALSE;
84 }
85
86 #define PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN \
87 assert(sv); \
88 assert(namesv || name)
89
90 STATIC bool
S_sv_derived_from_svpvn(pTHX_ SV * sv,SV * namesv,const char * name,const STRLEN len,U32 flags)91 S_sv_derived_from_svpvn(pTHX_ SV *sv, SV *namesv, const char * name, const STRLEN len, U32 flags)
92 {
93 HV* stash;
94
95 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN;
96 SvGETMAGIC(sv);
97
98 if (SvROK(sv)) {
99 const char *type;
100 sv = SvRV(sv);
101 type = sv_reftype(sv,0);
102 if (type) {
103 if (namesv)
104 name = SvPV_nolen(namesv);
105 if (strEQ(name, type))
106 return TRUE;
107 }
108 if (!SvOBJECT(sv))
109 return FALSE;
110 stash = SvSTASH(sv);
111 }
112 else {
113 stash = gv_stashsv(sv, 0);
114 }
115
116 if (stash && isa_lookup(stash, namesv, name, len, flags))
117 return TRUE;
118
119 stash = gv_stashpvs("UNIVERSAL", 0);
120 return stash && isa_lookup(stash, namesv, name, len, flags);
121 }
122
123 /*
124 =for apidoc_section $SV
125
126 =for apidoc sv_derived_from_pvn
127
128 Returns a boolean indicating whether the SV is derived from the specified class
129 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
130 normal Perl method.
131
132 Currently, the only significant value for C<flags> is SVf_UTF8.
133
134 =cut
135
136 =for apidoc sv_derived_from_sv
137
138 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
139 of an SV instead of a string/length pair. This is the advised form.
140
141 =cut
142
143 */
144
145 bool
Perl_sv_derived_from_sv(pTHX_ SV * sv,SV * namesv,U32 flags)146 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
147 {
148 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
149 return sv_derived_from_svpvn(sv, namesv, NULL, 0, flags);
150 }
151
152 /*
153 =for apidoc sv_derived_from
154
155 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
156
157 =cut
158 */
159
160 bool
Perl_sv_derived_from(pTHX_ SV * sv,const char * const name)161 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
162 {
163 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
164 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), 0);
165 }
166
167 /*
168 =for apidoc sv_derived_from_pv
169
170 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
171 instead of a string/length pair.
172
173 =cut
174 */
175
176
177 bool
Perl_sv_derived_from_pv(pTHX_ SV * sv,const char * const name,U32 flags)178 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
179 {
180 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
181 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), flags);
182 }
183
184 bool
Perl_sv_derived_from_pvn(pTHX_ SV * sv,const char * const name,const STRLEN len,U32 flags)185 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
186 {
187 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
188 return sv_derived_from_svpvn(sv, NULL, name, len, flags);
189 }
190
191 /*
192 =for apidoc sv_derived_from_hv
193
194 Exactly like L</sv_derived_from_pvn>, but takes the name string as the
195 C<HvNAME> of the given HV (which would presumably represent a stash).
196
197 =cut
198 */
199
200 bool
Perl_sv_derived_from_hv(pTHX_ SV * sv,HV * hv)201 Perl_sv_derived_from_hv(pTHX_ SV *sv, HV *hv)
202 {
203 PERL_ARGS_ASSERT_SV_DERIVED_FROM_HV;
204
205 const char *hvname = HvNAME(hv);
206 if(!hvname)
207 return FALSE;
208
209 return sv_derived_from_svpvn(sv, NULL, hvname, HvNAMELEN(hv), HvNAMEUTF8(hv) ? SVf_UTF8 : 0);
210 }
211
212 /*
213 =for apidoc sv_isa_sv
214
215 Returns a boolean indicating whether the SV is an object reference and is
216 derived from the specified class, respecting any C<isa()> method overloading
217 it may have. Returns false if C<sv> is not a reference to an object, or is
218 not derived from the specified class.
219
220 This is the function used to implement the behaviour of the C<isa> operator.
221
222 Does not invoke magic on C<sv>.
223
224 Not to be confused with the older C<sv_isa> function, which does not use an
225 overloaded C<isa()> method, nor will check subclassing.
226
227 =cut
228
229 */
230
231 bool
Perl_sv_isa_sv(pTHX_ SV * sv,SV * namesv)232 Perl_sv_isa_sv(pTHX_ SV *sv, SV *namesv)
233 {
234 GV *isagv;
235
236 PERL_ARGS_ASSERT_SV_ISA_SV;
237
238 if(!SvROK(sv) || !SvOBJECT(SvRV(sv)))
239 return FALSE;
240
241 isagv = gv_fetchmeth_pvn(SvSTASH(SvRV(sv)), "isa", 3, -1, GV_NOUNIVERSAL);
242 if(isagv) {
243 dSP;
244 CV *isacv = isGV(isagv) ? GvCV(isagv) : (CV *)isagv;
245 SV *retsv;
246 bool ret;
247
248 PUTBACK;
249
250 ENTER;
251 SAVETMPS;
252
253 EXTEND(SP, 2);
254 PUSHMARK(SP);
255 PUSHs(sv);
256 PUSHs(namesv);
257 PUTBACK;
258
259 call_sv((SV *)isacv, G_SCALAR);
260
261 SPAGAIN;
262 retsv = POPs;
263 ret = SvTRUE(retsv);
264 PUTBACK;
265
266 FREETMPS;
267 LEAVE;
268
269 return ret;
270 }
271
272 /* TODO: Support namesv being an HV ref to the stash directly? */
273
274 return sv_derived_from_sv(sv, namesv, 0);
275 }
276
277 /*
278 =for apidoc sv_does_sv
279
280 Returns a boolean indicating whether the SV performs a specific, named role.
281 The SV can be a Perl object or the name of a Perl class.
282
283 =cut
284 */
285
286 #include "XSUB.h"
287
288 bool
Perl_sv_does_sv(pTHX_ SV * sv,SV * namesv,U32 flags)289 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
290 {
291 SV *classname;
292 bool does_it;
293 SV *methodname;
294 dSP;
295
296 PERL_ARGS_ASSERT_SV_DOES_SV;
297 PERL_UNUSED_ARG(flags);
298
299 ENTER;
300 SAVETMPS;
301
302 SvGETMAGIC(sv);
303
304 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
305 LEAVE;
306 return FALSE;
307 }
308
309 if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
310 classname = sv_ref(NULL,SvRV(sv),TRUE);
311 } else {
312 classname = sv;
313 }
314
315 if (sv_eq(classname, namesv)) {
316 LEAVE;
317 return TRUE;
318 }
319
320 PUSHMARK(SP);
321 EXTEND(SP, 2);
322 PUSHs(sv);
323 PUSHs(namesv);
324 PUTBACK;
325
326 /* create a PV with value "isa", but with a special address
327 * so that perl knows we're really doing "DOES" instead */
328 methodname = newSV_type_mortal(SVt_PV);
329 SvLEN_set(methodname, 0);
330 SvCUR_set(methodname, strlen(PL_isa_DOES));
331 SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
332 SvPOK_on(methodname);
333 call_sv(methodname, G_SCALAR | G_METHOD);
334 SPAGAIN;
335
336 does_it = SvTRUE_NN( TOPs );
337 FREETMPS;
338 LEAVE;
339
340 return does_it;
341 }
342
343 /*
344 =for apidoc sv_does
345
346 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
347
348 =cut
349 */
350
351 bool
Perl_sv_does(pTHX_ SV * sv,const char * const name)352 Perl_sv_does(pTHX_ SV *sv, const char *const name)
353 {
354 PERL_ARGS_ASSERT_SV_DOES;
355 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
356 }
357
358 /*
359 =for apidoc sv_does_pv
360
361 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
362
363 =cut
364 */
365
366
367 bool
Perl_sv_does_pv(pTHX_ SV * sv,const char * const name,U32 flags)368 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
369 {
370 PERL_ARGS_ASSERT_SV_DOES_PV;
371 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
372 }
373
374 /*
375 =for apidoc sv_does_pvn
376
377 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
378
379 =cut
380 */
381
382 bool
Perl_sv_does_pvn(pTHX_ SV * sv,const char * const name,const STRLEN len,U32 flags)383 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
384 {
385 PERL_ARGS_ASSERT_SV_DOES_PVN;
386
387 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
388 }
389
390 /*
391 =for apidoc croak_xs_usage
392
393 A specialised variant of C<croak()> for emitting the usage message for xsubs
394
395 croak_xs_usage(cv, "eee_yow");
396
397 works out the package name and subroutine name from C<cv>, and then calls
398 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
399
400 diag_listed_as: SKIPME
401 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
402 "eee_yow");
403
404 =cut
405 */
406
407 void
Perl_croak_xs_usage(const CV * const cv,const char * const params)408 Perl_croak_xs_usage(const CV *const cv, const char *const params)
409 {
410 /* Avoid CvGV as it requires aTHX. */
411 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
412
413 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
414
415 if (gv) got_gv: {
416 const HV *const stash = GvSTASH(gv);
417
418 if (HvNAME_get(stash))
419 /* diag_listed_as: SKIPME */
420 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
421 HEKfARG(HvNAME_HEK(stash)),
422 HEKfARG(GvNAME_HEK(gv)),
423 params);
424 else
425 /* diag_listed_as: SKIPME */
426 Perl_croak_nocontext("Usage: %" HEKf "(%s)",
427 HEKfARG(GvNAME_HEK(gv)), params);
428 } else {
429 dTHX;
430 if ((gv = CvGV(cv))) goto got_gv;
431
432 /* Pants. I don't think that it should be possible to get here. */
433 /* diag_listed_as: SKIPME */
434 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
435 }
436 }
437
438 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_isa)439 XS(XS_UNIVERSAL_isa)
440 {
441 dXSARGS;
442
443 if (items != 2)
444 croak_xs_usage(cv, "reference, kind");
445 else {
446 SV * const sv = ST(0);
447
448 SvGETMAGIC(sv);
449
450 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
451 XSRETURN_UNDEF;
452
453 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
454 XSRETURN(1);
455 }
456 }
457
458 XS(XS_UNIVERSAL_import_unimport); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_import_unimport)459 XS(XS_UNIVERSAL_import_unimport)
460 {
461 dXSARGS;
462 dXSI32;
463
464 if (items > 1) {
465 char *class_pv= SvPV_nolen(ST(0));
466 if (strEQ(class_pv,"UNIVERSAL"))
467 Perl_croak(aTHX_ "UNIVERSAL does not export anything");
468 /* _charnames is special - ignore it for now as the code that
469 * depends on it has its own "no import" logic that produces better
470 * warnings than this does. */
471 if (strNE(class_pv,"_charnames"))
472 Perl_ck_warner_d(aTHX_
473 packWARN(WARN_DEPRECATED__MISSING_IMPORT_CALLED_WITH_ARGS),
474 "Attempt to call undefined %s method with arguments "
475 "(%" SVf_QUOTEDPREFIX "%s) via package "
476 "%" SVf_QUOTEDPREFIX " (Perhaps you forgot to load the package?)",
477 ix ? "unimport" : "import",
478 SVfARG(ST(1)),
479 (items > 2 ? " ..." : ""),
480 SVfARG(ST(0)));
481 }
482 XSRETURN_EMPTY;
483 }
484
485
486 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_can)487 XS(XS_UNIVERSAL_can)
488 {
489 dXSARGS;
490 SV *sv;
491 SV *rv;
492 HV *pkg = NULL;
493 GV *iogv;
494
495 if (items != 2)
496 croak_xs_usage(cv, "object-ref, method");
497
498 sv = ST(0);
499
500 SvGETMAGIC(sv);
501
502 /* Reject undef and empty string. Note that the string form takes
503 precedence here over the numeric form, as (!1)->foo treats the
504 invocant as the empty string, though it is a dualvar. */
505 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
506 XSRETURN_UNDEF;
507
508 rv = &PL_sv_undef;
509
510 if (SvROK(sv)) {
511 sv = MUTABLE_SV(SvRV(sv));
512 if (SvOBJECT(sv))
513 pkg = SvSTASH(sv);
514 else if (isGV_with_GP(sv) && GvIO(sv))
515 pkg = SvSTASH(GvIO(sv));
516 }
517 else if (isGV_with_GP(sv) && GvIO(sv))
518 pkg = SvSTASH(GvIO(sv));
519 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
520 pkg = SvSTASH(GvIO(iogv));
521 else {
522 pkg = gv_stashsv(sv, 0);
523 if (!pkg)
524 pkg = gv_stashpvs("UNIVERSAL", 0);
525 }
526
527 if (pkg) {
528 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
529 if (gv && isGV(gv))
530 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
531 }
532
533 ST(0) = rv;
534 XSRETURN(1);
535 }
536
537 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_DOES)538 XS(XS_UNIVERSAL_DOES)
539 {
540 dXSARGS;
541 PERL_UNUSED_ARG(cv);
542
543 if (items != 2)
544 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
545 else {
546 SV * const sv = ST(0);
547 if (sv_does_sv( sv, ST(1), 0 ))
548 XSRETURN_YES;
549
550 XSRETURN_NO;
551 }
552 }
553
554 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_is_utf8)555 XS(XS_utf8_is_utf8)
556 {
557 dXSARGS;
558 if (items != 1)
559 croak_xs_usage(cv, "sv");
560 else {
561 SV * const sv = ST(0);
562 SvGETMAGIC(sv);
563 if (SvUTF8(sv))
564 XSRETURN_YES;
565 else
566 XSRETURN_NO;
567 }
568 XSRETURN_EMPTY;
569 }
570
571 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_valid)572 XS(XS_utf8_valid)
573 {
574 dXSARGS;
575 if (items != 1)
576 croak_xs_usage(cv, "sv");
577 else {
578 SV * const sv = ST(0);
579 STRLEN len;
580 const char * const s = SvPV_const(sv,len);
581 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
582 XSRETURN_YES;
583 else
584 XSRETURN_NO;
585 }
586 XSRETURN_EMPTY;
587 }
588
589 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_encode)590 XS(XS_utf8_encode)
591 {
592 dXSARGS;
593 if (items != 1)
594 croak_xs_usage(cv, "sv");
595 sv_utf8_encode(ST(0));
596 SvSETMAGIC(ST(0));
597 XSRETURN_EMPTY;
598 }
599
600 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_decode)601 XS(XS_utf8_decode)
602 {
603 dXSARGS;
604 if (items != 1)
605 croak_xs_usage(cv, "sv");
606 else {
607 SV * const sv = ST(0);
608 bool RETVAL;
609 SvPV_force_nolen(sv);
610 RETVAL = sv_utf8_decode(sv);
611 SvSETMAGIC(sv);
612 ST(0) = boolSV(RETVAL);
613 }
614 XSRETURN(1);
615 }
616
617 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_upgrade)618 XS(XS_utf8_upgrade)
619 {
620 dXSARGS;
621 if (items != 1)
622 croak_xs_usage(cv, "sv");
623 else {
624 SV * const sv = ST(0);
625 STRLEN RETVAL = 0;
626 dXSTARG;
627
628 XSprePUSH;
629 if (UNLIKELY(! sv)) {
630 XSRETURN_UNDEF;
631 }
632
633 SvGETMAGIC(sv);
634 if (UNLIKELY(! SvOK(sv))) {
635 XSRETURN_UNDEF;
636 }
637
638 RETVAL = sv_utf8_upgrade_nomg(sv);
639 PUSHi( (IV) RETVAL);
640 }
641 XSRETURN(1);
642 }
643
644 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_downgrade)645 XS(XS_utf8_downgrade)
646 {
647 dXSARGS;
648 if (items < 1 || items > 2)
649 croak_xs_usage(cv, "sv, failok=0");
650 else {
651 SV * const sv0 = ST(0);
652 SV * const sv1 = ST(1);
653 const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0;
654 const bool RETVAL = sv_utf8_downgrade(sv0, failok);
655
656 ST(0) = boolSV(RETVAL);
657 }
658 XSRETURN(1);
659 }
660
661 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_native_to_unicode)662 XS(XS_utf8_native_to_unicode)
663 {
664 dXSARGS;
665 const UV uv = SvUV(ST(0));
666
667 if (items > 1)
668 croak_xs_usage(cv, "sv");
669
670 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
671 XSRETURN(1);
672 }
673
674 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_unicode_to_native)675 XS(XS_utf8_unicode_to_native)
676 {
677 dXSARGS;
678 const UV uv = SvUV(ST(0));
679
680 if (items > 1)
681 croak_xs_usage(cv, "sv");
682
683 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
684 XSRETURN(1);
685 }
686
687 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_SvREADONLY)688 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
689 {
690 dXSARGS;
691 SV * const svz = ST(0);
692 SV * sv;
693
694 /* [perl #77776] - called as &foo() not foo() */
695 if (!SvROK(svz))
696 croak_xs_usage(cv, "SCALAR[, ON]");
697
698 sv = SvRV(svz);
699
700 if (items == 1) {
701 if (SvREADONLY(sv))
702 XSRETURN_YES;
703 else
704 XSRETURN_NO;
705 }
706 else if (items == 2) {
707 SV *sv1 = ST(1);
708 if (SvTRUE_NN(sv1)) {
709 SvFLAGS(sv) |= SVf_READONLY;
710 XSRETURN_YES;
711 }
712 else {
713 /* I hope you really know what you are doing. */
714 SvFLAGS(sv) &=~ SVf_READONLY;
715 XSRETURN_NO;
716 }
717 }
718 XSRETURN_UNDEF; /* Can't happen. */
719 }
720
721 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
XS(XS_constant__make_const)722 XS(XS_constant__make_const) /* This is dangerous stuff. */
723 {
724 dXSARGS;
725 SV * const svz = ST(0);
726 SV * sv;
727
728 /* [perl #77776] - called as &foo() not foo() */
729 if (!SvROK(svz) || items != 1)
730 croak_xs_usage(cv, "SCALAR");
731
732 sv = SvRV(svz);
733
734 SvREADONLY_on(sv);
735 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
736 /* for constant.pm; nobody else should be calling this
737 on arrays anyway. */
738 SV **svp;
739 for (svp = AvARRAY(sv) + AvFILLp(sv)
740 ; svp >= AvARRAY(sv)
741 ; --svp)
742 if (*svp) SvPADTMP_on(*svp);
743 }
744 XSRETURN(0);
745 }
746
747 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_SvREFCNT)748 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
749 {
750 dXSARGS;
751 SV * const svz = ST(0);
752 SV * sv;
753 U32 refcnt;
754
755 /* [perl #77776] - called as &foo() not foo() */
756 if ((items != 1 && items != 2) || !SvROK(svz))
757 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
758
759 sv = SvRV(svz);
760
761 /* I hope you really know what you are doing. */
762 /* idea is for SvREFCNT(sv) to be accessed only once */
763 refcnt = items == 2 ?
764 /* we free one ref on exit */
765 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
766 : SvREFCNT(sv);
767 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
768
769 }
770
771 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_hv_clear_placehold)772 XS(XS_Internals_hv_clear_placehold)
773 {
774 dXSARGS;
775
776 if (items != 1 || !SvROK(ST(0)))
777 croak_xs_usage(cv, "hv");
778 else {
779 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
780 hv_clear_placeholders(hv);
781 XSRETURN(0);
782 }
783 }
784
785 XS(XS_Internals_stack_refcounted); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_stack_refcounted)786 XS(XS_Internals_stack_refcounted)
787 {
788 dXSARGS;
789 UV val = 0;
790
791 if (items != 0)
792 croak_xs_usage(cv, "");
793 #ifdef PERL_RC_STACK
794 val |= 1;
795 #endif
796 XSRETURN_UV(val);
797 }
798
799 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO_get_layers)800 XS(XS_PerlIO_get_layers)
801 {
802 dXSARGS;
803 if (items < 1 || items % 2 == 0)
804 croak_xs_usage(cv, "filehandle[,args]");
805 #if defined(USE_PERLIO)
806 {
807 SV * sv;
808 GV * gv;
809 IO * io = NULL;
810 bool input = TRUE;
811 bool details = FALSE;
812
813 if (items > 1) {
814 SV * const *svp;
815 for (svp = MARK + 2; svp <= SP; svp += 2) {
816 SV * const * const varp = svp;
817 SV * const * const valp = svp + 1;
818 STRLEN klen;
819 const char * const key = SvPV_const(*varp, klen);
820
821 switch (*key) {
822 case 'i':
823 if (memEQs(key, klen, "input")) {
824 input = SvTRUE(*valp);
825 break;
826 }
827 goto fail;
828 case 'o':
829 if (memEQs(key, klen, "output")) {
830 input = !SvTRUE(*valp);
831 break;
832 }
833 goto fail;
834 case 'd':
835 if (memEQs(key, klen, "details")) {
836 details = SvTRUE(*valp);
837 break;
838 }
839 goto fail;
840 default:
841 fail:
842 Perl_croak(aTHX_
843 "get_layers: unknown argument '%s'",
844 key);
845 }
846 }
847
848 SP -= (items - 1);
849 }
850
851 sv = POPs;
852
853 /* MAYBE_DEREF_GV will call get magic */
854 if ((gv = MAYBE_DEREF_GV(sv)))
855 io = GvIO(gv);
856 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO)
857 io = (IO*)SvRV(sv);
858 else if (!SvROK(sv) && (gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)))
859 io = GvIO(gv);
860
861 if (io) {
862 AV* const av = PerlIO_get_layers(aTHX_ input ?
863 IoIFP(io) : IoOFP(io));
864 SSize_t i;
865 const SSize_t last = av_top_index(av);
866 SSize_t nitem = 0;
867
868 for (i = last; i >= 0; i -= 3) {
869 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
870 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
871 SV * const * const flgsvp = av_fetch(av, i, FALSE);
872
873 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
874 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
875 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
876
877 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
878 if (details) {
879 /* Indents of 5? Yuck. */
880 /* We know that PerlIO_get_layers creates a new SV for
881 the name and flags, so we can just take a reference
882 and "steal" it when we free the AV below. */
883 PUSHs(namok
884 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
885 : &PL_sv_undef);
886 PUSHs(argok
887 ? newSVpvn_flags(SvPVX_const(*argsvp),
888 SvCUR(*argsvp),
889 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
890 | SVs_TEMP)
891 : &PL_sv_undef);
892 PUSHs(flgok
893 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
894 : &PL_sv_undef);
895 nitem += 3;
896 }
897 else {
898 if (namok && argok)
899 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
900 SVfARG(*namsvp),
901 SVfARG(*argsvp))));
902 else if (namok)
903 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
904 else
905 PUSHs(&PL_sv_undef);
906 nitem++;
907 if (flgok) {
908 const IV flags = SvIVX(*flgsvp);
909
910 if (flags & PERLIO_F_UTF8) {
911 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
912 nitem++;
913 }
914 }
915 }
916 }
917
918 SvREFCNT_dec(av);
919
920 XSRETURN(nitem);
921 }
922 }
923 #endif
924
925 XSRETURN(0);
926 }
927
928 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_is_regexp)929 XS(XS_re_is_regexp)
930 {
931 dXSARGS;
932
933 if (items != 1)
934 croak_xs_usage(cv, "sv");
935
936 if (SvRXOK(ST(0))) {
937 XSRETURN_YES;
938 } else {
939 XSRETURN_NO;
940 }
941 }
942
943 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regnames_count)944 XS(XS_re_regnames_count)
945 {
946 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
947 SV * ret;
948 dXSARGS;
949
950 if (items != 0)
951 croak_xs_usage(cv, "");
952
953 if (!rx)
954 XSRETURN_UNDEF;
955
956 ret = CALLREG_NAMED_BUFF_COUNT(rx);
957
958 SPAGAIN;
959 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
960 XSRETURN(1);
961 }
962
963 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regname)964 XS(XS_re_regname)
965 {
966 dXSARGS;
967 REGEXP * rx;
968 U32 flags;
969 SV * ret;
970
971 if (items < 1 || items > 2)
972 croak_xs_usage(cv, "name[, all ]");
973
974 SP -= items;
975 PUTBACK;
976
977 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
978
979 if (!rx)
980 XSRETURN_UNDEF;
981
982 if (items == 2 && SvTRUE_NN(ST(1))) {
983 flags = RXapif_ALL;
984 } else {
985 flags = RXapif_ONE;
986 }
987 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
988
989 SPAGAIN;
990 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
991 XSRETURN(1);
992 }
993
994
995 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regnames)996 XS(XS_re_regnames)
997 {
998 dXSARGS;
999 REGEXP * rx;
1000 U32 flags;
1001 SV *ret;
1002 AV *av;
1003 SSize_t length;
1004 SSize_t i;
1005 SV **entry;
1006
1007 if (items > 1)
1008 croak_xs_usage(cv, "[all]");
1009
1010 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1011
1012 if (!rx)
1013 XSRETURN_UNDEF;
1014
1015 if (items == 1 && SvTRUE_NN(ST(0))) {
1016 flags = RXapif_ALL;
1017 } else {
1018 flags = RXapif_ONE;
1019 }
1020
1021 SP -= items;
1022 PUTBACK;
1023
1024 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1025
1026 SPAGAIN;
1027
1028 if (!ret)
1029 XSRETURN_UNDEF;
1030
1031 av = MUTABLE_AV(SvRV(ret));
1032 length = av_count(av);
1033
1034 EXTEND(SP, length); /* better extend stack just once */
1035 for (i = 0; i < length; i++) {
1036 entry = av_fetch(av, i, FALSE);
1037
1038 if (!entry)
1039 /* diag_listed_as: SKIPME */
1040 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1041
1042 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
1043 }
1044
1045 SvREFCNT_dec(ret);
1046
1047 PUTBACK;
1048 return;
1049 }
1050
1051 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regexp_pattern)1052 XS(XS_re_regexp_pattern)
1053 {
1054 dXSARGS;
1055 REGEXP *re;
1056 U8 const gimme = GIMME_V;
1057
1058 EXTEND(SP, 2);
1059 SP -= items;
1060 if (items != 1)
1061 croak_xs_usage(cv, "sv");
1062
1063 /*
1064 Checks if a reference is a regex or not. If the parameter is
1065 not a ref, or is not the result of a qr// then returns false
1066 in scalar context and an empty list in list context.
1067 Otherwise in list context it returns the pattern and the
1068 modifiers, in scalar context it returns the pattern just as it
1069 would if the qr// was stringified normally, regardless as
1070 to the class of the variable and any stringification overloads
1071 on the object.
1072 */
1073
1074 if ((re = SvRX(ST(0)))) /* assign deliberate */
1075 {
1076 /* Houston, we have a regex! */
1077 SV *pattern;
1078
1079 if ( gimme == G_LIST ) {
1080 STRLEN left = 0;
1081 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1082 const char *fptr;
1083 char ch;
1084 U16 match_flags;
1085
1086 /*
1087 we are in list context so stringify
1088 the modifiers that apply. We ignore "negative
1089 modifiers" in this scenario, and the default character set
1090 */
1091
1092 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1093 STRLEN len;
1094 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1095 &len);
1096 Copy(name, reflags + left, len, char);
1097 left += len;
1098 }
1099 fptr = INT_PAT_MODS;
1100 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1101 >> RXf_PMf_STD_PMMOD_SHIFT);
1102
1103 while((ch = *fptr++)) {
1104 if(match_flags & 1) {
1105 reflags[left++] = ch;
1106 }
1107 match_flags >>= 1;
1108 }
1109
1110 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1111 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1112
1113 /* return the pattern and the modifiers */
1114 PUSHs(pattern);
1115 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1116 XSRETURN(2);
1117 } else {
1118 /* Scalar, so use the string that Perl would return */
1119 /* return the pattern in (?msixn:..) format */
1120 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1121 PUSHs(pattern);
1122 XSRETURN(1);
1123 }
1124 } else {
1125 /* It ain't a regexp folks */
1126 if ( gimme == G_LIST ) {
1127 /* return the empty list */
1128 XSRETURN_EMPTY;
1129 } else {
1130 /* Because of the (?:..) wrapping involved in a
1131 stringified pattern it is impossible to get a
1132 result for a real regexp that would evaluate to
1133 false. Therefore we can return PL_sv_no to signify
1134 that the object is not a regex, this means that one
1135 can say
1136
1137 if (regex($might_be_a_regex) eq '(?:foo)') { }
1138
1139 and not worry about undefined values.
1140 */
1141 XSRETURN_NO;
1142 }
1143 }
1144 NOT_REACHED; /* NOTREACHED */
1145 }
1146
1147 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
1148
XS(XS_Internals_getcwd)1149 XS(XS_Internals_getcwd)
1150 {
1151 dXSARGS;
1152 SV *sv = sv_newmortal();
1153
1154 if (items != 0)
1155 croak_xs_usage(cv, "");
1156
1157 (void)getcwd_sv(sv);
1158
1159 SvTAINTED_on(sv);
1160 PUSHs(sv);
1161 XSRETURN(1);
1162 }
1163
1164 #endif
1165
XS(XS_NamedCapture_tie_it)1166 XS(XS_NamedCapture_tie_it)
1167 {
1168 dXSARGS;
1169
1170 if (items != 1)
1171 croak_xs_usage(cv, "sv");
1172 {
1173 SV *sv = ST(0);
1174 GV * const gv = (GV *)sv;
1175 HV * const hv = GvHVn(gv);
1176 SV *rv = newSV_type(SVt_IV);
1177 const char *gv_name = GvNAME(gv);
1178
1179 sv_setrv_noinc(rv, newSVuv(
1180 strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
1181 ? RXapif_ALL : RXapif_ONE));
1182 sv_bless(rv, GvSTASH(CvGV(cv)));
1183
1184 sv_unmagic((SV *)hv, PERL_MAGIC_tied);
1185 sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
1186 SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
1187 }
1188 XSRETURN_EMPTY;
1189 }
1190
XS(XS_NamedCapture_TIEHASH)1191 XS(XS_NamedCapture_TIEHASH)
1192 {
1193 dXSARGS;
1194 if (items < 1)
1195 croak_xs_usage(cv, "package, ...");
1196 {
1197 const char * package = (const char *)SvPV_nolen(ST(0));
1198 UV flag = RXapif_ONE;
1199 mark += 2;
1200 while(mark < sp) {
1201 STRLEN len;
1202 const char *p = SvPV_const(*mark, len);
1203 if(memEQs(p, len, "all"))
1204 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
1205 mark += 2;
1206 }
1207 ST(0) = newSV_type_mortal(SVt_IV);
1208 sv_setuv(newSVrv(ST(0), package), flag);
1209 }
1210 XSRETURN(1);
1211 }
1212
1213 /* These are tightly coupled to the RXapif_* flags defined in regexp.h */
1214 #define UNDEF_FATAL 0x80000
1215 #define DISCARD 0x40000
1216 #define EXPECT_SHIFT 24
1217 #define ACTION_MASK 0x000FF
1218
1219 #define FETCH_ALIAS (RXapif_FETCH | (2 << EXPECT_SHIFT))
1220 #define STORE_ALIAS (RXapif_STORE | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1221 #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
1222 #define CLEAR_ALIAS (RXapif_CLEAR | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1223 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
1224 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
1225
XS(XS_NamedCapture_FETCH)1226 XS(XS_NamedCapture_FETCH)
1227 {
1228 dXSARGS;
1229 dXSI32;
1230 PERL_UNUSED_VAR(cv); /* -W */
1231 PERL_UNUSED_VAR(ax); /* -Wall */
1232 SP -= items;
1233 {
1234 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1235 U32 flags;
1236 SV *ret;
1237 const U32 action = ix & ACTION_MASK;
1238 const int expect = ix >> EXPECT_SHIFT;
1239 if (items != expect)
1240 croak_xs_usage(cv, expect == 2 ? "$key"
1241 : (expect == 3 ? "$key, $value"
1242 : ""));
1243
1244 if (!rx || !SvROK(ST(0))) {
1245 if (ix & UNDEF_FATAL)
1246 Perl_croak_no_modify();
1247 else
1248 XSRETURN_UNDEF;
1249 }
1250
1251 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1252
1253 PUTBACK;
1254 ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
1255 expect >= 3 ? ST(2) : NULL, flags | action);
1256 SPAGAIN;
1257
1258 if (ix & DISCARD) {
1259 /* Called with G_DISCARD, so our return stack state is thrown away.
1260 Hence if we were returned anything, free it immediately. */
1261 SvREFCNT_dec(ret);
1262 } else {
1263 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1264 }
1265 PUTBACK;
1266 return;
1267 }
1268 }
1269
1270
XS(XS_NamedCapture_FIRSTKEY)1271 XS(XS_NamedCapture_FIRSTKEY)
1272 {
1273 dXSARGS;
1274 dXSI32;
1275 PERL_UNUSED_VAR(cv); /* -W */
1276 PERL_UNUSED_VAR(ax); /* -Wall */
1277 SP -= items;
1278 {
1279 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1280 U32 flags;
1281 SV *ret;
1282 const int expect = ix ? 2 : 1;
1283 const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
1284 if (items != expect)
1285 croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
1286
1287 if (!rx || !SvROK(ST(0)))
1288 XSRETURN_UNDEF;
1289
1290 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1291
1292 PUTBACK;
1293 ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
1294 expect >= 2 ? ST(1) : NULL,
1295 flags | action);
1296 SPAGAIN;
1297
1298 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1299 PUTBACK;
1300 return;
1301 }
1302 }
1303
1304 /* is this still needed? */
XS(XS_NamedCapture_flags)1305 XS(XS_NamedCapture_flags)
1306 {
1307 dXSARGS;
1308 PERL_UNUSED_VAR(cv); /* -W */
1309 PERL_UNUSED_VAR(ax); /* -Wall */
1310 SP -= items;
1311 {
1312 EXTEND(SP, 2);
1313 mPUSHu(RXapif_ONE);
1314 mPUSHu(RXapif_ALL);
1315 PUTBACK;
1316 return;
1317 }
1318 }
1319
1320 #include "vutil.h"
1321 #include "vxs.inc"
1322
1323 struct xsub_details {
1324 const char *name;
1325 XSUBADDR_t xsub;
1326 const char *proto;
1327 int ix;
1328 };
1329
1330 static const struct xsub_details these_details[] = {
1331 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
1332 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
1333 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 },
1334 {"UNIVERSAL::import", XS_UNIVERSAL_import_unimport, NULL, 0},
1335 {"UNIVERSAL::unimport", XS_UNIVERSAL_import_unimport, NULL, 1},
1336 #define VXS_XSUB_DETAILS
1337 #include "vxs.inc"
1338 #undef VXS_XSUB_DETAILS
1339 {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 },
1340 {"utf8::valid", XS_utf8_valid, NULL, 0 },
1341 {"utf8::encode", XS_utf8_encode, NULL, 0 },
1342 {"utf8::decode", XS_utf8_decode, NULL, 0 },
1343 {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 },
1344 {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 },
1345 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 },
1346 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 },
1347 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 },
1348 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 },
1349 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 },
1350 {"Internals::stack_refcounted", XS_Internals_stack_refcounted, NULL, 0 },
1351 {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 },
1352 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 },
1353 {"re::is_regexp", XS_re_is_regexp, "$", 0 },
1354 {"re::regname", XS_re_regname, ";$$", 0 },
1355 {"re::regnames", XS_re_regnames, ";$", 0 },
1356 {"re::regnames_count", XS_re_regnames_count, "", 0 },
1357 {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 },
1358 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
1359 {"Internals::getcwd", XS_Internals_getcwd, "", 0 },
1360 #endif
1361 {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
1362 {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },
1363 {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS },
1364 {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS },
1365 {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS },
1366 {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS },
1367 {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS },
1368 {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS },
1369 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 },
1370 {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 },
1371 {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 },
1372 };
1373
1374 STATIC OP*
optimize_out_native_convert_function(pTHX_ OP * entersubop,GV * namegv,SV * protosv)1375 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1376 GV* namegv,
1377 SV* protosv)
1378 {
1379 /* Optimizes out an identity function, i.e., one that just returns its
1380 * argument. The passed in function is assumed to be an identity function,
1381 * with no checking. This is designed to be called for utf8_to_native()
1382 * and native_to_utf8() on ASCII platforms, as they just return their
1383 * arguments, but it could work on any such function.
1384 *
1385 * The code is mostly just cargo-culted from Memoize::Lift */
1386
1387 OP *pushop, *argop;
1388 OP *parent;
1389 SV* prototype = newSVpvs("$");
1390
1391 PERL_UNUSED_ARG(protosv);
1392
1393 assert(entersubop->op_type == OP_ENTERSUB);
1394
1395 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1396 parent = entersubop;
1397
1398 SvREFCNT_dec(prototype);
1399
1400 pushop = cUNOPx(entersubop)->op_first;
1401 if (! OpHAS_SIBLING(pushop)) {
1402 parent = pushop;
1403 pushop = cUNOPx(pushop)->op_first;
1404 }
1405 argop = OpSIBLING(pushop);
1406
1407 /* Carry on without doing the optimization if it is not something we're
1408 * expecting, so continues to work */
1409 if ( ! argop
1410 || ! OpHAS_SIBLING(argop)
1411 || OpHAS_SIBLING(OpSIBLING(argop))
1412 ) {
1413 return entersubop;
1414 }
1415
1416 /* cut argop from the subtree */
1417 (void)op_sibling_splice(parent, pushop, 1, NULL);
1418
1419 op_free(entersubop);
1420 return argop;
1421 }
1422
1423 void
Perl_boot_core_UNIVERSAL(pTHX)1424 Perl_boot_core_UNIVERSAL(pTHX)
1425 {
1426 static const char file[] = __FILE__;
1427 const struct xsub_details *xsub = these_details;
1428 const struct xsub_details *end = C_ARRAY_END(these_details);
1429
1430 do {
1431 CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1432 XSANY.any_i32 = xsub->ix;
1433 } while (++xsub < end);
1434
1435 #ifndef EBCDIC
1436 { /* On ASCII platforms these functions just return their argument, so can
1437 be optimized away */
1438
1439 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1440 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1441
1442 cv_set_call_checker_flags(to_native_cv,
1443 optimize_out_native_convert_function,
1444 (SV*) to_native_cv, 0);
1445 cv_set_call_checker_flags(to_unicode_cv,
1446 optimize_out_native_convert_function,
1447 (SV*) to_unicode_cv, 0);
1448 }
1449 #endif
1450
1451 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1452 {
1453 CV * const cv =
1454 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1455 char ** cvfile = &CvFILE(cv);
1456 char * oldfile = *cvfile;
1457 CvDYNFILE_off(cv);
1458 *cvfile = (char *)file;
1459 Safefree(oldfile);
1460 }
1461 }
1462
1463 /*
1464 * ex: set ts=8 sts=4 sw=4 et:
1465 */
1466