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