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