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