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