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