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