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