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