Call get-magic once for CV-to-GV assignment
[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     SV *ret;
315     const char *undef;
316     PERL_UNUSED_ARG(cv);
317
318     if (SvROK(ST(0))) {
319         sv = MUTABLE_SV(SvRV(ST(0)));
320         if (!SvOBJECT(sv))
321             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
322         pkg = SvSTASH(sv);
323     }
324     else {
325         pkg = gv_stashsv(ST(0), 0);
326     }
327
328     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
329
330     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
331         ret = sv_newmortal();
332         sv_setsv(ret, sv);
333         undef = NULL;
334     }
335     else {
336         sv = ret = &PL_sv_undef;
337         undef = "(undef)";
338     }
339
340     if (items > 1) {
341         SV *req = ST(1);
342
343         if (undef) {
344             if (pkg) {
345                 const char * const name = HvNAME_get(pkg);
346                 Perl_croak(aTHX_
347                            "%s does not define $%s::VERSION--version check failed",
348                            name, name);
349             } else {
350                 Perl_croak(aTHX_
351                              "%s defines neither package nor VERSION--version check failed",
352                              SvPVx_nolen_const(ST(0)) );
353              }
354         }
355
356         if ( !sv_derived_from(sv, "version"))
357             upg_version(sv, FALSE);
358
359         if ( !sv_derived_from(req, "version")) {
360             /* req may very well be R/O, so create a new object */
361             req = sv_2mortal( new_version(req) );
362         }
363
364         if ( vcmp( req, sv ) > 0 ) {
365             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
366                 Perl_croak(aTHX_ "%s version %"SVf" required--"
367                        "this is only version %"SVf"", HvNAME_get(pkg),
368                        SVfARG(sv_2mortal(vnormal(req))),
369                        SVfARG(sv_2mortal(vnormal(sv))));
370             } else {
371                 Perl_croak(aTHX_ "%s version %"SVf" required--"
372                        "this is only version %"SVf"", HvNAME_get(pkg),
373                        SVfARG(sv_2mortal(vstringify(req))),
374                        SVfARG(sv_2mortal(vstringify(sv))));
375             }
376         }
377
378     }
379
380     ST(0) = ret;
381
382     XSRETURN(1);
383 }
384
385 XS(XS_version_new)
386 {
387     dVAR;
388     dXSARGS;
389     if (items > 3)
390         croak_xs_usage(cv, "class, version");
391     SP -= items;
392     {
393         SV *vs = ST(1);
394         SV *rv;
395         const char * const classname =
396             sv_isobject(ST(0)) /* get the class if called as an object method */
397                 ? HvNAME(SvSTASH(SvRV(ST(0))))
398                 : (char *)SvPV_nolen(ST(0));
399
400         if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
401             /* create empty object */
402             vs = sv_newmortal();
403             sv_setpvs(vs, "0");
404         }
405         else if ( items == 3 ) {
406             vs = sv_newmortal();
407             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
408         }
409
410         rv = new_version(vs);
411         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
412             sv_bless(rv, gv_stashpv(classname, GV_ADD));
413
414         mPUSHs(rv);
415         PUTBACK;
416         return;
417     }
418 }
419
420 XS(XS_version_stringify)
421 {
422      dVAR;
423      dXSARGS;
424      if (items < 1)
425          croak_xs_usage(cv, "lobj, ...");
426      SP -= items;
427      {
428           SV *  lobj = ST(0);
429
430           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
431                lobj = SvRV(lobj);
432           }
433           else
434                Perl_croak(aTHX_ "lobj is not of type version");
435
436           mPUSHs(vstringify(lobj));
437
438           PUTBACK;
439           return;
440      }
441 }
442
443 XS(XS_version_numify)
444 {
445      dVAR;
446      dXSARGS;
447      if (items < 1)
448          croak_xs_usage(cv, "lobj, ...");
449      SP -= items;
450      {
451           SV *  lobj = ST(0);
452
453           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
454                lobj = SvRV(lobj);
455           }
456           else
457                Perl_croak(aTHX_ "lobj is not of type version");
458
459           mPUSHs(vnumify(lobj));
460
461           PUTBACK;
462           return;
463      }
464 }
465
466 XS(XS_version_normal)
467 {
468      dVAR;
469      dXSARGS;
470      if (items < 1)
471          croak_xs_usage(cv, "lobj, ...");
472      SP -= items;
473      {
474           SV *  lobj = ST(0);
475
476           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
477                lobj = SvRV(lobj);
478           }
479           else
480                Perl_croak(aTHX_ "lobj is not of type version");
481
482           mPUSHs(vnormal(lobj));
483
484           PUTBACK;
485           return;
486      }
487 }
488
489 XS(XS_version_vcmp)
490 {
491      dVAR;
492      dXSARGS;
493      if (items < 1)
494          croak_xs_usage(cv, "lobj, ...");
495      SP -= items;
496      {
497           SV *  lobj = ST(0);
498
499           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
500                lobj = SvRV(lobj);
501           }
502           else
503                Perl_croak(aTHX_ "lobj is not of type version");
504
505           {
506                SV       *rs;
507                SV       *rvs;
508                SV * robj = ST(1);
509                const IV  swap = (IV)SvIV(ST(2));
510
511                if ( ! sv_derived_from(robj, "version") )
512                {
513                     robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
514                     sv_2mortal(robj);
515                }
516                rvs = SvRV(robj);
517
518                if ( swap )
519                {
520                     rs = newSViv(vcmp(rvs,lobj));
521                }
522                else
523                {
524                     rs = newSViv(vcmp(lobj,rvs));
525                }
526
527                mPUSHs(rs);
528           }
529
530           PUTBACK;
531           return;
532      }
533 }
534
535 XS(XS_version_boolean)
536 {
537     dVAR;
538     dXSARGS;
539     if (items < 1)
540         croak_xs_usage(cv, "lobj, ...");
541     SP -= items;
542     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
543         SV * const lobj = SvRV(ST(0));
544         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
545         mPUSHs(rs);
546         PUTBACK;
547         return;
548     }
549     else
550         Perl_croak(aTHX_ "lobj is not of type version");
551 }
552
553 XS(XS_version_noop)
554 {
555     dVAR;
556     dXSARGS;
557     if (items < 1)
558         croak_xs_usage(cv, "lobj, ...");
559     if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
560         Perl_croak(aTHX_ "operation not supported with version object");
561     else
562         Perl_croak(aTHX_ "lobj is not of type version");
563 #ifndef HASATTRIBUTE_NORETURN
564     XSRETURN_EMPTY;
565 #endif
566 }
567
568 XS(XS_version_is_alpha)
569 {
570     dVAR;
571     dXSARGS;
572     if (items != 1)
573         croak_xs_usage(cv, "lobj");
574     SP -= items;
575     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
576         SV * const lobj = ST(0);
577         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
578             XSRETURN_YES;
579         else
580             XSRETURN_NO;
581         PUTBACK;
582         return;
583     }
584     else
585         Perl_croak(aTHX_ "lobj is not of type version");
586 }
587
588 XS(XS_version_qv)
589 {
590     dVAR;
591     dXSARGS;
592     PERL_UNUSED_ARG(cv);
593     SP -= items;
594     {
595         SV * ver = ST(0);
596         SV * rv;
597         const char * classname = "";
598         if ( items == 2 && SvOK(ST(1)) ) {
599             /* getting called as object or class method */
600             ver = ST(1);
601             classname = 
602                 sv_isobject(ST(0)) /* class called as an object method */
603                     ? HvNAME_get(SvSTASH(SvRV(ST(0))))
604                     : (char *)SvPV_nolen(ST(0));
605         }
606         if ( !SvVOK(ver) ) { /* not already a v-string */
607             rv = sv_newmortal();
608             sv_setsv(rv,ver); /* make a duplicate */
609             upg_version(rv, TRUE);
610         } else {
611             rv = sv_2mortal(new_version(ver));
612         }
613         if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
614             sv_bless(rv, gv_stashpv(classname, GV_ADD));
615         }
616         PUSHs(rv);
617     }
618     PUTBACK;
619     return;
620 }
621
622 XS(XS_version_is_qv)
623 {
624     dVAR;
625     dXSARGS;
626     if (items != 1)
627         croak_xs_usage(cv, "lobj");
628     SP -= items;
629     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
630         SV * const lobj = ST(0);
631         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
632             XSRETURN_YES;
633         else
634             XSRETURN_NO;
635         PUTBACK;
636         return;
637     }
638     else
639         Perl_croak(aTHX_ "lobj is not of type version");
640 }
641
642 XS(XS_utf8_is_utf8)
643 {
644      dVAR;
645      dXSARGS;
646      if (items != 1)
647          croak_xs_usage(cv, "sv");
648      else {
649         SV * const sv = ST(0);
650         SvGETMAGIC(sv);
651             if (SvUTF8(sv))
652                 XSRETURN_YES;
653             else
654                 XSRETURN_NO;
655      }
656      XSRETURN_EMPTY;
657 }
658
659 XS(XS_utf8_valid)
660 {
661      dVAR;
662      dXSARGS;
663      if (items != 1)
664          croak_xs_usage(cv, "sv");
665     else {
666         SV * const sv = ST(0);
667         STRLEN len;
668         const char * const s = SvPV_const(sv,len);
669         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
670             XSRETURN_YES;
671         else
672             XSRETURN_NO;
673     }
674      XSRETURN_EMPTY;
675 }
676
677 XS(XS_utf8_encode)
678 {
679     dVAR;
680     dXSARGS;
681     if (items != 1)
682         croak_xs_usage(cv, "sv");
683     sv_utf8_encode(ST(0));
684     XSRETURN_EMPTY;
685 }
686
687 XS(XS_utf8_decode)
688 {
689     dVAR;
690     dXSARGS;
691     if (items != 1)
692         croak_xs_usage(cv, "sv");
693     else {
694         SV * const sv = ST(0);
695         bool RETVAL;
696         if (SvIsCOW(sv)) sv_force_normal(sv);
697         RETVAL = sv_utf8_decode(sv);
698         ST(0) = boolSV(RETVAL);
699     }
700     XSRETURN(1);
701 }
702
703 XS(XS_utf8_upgrade)
704 {
705     dVAR;
706     dXSARGS;
707     if (items != 1)
708         croak_xs_usage(cv, "sv");
709     else {
710         SV * const sv = ST(0);
711         STRLEN  RETVAL;
712         dXSTARG;
713
714         RETVAL = sv_utf8_upgrade(sv);
715         XSprePUSH; PUSHi((IV)RETVAL);
716     }
717     XSRETURN(1);
718 }
719
720 XS(XS_utf8_downgrade)
721 {
722     dVAR;
723     dXSARGS;
724     if (items < 1 || items > 2)
725         croak_xs_usage(cv, "sv, failok=0");
726     else {
727         SV * const sv = ST(0);
728         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
729         const bool RETVAL = sv_utf8_downgrade(sv, failok);
730
731         ST(0) = boolSV(RETVAL);
732     }
733     XSRETURN(1);
734 }
735
736 XS(XS_utf8_native_to_unicode)
737 {
738  dVAR;
739  dXSARGS;
740  const UV uv = SvUV(ST(0));
741
742  if (items > 1)
743      croak_xs_usage(cv, "sv");
744
745  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
746  XSRETURN(1);
747 }
748
749 XS(XS_utf8_unicode_to_native)
750 {
751  dVAR;
752  dXSARGS;
753  const UV uv = SvUV(ST(0));
754
755  if (items > 1)
756      croak_xs_usage(cv, "sv");
757
758  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
759  XSRETURN(1);
760 }
761
762 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
763 {
764     dVAR;
765     dXSARGS;
766     SV * const svz = ST(0);
767     SV * sv;
768     PERL_UNUSED_ARG(cv);
769
770     /* [perl #77776] - called as &foo() not foo() */
771     if (!SvROK(svz))
772         croak_xs_usage(cv, "SCALAR[, ON]");
773
774     sv = SvRV(svz);
775
776     if (items == 1) {
777          if (SvREADONLY(sv) && !SvIsCOW(sv))
778              XSRETURN_YES;
779          else
780              XSRETURN_NO;
781     }
782     else if (items == 2) {
783         if (SvTRUE(ST(1))) {
784             if (SvIsCOW(sv)) sv_force_normal(sv);
785             SvREADONLY_on(sv);
786             XSRETURN_YES;
787         }
788         else {
789             /* I hope you really know what you are doing. */
790             if (!SvIsCOW(sv)) SvREADONLY_off(sv);
791             XSRETURN_NO;
792         }
793     }
794     XSRETURN_UNDEF; /* Can't happen. */
795 }
796
797 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
798 {
799     dVAR;
800     dXSARGS;
801     SV * const svz = ST(0);
802     SV * sv;
803     PERL_UNUSED_ARG(cv);
804
805     /* [perl #77776] - called as &foo() not foo() */
806     if (!SvROK(svz))
807         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
808
809     sv = SvRV(svz);
810
811     if (items == 1)
812          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
813     else if (items == 2) {
814          /* I hope you really know what you are doing. */
815          SvREFCNT(sv) = SvIV(ST(1));
816          XSRETURN_IV(SvREFCNT(sv));
817     }
818     XSRETURN_UNDEF; /* Can't happen. */
819 }
820
821 XS(XS_Internals_hv_clear_placehold)
822 {
823     dVAR;
824     dXSARGS;
825
826     if (items != 1 || !SvROK(ST(0)))
827         croak_xs_usage(cv, "hv");
828     else {
829         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
830         hv_clear_placeholders(hv);
831         XSRETURN(0);
832     }
833 }
834
835 XS(XS_PerlIO_get_layers)
836 {
837     dVAR;
838     dXSARGS;
839     if (items < 1 || items % 2 == 0)
840         croak_xs_usage(cv, "filehandle[,args]");
841 #ifdef USE_PERLIO
842     {
843         SV *    sv;
844         GV *    gv;
845         IO *    io;
846         bool    input = TRUE;
847         bool    details = FALSE;
848
849         if (items > 1) {
850              SV * const *svp;
851              for (svp = MARK + 2; svp <= SP; svp += 2) {
852                   SV * const * const varp = svp;
853                   SV * const * const valp = svp + 1;
854                   STRLEN klen;
855                   const char * const key = SvPV_const(*varp, klen);
856
857                   switch (*key) {
858                   case 'i':
859                        if (klen == 5 && memEQ(key, "input", 5)) {
860                             input = SvTRUE(*valp);
861                             break;
862                        }
863                        goto fail;
864                   case 'o': 
865                        if (klen == 6 && memEQ(key, "output", 6)) {
866                             input = !SvTRUE(*valp);
867                             break;
868                        }
869                        goto fail;
870                   case 'd':
871                        if (klen == 7 && memEQ(key, "details", 7)) {
872                             details = SvTRUE(*valp);
873                             break;
874                        }
875                        goto fail;
876                   default:
877                   fail:
878                        Perl_croak(aTHX_
879                                   "get_layers: unknown argument '%s'",
880                                   key);
881                   }
882              }
883
884              SP -= (items - 1);
885         }
886
887         sv = POPs;
888         gv = MUTABLE_GV(sv);
889
890         if (!isGV(sv)) {
891              if (SvROK(sv) && isGV(SvRV(sv)))
892                   gv = MUTABLE_GV(SvRV(sv));
893              else if (SvPOKp(sv))
894                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
895         }
896
897         if (gv && (io = GvIO(gv))) {
898              AV* const av = PerlIO_get_layers(aTHX_ input ?
899                                         IoIFP(io) : IoOFP(io));
900              I32 i;
901              const I32 last = av_len(av);
902              I32 nitem = 0;
903              
904              for (i = last; i >= 0; i -= 3) {
905                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
906                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
907                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
908
909                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
910                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
911                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
912
913                   if (details) {
914                       /* Indents of 5? Yuck.  */
915                       /* We know that PerlIO_get_layers creates a new SV for
916                          the name and flags, so we can just take a reference
917                          and "steal" it when we free the AV below.  */
918                        XPUSHs(namok
919                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
920                               : &PL_sv_undef);
921                        XPUSHs(argok
922                               ? newSVpvn_flags(SvPVX_const(*argsvp),
923                                                SvCUR(*argsvp),
924                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
925                                                | SVs_TEMP)
926                               : &PL_sv_undef);
927                        XPUSHs(flgok
928                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
929                               : &PL_sv_undef);
930                        nitem += 3;
931                   }
932                   else {
933                        if (namok && argok)
934                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
935                                                  SVfARG(*namsvp),
936                                                  SVfARG(*argsvp))));
937                        else if (namok)
938                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
939                        else
940                             XPUSHs(&PL_sv_undef);
941                        nitem++;
942                        if (flgok) {
943                             const IV flags = SvIVX(*flgsvp);
944
945                             if (flags & PERLIO_F_UTF8) {
946                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
947                                  nitem++;
948                             }
949                        }
950                   }
951              }
952
953              SvREFCNT_dec(av);
954
955              XSRETURN(nitem);
956         }
957     }
958 #endif
959
960     XSRETURN(0);
961 }
962
963 XS(XS_Internals_hash_seed)
964 {
965     dVAR;
966     /* Using dXSARGS would also have dITEM and dSP,
967      * which define 2 unused local variables.  */
968     dAXMARK;
969     PERL_UNUSED_ARG(cv);
970     PERL_UNUSED_VAR(mark);
971     XSRETURN_UV(PERL_HASH_SEED);
972 }
973
974 XS(XS_Internals_rehash_seed)
975 {
976     dVAR;
977     /* Using dXSARGS would also have dITEM and dSP,
978      * which define 2 unused local variables.  */
979     dAXMARK;
980     PERL_UNUSED_ARG(cv);
981     PERL_UNUSED_VAR(mark);
982     XSRETURN_UV(PL_rehash_seed);
983 }
984
985 XS(XS_Internals_HvREHASH)       /* Subject to change  */
986 {
987     dVAR;
988     dXSARGS;
989     PERL_UNUSED_ARG(cv);
990     if (SvROK(ST(0))) {
991         const HV * const hv = (const HV *) SvRV(ST(0));
992         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
993             if (HvREHASH(hv))
994                 XSRETURN_YES;
995             else
996                 XSRETURN_NO;
997         }
998     }
999     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1000 }
1001
1002 XS(XS_re_is_regexp)
1003 {
1004     dVAR; 
1005     dXSARGS;
1006     PERL_UNUSED_VAR(cv);
1007
1008     if (items != 1)
1009         croak_xs_usage(cv, "sv");
1010
1011     if (SvRXOK(ST(0))) {
1012         XSRETURN_YES;
1013     } else {
1014         XSRETURN_NO;
1015     }
1016 }
1017
1018 XS(XS_re_regnames_count)
1019 {
1020     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1021     SV * ret;
1022     dVAR; 
1023     dXSARGS;
1024
1025     if (items != 0)
1026         croak_xs_usage(cv, "");
1027
1028     SP -= items;
1029     PUTBACK;
1030
1031     if (!rx)
1032         XSRETURN_UNDEF;
1033
1034     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1035
1036     SPAGAIN;
1037     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1038     XSRETURN(1);
1039 }
1040
1041 XS(XS_re_regname)
1042 {
1043     dVAR;
1044     dXSARGS;
1045     REGEXP * rx;
1046     U32 flags;
1047     SV * ret;
1048
1049     if (items < 1 || items > 2)
1050         croak_xs_usage(cv, "name[, all ]");
1051
1052     SP -= items;
1053     PUTBACK;
1054
1055     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1056
1057     if (!rx)
1058         XSRETURN_UNDEF;
1059
1060     if (items == 2 && SvTRUE(ST(1))) {
1061         flags = RXapif_ALL;
1062     } else {
1063         flags = RXapif_ONE;
1064     }
1065     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1066
1067     SPAGAIN;
1068     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1069     XSRETURN(1);
1070 }
1071
1072
1073 XS(XS_re_regnames)
1074 {
1075     dVAR;
1076     dXSARGS;
1077     REGEXP * rx;
1078     U32 flags;
1079     SV *ret;
1080     AV *av;
1081     I32 length;
1082     I32 i;
1083     SV **entry;
1084
1085     if (items > 1)
1086         croak_xs_usage(cv, "[all]");
1087
1088     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1089
1090     if (!rx)
1091         XSRETURN_UNDEF;
1092
1093     if (items == 1 && SvTRUE(ST(0))) {
1094         flags = RXapif_ALL;
1095     } else {
1096         flags = RXapif_ONE;
1097     }
1098
1099     SP -= items;
1100     PUTBACK;
1101
1102     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1103
1104     SPAGAIN;
1105
1106     if (!ret)
1107         XSRETURN_UNDEF;
1108
1109     av = MUTABLE_AV(SvRV(ret));
1110     length = av_len(av);
1111
1112     for (i = 0; i <= length; i++) {
1113         entry = av_fetch(av, i, FALSE);
1114         
1115         if (!entry)
1116             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1117
1118         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1119     }
1120
1121     SvREFCNT_dec(ret);
1122
1123     PUTBACK;
1124     return;
1125 }
1126
1127 XS(XS_re_regexp_pattern)
1128 {
1129     dVAR;
1130     dXSARGS;
1131     REGEXP *re;
1132
1133     if (items != 1)
1134         croak_xs_usage(cv, "sv");
1135
1136     SP -= items;
1137
1138     /*
1139        Checks if a reference is a regex or not. If the parameter is
1140        not a ref, or is not the result of a qr// then returns false
1141        in scalar context and an empty list in list context.
1142        Otherwise in list context it returns the pattern and the
1143        modifiers, in scalar context it returns the pattern just as it
1144        would if the qr// was stringified normally, regardless as
1145        to the class of the variable and any stringification overloads
1146        on the object.
1147     */
1148
1149     if ((re = SvRX(ST(0)))) /* assign deliberate */
1150     {
1151         /* Houston, we have a regex! */
1152         SV *pattern;
1153
1154         if ( GIMME_V == G_ARRAY ) {
1155             STRLEN left = 0;
1156             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1157             const char *fptr;
1158             char ch;
1159             U16 match_flags;
1160
1161             /*
1162                we are in list context so stringify
1163                the modifiers that apply. We ignore "negative
1164                modifiers" in this scenario, and the default character set
1165             */
1166
1167             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1168                 STRLEN len;
1169                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1170                                                                 &len);
1171                 Copy(name, reflags + left, len, char);
1172                 left += len;
1173             }
1174             fptr = INT_PAT_MODS;
1175             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1176                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1177
1178             while((ch = *fptr++)) {
1179                 if(match_flags & 1) {
1180                     reflags[left++] = ch;
1181                 }
1182                 match_flags >>= 1;
1183             }
1184
1185             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1186                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1187
1188             /* return the pattern and the modifiers */
1189             XPUSHs(pattern);
1190             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1191             XSRETURN(2);
1192         } else {
1193             /* Scalar, so use the string that Perl would return */
1194             /* return the pattern in (?msix:..) format */
1195 #if PERL_VERSION >= 11
1196             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1197 #else
1198             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1199                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1200 #endif
1201             XPUSHs(pattern);
1202             XSRETURN(1);
1203         }
1204     } else {
1205         /* It ain't a regexp folks */
1206         if ( GIMME_V == G_ARRAY ) {
1207             /* return the empty list */
1208             XSRETURN_UNDEF;
1209         } else {
1210             /* Because of the (?:..) wrapping involved in a
1211                stringified pattern it is impossible to get a
1212                result for a real regexp that would evaluate to
1213                false. Therefore we can return PL_sv_no to signify
1214                that the object is not a regex, this means that one
1215                can say
1216
1217                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1218
1219                and not worry about undefined values.
1220             */
1221             XSRETURN_NO;
1222         }
1223     }
1224     /* NOT-REACHED */
1225 }
1226
1227 struct xsub_details {
1228     const char *name;
1229     XSUBADDR_t xsub;
1230     const char *proto;
1231 };
1232
1233 struct xsub_details details[] = {
1234     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1235     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1236     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1237     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1238     {"version::()", XS_version_noop, NULL},
1239     {"version::new", XS_version_new, NULL},
1240     {"version::parse", XS_version_new, NULL},
1241     {"version::(\"\"", XS_version_stringify, NULL},
1242     {"version::stringify", XS_version_stringify, NULL},
1243     {"version::(0+", XS_version_numify, NULL},
1244     {"version::numify", XS_version_numify, NULL},
1245     {"version::normal", XS_version_normal, NULL},
1246     {"version::(cmp", XS_version_vcmp, NULL},
1247     {"version::(<=>", XS_version_vcmp, NULL},
1248     {"version::vcmp", XS_version_vcmp, NULL},
1249     {"version::(bool", XS_version_boolean, NULL},
1250     {"version::boolean", XS_version_boolean, NULL},
1251     {"version::(nomethod", XS_version_noop, NULL},
1252     {"version::noop", XS_version_noop, NULL},
1253     {"version::is_alpha", XS_version_is_alpha, NULL},
1254     {"version::qv", XS_version_qv, NULL},
1255     {"version::declare", XS_version_qv, NULL},
1256     {"version::is_qv", XS_version_is_qv, NULL},
1257     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1258     {"utf8::valid", XS_utf8_valid, NULL},
1259     {"utf8::encode", XS_utf8_encode, NULL},
1260     {"utf8::decode", XS_utf8_decode, NULL},
1261     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1262     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1263     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1264     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1265     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1266     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1267     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1268     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1269     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1270     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1271     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1272     {"re::is_regexp", XS_re_is_regexp, "$"},
1273     {"re::regname", XS_re_regname, ";$$"},
1274     {"re::regnames", XS_re_regnames, ";$"},
1275     {"re::regnames_count", XS_re_regnames_count, ""},
1276     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1277 };
1278
1279 void
1280 Perl_boot_core_UNIVERSAL(pTHX)
1281 {
1282     dVAR;
1283     static const char file[] = __FILE__;
1284     struct xsub_details *xsub = details;
1285     const struct xsub_details *end
1286         = details + sizeof(details) / sizeof(details[0]);
1287
1288     do {
1289         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1290     } while (++xsub < end);
1291
1292     /* register the overloading (type 'A') magic */
1293     PL_amagic_generation++;
1294
1295     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1296     {
1297         CV * const cv =
1298             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1299         Safefree(CvFILE(cv));
1300         CvFILE(cv) = (char *)file;
1301         CvDYNFILE_off(cv);
1302     }
1303 }
1304
1305 /*
1306  * Local variables:
1307  * c-indentation-style: bsd
1308  * c-basic-offset: 4
1309  * indent-tabs-mode: t
1310  * End:
1311  *
1312  * ex: set ts=8 sts=4 sw=4 noet:
1313  */