This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
segfault on &Internals::* due to missing SvROK()
[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 seperate 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 #ifdef USE_PERLIO
33 #include "perliol.h" /* For the PERLIO_F_XXX */
34 #endif
35
36 static HV *
37 S_get_isa_hash(pTHX_ HV *const stash)
38 {
39     dVAR;
40     struct mro_meta *const meta = HvMROMETA(stash);
41
42     PERL_ARGS_ASSERT_GET_ISA_HASH;
43
44     if (!meta->isa) {
45         AV *const isa = mro_get_linear_isa(stash);
46         if (!meta->isa) {
47             HV *const isa_hash = newHV();
48             /* Linearisation didn't build it for us, so do it here.  */
49             SV *const *svp = AvARRAY(isa);
50             SV *const *const svp_end = svp + AvFILLp(isa) + 1;
51             const HEK *const canon_name = HvNAME_HEK(stash);
52
53             while (svp < svp_end) {
54                 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
55             }
56
57             (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
58                              HEK_LEN(canon_name), HEK_FLAGS(canon_name),
59                              HV_FETCH_ISSTORE, &PL_sv_undef,
60                              HEK_HASH(canon_name));
61             (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
62
63             SvREADONLY_on(isa_hash);
64
65             meta->isa = isa_hash;
66         }
67     }
68     return meta->isa;
69 }
70
71 /*
72  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
73  * The main guts of traverse_isa was actually copied from gv_fetchmeth
74  */
75
76 STATIC bool
77 S_isa_lookup(pTHX_ HV *stash, const char * const name)
78 {
79     dVAR;
80     const struct mro_meta *const meta = HvMROMETA(stash);
81     HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash);
82     STRLEN len = strlen(name);
83     const HV *our_stash;
84
85     PERL_ARGS_ASSERT_ISA_LOOKUP;
86
87     if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
88                                              a char * argument*/,
89                   HV_FETCH_ISEXISTS, NULL, 0)) {
90         /* Direct name lookup worked.  */
91         return TRUE;
92     }
93
94     /* A stash/class can go by many names (ie. User == main::User), so 
95        we use the name in the stash itself, which is canonical.  */
96     our_stash = gv_stashpvn(name, len, 0);
97
98     if (our_stash) {
99         HEK *const canon_name = HvNAME_HEK(our_stash);
100
101         if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
102                       HEK_FLAGS(canon_name),
103                       HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
104             return TRUE;
105         }
106     }
107
108     return FALSE;
109 }
110
111 /*
112 =head1 SV Manipulation Functions
113
114 =for apidoc sv_derived_from
115
116 Returns a boolean indicating whether the SV is derived from the specified class
117 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
118 normal Perl method.
119
120 =cut
121 */
122
123 bool
124 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
125 {
126     dVAR;
127     HV *stash;
128
129     PERL_ARGS_ASSERT_SV_DERIVED_FROM;
130
131     SvGETMAGIC(sv);
132
133     if (SvROK(sv)) {
134         const char *type;
135         sv = SvRV(sv);
136         type = sv_reftype(sv,0);
137         if (type && strEQ(type,name))
138             return TRUE;
139         stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
140     }
141     else {
142         stash = gv_stashsv(sv, 0);
143     }
144
145     return stash ? isa_lookup(stash, name) : FALSE;
146 }
147
148 /*
149 =for apidoc sv_does
150
151 Returns a boolean indicating whether the SV performs a specific, named role.
152 The SV can be a Perl object or the name of a Perl class.
153
154 =cut
155 */
156
157 #include "XSUB.h"
158
159 bool
160 Perl_sv_does(pTHX_ SV *sv, const char *const name)
161 {
162     const char *classname;
163     bool does_it;
164     SV *methodname;
165     dSP;
166
167     PERL_ARGS_ASSERT_SV_DOES;
168
169     ENTER;
170     SAVETMPS;
171
172     SvGETMAGIC(sv);
173
174     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
175             || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
176         LEAVE;
177         return FALSE;
178     }
179
180     if (sv_isobject(sv)) {
181         classname = sv_reftype(SvRV(sv),TRUE);
182     } else {
183         classname = SvPV_nolen(sv);
184     }
185
186     if (strEQ(name,classname)) {
187         LEAVE;
188         return TRUE;
189     }
190
191     PUSHMARK(SP);
192     XPUSHs(sv);
193     mXPUSHs(newSVpv(name, 0));
194     PUTBACK;
195
196     methodname = newSVpvs_flags("isa", SVs_TEMP);
197     /* ugly hack: use the SvSCREAM flag so S_method_common
198      * can figure out we're calling DOES() and not isa(),
199      * and report eventual errors correctly. --rgs */
200     SvSCREAM_on(methodname);
201     call_sv(methodname, G_SCALAR | G_METHOD);
202     SPAGAIN;
203
204     does_it = SvTRUE( TOPs );
205     FREETMPS;
206     LEAVE;
207
208     return does_it;
209 }
210
211 /*
212 =for apidoc croak_xs_usage
213
214 A specialised variant of C<croak()> for emitting the usage message for xsubs
215
216     croak_xs_usage(cv, "eee_yow");
217
218 works out the package name and subroutine name from C<cv>, and then calls
219 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
220
221     Perl_croak(aTHX_ "Usage: %s::%s(%s)", "ouch" "awk", "eee_yow");
222
223 =cut
224 */
225
226 void
227 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
228 {
229     const GV *const gv = CvGV(cv);
230
231     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
232
233     if (gv) {
234         const char *const gvname = GvNAME(gv);
235         const HV *const stash = GvSTASH(gv);
236         const char *const hvname = stash ? HvNAME_get(stash) : NULL;
237
238         if (hvname)
239             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
240         else
241             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
242     } else {
243         /* Pants. I don't think that it should be possible to get here. */
244         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
245     }
246 }
247
248 XS(XS_UNIVERSAL_isa)
249 {
250     dVAR;
251     dXSARGS;
252
253     if (items != 2)
254         croak_xs_usage(cv, "reference, kind");
255     else {
256         SV * const sv = ST(0);
257         const char *name;
258
259         SvGETMAGIC(sv);
260
261         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
262                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
263             XSRETURN_UNDEF;
264
265         name = SvPV_nolen_const(ST(1));
266
267         ST(0) = boolSV(sv_derived_from(sv, name));
268         XSRETURN(1);
269     }
270 }
271
272 XS(XS_UNIVERSAL_can)
273 {
274     dVAR;
275     dXSARGS;
276     SV   *sv;
277     const char *name;
278     SV   *rv;
279     HV   *pkg = NULL;
280
281     if (items != 2)
282         croak_xs_usage(cv, "object-ref, method");
283
284     sv = ST(0);
285
286     SvGETMAGIC(sv);
287
288     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
289                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
290         XSRETURN_UNDEF;
291
292     name = SvPV_nolen_const(ST(1));
293     rv = &PL_sv_undef;
294
295     if (SvROK(sv)) {
296         sv = MUTABLE_SV(SvRV(sv));
297         if (SvOBJECT(sv))
298             pkg = SvSTASH(sv);
299     }
300     else {
301         pkg = gv_stashsv(sv, 0);
302     }
303
304     if (pkg) {
305         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
306         if (gv && isGV(gv))
307             rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
308     }
309
310     ST(0) = rv;
311     XSRETURN(1);
312 }
313
314 XS(XS_UNIVERSAL_DOES)
315 {
316     dVAR;
317     dXSARGS;
318     PERL_UNUSED_ARG(cv);
319
320     if (items != 2)
321         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
322     else {
323         SV * const sv = ST(0);
324         const char *name;
325
326         name = SvPV_nolen_const(ST(1));
327         if (sv_does( sv, name ))
328             XSRETURN_YES;
329
330         XSRETURN_NO;
331     }
332 }
333
334 XS(XS_UNIVERSAL_VERSION)
335 {
336     dVAR;
337     dXSARGS;
338     HV *pkg;
339     GV **gvp;
340     GV *gv;
341     SV *sv;
342     const char *undef;
343     PERL_UNUSED_ARG(cv);
344
345     if (SvROK(ST(0))) {
346         sv = MUTABLE_SV(SvRV(ST(0)));
347         if (!SvOBJECT(sv))
348             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
349         pkg = SvSTASH(sv);
350     }
351     else {
352         pkg = gv_stashsv(ST(0), 0);
353     }
354
355     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
356
357     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
358         SV * const nsv = sv_newmortal();
359         sv_setsv(nsv, sv);
360         sv = nsv;
361         if ( !sv_derived_from(sv, "version"))
362             upg_version(sv, FALSE);
363         undef = NULL;
364     }
365     else {
366         sv = &PL_sv_undef;
367         undef = "(undef)";
368     }
369
370     if (items > 1) {
371         SV *req = ST(1);
372
373         if (undef) {
374             if (pkg) {
375                 const char * const name = HvNAME_get(pkg);
376                 Perl_croak(aTHX_
377                            "%s does not define $%s::VERSION--version check failed",
378                            name, name);
379             } else {
380                 Perl_croak(aTHX_
381                              "%s defines neither package nor VERSION--version check failed",
382                              SvPVx_nolen_const(ST(0)) );
383              }
384         }
385
386         if ( !sv_derived_from(req, "version")) {
387             /* req may very well be R/O, so create a new object */
388             req = sv_2mortal( new_version(req) );
389         }
390
391         if ( vcmp( req, sv ) > 0 ) {
392             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
393                 Perl_croak(aTHX_ "%s version %"SVf" required--"
394                        "this is only version %"SVf"", HvNAME_get(pkg),
395                        SVfARG(sv_2mortal(vnormal(req))),
396                        SVfARG(sv_2mortal(vnormal(sv))));
397             } else {
398                 Perl_croak(aTHX_ "%s version %"SVf" required--"
399                        "this is only version %"SVf"", HvNAME_get(pkg),
400                        SVfARG(sv_2mortal(vstringify(req))),
401                        SVfARG(sv_2mortal(vstringify(sv))));
402             }
403         }
404
405     }
406
407     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
408         ST(0) = sv_2mortal(vstringify(sv));
409     } else {
410         ST(0) = sv;
411     }
412
413     XSRETURN(1);
414 }
415
416 XS(XS_version_new)
417 {
418     dVAR;
419     dXSARGS;
420     if (items > 3)
421         croak_xs_usage(cv, "class, version");
422     SP -= items;
423     {
424         SV *vs = ST(1);
425         SV *rv;
426         const char * const classname =
427             sv_isobject(ST(0)) /* get the class if called as an object method */
428                 ? HvNAME(SvSTASH(SvRV(ST(0))))
429                 : (char *)SvPV_nolen(ST(0));
430
431         if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
432             /* create empty object */
433             vs = sv_newmortal();
434             sv_setpvs(vs, "0");
435         }
436         else if ( items == 3 ) {
437             vs = sv_newmortal();
438             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
439         }
440
441         rv = new_version(vs);
442         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
443             sv_bless(rv, gv_stashpv(classname, GV_ADD));
444
445         mPUSHs(rv);
446         PUTBACK;
447         return;
448     }
449 }
450
451 XS(XS_version_stringify)
452 {
453      dVAR;
454      dXSARGS;
455      if (items < 1)
456          croak_xs_usage(cv, "lobj, ...");
457      SP -= items;
458      {
459           SV *  lobj = ST(0);
460
461           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
462                lobj = SvRV(lobj);
463           }
464           else
465                Perl_croak(aTHX_ "lobj is not of type version");
466
467           mPUSHs(vstringify(lobj));
468
469           PUTBACK;
470           return;
471      }
472 }
473
474 XS(XS_version_numify)
475 {
476      dVAR;
477      dXSARGS;
478      if (items < 1)
479          croak_xs_usage(cv, "lobj, ...");
480      SP -= items;
481      {
482           SV *  lobj = ST(0);
483
484           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
485                lobj = SvRV(lobj);
486           }
487           else
488                Perl_croak(aTHX_ "lobj is not of type version");
489
490           mPUSHs(vnumify(lobj));
491
492           PUTBACK;
493           return;
494      }
495 }
496
497 XS(XS_version_normal)
498 {
499      dVAR;
500      dXSARGS;
501      if (items < 1)
502          croak_xs_usage(cv, "lobj, ...");
503      SP -= items;
504      {
505           SV *  lobj = ST(0);
506
507           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
508                lobj = SvRV(lobj);
509           }
510           else
511                Perl_croak(aTHX_ "lobj is not of type version");
512
513           mPUSHs(vnormal(lobj));
514
515           PUTBACK;
516           return;
517      }
518 }
519
520 XS(XS_version_vcmp)
521 {
522      dVAR;
523      dXSARGS;
524      if (items < 1)
525          croak_xs_usage(cv, "lobj, ...");
526      SP -= items;
527      {
528           SV *  lobj = ST(0);
529
530           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
531                lobj = SvRV(lobj);
532           }
533           else
534                Perl_croak(aTHX_ "lobj is not of type version");
535
536           {
537                SV       *rs;
538                SV       *rvs;
539                SV * robj = ST(1);
540                const IV  swap = (IV)SvIV(ST(2));
541
542                if ( ! sv_derived_from(robj, "version") )
543                {
544                     robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
545                     sv_2mortal(robj);
546                }
547                rvs = SvRV(robj);
548
549                if ( swap )
550                {
551                     rs = newSViv(vcmp(rvs,lobj));
552                }
553                else
554                {
555                     rs = newSViv(vcmp(lobj,rvs));
556                }
557
558                mPUSHs(rs);
559           }
560
561           PUTBACK;
562           return;
563      }
564 }
565
566 XS(XS_version_boolean)
567 {
568     dVAR;
569     dXSARGS;
570     if (items < 1)
571         croak_xs_usage(cv, "lobj, ...");
572     SP -= items;
573     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
574         SV * const lobj = SvRV(ST(0));
575         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
576         mPUSHs(rs);
577         PUTBACK;
578         return;
579     }
580     else
581         Perl_croak(aTHX_ "lobj is not of type version");
582 }
583
584 XS(XS_version_noop)
585 {
586     dVAR;
587     dXSARGS;
588     if (items < 1)
589         croak_xs_usage(cv, "lobj, ...");
590     if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
591         Perl_croak(aTHX_ "operation not supported with version object");
592     else
593         Perl_croak(aTHX_ "lobj is not of type version");
594 #ifndef HASATTRIBUTE_NORETURN
595     XSRETURN_EMPTY;
596 #endif
597 }
598
599 XS(XS_version_is_alpha)
600 {
601     dVAR;
602     dXSARGS;
603     if (items != 1)
604         croak_xs_usage(cv, "lobj");
605     SP -= items;
606     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
607         SV * const lobj = ST(0);
608         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
609             XSRETURN_YES;
610         else
611             XSRETURN_NO;
612         PUTBACK;
613         return;
614     }
615     else
616         Perl_croak(aTHX_ "lobj is not of type version");
617 }
618
619 XS(XS_version_qv)
620 {
621     dVAR;
622     dXSARGS;
623     PERL_UNUSED_ARG(cv);
624     SP -= items;
625     {
626         SV * ver = ST(0);
627         SV * rv;
628         const char * classname = "";
629         if ( items == 2 && SvOK(ST(1)) ) {
630             /* getting called as object or class method */
631             ver = ST(1);
632             classname = 
633                 sv_isobject(ST(0)) /* class called as an object method */
634                     ? HvNAME_get(SvSTASH(SvRV(ST(0))))
635                     : (char *)SvPV_nolen(ST(0));
636         }
637         if ( !SvVOK(ver) ) { /* not already a v-string */
638             rv = sv_newmortal();
639             sv_setsv(rv,ver); /* make a duplicate */
640             upg_version(rv, TRUE);
641         } else {
642             rv = sv_2mortal(new_version(ver));
643         }
644         if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
645             sv_bless(rv, gv_stashpv(classname, GV_ADD));
646         }
647         PUSHs(rv);
648     }
649     PUTBACK;
650     return;
651 }
652
653 XS(XS_version_is_qv)
654 {
655     dVAR;
656     dXSARGS;
657     if (items != 1)
658         croak_xs_usage(cv, "lobj");
659     SP -= items;
660     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
661         SV * const lobj = ST(0);
662         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
663             XSRETURN_YES;
664         else
665             XSRETURN_NO;
666         PUTBACK;
667         return;
668     }
669     else
670         Perl_croak(aTHX_ "lobj is not of type version");
671 }
672
673 XS(XS_utf8_is_utf8)
674 {
675      dVAR;
676      dXSARGS;
677      if (items != 1)
678          croak_xs_usage(cv, "sv");
679      else {
680         SV * const sv = ST(0);
681         SvGETMAGIC(sv);
682             if (SvUTF8(sv))
683                 XSRETURN_YES;
684             else
685                 XSRETURN_NO;
686      }
687      XSRETURN_EMPTY;
688 }
689
690 XS(XS_utf8_valid)
691 {
692      dVAR;
693      dXSARGS;
694      if (items != 1)
695          croak_xs_usage(cv, "sv");
696     else {
697         SV * const sv = ST(0);
698         STRLEN len;
699         const char * const s = SvPV_const(sv,len);
700         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
701             XSRETURN_YES;
702         else
703             XSRETURN_NO;
704     }
705      XSRETURN_EMPTY;
706 }
707
708 XS(XS_utf8_encode)
709 {
710     dVAR;
711     dXSARGS;
712     if (items != 1)
713         croak_xs_usage(cv, "sv");
714     sv_utf8_encode(ST(0));
715     XSRETURN_EMPTY;
716 }
717
718 XS(XS_utf8_decode)
719 {
720     dVAR;
721     dXSARGS;
722     if (items != 1)
723         croak_xs_usage(cv, "sv");
724     else {
725         SV * const sv = ST(0);
726         const bool RETVAL = sv_utf8_decode(sv);
727         ST(0) = boolSV(RETVAL);
728         sv_2mortal(ST(0));
729     }
730     XSRETURN(1);
731 }
732
733 XS(XS_utf8_upgrade)
734 {
735     dVAR;
736     dXSARGS;
737     if (items != 1)
738         croak_xs_usage(cv, "sv");
739     else {
740         SV * const sv = ST(0);
741         STRLEN  RETVAL;
742         dXSTARG;
743
744         RETVAL = sv_utf8_upgrade(sv);
745         XSprePUSH; PUSHi((IV)RETVAL);
746     }
747     XSRETURN(1);
748 }
749
750 XS(XS_utf8_downgrade)
751 {
752     dVAR;
753     dXSARGS;
754     if (items < 1 || items > 2)
755         croak_xs_usage(cv, "sv, failok=0");
756     else {
757         SV * const sv = ST(0);
758         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
759         const bool RETVAL = sv_utf8_downgrade(sv, failok);
760
761         ST(0) = boolSV(RETVAL);
762         sv_2mortal(ST(0));
763     }
764     XSRETURN(1);
765 }
766
767 XS(XS_utf8_native_to_unicode)
768 {
769  dVAR;
770  dXSARGS;
771  const UV uv = SvUV(ST(0));
772
773  if (items > 1)
774      croak_xs_usage(cv, "sv");
775
776  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
777  XSRETURN(1);
778 }
779
780 XS(XS_utf8_unicode_to_native)
781 {
782  dVAR;
783  dXSARGS;
784  const UV uv = SvUV(ST(0));
785
786  if (items > 1)
787      croak_xs_usage(cv, "sv");
788
789  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
790  XSRETURN(1);
791 }
792
793 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
794 {
795     dVAR;
796     dXSARGS;
797     SV * const svz = ST(0);
798     SV * sv;
799     PERL_UNUSED_ARG(cv);
800
801     /* [perl #77776] - called as &foo() not foo() */
802     if (!SvROK(svz))
803         croak_xs_usage(cv, "SCALAR[, ON]");
804
805     sv = SvRV(svz);
806
807     if (items == 1) {
808          if (SvREADONLY(sv))
809              XSRETURN_YES;
810          else
811              XSRETURN_NO;
812     }
813     else if (items == 2) {
814         if (SvTRUE(ST(1))) {
815             SvREADONLY_on(sv);
816             XSRETURN_YES;
817         }
818         else {
819             /* I hope you really know what you are doing. */
820             SvREADONLY_off(sv);
821             XSRETURN_NO;
822         }
823     }
824     XSRETURN_UNDEF; /* Can't happen. */
825 }
826
827 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
828 {
829     dVAR;
830     dXSARGS;
831     SV * const svz = ST(0);
832     SV * sv;
833     PERL_UNUSED_ARG(cv);
834
835     /* [perl #77776] - called as &foo() not foo() */
836     if (!SvROK(svz))
837         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
838
839     sv = SvRV(svz);
840
841     if (items == 1)
842          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
843     else if (items == 2) {
844          /* I hope you really know what you are doing. */
845          SvREFCNT(sv) = SvIV(ST(1));
846          XSRETURN_IV(SvREFCNT(sv));
847     }
848     XSRETURN_UNDEF; /* Can't happen. */
849 }
850
851 XS(XS_Internals_hv_clear_placehold)
852 {
853     dVAR;
854     dXSARGS;
855
856     if (items != 1 || !SvROK(ST(0)))
857         croak_xs_usage(cv, "hv");
858     else {
859         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
860         hv_clear_placeholders(hv);
861         XSRETURN(0);
862     }
863 }
864
865 XS(XS_PerlIO_get_layers)
866 {
867     dVAR;
868     dXSARGS;
869     if (items < 1 || items % 2 == 0)
870         croak_xs_usage(cv, "filehandle[,args]");
871 #ifdef USE_PERLIO
872     {
873         SV *    sv;
874         GV *    gv;
875         IO *    io;
876         bool    input = TRUE;
877         bool    details = FALSE;
878
879         if (items > 1) {
880              SV * const *svp;
881              for (svp = MARK + 2; svp <= SP; svp += 2) {
882                   SV * const * const varp = svp;
883                   SV * const * const valp = svp + 1;
884                   STRLEN klen;
885                   const char * const key = SvPV_const(*varp, klen);
886
887                   switch (*key) {
888                   case 'i':
889                        if (klen == 5 && memEQ(key, "input", 5)) {
890                             input = SvTRUE(*valp);
891                             break;
892                        }
893                        goto fail;
894                   case 'o': 
895                        if (klen == 6 && memEQ(key, "output", 6)) {
896                             input = !SvTRUE(*valp);
897                             break;
898                        }
899                        goto fail;
900                   case 'd':
901                        if (klen == 7 && memEQ(key, "details", 7)) {
902                             details = SvTRUE(*valp);
903                             break;
904                        }
905                        goto fail;
906                   default:
907                   fail:
908                        Perl_croak(aTHX_
909                                   "get_layers: unknown argument '%s'",
910                                   key);
911                   }
912              }
913
914              SP -= (items - 1);
915         }
916
917         sv = POPs;
918         gv = MUTABLE_GV(sv);
919
920         if (!isGV(sv)) {
921              if (SvROK(sv) && isGV(SvRV(sv)))
922                   gv = MUTABLE_GV(SvRV(sv));
923              else if (SvPOKp(sv))
924                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
925         }
926
927         if (gv && (io = GvIO(gv))) {
928              AV* const av = PerlIO_get_layers(aTHX_ input ?
929                                         IoIFP(io) : IoOFP(io));
930              I32 i;
931              const I32 last = av_len(av);
932              I32 nitem = 0;
933              
934              for (i = last; i >= 0; i -= 3) {
935                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
936                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
937                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
938
939                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
940                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
941                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
942
943                   if (details) {
944                       /* Indents of 5? Yuck.  */
945                       /* We know that PerlIO_get_layers creates a new SV for
946                          the name and flags, so we can just take a reference
947                          and "steal" it when we free the AV below.  */
948                        XPUSHs(namok
949                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
950                               : &PL_sv_undef);
951                        XPUSHs(argok
952                               ? newSVpvn_flags(SvPVX_const(*argsvp),
953                                                SvCUR(*argsvp),
954                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
955                                                | SVs_TEMP)
956                               : &PL_sv_undef);
957                        XPUSHs(flgok
958                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
959                               : &PL_sv_undef);
960                        nitem += 3;
961                   }
962                   else {
963                        if (namok && argok)
964                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
965                                                  SVfARG(*namsvp),
966                                                  SVfARG(*argsvp))));
967                        else if (namok)
968                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
969                        else
970                             XPUSHs(&PL_sv_undef);
971                        nitem++;
972                        if (flgok) {
973                             const IV flags = SvIVX(*flgsvp);
974
975                             if (flags & PERLIO_F_UTF8) {
976                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
977                                  nitem++;
978                             }
979                        }
980                   }
981              }
982
983              SvREFCNT_dec(av);
984
985              XSRETURN(nitem);
986         }
987     }
988 #endif
989
990     XSRETURN(0);
991 }
992
993 XS(XS_Internals_hash_seed)
994 {
995     dVAR;
996     /* Using dXSARGS would also have dITEM and dSP,
997      * which define 2 unused local variables.  */
998     dAXMARK;
999     PERL_UNUSED_ARG(cv);
1000     PERL_UNUSED_VAR(mark);
1001     XSRETURN_UV(PERL_HASH_SEED);
1002 }
1003
1004 XS(XS_Internals_rehash_seed)
1005 {
1006     dVAR;
1007     /* Using dXSARGS would also have dITEM and dSP,
1008      * which define 2 unused local variables.  */
1009     dAXMARK;
1010     PERL_UNUSED_ARG(cv);
1011     PERL_UNUSED_VAR(mark);
1012     XSRETURN_UV(PL_rehash_seed);
1013 }
1014
1015 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1016 {
1017     dVAR;
1018     dXSARGS;
1019     PERL_UNUSED_ARG(cv);
1020     if (SvROK(ST(0))) {
1021         const HV * const hv = (const HV *) SvRV(ST(0));
1022         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1023             if (HvREHASH(hv))
1024                 XSRETURN_YES;
1025             else
1026                 XSRETURN_NO;
1027         }
1028     }
1029     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1030 }
1031
1032 XS(XS_mauve_reftype)
1033 {
1034     SV *sv;
1035     dVAR;
1036     dXSARGS;
1037     PERL_UNUSED_VAR(cv);
1038
1039     if (items != 1)
1040         croak_xs_usage(cv, "sv");
1041
1042     SP -= items;
1043     sv = (SV*)ST(0);
1044
1045     if (SvMAGICAL(sv))
1046         mg_get(sv);
1047     if (!SvROK(sv)) {
1048        XSRETURN_NO;
1049     } else {
1050         STRLEN len;
1051         char *type= (char *)sv_reftype_len(SvRV(sv),FALSE,&len);
1052         XPUSHs(sv_2mortal(newSVpv(type,len)));
1053     }
1054 }
1055
1056 XS(XS_mauve_refaddr)
1057 {
1058     SV *sv;
1059     dVAR;
1060     dXSARGS;
1061     PERL_UNUSED_VAR(cv);
1062
1063     if (items != 1)
1064         croak_xs_usage(cv, "sv");
1065
1066     SP -= items;
1067     sv = (SV*)ST(0);
1068
1069     if (SvMAGICAL(sv))
1070         mg_get(sv);
1071     if (!SvROK(sv)) {
1072        XSRETURN_NO;
1073     } else {
1074        XPUSHs(sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))));
1075     }
1076 }
1077
1078 XS(XS_mauve_blessed)
1079 {
1080     SV *sv;
1081     dVAR;
1082     dXSARGS;
1083     PERL_UNUSED_VAR(cv);
1084
1085     if (items != 1)
1086         croak_xs_usage(cv, "sv");
1087
1088     SP -= items;
1089     sv = (SV*)ST(0);
1090
1091     if (SvMAGICAL(sv))
1092         mg_get(sv);
1093     if ( SvROK(sv) && SvOBJECT(SvRV(sv)) ) {
1094         STRLEN len;
1095         char *type= (char *)sv_reftype_len(SvRV(sv),TRUE,&len);
1096         XPUSHs(sv_2mortal(newSVpv(type,len)));
1097     } else {
1098         XPUSHs(sv_2mortal(newSVpv("",0)));
1099     }
1100 }
1101
1102 XS(XS_mauve_weaken)
1103 {
1104     SV *sv;
1105     dVAR;
1106     dXSARGS;
1107     PERL_UNUSED_VAR(cv);
1108
1109     if (items != 1)
1110         croak_xs_usage(cv, "sv");
1111
1112     SP -= items;
1113     sv = (SV*)ST(0);
1114
1115     if (SvMAGICAL(sv))
1116         mg_get(sv);
1117     sv_rvweaken(sv);
1118     XSRETURN_EMPTY;
1119 }
1120
1121 XS(XS_mauve_isweak)
1122 {
1123     dVAR;
1124     dXSARGS;
1125     if (items != 1)
1126        croak_xs_usage(cv,  "sv");
1127     {
1128         SV *    sv = ST(0);
1129         if (SvMAGICAL(sv))
1130             mg_get(sv);
1131         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
1132         XSRETURN(1);
1133     }
1134     XSRETURN(1);
1135 }
1136
1137 XS(XS_re_is_regexp)
1138 {
1139     dVAR; 
1140     dXSARGS;
1141     PERL_UNUSED_VAR(cv);
1142
1143     if (items != 1)
1144         croak_xs_usage(cv, "sv");
1145
1146     SP -= items;
1147
1148     if (SvRXOK(ST(0))) {
1149         XSRETURN_YES;
1150     } else {
1151         XSRETURN_NO;
1152     }
1153 }
1154
1155 XS(XS_re_regnames_count)
1156 {
1157     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1158     SV * ret;
1159     dVAR; 
1160     dXSARGS;
1161
1162     if (items != 0)
1163         croak_xs_usage(cv, "");
1164
1165     SP -= items;
1166
1167     if (!rx)
1168         XSRETURN_UNDEF;
1169
1170     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1171
1172     SPAGAIN;
1173
1174     if (ret) {
1175         mXPUSHs(ret);
1176         PUTBACK;
1177         return;
1178     } else {
1179         XSRETURN_UNDEF;
1180     }
1181 }
1182
1183 XS(XS_re_regname)
1184 {
1185     dVAR;
1186     dXSARGS;
1187     REGEXP * rx;
1188     U32 flags;
1189     SV * ret;
1190
1191     if (items < 1 || items > 2)
1192         croak_xs_usage(cv, "name[, all ]");
1193
1194     SP -= items;
1195
1196     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1197
1198     if (!rx)
1199         XSRETURN_UNDEF;
1200
1201     if (items == 2 && SvTRUE(ST(1))) {
1202         flags = RXapif_ALL;
1203     } else {
1204         flags = RXapif_ONE;
1205     }
1206     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1207
1208     if (ret) {
1209         mXPUSHs(ret);
1210         XSRETURN(1);
1211     }
1212     XSRETURN_UNDEF;    
1213 }
1214
1215
1216 XS(XS_re_regnames)
1217 {
1218     dVAR;
1219     dXSARGS;
1220     REGEXP * rx;
1221     U32 flags;
1222     SV *ret;
1223     AV *av;
1224     I32 length;
1225     I32 i;
1226     SV **entry;
1227
1228     if (items > 1)
1229         croak_xs_usage(cv, "[all]");
1230
1231     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1232
1233     if (!rx)
1234         XSRETURN_UNDEF;
1235
1236     if (items == 1 && SvTRUE(ST(0))) {
1237         flags = RXapif_ALL;
1238     } else {
1239         flags = RXapif_ONE;
1240     }
1241
1242     SP -= items;
1243
1244     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1245
1246     SPAGAIN;
1247
1248     SP -= items;
1249
1250     if (!ret)
1251         XSRETURN_UNDEF;
1252
1253     av = MUTABLE_AV(SvRV(ret));
1254     length = av_len(av);
1255
1256     for (i = 0; i <= length; i++) {
1257         entry = av_fetch(av, i, FALSE);
1258         
1259         if (!entry)
1260             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1261
1262         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1263     }
1264
1265     SvREFCNT_dec(ret);
1266
1267     PUTBACK;
1268     return;
1269 }
1270
1271 XS(XS_re_regexp_pattern)
1272 {
1273     dVAR;
1274     dXSARGS;
1275     REGEXP *re;
1276
1277     if (items != 1)
1278         croak_xs_usage(cv, "sv");
1279
1280     SP -= items;
1281
1282     /*
1283        Checks if a reference is a regex or not. If the parameter is
1284        not a ref, or is not the result of a qr// then returns false
1285        in scalar context and an empty list in list context.
1286        Otherwise in list context it returns the pattern and the
1287        modifiers, in scalar context it returns the pattern just as it
1288        would if the qr// was stringified normally, regardless as
1289        to the class of the variable and any strigification overloads
1290        on the object.
1291     */
1292
1293     if ((re = SvRX(ST(0)))) /* assign deliberate */
1294     {
1295         /* Houston, we have a regex! */
1296         SV *pattern;
1297         STRLEN left = 0;
1298         char reflags[sizeof(INT_PAT_MODS)];
1299
1300         if ( GIMME_V == G_ARRAY ) {
1301             /*
1302                we are in list context so stringify
1303                the modifiers that apply. We ignore "negative
1304                modifiers" in this scenario.
1305             */
1306
1307             const char *fptr = INT_PAT_MODS;
1308             char ch;
1309             U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1310                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1311
1312             while((ch = *fptr++)) {
1313                 if(match_flags & 1) {
1314                     reflags[left++] = ch;
1315                 }
1316                 match_flags >>= 1;
1317             }
1318
1319             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1320                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1321
1322             /* return the pattern and the modifiers */
1323             XPUSHs(pattern);
1324             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1325             XSRETURN(2);
1326         } else {
1327             /* Scalar, so use the string that Perl would return */
1328             /* return the pattern in (?msix:..) format */
1329 #if PERL_VERSION >= 11
1330             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1331 #else
1332             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1333                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1334 #endif
1335             XPUSHs(pattern);
1336             XSRETURN(1);
1337         }
1338     } else {
1339         /* It ain't a regexp folks */
1340         if ( GIMME_V == G_ARRAY ) {
1341             /* return the empty list */
1342             XSRETURN_UNDEF;
1343         } else {
1344             /* Because of the (?:..) wrapping involved in a
1345                stringified pattern it is impossible to get a
1346                result for a real regexp that would evaluate to
1347                false. Therefore we can return PL_sv_no to signify
1348                that the object is not a regex, this means that one
1349                can say
1350
1351                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1352
1353                and not worry about undefined values.
1354             */
1355             XSRETURN_NO;
1356         }
1357     }
1358     /* NOT-REACHED */
1359 }
1360
1361 XS(XS_Tie_Hash_NamedCapture_FETCH)
1362 {
1363     dVAR;
1364     dXSARGS;
1365     REGEXP * rx;
1366     U32 flags;
1367     SV * ret;
1368
1369     if (items != 2)
1370         croak_xs_usage(cv, "$key, $flags");
1371
1372     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1373
1374     if (!rx || !SvROK(ST(0)))
1375         XSRETURN_UNDEF;
1376
1377     SP -= items;
1378
1379     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1380     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1381
1382     SPAGAIN;
1383
1384     if (ret) {
1385         mXPUSHs(ret);
1386         PUTBACK;
1387         return;
1388     }
1389     XSRETURN_UNDEF;
1390 }
1391
1392 XS(XS_Tie_Hash_NamedCapture_STORE)
1393 {
1394     dVAR;
1395     dXSARGS;
1396     REGEXP * rx;
1397     U32 flags;
1398
1399     if (items != 3)
1400         croak_xs_usage(cv, "$key, $value, $flags");
1401
1402     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1403
1404     if (!rx || !SvROK(ST(0))) {
1405         if (!PL_localizing)
1406             Perl_croak_no_modify(aTHX);
1407         else
1408             XSRETURN_UNDEF;
1409     }
1410
1411     SP -= items;
1412
1413     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1414     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1415 }
1416
1417 XS(XS_Tie_Hash_NamedCapture_DELETE)
1418 {
1419     dVAR;
1420     dXSARGS;
1421     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1422     U32 flags;
1423
1424     if (items != 2)
1425         croak_xs_usage(cv, "$key, $flags");
1426
1427     if (!rx || !SvROK(ST(0)))
1428         Perl_croak_no_modify(aTHX);
1429
1430     SP -= items;
1431
1432     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1433     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1434 }
1435
1436 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1437 {
1438     dVAR;
1439     dXSARGS;
1440     REGEXP * rx;
1441     U32 flags;
1442
1443     if (items != 1)
1444         croak_xs_usage(cv, "$flags");
1445
1446     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1447
1448     if (!rx || !SvROK(ST(0)))
1449         Perl_croak_no_modify(aTHX);
1450
1451     SP -= items;
1452
1453     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1454     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1455 }
1456
1457 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1458 {
1459     dVAR;
1460     dXSARGS;
1461     REGEXP * rx;
1462     U32 flags;
1463     SV * ret;
1464
1465     if (items != 2)
1466         croak_xs_usage(cv, "$key, $flags");
1467
1468     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1469
1470     if (!rx || !SvROK(ST(0)))
1471         XSRETURN_UNDEF;
1472
1473     SP -= items;
1474
1475     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1476     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1477
1478     SPAGAIN;
1479
1480         XPUSHs(ret);
1481         PUTBACK;
1482         return;
1483 }
1484
1485 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1486 {
1487     dVAR;
1488     dXSARGS;
1489     REGEXP * rx;
1490     U32 flags;
1491     SV * ret;
1492
1493     if (items != 1)
1494         croak_xs_usage(cv, "");
1495
1496     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1497
1498     if (!rx || !SvROK(ST(0)))
1499         XSRETURN_UNDEF;
1500
1501     SP -= items;
1502
1503     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1504     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1505
1506     SPAGAIN;
1507
1508     if (ret) {
1509         mXPUSHs(ret);
1510         PUTBACK;
1511     } else {
1512         XSRETURN_UNDEF;
1513     }
1514
1515 }
1516
1517 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1518 {
1519     dVAR;
1520     dXSARGS;
1521     REGEXP * rx;
1522     U32 flags;
1523     SV * ret;
1524
1525     if (items != 2)
1526         croak_xs_usage(cv, "$lastkey");
1527
1528     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1529
1530     if (!rx || !SvROK(ST(0)))
1531         XSRETURN_UNDEF;
1532
1533     SP -= items;
1534
1535     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1536     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1537
1538     SPAGAIN;
1539
1540     if (ret) {
1541         mXPUSHs(ret);
1542     } else {
1543         XSRETURN_UNDEF;
1544     }  
1545     PUTBACK;
1546 }
1547
1548 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1549 {
1550     dVAR;
1551     dXSARGS;
1552     REGEXP * rx;
1553     U32 flags;
1554     SV * ret;
1555
1556     if (items != 1)
1557         croak_xs_usage(cv, "");
1558
1559     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1560
1561     if (!rx || !SvROK(ST(0)))
1562         XSRETURN_UNDEF;
1563
1564     SP -= items;
1565
1566     flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1567     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1568
1569     SPAGAIN;
1570
1571     if (ret) {
1572         mXPUSHs(ret);
1573         PUTBACK;
1574         return;
1575     } else {
1576         XSRETURN_UNDEF;
1577     }
1578 }
1579
1580 XS(XS_Tie_Hash_NamedCapture_flags)
1581 {
1582     dVAR;
1583     dXSARGS;
1584
1585     if (items != 0)
1586         croak_xs_usage(cv, "");
1587
1588         mXPUSHu(RXapif_ONE);
1589         mXPUSHu(RXapif_ALL);
1590         PUTBACK;
1591         return;
1592 }
1593
1594 struct xsub_details {
1595     const char *name;
1596     XSUBADDR_t xsub;
1597     const char *proto;
1598 };
1599
1600 struct xsub_details details[] = {
1601     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1602     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1603     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1604     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1605     {"version::()", XS_version_noop, NULL},
1606     {"version::new", XS_version_new, NULL},
1607     {"version::parse", XS_version_new, NULL},
1608     {"version::(\"\"", XS_version_stringify, NULL},
1609     {"version::stringify", XS_version_stringify, NULL},
1610     {"version::(0+", XS_version_numify, NULL},
1611     {"version::numify", XS_version_numify, NULL},
1612     {"version::normal", XS_version_normal, NULL},
1613     {"version::(cmp", XS_version_vcmp, NULL},
1614     {"version::(<=>", XS_version_vcmp, NULL},
1615     {"version::vcmp", XS_version_vcmp, NULL},
1616     {"version::(bool", XS_version_boolean, NULL},
1617     {"version::boolean", XS_version_boolean, NULL},
1618     {"version::(nomethod", XS_version_noop, NULL},
1619     {"version::noop", XS_version_noop, NULL},
1620     {"version::is_alpha", XS_version_is_alpha, NULL},
1621     {"version::qv", XS_version_qv, NULL},
1622     {"version::declare", XS_version_qv, NULL},
1623     {"version::is_qv", XS_version_is_qv, NULL},
1624     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1625     {"utf8::valid", XS_utf8_valid, NULL},
1626     {"utf8::encode", XS_utf8_encode, NULL},
1627     {"utf8::decode", XS_utf8_decode, NULL},
1628     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1629     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1630     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1631     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1632     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1633     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1634     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1635     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1636     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1637     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1638     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1639     {"re::is_regexp", XS_re_is_regexp, "$"},
1640     {"re::regname", XS_re_regname, ";$$"},
1641     {"re::regnames", XS_re_regnames, ";$"},
1642     {"re::regnames_count", XS_re_regnames_count, ""},
1643     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1644     {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1645     {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1646     {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1647     {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1648     {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1649     {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1650     {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1651     {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1652     {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
1653     ,{"mauve::reftype", XS_mauve_reftype, "$"}
1654     ,{"mauve::refaddr", XS_mauve_refaddr, "$"}
1655     ,{"mauve::blessed", XS_mauve_blessed, "$"}
1656     ,{"mauve::weaken", XS_mauve_weaken, "$"}
1657     ,{"mauve::isweak", XS_mauve_isweak, "$"}
1658 };
1659
1660 void
1661 Perl_boot_core_UNIVERSAL(pTHX)
1662 {
1663     dVAR;
1664     static const char file[] = __FILE__;
1665     struct xsub_details *xsub = details;
1666     const struct xsub_details *end
1667         = details + sizeof(details) / sizeof(details[0]);
1668
1669     do {
1670         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1671     } while (++xsub < end);
1672
1673     /* register the overloading (type 'A') magic */
1674     PL_amagic_generation++;
1675
1676     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1677     CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1678         = (char *)file;
1679 }
1680
1681 /*
1682  * Local variables:
1683  * c-indentation-style: bsd
1684  * c-basic-offset: 4
1685  * indent-tabs-mode: t
1686  * End:
1687  *
1688  * ex: set ts=8 sts=4 sw=4 noet:
1689  */