copyedit perldelta
[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) && !SvIsCOW(sv))
781              XSRETURN_YES;
782          else
783              XSRETURN_NO;
784     }
785     else if (items == 2) {
786         if (SvTRUE(ST(1))) {
787             if (SvIsCOW(sv)) sv_force_normal(sv);
788             SvREADONLY_on(sv);
789             XSRETURN_YES;
790         }
791         else {
792             /* I hope you really know what you are doing. */
793             if (!SvIsCOW(sv)) SvREADONLY_off(sv);
794             XSRETURN_NO;
795         }
796     }
797     XSRETURN_UNDEF; /* Can't happen. */
798 }
799
800 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
801 {
802     dVAR;
803     dXSARGS;
804     SV * const svz = ST(0);
805     SV * sv;
806     PERL_UNUSED_ARG(cv);
807
808     /* [perl #77776] - called as &foo() not foo() */
809     if (!SvROK(svz))
810         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
811
812     sv = SvRV(svz);
813
814     if (items == 1)
815          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
816     else if (items == 2) {
817          /* I hope you really know what you are doing. */
818          SvREFCNT(sv) = SvIV(ST(1));
819          XSRETURN_IV(SvREFCNT(sv));
820     }
821     XSRETURN_UNDEF; /* Can't happen. */
822 }
823
824 XS(XS_Internals_hv_clear_placehold)
825 {
826     dVAR;
827     dXSARGS;
828
829     if (items != 1 || !SvROK(ST(0)))
830         croak_xs_usage(cv, "hv");
831     else {
832         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
833         hv_clear_placeholders(hv);
834         XSRETURN(0);
835     }
836 }
837
838 XS(XS_PerlIO_get_layers)
839 {
840     dVAR;
841     dXSARGS;
842     if (items < 1 || items % 2 == 0)
843         croak_xs_usage(cv, "filehandle[,args]");
844 #ifdef USE_PERLIO
845     {
846         SV *    sv;
847         GV *    gv;
848         IO *    io;
849         bool    input = TRUE;
850         bool    details = FALSE;
851
852         if (items > 1) {
853              SV * const *svp;
854              for (svp = MARK + 2; svp <= SP; svp += 2) {
855                   SV * const * const varp = svp;
856                   SV * const * const valp = svp + 1;
857                   STRLEN klen;
858                   const char * const key = SvPV_const(*varp, klen);
859
860                   switch (*key) {
861                   case 'i':
862                        if (klen == 5 && memEQ(key, "input", 5)) {
863                             input = SvTRUE(*valp);
864                             break;
865                        }
866                        goto fail;
867                   case 'o': 
868                        if (klen == 6 && memEQ(key, "output", 6)) {
869                             input = !SvTRUE(*valp);
870                             break;
871                        }
872                        goto fail;
873                   case 'd':
874                        if (klen == 7 && memEQ(key, "details", 7)) {
875                             details = SvTRUE(*valp);
876                             break;
877                        }
878                        goto fail;
879                   default:
880                   fail:
881                        Perl_croak(aTHX_
882                                   "get_layers: unknown argument '%s'",
883                                   key);
884                   }
885              }
886
887              SP -= (items - 1);
888         }
889
890         sv = POPs;
891         gv = MUTABLE_GV(sv);
892
893         if (!isGV(sv)) {
894              if (SvROK(sv) && isGV(SvRV(sv)))
895                   gv = MUTABLE_GV(SvRV(sv));
896              else if (SvPOKp(sv))
897                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
898         }
899
900         if (gv && (io = GvIO(gv))) {
901              AV* const av = PerlIO_get_layers(aTHX_ input ?
902                                         IoIFP(io) : IoOFP(io));
903              I32 i;
904              const I32 last = av_len(av);
905              I32 nitem = 0;
906              
907              for (i = last; i >= 0; i -= 3) {
908                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
909                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
910                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
911
912                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
913                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
914                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
915
916                   if (details) {
917                       /* Indents of 5? Yuck.  */
918                       /* We know that PerlIO_get_layers creates a new SV for
919                          the name and flags, so we can just take a reference
920                          and "steal" it when we free the AV below.  */
921                        XPUSHs(namok
922                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
923                               : &PL_sv_undef);
924                        XPUSHs(argok
925                               ? newSVpvn_flags(SvPVX_const(*argsvp),
926                                                SvCUR(*argsvp),
927                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
928                                                | SVs_TEMP)
929                               : &PL_sv_undef);
930                        XPUSHs(flgok
931                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
932                               : &PL_sv_undef);
933                        nitem += 3;
934                   }
935                   else {
936                        if (namok && argok)
937                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
938                                                  SVfARG(*namsvp),
939                                                  SVfARG(*argsvp))));
940                        else if (namok)
941                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
942                        else
943                             XPUSHs(&PL_sv_undef);
944                        nitem++;
945                        if (flgok) {
946                             const IV flags = SvIVX(*flgsvp);
947
948                             if (flags & PERLIO_F_UTF8) {
949                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
950                                  nitem++;
951                             }
952                        }
953                   }
954              }
955
956              SvREFCNT_dec(av);
957
958              XSRETURN(nitem);
959         }
960     }
961 #endif
962
963     XSRETURN(0);
964 }
965
966 XS(XS_Internals_hash_seed)
967 {
968     dVAR;
969     /* Using dXSARGS would also have dITEM and dSP,
970      * which define 2 unused local variables.  */
971     dAXMARK;
972     PERL_UNUSED_ARG(cv);
973     PERL_UNUSED_VAR(mark);
974     XSRETURN_UV(PERL_HASH_SEED);
975 }
976
977 XS(XS_Internals_rehash_seed)
978 {
979     dVAR;
980     /* Using dXSARGS would also have dITEM and dSP,
981      * which define 2 unused local variables.  */
982     dAXMARK;
983     PERL_UNUSED_ARG(cv);
984     PERL_UNUSED_VAR(mark);
985     XSRETURN_UV(PL_rehash_seed);
986 }
987
988 XS(XS_Internals_HvREHASH)       /* Subject to change  */
989 {
990     dVAR;
991     dXSARGS;
992     PERL_UNUSED_ARG(cv);
993     if (SvROK(ST(0))) {
994         const HV * const hv = (const HV *) SvRV(ST(0));
995         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
996             if (HvREHASH(hv))
997                 XSRETURN_YES;
998             else
999                 XSRETURN_NO;
1000         }
1001     }
1002     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1003 }
1004
1005 XS(XS_re_is_regexp)
1006 {
1007     dVAR; 
1008     dXSARGS;
1009     PERL_UNUSED_VAR(cv);
1010
1011     if (items != 1)
1012         croak_xs_usage(cv, "sv");
1013
1014     if (SvRXOK(ST(0))) {
1015         XSRETURN_YES;
1016     } else {
1017         XSRETURN_NO;
1018     }
1019 }
1020
1021 XS(XS_re_regnames_count)
1022 {
1023     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1024     SV * ret;
1025     dVAR; 
1026     dXSARGS;
1027
1028     if (items != 0)
1029         croak_xs_usage(cv, "");
1030
1031     SP -= items;
1032     PUTBACK;
1033
1034     if (!rx)
1035         XSRETURN_UNDEF;
1036
1037     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1038
1039     SPAGAIN;
1040     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1041     XSRETURN(1);
1042 }
1043
1044 XS(XS_re_regname)
1045 {
1046     dVAR;
1047     dXSARGS;
1048     REGEXP * rx;
1049     U32 flags;
1050     SV * ret;
1051
1052     if (items < 1 || items > 2)
1053         croak_xs_usage(cv, "name[, all ]");
1054
1055     SP -= items;
1056     PUTBACK;
1057
1058     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1059
1060     if (!rx)
1061         XSRETURN_UNDEF;
1062
1063     if (items == 2 && SvTRUE(ST(1))) {
1064         flags = RXapif_ALL;
1065     } else {
1066         flags = RXapif_ONE;
1067     }
1068     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1069
1070     SPAGAIN;
1071     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1072     XSRETURN(1);
1073 }
1074
1075
1076 XS(XS_re_regnames)
1077 {
1078     dVAR;
1079     dXSARGS;
1080     REGEXP * rx;
1081     U32 flags;
1082     SV *ret;
1083     AV *av;
1084     I32 length;
1085     I32 i;
1086     SV **entry;
1087
1088     if (items > 1)
1089         croak_xs_usage(cv, "[all]");
1090
1091     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1092
1093     if (!rx)
1094         XSRETURN_UNDEF;
1095
1096     if (items == 1 && SvTRUE(ST(0))) {
1097         flags = RXapif_ALL;
1098     } else {
1099         flags = RXapif_ONE;
1100     }
1101
1102     SP -= items;
1103     PUTBACK;
1104
1105     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1106
1107     SPAGAIN;
1108
1109     if (!ret)
1110         XSRETURN_UNDEF;
1111
1112     av = MUTABLE_AV(SvRV(ret));
1113     length = av_len(av);
1114
1115     for (i = 0; i <= length; i++) {
1116         entry = av_fetch(av, i, FALSE);
1117         
1118         if (!entry)
1119             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1120
1121         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1122     }
1123
1124     SvREFCNT_dec(ret);
1125
1126     PUTBACK;
1127     return;
1128 }
1129
1130 XS(XS_re_regexp_pattern)
1131 {
1132     dVAR;
1133     dXSARGS;
1134     REGEXP *re;
1135
1136     if (items != 1)
1137         croak_xs_usage(cv, "sv");
1138
1139     SP -= items;
1140
1141     /*
1142        Checks if a reference is a regex or not. If the parameter is
1143        not a ref, or is not the result of a qr// then returns false
1144        in scalar context and an empty list in list context.
1145        Otherwise in list context it returns the pattern and the
1146        modifiers, in scalar context it returns the pattern just as it
1147        would if the qr// was stringified normally, regardless as
1148        to the class of the variable and any stringification overloads
1149        on the object.
1150     */
1151
1152     if ((re = SvRX(ST(0)))) /* assign deliberate */
1153     {
1154         /* Houston, we have a regex! */
1155         SV *pattern;
1156
1157         if ( GIMME_V == G_ARRAY ) {
1158             STRLEN left = 0;
1159             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1160             const char *fptr;
1161             char ch;
1162             U16 match_flags;
1163
1164             /*
1165                we are in list context so stringify
1166                the modifiers that apply. We ignore "negative
1167                modifiers" in this scenario, and the default character set
1168             */
1169
1170             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1171                 STRLEN len;
1172                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1173                                                                 &len);
1174                 Copy(name, reflags + left, len, char);
1175                 left += len;
1176             }
1177             fptr = INT_PAT_MODS;
1178             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1179                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1180
1181             while((ch = *fptr++)) {
1182                 if(match_flags & 1) {
1183                     reflags[left++] = ch;
1184                 }
1185                 match_flags >>= 1;
1186             }
1187
1188             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1189                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1190
1191             /* return the pattern and the modifiers */
1192             XPUSHs(pattern);
1193             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1194             XSRETURN(2);
1195         } else {
1196             /* Scalar, so use the string that Perl would return */
1197             /* return the pattern in (?msix:..) format */
1198 #if PERL_VERSION >= 11
1199             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1200 #else
1201             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1202                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1203 #endif
1204             XPUSHs(pattern);
1205             XSRETURN(1);
1206         }
1207     } else {
1208         /* It ain't a regexp folks */
1209         if ( GIMME_V == G_ARRAY ) {
1210             /* return the empty list */
1211             XSRETURN_UNDEF;
1212         } else {
1213             /* Because of the (?:..) wrapping involved in a
1214                stringified pattern it is impossible to get a
1215                result for a real regexp that would evaluate to
1216                false. Therefore we can return PL_sv_no to signify
1217                that the object is not a regex, this means that one
1218                can say
1219
1220                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1221
1222                and not worry about undefined values.
1223             */
1224             XSRETURN_NO;
1225         }
1226     }
1227     /* NOT-REACHED */
1228 }
1229
1230 struct xsub_details {
1231     const char *name;
1232     XSUBADDR_t xsub;
1233     const char *proto;
1234 };
1235
1236 struct xsub_details details[] = {
1237     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1238     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1239     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1240     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1241     {"version::()", XS_version_noop, NULL},
1242     {"version::new", XS_version_new, NULL},
1243     {"version::parse", XS_version_new, NULL},
1244     {"version::(\"\"", XS_version_stringify, NULL},
1245     {"version::stringify", XS_version_stringify, NULL},
1246     {"version::(0+", XS_version_numify, NULL},
1247     {"version::numify", XS_version_numify, NULL},
1248     {"version::normal", XS_version_normal, NULL},
1249     {"version::(cmp", XS_version_vcmp, NULL},
1250     {"version::(<=>", XS_version_vcmp, NULL},
1251     {"version::vcmp", XS_version_vcmp, NULL},
1252     {"version::(bool", XS_version_boolean, NULL},
1253     {"version::boolean", XS_version_boolean, NULL},
1254     {"version::(nomethod", XS_version_noop, NULL},
1255     {"version::noop", XS_version_noop, NULL},
1256     {"version::is_alpha", XS_version_is_alpha, NULL},
1257     {"version::qv", XS_version_qv, NULL},
1258     {"version::declare", XS_version_qv, NULL},
1259     {"version::is_qv", XS_version_is_qv, NULL},
1260     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1261     {"utf8::valid", XS_utf8_valid, NULL},
1262     {"utf8::encode", XS_utf8_encode, NULL},
1263     {"utf8::decode", XS_utf8_decode, NULL},
1264     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1265     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1266     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1267     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1268     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1269     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1270     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1271     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1272     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1273     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1274     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1275     {"re::is_regexp", XS_re_is_regexp, "$"},
1276     {"re::regname", XS_re_regname, ";$$"},
1277     {"re::regnames", XS_re_regnames, ";$"},
1278     {"re::regnames_count", XS_re_regnames_count, ""},
1279     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1280 };
1281
1282 void
1283 Perl_boot_core_UNIVERSAL(pTHX)
1284 {
1285     dVAR;
1286     static const char file[] = __FILE__;
1287     struct xsub_details *xsub = details;
1288     const struct xsub_details *end
1289         = details + sizeof(details) / sizeof(details[0]);
1290
1291     do {
1292         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1293     } while (++xsub < end);
1294
1295     /* register the overloading (type 'A') magic */
1296     PL_amagic_generation++;
1297
1298     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1299     CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1300         = (char *)file;
1301 }
1302
1303 /*
1304  * Local variables:
1305  * c-indentation-style: bsd
1306  * c-basic-offset: 4
1307  * indent-tabs-mode: t
1308  * End:
1309  *
1310  * ex: set ts=8 sts=4 sw=4 noet:
1311  */