utf8.c: Generalize static fcn return for indeterminate result
[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( 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 sv = ST(0);
513         const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
514         const bool RETVAL = sv_utf8_downgrade(sv, failok);
515
516         ST(0) = boolSV(RETVAL);
517     }
518     XSRETURN(1);
519 }
520
521 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
522 XS(XS_utf8_native_to_unicode)
523 {
524  dXSARGS;
525  const UV uv = SvUV(ST(0));
526
527  if (items > 1)
528      croak_xs_usage(cv, "sv");
529
530  ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
531  XSRETURN(1);
532 }
533
534 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
535 XS(XS_utf8_unicode_to_native)
536 {
537  dXSARGS;
538  const UV uv = SvUV(ST(0));
539
540  if (items > 1)
541      croak_xs_usage(cv, "sv");
542
543  ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
544  XSRETURN(1);
545 }
546
547 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
548 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
549 {
550     dXSARGS;
551     SV * const svz = ST(0);
552     SV * sv;
553
554     /* [perl #77776] - called as &foo() not foo() */
555     if (!SvROK(svz))
556         croak_xs_usage(cv, "SCALAR[, ON]");
557
558     sv = SvRV(svz);
559
560     if (items == 1) {
561          if (SvREADONLY(sv))
562              XSRETURN_YES;
563          else
564              XSRETURN_NO;
565     }
566     else if (items == 2) {
567         if (SvTRUE(ST(1))) {
568             SvFLAGS(sv) |= SVf_READONLY;
569             XSRETURN_YES;
570         }
571         else {
572             /* I hope you really know what you are doing. */
573             SvFLAGS(sv) &=~ SVf_READONLY;
574             XSRETURN_NO;
575         }
576     }
577     XSRETURN_UNDEF; /* Can't happen. */
578 }
579
580 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
581 XS(XS_constant__make_const)     /* This is dangerous stuff. */
582 {
583     dXSARGS;
584     SV * const svz = ST(0);
585     SV * sv;
586
587     /* [perl #77776] - called as &foo() not foo() */
588     if (!SvROK(svz) || items != 1)
589         croak_xs_usage(cv, "SCALAR");
590
591     sv = SvRV(svz);
592
593     SvREADONLY_on(sv);
594     if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
595         /* for constant.pm; nobody else should be calling this
596            on arrays anyway. */
597         SV **svp;
598         for (svp = AvARRAY(sv) + AvFILLp(sv)
599            ; svp >= AvARRAY(sv)
600            ; --svp)
601             if (*svp) SvPADTMP_on(*svp);
602     }
603     XSRETURN(0);
604 }
605
606 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
607 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
608 {
609     dXSARGS;
610     SV * const svz = ST(0);
611     SV * sv;
612     U32 refcnt;
613
614     /* [perl #77776] - called as &foo() not foo() */
615     if ((items != 1 && items != 2) || !SvROK(svz))
616         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
617
618     sv = SvRV(svz);
619
620          /* I hope you really know what you are doing. */
621     /* idea is for SvREFCNT(sv) to be accessed only once */
622     refcnt = items == 2 ?
623                 /* we free one ref on exit */
624                 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
625                 : SvREFCNT(sv);
626     XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */        
627
628 }
629
630 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
631 XS(XS_Internals_hv_clear_placehold)
632 {
633     dXSARGS;
634
635     if (items != 1 || !SvROK(ST(0)))
636         croak_xs_usage(cv, "hv");
637     else {
638         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
639         hv_clear_placeholders(hv);
640         XSRETURN(0);
641     }
642 }
643
644 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
645 XS(XS_PerlIO_get_layers)
646 {
647     dXSARGS;
648     if (items < 1 || items % 2 == 0)
649         croak_xs_usage(cv, "filehandle[,args]");
650 #if defined(USE_PERLIO)
651     {
652         SV *    sv;
653         GV *    gv;
654         IO *    io;
655         bool    input = TRUE;
656         bool    details = FALSE;
657
658         if (items > 1) {
659              SV * const *svp;
660              for (svp = MARK + 2; svp <= SP; svp += 2) {
661                   SV * const * const varp = svp;
662                   SV * const * const valp = svp + 1;
663                   STRLEN klen;
664                   const char * const key = SvPV_const(*varp, klen);
665
666                   switch (*key) {
667                   case 'i':
668                        if (memEQs(key, klen, "input")) {
669                             input = SvTRUE(*valp);
670                             break;
671                        }
672                        goto fail;
673                   case 'o': 
674                        if (memEQs(key, klen, "output")) {
675                             input = !SvTRUE(*valp);
676                             break;
677                        }
678                        goto fail;
679                   case 'd':
680                        if (memEQs(key, klen, "details")) {
681                             details = SvTRUE(*valp);
682                             break;
683                        }
684                        goto fail;
685                   default:
686                   fail:
687                        Perl_croak(aTHX_
688                                   "get_layers: unknown argument '%s'",
689                                   key);
690                   }
691              }
692
693              SP -= (items - 1);
694         }
695
696         sv = POPs;
697         gv = MAYBE_DEREF_GV(sv);
698
699         if (!gv && !SvROK(sv))
700             gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
701
702         if (gv && (io = GvIO(gv))) {
703              AV* const av = PerlIO_get_layers(aTHX_ input ?
704                                         IoIFP(io) : IoOFP(io));
705              SSize_t i;
706              const SSize_t last = av_tindex(av);
707              SSize_t nitem = 0;
708              
709              for (i = last; i >= 0; i -= 3) {
710                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
711                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
712                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
713
714                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
715                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
716                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
717
718                   EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
719                   if (details) {
720                       /* Indents of 5? Yuck.  */
721                       /* We know that PerlIO_get_layers creates a new SV for
722                          the name and flags, so we can just take a reference
723                          and "steal" it when we free the AV below.  */
724                        PUSHs(namok
725                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
726                               : &PL_sv_undef);
727                        PUSHs(argok
728                               ? newSVpvn_flags(SvPVX_const(*argsvp),
729                                                SvCUR(*argsvp),
730                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
731                                                | SVs_TEMP)
732                               : &PL_sv_undef);
733                        PUSHs(flgok
734                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
735                               : &PL_sv_undef);
736                        nitem += 3;
737                   }
738                   else {
739                        if (namok && argok)
740                             PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
741                                                  SVfARG(*namsvp),
742                                                  SVfARG(*argsvp))));
743                        else if (namok)
744                             PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
745                        else
746                             PUSHs(&PL_sv_undef);
747                        nitem++;
748                        if (flgok) {
749                             const IV flags = SvIVX(*flgsvp);
750
751                             if (flags & PERLIO_F_UTF8) {
752                                  PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
753                                  nitem++;
754                             }
755                        }
756                   }
757              }
758
759              SvREFCNT_dec(av);
760
761              XSRETURN(nitem);
762         }
763     }
764 #endif
765
766     XSRETURN(0);
767 }
768
769 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
770 XS(XS_re_is_regexp)
771 {
772     dXSARGS;
773
774     if (items != 1)
775         croak_xs_usage(cv, "sv");
776
777     if (SvRXOK(ST(0))) {
778         XSRETURN_YES;
779     } else {
780         XSRETURN_NO;
781     }
782 }
783
784 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
785 XS(XS_re_regnames_count)
786 {
787     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
788     SV * ret;
789     dXSARGS;
790
791     if (items != 0)
792         croak_xs_usage(cv, "");
793
794     if (!rx)
795         XSRETURN_UNDEF;
796
797     ret = CALLREG_NAMED_BUFF_COUNT(rx);
798
799     SPAGAIN;
800     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
801     XSRETURN(1);
802 }
803
804 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
805 XS(XS_re_regname)
806 {
807     dXSARGS;
808     REGEXP * rx;
809     U32 flags;
810     SV * ret;
811
812     if (items < 1 || items > 2)
813         croak_xs_usage(cv, "name[, all ]");
814
815     SP -= items;
816     PUTBACK;
817
818     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
819
820     if (!rx)
821         XSRETURN_UNDEF;
822
823     if (items == 2 && SvTRUE(ST(1))) {
824         flags = RXapif_ALL;
825     } else {
826         flags = RXapif_ONE;
827     }
828     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
829
830     SPAGAIN;
831     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
832     XSRETURN(1);
833 }
834
835
836 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
837 XS(XS_re_regnames)
838 {
839     dXSARGS;
840     REGEXP * rx;
841     U32 flags;
842     SV *ret;
843     AV *av;
844     SSize_t length;
845     SSize_t i;
846     SV **entry;
847
848     if (items > 1)
849         croak_xs_usage(cv, "[all]");
850
851     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
852
853     if (!rx)
854         XSRETURN_UNDEF;
855
856     if (items == 1 && SvTRUE(ST(0))) {
857         flags = RXapif_ALL;
858     } else {
859         flags = RXapif_ONE;
860     }
861
862     SP -= items;
863     PUTBACK;
864
865     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
866
867     SPAGAIN;
868
869     if (!ret)
870         XSRETURN_UNDEF;
871
872     av = MUTABLE_AV(SvRV(ret));
873     length = av_tindex(av);
874
875     EXTEND(SP, length+1); /* better extend stack just once */
876     for (i = 0; i <= length; i++) {
877         entry = av_fetch(av, i, FALSE);
878         
879         if (!entry)
880             Perl_croak(aTHX_ "NULL array element in re::regnames()");
881
882         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
883     }
884
885     SvREFCNT_dec(ret);
886
887     PUTBACK;
888     return;
889 }
890
891 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
892 XS(XS_re_regexp_pattern)
893 {
894     dXSARGS;
895     REGEXP *re;
896     U8 const gimme = GIMME_V;
897
898     EXTEND(SP, 2);
899     SP -= items;
900     if (items != 1)
901         croak_xs_usage(cv, "sv");
902
903     /*
904        Checks if a reference is a regex or not. If the parameter is
905        not a ref, or is not the result of a qr// then returns false
906        in scalar context and an empty list in list context.
907        Otherwise in list context it returns the pattern and the
908        modifiers, in scalar context it returns the pattern just as it
909        would if the qr// was stringified normally, regardless as
910        to the class of the variable and any stringification overloads
911        on the object.
912     */
913
914     if ((re = SvRX(ST(0)))) /* assign deliberate */
915     {
916         /* Houston, we have a regex! */
917         SV *pattern;
918
919         if ( gimme == G_ARRAY ) {
920             STRLEN left = 0;
921             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
922             const char *fptr;
923             char ch;
924             U16 match_flags;
925
926             /*
927                we are in list context so stringify
928                the modifiers that apply. We ignore "negative
929                modifiers" in this scenario, and the default character set
930             */
931
932             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
933                 STRLEN len;
934                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
935                                                                 &len);
936                 Copy(name, reflags + left, len, char);
937                 left += len;
938             }
939             fptr = INT_PAT_MODS;
940             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
941                                     >> RXf_PMf_STD_PMMOD_SHIFT);
942
943             while((ch = *fptr++)) {
944                 if(match_flags & 1) {
945                     reflags[left++] = ch;
946                 }
947                 match_flags >>= 1;
948             }
949
950             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
951                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
952
953             /* return the pattern and the modifiers */
954             PUSHs(pattern);
955             PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
956             XSRETURN(2);
957         } else {
958             /* Scalar, so use the string that Perl would return */
959             /* return the pattern in (?msixn:..) format */
960             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
961             PUSHs(pattern);
962             XSRETURN(1);
963         }
964     } else {
965         /* It ain't a regexp folks */
966         if ( gimme == G_ARRAY ) {
967             /* return the empty list */
968             XSRETURN_EMPTY;
969         } else {
970             /* Because of the (?:..) wrapping involved in a
971                stringified pattern it is impossible to get a
972                result for a real regexp that would evaluate to
973                false. Therefore we can return PL_sv_no to signify
974                that the object is not a regex, this means that one
975                can say
976
977                  if (regex($might_be_a_regex) eq '(?:foo)') { }
978
979                and not worry about undefined values.
980             */
981             XSRETURN_NO;
982         }
983     }
984     NOT_REACHED; /* NOTREACHED */
985 }
986
987 #include "vutil.h"
988 #include "vxs.inc"
989
990 struct xsub_details {
991     const char *name;
992     XSUBADDR_t xsub;
993     const char *proto;
994 };
995
996 static const struct xsub_details details[] = {
997     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
998     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
999     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1000 #define VXS_XSUB_DETAILS
1001 #include "vxs.inc"
1002 #undef VXS_XSUB_DETAILS
1003     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1004     {"utf8::valid", XS_utf8_valid, NULL},
1005     {"utf8::encode", XS_utf8_encode, NULL},
1006     {"utf8::decode", XS_utf8_decode, NULL},
1007     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1008     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1009     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1010     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1011     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1012     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1013     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1014     {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
1015     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1016     {"re::is_regexp", XS_re_is_regexp, "$"},
1017     {"re::regname", XS_re_regname, ";$$"},
1018     {"re::regnames", XS_re_regnames, ";$"},
1019     {"re::regnames_count", XS_re_regnames_count, ""},
1020     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1021 };
1022
1023 STATIC OP*
1024 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1025                                            GV* namegv,
1026                                            SV* protosv)
1027 {
1028     /* Optimizes out an identity function, i.e., one that just returns its
1029      * argument.  The passed in function is assumed to be an identity function,
1030      * with no checking.  This is designed to be called for utf8_to_native()
1031      * and native_to_utf8() on ASCII platforms, as they just return their
1032      * arguments, but it could work on any such function.
1033      *
1034      * The code is mostly just cargo-culted from Memoize::Lift */
1035
1036     OP *pushop, *argop;
1037     OP *parent;
1038     SV* prototype = newSVpvs("$");
1039
1040     PERL_UNUSED_ARG(protosv);
1041
1042     assert(entersubop->op_type == OP_ENTERSUB);
1043
1044     entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1045     parent = entersubop;
1046
1047     SvREFCNT_dec(prototype);
1048
1049     pushop = cUNOPx(entersubop)->op_first;
1050     if (! OpHAS_SIBLING(pushop)) {
1051         parent = pushop;
1052         pushop = cUNOPx(pushop)->op_first;
1053     }
1054     argop = OpSIBLING(pushop);
1055
1056     /* Carry on without doing the optimization if it is not something we're
1057      * expecting, so continues to work */
1058     if (   ! argop
1059         || ! OpHAS_SIBLING(argop)
1060         ||   OpHAS_SIBLING(OpSIBLING(argop))
1061     ) {
1062         return entersubop;
1063     }
1064
1065     /* cut argop from the subtree */
1066     (void)op_sibling_splice(parent, pushop, 1, NULL);
1067
1068     op_free(entersubop);
1069     return argop;
1070 }
1071
1072 void
1073 Perl_boot_core_UNIVERSAL(pTHX)
1074 {
1075     static const char file[] = __FILE__;
1076     const struct xsub_details *xsub = details;
1077     const struct xsub_details *end = C_ARRAY_END(details);
1078
1079     do {
1080         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1081     } while (++xsub < end);
1082
1083 #ifndef EBCDIC
1084     { /* On ASCII platforms these functions just return their argument, so can
1085          be optimized away */
1086
1087         CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1088         CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1089
1090         cv_set_call_checker(to_native_cv,
1091                             optimize_out_native_convert_function,
1092                             (SV*) to_native_cv);
1093         cv_set_call_checker(to_unicode_cv,
1094                             optimize_out_native_convert_function,
1095                             (SV*) to_unicode_cv);
1096     }
1097 #endif
1098
1099     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1100     {
1101         CV * const cv =
1102             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1103         char ** cvfile = &CvFILE(cv);
1104         char * oldfile = *cvfile;
1105         CvDYNFILE_off(cv);
1106         *cvfile = (char *)file;
1107         Safefree(oldfile);
1108     }
1109 }
1110
1111 /*
1112  * ex: set ts=8 sts=4 sw=4 et:
1113  */