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