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