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