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 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
401 "eee_yow");
402
403 =cut
404 */
405
406 void
Perl_croak_xs_usage(const CV * const cv,const char * const params)407 Perl_croak_xs_usage(const CV *const cv, const char *const params)
408 {
409 /* Avoid CvGV as it requires aTHX. */
410 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
411
412 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
413
414 if (gv) got_gv: {
415 const HV *const stash = GvSTASH(gv);
416
417 if (HvNAME_get(stash))
418 /* diag_listed_as: SKIPME */
419 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
420 HEKfARG(HvNAME_HEK(stash)),
421 HEKfARG(GvNAME_HEK(gv)),
422 params);
423 else
424 /* diag_listed_as: SKIPME */
425 Perl_croak_nocontext("Usage: %" HEKf "(%s)",
426 HEKfARG(GvNAME_HEK(gv)), params);
427 } else {
428 dTHX;
429 if ((gv = CvGV(cv))) goto got_gv;
430
431 /* Pants. I don't think that it should be possible to get here. */
432 /* diag_listed_as: SKIPME */
433 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
434 }
435 }
436
437 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_isa)438 XS(XS_UNIVERSAL_isa)
439 {
440 dXSARGS;
441
442 if (items != 2)
443 croak_xs_usage(cv, "reference, kind");
444 else {
445 SV * const sv = ST(0);
446
447 SvGETMAGIC(sv);
448
449 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
450 XSRETURN_UNDEF;
451
452 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
453 XSRETURN(1);
454 }
455 }
456
457 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_can)458 XS(XS_UNIVERSAL_can)
459 {
460 dXSARGS;
461 SV *sv;
462 SV *rv;
463 HV *pkg = NULL;
464 GV *iogv;
465
466 if (items != 2)
467 croak_xs_usage(cv, "object-ref, method");
468
469 sv = ST(0);
470
471 SvGETMAGIC(sv);
472
473 /* Reject undef and empty string. Note that the string form takes
474 precedence here over the numeric form, as (!1)->foo treats the
475 invocant as the empty string, though it is a dualvar. */
476 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
477 XSRETURN_UNDEF;
478
479 rv = &PL_sv_undef;
480
481 if (SvROK(sv)) {
482 sv = MUTABLE_SV(SvRV(sv));
483 if (SvOBJECT(sv))
484 pkg = SvSTASH(sv);
485 else if (isGV_with_GP(sv) && GvIO(sv))
486 pkg = SvSTASH(GvIO(sv));
487 }
488 else if (isGV_with_GP(sv) && GvIO(sv))
489 pkg = SvSTASH(GvIO(sv));
490 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
491 pkg = SvSTASH(GvIO(iogv));
492 else {
493 pkg = gv_stashsv(sv, 0);
494 if (!pkg)
495 pkg = gv_stashpvs("UNIVERSAL", 0);
496 }
497
498 if (pkg) {
499 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
500 if (gv && isGV(gv))
501 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
502 }
503
504 ST(0) = rv;
505 XSRETURN(1);
506 }
507
508 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_DOES)509 XS(XS_UNIVERSAL_DOES)
510 {
511 dXSARGS;
512 PERL_UNUSED_ARG(cv);
513
514 if (items != 2)
515 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
516 else {
517 SV * const sv = ST(0);
518 if (sv_does_sv( sv, ST(1), 0 ))
519 XSRETURN_YES;
520
521 XSRETURN_NO;
522 }
523 }
524
525 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_is_utf8)526 XS(XS_utf8_is_utf8)
527 {
528 dXSARGS;
529 if (items != 1)
530 croak_xs_usage(cv, "sv");
531 else {
532 SV * const sv = ST(0);
533 SvGETMAGIC(sv);
534 if (SvUTF8(sv))
535 XSRETURN_YES;
536 else
537 XSRETURN_NO;
538 }
539 XSRETURN_EMPTY;
540 }
541
542 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_valid)543 XS(XS_utf8_valid)
544 {
545 dXSARGS;
546 if (items != 1)
547 croak_xs_usage(cv, "sv");
548 else {
549 SV * const sv = ST(0);
550 STRLEN len;
551 const char * const s = SvPV_const(sv,len);
552 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
553 XSRETURN_YES;
554 else
555 XSRETURN_NO;
556 }
557 XSRETURN_EMPTY;
558 }
559
560 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_encode)561 XS(XS_utf8_encode)
562 {
563 dXSARGS;
564 if (items != 1)
565 croak_xs_usage(cv, "sv");
566 sv_utf8_encode(ST(0));
567 SvSETMAGIC(ST(0));
568 XSRETURN_EMPTY;
569 }
570
571 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_decode)572 XS(XS_utf8_decode)
573 {
574 dXSARGS;
575 if (items != 1)
576 croak_xs_usage(cv, "sv");
577 else {
578 SV * const sv = ST(0);
579 bool RETVAL;
580 SvPV_force_nolen(sv);
581 RETVAL = sv_utf8_decode(sv);
582 SvSETMAGIC(sv);
583 ST(0) = boolSV(RETVAL);
584 }
585 XSRETURN(1);
586 }
587
588 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_upgrade)589 XS(XS_utf8_upgrade)
590 {
591 dXSARGS;
592 if (items != 1)
593 croak_xs_usage(cv, "sv");
594 else {
595 SV * const sv = ST(0);
596 STRLEN RETVAL = 0;
597 dXSTARG;
598
599 XSprePUSH;
600 if (UNLIKELY(! sv)) {
601 XSRETURN_UNDEF;
602 }
603
604 SvGETMAGIC(sv);
605 if (UNLIKELY(! SvOK(sv))) {
606 XSRETURN_UNDEF;
607 }
608
609 RETVAL = sv_utf8_upgrade_nomg(sv);
610 PUSHi( (IV) RETVAL);
611 }
612 XSRETURN(1);
613 }
614
615 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_downgrade)616 XS(XS_utf8_downgrade)
617 {
618 dXSARGS;
619 if (items < 1 || items > 2)
620 croak_xs_usage(cv, "sv, failok=0");
621 else {
622 SV * const sv0 = ST(0);
623 SV * const sv1 = ST(1);
624 const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0;
625 const bool RETVAL = sv_utf8_downgrade(sv0, failok);
626
627 ST(0) = boolSV(RETVAL);
628 }
629 XSRETURN(1);
630 }
631
632 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_native_to_unicode)633 XS(XS_utf8_native_to_unicode)
634 {
635 dXSARGS;
636 const UV uv = SvUV(ST(0));
637
638 if (items > 1)
639 croak_xs_usage(cv, "sv");
640
641 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
642 XSRETURN(1);
643 }
644
645 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_unicode_to_native)646 XS(XS_utf8_unicode_to_native)
647 {
648 dXSARGS;
649 const UV uv = SvUV(ST(0));
650
651 if (items > 1)
652 croak_xs_usage(cv, "sv");
653
654 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
655 XSRETURN(1);
656 }
657
658 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_SvREADONLY)659 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
660 {
661 dXSARGS;
662 SV * const svz = ST(0);
663 SV * sv;
664
665 /* [perl #77776] - called as &foo() not foo() */
666 if (!SvROK(svz))
667 croak_xs_usage(cv, "SCALAR[, ON]");
668
669 sv = SvRV(svz);
670
671 if (items == 1) {
672 if (SvREADONLY(sv))
673 XSRETURN_YES;
674 else
675 XSRETURN_NO;
676 }
677 else if (items == 2) {
678 SV *sv1 = ST(1);
679 if (SvTRUE_NN(sv1)) {
680 SvFLAGS(sv) |= SVf_READONLY;
681 XSRETURN_YES;
682 }
683 else {
684 /* I hope you really know what you are doing. */
685 SvFLAGS(sv) &=~ SVf_READONLY;
686 XSRETURN_NO;
687 }
688 }
689 XSRETURN_UNDEF; /* Can't happen. */
690 }
691
692 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
XS(XS_constant__make_const)693 XS(XS_constant__make_const) /* This is dangerous stuff. */
694 {
695 dXSARGS;
696 SV * const svz = ST(0);
697 SV * sv;
698
699 /* [perl #77776] - called as &foo() not foo() */
700 if (!SvROK(svz) || items != 1)
701 croak_xs_usage(cv, "SCALAR");
702
703 sv = SvRV(svz);
704
705 SvREADONLY_on(sv);
706 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
707 /* for constant.pm; nobody else should be calling this
708 on arrays anyway. */
709 SV **svp;
710 for (svp = AvARRAY(sv) + AvFILLp(sv)
711 ; svp >= AvARRAY(sv)
712 ; --svp)
713 if (*svp) SvPADTMP_on(*svp);
714 }
715 XSRETURN(0);
716 }
717
718 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_SvREFCNT)719 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
720 {
721 dXSARGS;
722 SV * const svz = ST(0);
723 SV * sv;
724 U32 refcnt;
725
726 /* [perl #77776] - called as &foo() not foo() */
727 if ((items != 1 && items != 2) || !SvROK(svz))
728 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
729
730 sv = SvRV(svz);
731
732 /* I hope you really know what you are doing. */
733 /* idea is for SvREFCNT(sv) to be accessed only once */
734 refcnt = items == 2 ?
735 /* we free one ref on exit */
736 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
737 : SvREFCNT(sv);
738 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
739
740 }
741
742 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
XS(XS_Internals_hv_clear_placehold)743 XS(XS_Internals_hv_clear_placehold)
744 {
745 dXSARGS;
746
747 if (items != 1 || !SvROK(ST(0)))
748 croak_xs_usage(cv, "hv");
749 else {
750 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
751 hv_clear_placeholders(hv);
752 XSRETURN(0);
753 }
754 }
755
756 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO_get_layers)757 XS(XS_PerlIO_get_layers)
758 {
759 dXSARGS;
760 if (items < 1 || items % 2 == 0)
761 croak_xs_usage(cv, "filehandle[,args]");
762 #if defined(USE_PERLIO)
763 {
764 SV * sv;
765 GV * gv;
766 IO * io = NULL;
767 bool input = TRUE;
768 bool details = FALSE;
769
770 if (items > 1) {
771 SV * const *svp;
772 for (svp = MARK + 2; svp <= SP; svp += 2) {
773 SV * const * const varp = svp;
774 SV * const * const valp = svp + 1;
775 STRLEN klen;
776 const char * const key = SvPV_const(*varp, klen);
777
778 switch (*key) {
779 case 'i':
780 if (memEQs(key, klen, "input")) {
781 input = SvTRUE(*valp);
782 break;
783 }
784 goto fail;
785 case 'o':
786 if (memEQs(key, klen, "output")) {
787 input = !SvTRUE(*valp);
788 break;
789 }
790 goto fail;
791 case 'd':
792 if (memEQs(key, klen, "details")) {
793 details = SvTRUE(*valp);
794 break;
795 }
796 goto fail;
797 default:
798 fail:
799 Perl_croak(aTHX_
800 "get_layers: unknown argument '%s'",
801 key);
802 }
803 }
804
805 SP -= (items - 1);
806 }
807
808 sv = POPs;
809
810 /* MAYBE_DEREF_GV will call get magic */
811 if ((gv = MAYBE_DEREF_GV(sv)))
812 io = GvIO(gv);
813 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO)
814 io = (IO*)SvRV(sv);
815 else if (!SvROK(sv) && (gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)))
816 io = GvIO(gv);
817
818 if (io) {
819 AV* const av = PerlIO_get_layers(aTHX_ input ?
820 IoIFP(io) : IoOFP(io));
821 SSize_t i;
822 const SSize_t last = av_top_index(av);
823 SSize_t nitem = 0;
824
825 for (i = last; i >= 0; i -= 3) {
826 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
827 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
828 SV * const * const flgsvp = av_fetch(av, i, FALSE);
829
830 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
831 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
832 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
833
834 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
835 if (details) {
836 /* Indents of 5? Yuck. */
837 /* We know that PerlIO_get_layers creates a new SV for
838 the name and flags, so we can just take a reference
839 and "steal" it when we free the AV below. */
840 PUSHs(namok
841 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
842 : &PL_sv_undef);
843 PUSHs(argok
844 ? newSVpvn_flags(SvPVX_const(*argsvp),
845 SvCUR(*argsvp),
846 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
847 | SVs_TEMP)
848 : &PL_sv_undef);
849 PUSHs(flgok
850 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
851 : &PL_sv_undef);
852 nitem += 3;
853 }
854 else {
855 if (namok && argok)
856 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
857 SVfARG(*namsvp),
858 SVfARG(*argsvp))));
859 else if (namok)
860 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
861 else
862 PUSHs(&PL_sv_undef);
863 nitem++;
864 if (flgok) {
865 const IV flags = SvIVX(*flgsvp);
866
867 if (flags & PERLIO_F_UTF8) {
868 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
869 nitem++;
870 }
871 }
872 }
873 }
874
875 SvREFCNT_dec(av);
876
877 XSRETURN(nitem);
878 }
879 }
880 #endif
881
882 XSRETURN(0);
883 }
884
885 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_is_regexp)886 XS(XS_re_is_regexp)
887 {
888 dXSARGS;
889
890 if (items != 1)
891 croak_xs_usage(cv, "sv");
892
893 if (SvRXOK(ST(0))) {
894 XSRETURN_YES;
895 } else {
896 XSRETURN_NO;
897 }
898 }
899
900 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regnames_count)901 XS(XS_re_regnames_count)
902 {
903 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
904 SV * ret;
905 dXSARGS;
906
907 if (items != 0)
908 croak_xs_usage(cv, "");
909
910 if (!rx)
911 XSRETURN_UNDEF;
912
913 ret = CALLREG_NAMED_BUFF_COUNT(rx);
914
915 SPAGAIN;
916 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
917 XSRETURN(1);
918 }
919
920 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regname)921 XS(XS_re_regname)
922 {
923 dXSARGS;
924 REGEXP * rx;
925 U32 flags;
926 SV * ret;
927
928 if (items < 1 || items > 2)
929 croak_xs_usage(cv, "name[, all ]");
930
931 SP -= items;
932 PUTBACK;
933
934 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
935
936 if (!rx)
937 XSRETURN_UNDEF;
938
939 if (items == 2 && SvTRUE_NN(ST(1))) {
940 flags = RXapif_ALL;
941 } else {
942 flags = RXapif_ONE;
943 }
944 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
945
946 SPAGAIN;
947 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
948 XSRETURN(1);
949 }
950
951
952 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regnames)953 XS(XS_re_regnames)
954 {
955 dXSARGS;
956 REGEXP * rx;
957 U32 flags;
958 SV *ret;
959 AV *av;
960 SSize_t length;
961 SSize_t i;
962 SV **entry;
963
964 if (items > 1)
965 croak_xs_usage(cv, "[all]");
966
967 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
968
969 if (!rx)
970 XSRETURN_UNDEF;
971
972 if (items == 1 && SvTRUE_NN(ST(0))) {
973 flags = RXapif_ALL;
974 } else {
975 flags = RXapif_ONE;
976 }
977
978 SP -= items;
979 PUTBACK;
980
981 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
982
983 SPAGAIN;
984
985 if (!ret)
986 XSRETURN_UNDEF;
987
988 av = MUTABLE_AV(SvRV(ret));
989 length = av_count(av);
990
991 EXTEND(SP, length); /* better extend stack just once */
992 for (i = 0; i < length; i++) {
993 entry = av_fetch(av, i, FALSE);
994
995 if (!entry)
996 Perl_croak(aTHX_ "NULL array element in re::regnames()");
997
998 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
999 }
1000
1001 SvREFCNT_dec(ret);
1002
1003 PUTBACK;
1004 return;
1005 }
1006
1007 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regexp_pattern)1008 XS(XS_re_regexp_pattern)
1009 {
1010 dXSARGS;
1011 REGEXP *re;
1012 U8 const gimme = GIMME_V;
1013
1014 EXTEND(SP, 2);
1015 SP -= items;
1016 if (items != 1)
1017 croak_xs_usage(cv, "sv");
1018
1019 /*
1020 Checks if a reference is a regex or not. If the parameter is
1021 not a ref, or is not the result of a qr// then returns false
1022 in scalar context and an empty list in list context.
1023 Otherwise in list context it returns the pattern and the
1024 modifiers, in scalar context it returns the pattern just as it
1025 would if the qr// was stringified normally, regardless as
1026 to the class of the variable and any stringification overloads
1027 on the object.
1028 */
1029
1030 if ((re = SvRX(ST(0)))) /* assign deliberate */
1031 {
1032 /* Houston, we have a regex! */
1033 SV *pattern;
1034
1035 if ( gimme == G_LIST ) {
1036 STRLEN left = 0;
1037 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1038 const char *fptr;
1039 char ch;
1040 U16 match_flags;
1041
1042 /*
1043 we are in list context so stringify
1044 the modifiers that apply. We ignore "negative
1045 modifiers" in this scenario, and the default character set
1046 */
1047
1048 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1049 STRLEN len;
1050 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1051 &len);
1052 Copy(name, reflags + left, len, char);
1053 left += len;
1054 }
1055 fptr = INT_PAT_MODS;
1056 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1057 >> RXf_PMf_STD_PMMOD_SHIFT);
1058
1059 while((ch = *fptr++)) {
1060 if(match_flags & 1) {
1061 reflags[left++] = ch;
1062 }
1063 match_flags >>= 1;
1064 }
1065
1066 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1067 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1068
1069 /* return the pattern and the modifiers */
1070 PUSHs(pattern);
1071 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1072 XSRETURN(2);
1073 } else {
1074 /* Scalar, so use the string that Perl would return */
1075 /* return the pattern in (?msixn:..) format */
1076 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1077 PUSHs(pattern);
1078 XSRETURN(1);
1079 }
1080 } else {
1081 /* It ain't a regexp folks */
1082 if ( gimme == G_LIST ) {
1083 /* return the empty list */
1084 XSRETURN_EMPTY;
1085 } else {
1086 /* Because of the (?:..) wrapping involved in a
1087 stringified pattern it is impossible to get a
1088 result for a real regexp that would evaluate to
1089 false. Therefore we can return PL_sv_no to signify
1090 that the object is not a regex, this means that one
1091 can say
1092
1093 if (regex($might_be_a_regex) eq '(?:foo)') { }
1094
1095 and not worry about undefined values.
1096 */
1097 XSRETURN_NO;
1098 }
1099 }
1100 NOT_REACHED; /* NOTREACHED */
1101 }
1102
1103 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
1104
XS(XS_Internals_getcwd)1105 XS(XS_Internals_getcwd)
1106 {
1107 dXSARGS;
1108 SV *sv = sv_newmortal();
1109
1110 if (items != 0)
1111 croak_xs_usage(cv, "");
1112
1113 (void)getcwd_sv(sv);
1114
1115 SvTAINTED_on(sv);
1116 PUSHs(sv);
1117 XSRETURN(1);
1118 }
1119
1120 #endif
1121
XS(XS_NamedCapture_tie_it)1122 XS(XS_NamedCapture_tie_it)
1123 {
1124 dXSARGS;
1125
1126 if (items != 1)
1127 croak_xs_usage(cv, "sv");
1128 {
1129 SV *sv = ST(0);
1130 GV * const gv = (GV *)sv;
1131 HV * const hv = GvHVn(gv);
1132 SV *rv = newSV_type(SVt_IV);
1133 const char *gv_name = GvNAME(gv);
1134
1135 sv_setrv_noinc(rv, newSVuv(
1136 strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
1137 ? RXapif_ALL : RXapif_ONE));
1138 sv_bless(rv, GvSTASH(CvGV(cv)));
1139
1140 sv_unmagic((SV *)hv, PERL_MAGIC_tied);
1141 sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
1142 SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
1143 }
1144 XSRETURN_EMPTY;
1145 }
1146
XS(XS_NamedCapture_TIEHASH)1147 XS(XS_NamedCapture_TIEHASH)
1148 {
1149 dXSARGS;
1150 if (items < 1)
1151 croak_xs_usage(cv, "package, ...");
1152 {
1153 const char * package = (const char *)SvPV_nolen(ST(0));
1154 UV flag = RXapif_ONE;
1155 mark += 2;
1156 while(mark < sp) {
1157 STRLEN len;
1158 const char *p = SvPV_const(*mark, len);
1159 if(memEQs(p, len, "all"))
1160 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
1161 mark += 2;
1162 }
1163 ST(0) = newSV_type_mortal(SVt_IV);
1164 sv_setuv(newSVrv(ST(0), package), flag);
1165 }
1166 XSRETURN(1);
1167 }
1168
1169 /* These are tightly coupled to the RXapif_* flags defined in regexp.h */
1170 #define UNDEF_FATAL 0x80000
1171 #define DISCARD 0x40000
1172 #define EXPECT_SHIFT 24
1173 #define ACTION_MASK 0x000FF
1174
1175 #define FETCH_ALIAS (RXapif_FETCH | (2 << EXPECT_SHIFT))
1176 #define STORE_ALIAS (RXapif_STORE | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1177 #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
1178 #define CLEAR_ALIAS (RXapif_CLEAR | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1179 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
1180 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
1181
XS(XS_NamedCapture_FETCH)1182 XS(XS_NamedCapture_FETCH)
1183 {
1184 dXSARGS;
1185 dXSI32;
1186 PERL_UNUSED_VAR(cv); /* -W */
1187 PERL_UNUSED_VAR(ax); /* -Wall */
1188 SP -= items;
1189 {
1190 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1191 U32 flags;
1192 SV *ret;
1193 const U32 action = ix & ACTION_MASK;
1194 const int expect = ix >> EXPECT_SHIFT;
1195 if (items != expect)
1196 croak_xs_usage(cv, expect == 2 ? "$key"
1197 : (expect == 3 ? "$key, $value"
1198 : ""));
1199
1200 if (!rx || !SvROK(ST(0))) {
1201 if (ix & UNDEF_FATAL)
1202 Perl_croak_no_modify();
1203 else
1204 XSRETURN_UNDEF;
1205 }
1206
1207 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1208
1209 PUTBACK;
1210 ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
1211 expect >= 3 ? ST(2) : NULL, flags | action);
1212 SPAGAIN;
1213
1214 if (ix & DISCARD) {
1215 /* Called with G_DISCARD, so our return stack state is thrown away.
1216 Hence if we were returned anything, free it immediately. */
1217 SvREFCNT_dec(ret);
1218 } else {
1219 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1220 }
1221 PUTBACK;
1222 return;
1223 }
1224 }
1225
1226
XS(XS_NamedCapture_FIRSTKEY)1227 XS(XS_NamedCapture_FIRSTKEY)
1228 {
1229 dXSARGS;
1230 dXSI32;
1231 PERL_UNUSED_VAR(cv); /* -W */
1232 PERL_UNUSED_VAR(ax); /* -Wall */
1233 SP -= items;
1234 {
1235 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1236 U32 flags;
1237 SV *ret;
1238 const int expect = ix ? 2 : 1;
1239 const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
1240 if (items != expect)
1241 croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
1242
1243 if (!rx || !SvROK(ST(0)))
1244 XSRETURN_UNDEF;
1245
1246 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1247
1248 PUTBACK;
1249 ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
1250 expect >= 2 ? ST(1) : NULL,
1251 flags | action);
1252 SPAGAIN;
1253
1254 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1255 PUTBACK;
1256 return;
1257 }
1258 }
1259
1260 /* is this still needed? */
XS(XS_NamedCapture_flags)1261 XS(XS_NamedCapture_flags)
1262 {
1263 dXSARGS;
1264 PERL_UNUSED_VAR(cv); /* -W */
1265 PERL_UNUSED_VAR(ax); /* -Wall */
1266 SP -= items;
1267 {
1268 EXTEND(SP, 2);
1269 mPUSHu(RXapif_ONE);
1270 mPUSHu(RXapif_ALL);
1271 PUTBACK;
1272 return;
1273 }
1274 }
1275
1276 #include "vutil.h"
1277 #include "vxs.inc"
1278
1279 struct xsub_details {
1280 const char *name;
1281 XSUBADDR_t xsub;
1282 const char *proto;
1283 int ix;
1284 };
1285
1286 static const struct xsub_details these_details[] = {
1287 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
1288 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
1289 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 },
1290 #define VXS_XSUB_DETAILS
1291 #include "vxs.inc"
1292 #undef VXS_XSUB_DETAILS
1293 {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 },
1294 {"utf8::valid", XS_utf8_valid, NULL, 0 },
1295 {"utf8::encode", XS_utf8_encode, NULL, 0 },
1296 {"utf8::decode", XS_utf8_decode, NULL, 0 },
1297 {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 },
1298 {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 },
1299 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 },
1300 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 },
1301 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 },
1302 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 },
1303 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 },
1304 {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 },
1305 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 },
1306 {"re::is_regexp", XS_re_is_regexp, "$", 0 },
1307 {"re::regname", XS_re_regname, ";$$", 0 },
1308 {"re::regnames", XS_re_regnames, ";$", 0 },
1309 {"re::regnames_count", XS_re_regnames_count, "", 0 },
1310 {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 },
1311 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
1312 {"Internals::getcwd", XS_Internals_getcwd, "", 0 },
1313 #endif
1314 {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
1315 {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },
1316 {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS },
1317 {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS },
1318 {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS },
1319 {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS },
1320 {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS },
1321 {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS },
1322 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 },
1323 {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 },
1324 {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 },
1325 };
1326
1327 STATIC OP*
optimize_out_native_convert_function(pTHX_ OP * entersubop,GV * namegv,SV * protosv)1328 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1329 GV* namegv,
1330 SV* protosv)
1331 {
1332 /* Optimizes out an identity function, i.e., one that just returns its
1333 * argument. The passed in function is assumed to be an identity function,
1334 * with no checking. This is designed to be called for utf8_to_native()
1335 * and native_to_utf8() on ASCII platforms, as they just return their
1336 * arguments, but it could work on any such function.
1337 *
1338 * The code is mostly just cargo-culted from Memoize::Lift */
1339
1340 OP *pushop, *argop;
1341 OP *parent;
1342 SV* prototype = newSVpvs("$");
1343
1344 PERL_UNUSED_ARG(protosv);
1345
1346 assert(entersubop->op_type == OP_ENTERSUB);
1347
1348 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1349 parent = entersubop;
1350
1351 SvREFCNT_dec(prototype);
1352
1353 pushop = cUNOPx(entersubop)->op_first;
1354 if (! OpHAS_SIBLING(pushop)) {
1355 parent = pushop;
1356 pushop = cUNOPx(pushop)->op_first;
1357 }
1358 argop = OpSIBLING(pushop);
1359
1360 /* Carry on without doing the optimization if it is not something we're
1361 * expecting, so continues to work */
1362 if ( ! argop
1363 || ! OpHAS_SIBLING(argop)
1364 || OpHAS_SIBLING(OpSIBLING(argop))
1365 ) {
1366 return entersubop;
1367 }
1368
1369 /* cut argop from the subtree */
1370 (void)op_sibling_splice(parent, pushop, 1, NULL);
1371
1372 op_free(entersubop);
1373 return argop;
1374 }
1375
1376 void
Perl_boot_core_UNIVERSAL(pTHX)1377 Perl_boot_core_UNIVERSAL(pTHX)
1378 {
1379 static const char file[] = __FILE__;
1380 const struct xsub_details *xsub = these_details;
1381 const struct xsub_details *end = C_ARRAY_END(these_details);
1382
1383 do {
1384 CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1385 XSANY.any_i32 = xsub->ix;
1386 } while (++xsub < end);
1387
1388 #ifndef EBCDIC
1389 { /* On ASCII platforms these functions just return their argument, so can
1390 be optimized away */
1391
1392 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1393 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1394
1395 cv_set_call_checker_flags(to_native_cv,
1396 optimize_out_native_convert_function,
1397 (SV*) to_native_cv, 0);
1398 cv_set_call_checker_flags(to_unicode_cv,
1399 optimize_out_native_convert_function,
1400 (SV*) to_unicode_cv, 0);
1401 }
1402 #endif
1403
1404 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1405 {
1406 CV * const cv =
1407 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1408 char ** cvfile = &CvFILE(cv);
1409 char * oldfile = *cvfile;
1410 CvDYNFILE_off(cv);
1411 *cvfile = (char *)file;
1412 Safefree(oldfile);
1413 }
1414 }
1415
1416 /*
1417 * ex: set ts=8 sts=4 sw=4 et:
1418 */
1419