PATCH: [perl #131598]
[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 #if defined(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     const struct mro_meta *const meta = HvMROMETA(stash);
45     HV *isa = meta->isa;
46     const HV *our_stash;
47
48     PERL_ARGS_ASSERT_ISA_LOOKUP;
49
50     if (!isa) {
51         (void)mro_get_linear_isa(stash);
52         isa = meta->isa;
53     }
54
55     if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
56                   HV_FETCH_ISEXISTS, NULL, 0)) {
57         /* Direct name lookup worked.  */
58         return TRUE;
59     }
60
61     /* A stash/class can go by many names (ie. User == main::User), so 
62        we use the HvENAME in the stash itself, which is canonical, falling
63        back to HvNAME if necessary.  */
64     our_stash = gv_stashpvn(name, len, flags);
65
66     if (our_stash) {
67         HEK *canon_name = HvENAME_HEK(our_stash);
68         if (!canon_name) canon_name = HvNAME_HEK(our_stash);
69         assert(canon_name);
70         if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
71                       HEK_FLAGS(canon_name),
72                       HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
73             return TRUE;
74         }
75     }
76
77     return FALSE;
78 }
79
80 /*
81 =head1 SV Manipulation Functions
82
83 =for apidoc sv_derived_from_pvn
84
85 Returns a boolean indicating whether the SV is derived from the specified class
86 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
87 normal Perl method.
88
89 Currently, the only significant value for C<flags> is SVf_UTF8.
90
91 =cut
92
93 =for apidoc sv_derived_from_sv
94
95 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
96 of an SV instead of a string/length pair.
97
98 =cut
99
100 */
101
102 bool
103 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
104 {
105     char *namepv;
106     STRLEN namelen;
107     PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
108     namepv = SvPV(namesv, namelen);
109     if (SvUTF8(namesv))
110        flags |= SVf_UTF8;
111     return sv_derived_from_pvn(sv, namepv, namelen, flags);
112 }
113
114 /*
115 =for apidoc sv_derived_from
116
117 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
118
119 =cut
120 */
121
122 bool
123 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
124 {
125     PERL_ARGS_ASSERT_SV_DERIVED_FROM;
126     return sv_derived_from_pvn(sv, name, strlen(name), 0);
127 }
128
129 /*
130 =for apidoc sv_derived_from_pv
131
132 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string 
133 instead of a string/length pair.
134
135 =cut
136 */
137
138
139 bool
140 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
141 {
142     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
143     return sv_derived_from_pvn(sv, name, strlen(name), flags);
144 }
145
146 bool
147 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
148 {
149     HV *stash;
150
151     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
152
153     SvGETMAGIC(sv);
154
155     if (SvROK(sv)) {
156         const char *type;
157         sv = SvRV(sv);
158         type = sv_reftype(sv,0);
159         if (type && strEQ(type,name))
160             return TRUE;
161         if (!SvOBJECT(sv))
162             return FALSE;
163         stash = SvSTASH(sv);
164     }
165     else {
166         stash = gv_stashsv(sv, 0);
167     }
168
169     if (stash && isa_lookup(stash, name, len, flags))
170         return TRUE;
171
172     stash = gv_stashpvs("UNIVERSAL", 0);
173     return stash && isa_lookup(stash, name, len, flags);
174 }
175
176 /*
177 =for apidoc sv_does_sv
178
179 Returns a boolean indicating whether the SV performs a specific, named role.
180 The SV can be a Perl object or the name of a Perl class.
181
182 =cut
183 */
184
185 #include "XSUB.h"
186
187 bool
188 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
189 {
190     SV *classname;
191     bool does_it;
192     SV *methodname;
193     dSP;
194
195     PERL_ARGS_ASSERT_SV_DOES_SV;
196     PERL_UNUSED_ARG(flags);
197
198     ENTER;
199     SAVETMPS;
200
201     SvGETMAGIC(sv);
202
203     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
204         LEAVE;
205         return FALSE;
206     }
207
208     if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
209         classname = sv_ref(NULL,SvRV(sv),TRUE);
210     } else {
211         classname = sv;
212     }
213
214     if (sv_eq(classname, namesv)) {
215         LEAVE;
216         return TRUE;
217     }
218
219     PUSHMARK(SP);
220     EXTEND(SP, 2);
221     PUSHs(sv);
222     PUSHs(namesv);
223     PUTBACK;
224
225     /* create a PV with value "isa", but with a special address
226      * so that perl knows we're really doing "DOES" instead */
227     methodname = newSV_type(SVt_PV);
228     SvLEN(methodname) = 0;
229     SvCUR(methodname) = strlen(PL_isa_DOES);
230     SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
231     SvPOK_on(methodname);
232     sv_2mortal(methodname);
233     call_sv(methodname, G_SCALAR | G_METHOD);
234     SPAGAIN;
235
236     does_it = SvTRUE_NN( TOPs );
237     FREETMPS;
238     LEAVE;
239
240     return does_it;
241 }
242
243 /*
244 =for apidoc sv_does
245
246 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
247
248 =cut
249 */
250
251 bool
252 Perl_sv_does(pTHX_ SV *sv, const char *const name)
253 {
254     PERL_ARGS_ASSERT_SV_DOES;
255     return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
256 }
257
258 /*
259 =for apidoc sv_does_pv
260
261 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
262
263 =cut
264 */
265
266
267 bool
268 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
269 {
270     PERL_ARGS_ASSERT_SV_DOES_PV;
271     return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
272 }
273
274 /*
275 =for apidoc sv_does_pvn
276
277 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
278
279 =cut
280 */
281
282 bool
283 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
284 {
285     PERL_ARGS_ASSERT_SV_DOES_PVN;
286
287     return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
288 }
289
290 /*
291 =for apidoc croak_xs_usage
292
293 A specialised variant of C<croak()> for emitting the usage message for xsubs
294
295     croak_xs_usage(cv, "eee_yow");
296
297 works out the package name and subroutine name from C<cv>, and then calls
298 C<croak()>.  Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
299
300  Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
301                                                      "eee_yow");
302
303 =cut
304 */
305
306 void
307 Perl_croak_xs_usage(const CV *const cv, const char *const params)
308 {
309     /* Avoid CvGV as it requires aTHX.  */
310     const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
311
312     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
313
314     if (gv) got_gv: {
315         const HV *const stash = GvSTASH(gv);
316
317         if (HvNAME_get(stash))
318             /* diag_listed_as: SKIPME */
319             Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
320                                 HEKfARG(HvNAME_HEK(stash)),
321                                 HEKfARG(GvNAME_HEK(gv)),
322                                 params);
323         else
324             /* diag_listed_as: SKIPME */
325             Perl_croak_nocontext("Usage: %" HEKf "(%s)",
326                                 HEKfARG(GvNAME_HEK(gv)), params);
327     } else {
328         dTHX;
329         if ((gv = CvGV(cv))) goto got_gv;
330
331         /* Pants. I don't think that it should be possible to get here. */
332         /* diag_listed_as: SKIPME */
333         Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
334     }
335 }
336
337 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
338 XS(XS_UNIVERSAL_isa)
339 {
340     dXSARGS;
341
342     if (items != 2)
343         croak_xs_usage(cv, "reference, kind");
344     else {
345         SV * const sv = ST(0);
346
347         SvGETMAGIC(sv);
348
349         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
350             XSRETURN_UNDEF;
351
352         ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
353         XSRETURN(1);
354     }
355 }
356
357 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
358 XS(XS_UNIVERSAL_can)
359 {
360     dXSARGS;
361     SV   *sv;
362     SV   *rv;
363     HV   *pkg = NULL;
364     GV   *iogv;
365
366     if (items != 2)
367         croak_xs_usage(cv, "object-ref, method");
368
369     sv = ST(0);
370
371     SvGETMAGIC(sv);
372
373     /* Reject undef and empty string.  Note that the string form takes
374        precedence here over the numeric form, as (!1)->foo treats the
375        invocant as the empty string, though it is a dualvar. */
376     if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
377         XSRETURN_UNDEF;
378
379     rv = &PL_sv_undef;
380
381     if (SvROK(sv)) {
382         sv = MUTABLE_SV(SvRV(sv));
383         if (SvOBJECT(sv))
384             pkg = SvSTASH(sv);
385         else if (isGV_with_GP(sv) && GvIO(sv))
386             pkg = SvSTASH(GvIO(sv));
387     }
388     else if (isGV_with_GP(sv) && GvIO(sv))
389         pkg = SvSTASH(GvIO(sv));
390     else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
391         pkg = SvSTASH(GvIO(iogv));
392     else {
393         pkg = gv_stashsv(sv, 0);
394         if (!pkg)
395             pkg = gv_stashpvs("UNIVERSAL", 0);
396     }
397
398     if (pkg) {
399         GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
400         if (gv && isGV(gv))
401             rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
402     }
403
404     ST(0) = rv;
405     XSRETURN(1);
406 }
407
408 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
409 XS(XS_UNIVERSAL_DOES)
410 {
411     dXSARGS;
412     PERL_UNUSED_ARG(cv);
413
414     if (items != 2)
415         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
416     else {
417         SV * const sv = ST(0);
418         if (sv_does_sv( sv, ST(1), 0 ))
419             XSRETURN_YES;
420
421         XSRETURN_NO;
422     }
423 }
424
425 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
426 XS(XS_utf8_is_utf8)
427 {
428      dXSARGS;
429      if (items != 1)
430          croak_xs_usage(cv, "sv");
431      else {
432         SV * const sv = ST(0);
433         SvGETMAGIC(sv);
434             if (SvUTF8(sv))
435                 XSRETURN_YES;
436             else
437                 XSRETURN_NO;
438      }
439      XSRETURN_EMPTY;
440 }
441
442 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
443 XS(XS_utf8_valid)
444 {
445      dXSARGS;
446      if (items != 1)
447          croak_xs_usage(cv, "sv");
448     else {
449         SV * const sv = ST(0);
450         STRLEN len;
451         const char * const s = SvPV_const(sv,len);
452         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
453             XSRETURN_YES;
454         else
455             XSRETURN_NO;
456     }
457      XSRETURN_EMPTY;
458 }
459
460 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
461 XS(XS_utf8_encode)
462 {
463     dXSARGS;
464     if (items != 1)
465         croak_xs_usage(cv, "sv");
466     sv_utf8_encode(ST(0));
467     SvSETMAGIC(ST(0));
468     XSRETURN_EMPTY;
469 }
470
471 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
472 XS(XS_utf8_decode)
473 {
474     dXSARGS;
475     if (items != 1)
476         croak_xs_usage(cv, "sv");
477     else {
478         SV * const sv = ST(0);
479         bool RETVAL;
480         SvPV_force_nolen(sv);
481         RETVAL = sv_utf8_decode(sv);
482         SvSETMAGIC(sv);
483         ST(0) = boolSV(RETVAL);
484     }
485     XSRETURN(1);
486 }
487
488 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
489 XS(XS_utf8_upgrade)
490 {
491     dXSARGS;
492     if (items != 1)
493         croak_xs_usage(cv, "sv");
494     else {
495         SV * const sv = ST(0);
496         STRLEN  RETVAL;
497         dXSTARG;
498
499         RETVAL = sv_utf8_upgrade(sv);
500         XSprePUSH; PUSHi((IV)RETVAL);
501     }
502     XSRETURN(1);
503 }
504
505 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
506 XS(XS_utf8_downgrade)
507 {
508     dXSARGS;
509     if (items < 1 || items > 2)
510         croak_xs_usage(cv, "sv, failok=0");
511     else {
512         SV * const sv0 = ST(0);
513         SV * const sv1 = ST(1);
514         const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0;
515         const bool RETVAL = sv_utf8_downgrade(sv0, failok);
516
517         ST(0) = boolSV(RETVAL);
518     }
519     XSRETURN(1);
520 }
521
522 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
523 XS(XS_utf8_native_to_unicode)
524 {
525  dXSARGS;
526  const UV uv = SvUV(ST(0));
527
528  if (items > 1)
529      croak_xs_usage(cv, "sv");
530
531  ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
532  XSRETURN(1);
533 }
534
535 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
536 XS(XS_utf8_unicode_to_native)
537 {
538  dXSARGS;
539  const UV uv = SvUV(ST(0));
540
541  if (items > 1)
542      croak_xs_usage(cv, "sv");
543
544  ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
545  XSRETURN(1);
546 }
547
548 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
549 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
550 {
551     dXSARGS;
552     SV * const svz = ST(0);
553     SV * sv;
554
555     /* [perl #77776] - called as &foo() not foo() */
556     if (!SvROK(svz))
557         croak_xs_usage(cv, "SCALAR[, ON]");
558
559     sv = SvRV(svz);
560
561     if (items == 1) {
562          if (SvREADONLY(sv))
563              XSRETURN_YES;
564          else
565              XSRETURN_NO;
566     }
567     else if (items == 2) {
568         SV *sv1 = ST(1);
569         if (SvTRUE_NN(sv1)) {
570             SvFLAGS(sv) |= SVf_READONLY;
571             XSRETURN_YES;
572         }
573         else {
574             /* I hope you really know what you are doing. */
575             SvFLAGS(sv) &=~ SVf_READONLY;
576             XSRETURN_NO;
577         }
578     }
579     XSRETURN_UNDEF; /* Can't happen. */
580 }
581
582 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
583 XS(XS_constant__make_const)     /* This is dangerous stuff. */
584 {
585     dXSARGS;
586     SV * const svz = ST(0);
587     SV * sv;
588
589     /* [perl #77776] - called as &foo() not foo() */
590     if (!SvROK(svz) || items != 1)
591         croak_xs_usage(cv, "SCALAR");
592
593     sv = SvRV(svz);
594
595     SvREADONLY_on(sv);
596     if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
597         /* for constant.pm; nobody else should be calling this
598            on arrays anyway. */
599         SV **svp;
600         for (svp = AvARRAY(sv) + AvFILLp(sv)
601            ; svp >= AvARRAY(sv)
602            ; --svp)
603             if (*svp) SvPADTMP_on(*svp);
604     }
605     XSRETURN(0);
606 }
607
608 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
609 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
610 {
611     dXSARGS;
612     SV * const svz = ST(0);
613     SV * sv;
614     U32 refcnt;
615
616     /* [perl #77776] - called as &foo() not foo() */
617     if ((items != 1 && items != 2) || !SvROK(svz))
618         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
619
620     sv = SvRV(svz);
621
622          /* I hope you really know what you are doing. */
623     /* idea is for SvREFCNT(sv) to be accessed only once */
624     refcnt = items == 2 ?
625                 /* we free one ref on exit */
626                 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
627                 : SvREFCNT(sv);
628     XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */        
629
630 }
631
632 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
633 XS(XS_Internals_hv_clear_placehold)
634 {
635     dXSARGS;
636
637     if (items != 1 || !SvROK(ST(0)))
638         croak_xs_usage(cv, "hv");
639     else {
640         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
641         hv_clear_placeholders(hv);
642         XSRETURN(0);
643     }
644 }
645
646 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
647 XS(XS_PerlIO_get_layers)
648 {
649     dXSARGS;
650     if (items < 1 || items % 2 == 0)
651         croak_xs_usage(cv, "filehandle[,args]");
652 #if defined(USE_PERLIO)
653     {
654         SV *    sv;
655         GV *    gv;
656         IO *    io;
657         bool    input = TRUE;
658         bool    details = FALSE;
659
660         if (items > 1) {
661              SV * const *svp;
662              for (svp = MARK + 2; svp <= SP; svp += 2) {
663                   SV * const * const varp = svp;
664                   SV * const * const valp = svp + 1;
665                   STRLEN klen;
666                   const char * const key = SvPV_const(*varp, klen);
667
668                   switch (*key) {
669                   case 'i':
670                        if (memEQs(key, klen, "input")) {
671                             input = SvTRUE(*valp);
672                             break;
673                        }
674                        goto fail;
675                   case 'o': 
676                        if (memEQs(key, klen, "output")) {
677                             input = !SvTRUE(*valp);
678                             break;
679                        }
680                        goto fail;
681                   case 'd':
682                        if (memEQs(key, klen, "details")) {
683                             details = SvTRUE(*valp);
684                             break;
685                        }
686                        goto fail;
687                   default:
688                   fail:
689                        Perl_croak(aTHX_
690                                   "get_layers: unknown argument '%s'",
691                                   key);
692                   }
693              }
694
695              SP -= (items - 1);
696         }
697
698         sv = POPs;
699         gv = MAYBE_DEREF_GV(sv);
700
701         if (!gv && !SvROK(sv))
702             gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
703
704         if (gv && (io = GvIO(gv))) {
705              AV* const av = PerlIO_get_layers(aTHX_ input ?
706                                         IoIFP(io) : IoOFP(io));
707              SSize_t i;
708              const SSize_t last = av_tindex(av);
709              SSize_t nitem = 0;
710              
711              for (i = last; i >= 0; i -= 3) {
712                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
713                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
714                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
715
716                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
717                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
718                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
719
720                   EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
721                   if (details) {
722                       /* Indents of 5? Yuck.  */
723                       /* We know that PerlIO_get_layers creates a new SV for
724                          the name and flags, so we can just take a reference
725                          and "steal" it when we free the AV below.  */
726                        PUSHs(namok
727                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
728                               : &PL_sv_undef);
729                        PUSHs(argok
730                               ? newSVpvn_flags(SvPVX_const(*argsvp),
731                                                SvCUR(*argsvp),
732                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
733                                                | SVs_TEMP)
734                               : &PL_sv_undef);
735                        PUSHs(flgok
736                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
737                               : &PL_sv_undef);
738                        nitem += 3;
739                   }
740                   else {
741                        if (namok && argok)
742                             PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
743                                                  SVfARG(*namsvp),
744                                                  SVfARG(*argsvp))));
745                        else if (namok)
746                             PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
747                        else
748                             PUSHs(&PL_sv_undef);
749                        nitem++;
750                        if (flgok) {
751                             const IV flags = SvIVX(*flgsvp);
752
753                             if (flags & PERLIO_F_UTF8) {
754                                  PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
755                                  nitem++;
756                             }
757                        }
758                   }
759              }
760
761              SvREFCNT_dec(av);
762
763              XSRETURN(nitem);
764         }
765     }
766 #endif
767
768     XSRETURN(0);
769 }
770
771 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
772 XS(XS_re_is_regexp)
773 {
774     dXSARGS;
775
776     if (items != 1)
777         croak_xs_usage(cv, "sv");
778
779     if (SvRXOK(ST(0))) {
780         XSRETURN_YES;
781     } else {
782         XSRETURN_NO;
783     }
784 }
785
786 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
787 XS(XS_re_regnames_count)
788 {
789     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
790     SV * ret;
791     dXSARGS;
792
793     if (items != 0)
794         croak_xs_usage(cv, "");
795
796     if (!rx)
797         XSRETURN_UNDEF;
798
799     ret = CALLREG_NAMED_BUFF_COUNT(rx);
800
801     SPAGAIN;
802     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
803     XSRETURN(1);
804 }
805
806 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
807 XS(XS_re_regname)
808 {
809     dXSARGS;
810     REGEXP * rx;
811     U32 flags;
812     SV * ret;
813
814     if (items < 1 || items > 2)
815         croak_xs_usage(cv, "name[, all ]");
816
817     SP -= items;
818     PUTBACK;
819
820     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
821
822     if (!rx)
823         XSRETURN_UNDEF;
824
825     if (items == 2 && SvTRUE_NN(ST(1))) {
826         flags = RXapif_ALL;
827     } else {
828         flags = RXapif_ONE;
829     }
830     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
831
832     SPAGAIN;
833     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
834     XSRETURN(1);
835 }
836
837
838 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
839 XS(XS_re_regnames)
840 {
841     dXSARGS;
842     REGEXP * rx;
843     U32 flags;
844     SV *ret;
845     AV *av;
846     SSize_t length;
847     SSize_t i;
848     SV **entry;
849
850     if (items > 1)
851         croak_xs_usage(cv, "[all]");
852
853     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
854
855     if (!rx)
856         XSRETURN_UNDEF;
857
858     if (items == 1 && SvTRUE_NN(ST(0))) {
859         flags = RXapif_ALL;
860     } else {
861         flags = RXapif_ONE;
862     }
863
864     SP -= items;
865     PUTBACK;
866
867     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
868
869     SPAGAIN;
870
871     if (!ret)
872         XSRETURN_UNDEF;
873
874     av = MUTABLE_AV(SvRV(ret));
875     length = av_tindex(av);
876
877     EXTEND(SP, length+1); /* better extend stack just once */
878     for (i = 0; i <= length; i++) {
879         entry = av_fetch(av, i, FALSE);
880         
881         if (!entry)
882             Perl_croak(aTHX_ "NULL array element in re::regnames()");
883
884         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
885     }
886
887     SvREFCNT_dec(ret);
888
889     PUTBACK;
890     return;
891 }
892
893 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
894 XS(XS_re_regexp_pattern)
895 {
896     dXSARGS;
897     REGEXP *re;
898     U8 const gimme = GIMME_V;
899
900     EXTEND(SP, 2);
901     SP -= items;
902     if (items != 1)
903         croak_xs_usage(cv, "sv");
904
905     /*
906        Checks if a reference is a regex or not. If the parameter is
907        not a ref, or is not the result of a qr// then returns false
908        in scalar context and an empty list in list context.
909        Otherwise in list context it returns the pattern and the
910        modifiers, in scalar context it returns the pattern just as it
911        would if the qr// was stringified normally, regardless as
912        to the class of the variable and any stringification overloads
913        on the object.
914     */
915
916     if ((re = SvRX(ST(0)))) /* assign deliberate */
917     {
918         /* Houston, we have a regex! */
919         SV *pattern;
920
921         if ( gimme == G_ARRAY ) {
922             STRLEN left = 0;
923             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
924             const char *fptr;
925             char ch;
926             U16 match_flags;
927
928             /*
929                we are in list context so stringify
930                the modifiers that apply. We ignore "negative
931                modifiers" in this scenario, and the default character set
932             */
933
934             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
935                 STRLEN len;
936                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
937                                                                 &len);
938                 Copy(name, reflags + left, len, char);
939                 left += len;
940             }
941             fptr = INT_PAT_MODS;
942             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
943                                     >> RXf_PMf_STD_PMMOD_SHIFT);
944
945             while((ch = *fptr++)) {
946                 if(match_flags & 1) {
947                     reflags[left++] = ch;
948                 }
949                 match_flags >>= 1;
950             }
951
952             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
953                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
954
955             /* return the pattern and the modifiers */
956             PUSHs(pattern);
957             PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
958             XSRETURN(2);
959         } else {
960             /* Scalar, so use the string that Perl would return */
961             /* return the pattern in (?msixn:..) format */
962             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
963             PUSHs(pattern);
964             XSRETURN(1);
965         }
966     } else {
967         /* It ain't a regexp folks */
968         if ( gimme == G_ARRAY ) {
969             /* return the empty list */
970             XSRETURN_EMPTY;
971         } else {
972             /* Because of the (?:..) wrapping involved in a
973                stringified pattern it is impossible to get a
974                result for a real regexp that would evaluate to
975                false. Therefore we can return PL_sv_no to signify
976                that the object is not a regex, this means that one
977                can say
978
979                  if (regex($might_be_a_regex) eq '(?:foo)') { }
980
981                and not worry about undefined values.
982             */
983             XSRETURN_NO;
984         }
985     }
986     NOT_REACHED; /* NOTREACHED */
987 }
988
989 #include "vutil.h"
990 #include "vxs.inc"
991
992 struct xsub_details {
993     const char *name;
994     XSUBADDR_t xsub;
995     const char *proto;
996 };
997
998 static const struct xsub_details details[] = {
999     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1000     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1001     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1002 #define VXS_XSUB_DETAILS
1003 #include "vxs.inc"
1004 #undef VXS_XSUB_DETAILS
1005     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1006     {"utf8::valid", XS_utf8_valid, NULL},
1007     {"utf8::encode", XS_utf8_encode, NULL},
1008     {"utf8::decode", XS_utf8_decode, NULL},
1009     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1010     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1011     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1012     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1013     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1014     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1015     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1016     {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
1017     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1018     {"re::is_regexp", XS_re_is_regexp, "$"},
1019     {"re::regname", XS_re_regname, ";$$"},
1020     {"re::regnames", XS_re_regnames, ";$"},
1021     {"re::regnames_count", XS_re_regnames_count, ""},
1022     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1023 };
1024
1025 STATIC OP*
1026 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1027                                            GV* namegv,
1028                                            SV* protosv)
1029 {
1030     /* Optimizes out an identity function, i.e., one that just returns its
1031      * argument.  The passed in function is assumed to be an identity function,
1032      * with no checking.  This is designed to be called for utf8_to_native()
1033      * and native_to_utf8() on ASCII platforms, as they just return their
1034      * arguments, but it could work on any such function.
1035      *
1036      * The code is mostly just cargo-culted from Memoize::Lift */
1037
1038     OP *pushop, *argop;
1039     OP *parent;
1040     SV* prototype = newSVpvs("$");
1041
1042     PERL_UNUSED_ARG(protosv);
1043
1044     assert(entersubop->op_type == OP_ENTERSUB);
1045
1046     entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1047     parent = entersubop;
1048
1049     SvREFCNT_dec(prototype);
1050
1051     pushop = cUNOPx(entersubop)->op_first;
1052     if (! OpHAS_SIBLING(pushop)) {
1053         parent = pushop;
1054         pushop = cUNOPx(pushop)->op_first;
1055     }
1056     argop = OpSIBLING(pushop);
1057
1058     /* Carry on without doing the optimization if it is not something we're
1059      * expecting, so continues to work */
1060     if (   ! argop
1061         || ! OpHAS_SIBLING(argop)
1062         ||   OpHAS_SIBLING(OpSIBLING(argop))
1063     ) {
1064         return entersubop;
1065     }
1066
1067     /* cut argop from the subtree */
1068     (void)op_sibling_splice(parent, pushop, 1, NULL);
1069
1070     op_free(entersubop);
1071     return argop;
1072 }
1073
1074 void
1075 Perl_boot_core_UNIVERSAL(pTHX)
1076 {
1077     static const char file[] = __FILE__;
1078     const struct xsub_details *xsub = details;
1079     const struct xsub_details *end = C_ARRAY_END(details);
1080
1081     do {
1082         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1083     } while (++xsub < end);
1084
1085 #ifndef EBCDIC
1086     { /* On ASCII platforms these functions just return their argument, so can
1087          be optimized away */
1088
1089         CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1090         CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1091
1092         cv_set_call_checker_flags(to_native_cv,
1093                             optimize_out_native_convert_function,
1094                             (SV*) to_native_cv, 0);
1095         cv_set_call_checker_flags(to_unicode_cv,
1096                             optimize_out_native_convert_function,
1097                             (SV*) to_unicode_cv, 0);
1098     }
1099 #endif
1100
1101     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1102     {
1103         CV * const cv =
1104             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1105         char ** cvfile = &CvFILE(cv);
1106         char * oldfile = *cvfile;
1107         CvDYNFILE_off(cv);
1108         *cvfile = (char *)file;
1109         Safefree(oldfile);
1110     }
1111 }
1112
1113 /*
1114  * ex: set ts=8 sts=4 sw=4 et:
1115  */