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