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