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