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