This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
move the implementation of %-, %+ into core
[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 XS(XS_NamedCapture_tie_it)
1023 {
1024     dXSARGS;
1025
1026     if (items != 1)
1027         croak_xs_usage(cv,  "sv");
1028     {
1029         SV *sv = ST(0);
1030         GV * const gv = (GV *)sv;
1031         HV * const hv = GvHVn(gv);
1032         SV *rv = newSV_type(SVt_IV);
1033         const char *gv_name = GvNAME(gv);
1034
1035         SvRV_set(rv, newSVuv(
1036             strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
1037             ? RXapif_ALL : RXapif_ONE));
1038         SvROK_on(rv);
1039         sv_bless(rv, GvSTASH(CvGV(cv)));
1040
1041         sv_unmagic((SV *)hv, PERL_MAGIC_tied);
1042         sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
1043         SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
1044     }
1045     XSRETURN_EMPTY;
1046 }
1047
1048 XS(XS_NamedCapture_TIEHASH)
1049 {
1050     dVAR; dXSARGS;
1051     if (items < 1)
1052        croak_xs_usage(cv,  "package, ...");
1053     {
1054         const char *    package = (const char *)SvPV_nolen(ST(0));
1055         UV flag = RXapif_ONE;
1056         mark += 2;
1057         while(mark < sp) {
1058             STRLEN len;
1059             const char *p = SvPV_const(*mark, len);
1060             if(memEQs(p, len, "all"))
1061                 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
1062             mark += 2;
1063         }
1064         ST(0) = sv_2mortal(newSV_type(SVt_IV));
1065         sv_setuv(newSVrv(ST(0), package), flag);
1066     }
1067     XSRETURN(1);
1068 }
1069
1070 /* These are tightly coupled to the RXapif_* flags defined in regexp.h  */
1071 #define UNDEF_FATAL  0x80000
1072 #define DISCARD      0x40000
1073 #define EXPECT_SHIFT 24
1074 #define ACTION_MASK  0x000FF
1075
1076 #define FETCH_ALIAS  (RXapif_FETCH  | (2 << EXPECT_SHIFT))
1077 #define STORE_ALIAS  (RXapif_STORE  | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1078 #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
1079 #define CLEAR_ALIAS  (RXapif_CLEAR  | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1080 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
1081 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
1082
1083 XS(XS_NamedCapture_FETCH)
1084 {
1085     dVAR; dXSARGS;
1086     dXSI32;
1087     PERL_UNUSED_VAR(cv); /* -W */
1088     PERL_UNUSED_VAR(ax); /* -Wall */
1089     SP -= items;
1090     {
1091         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1092         U32 flags;
1093         SV *ret;
1094         const U32 action = ix & ACTION_MASK;
1095         const int expect = ix >> EXPECT_SHIFT;
1096         if (items != expect)
1097             croak_xs_usage(cv, expect == 2 ? "$key"
1098                                            : (expect == 3 ? "$key, $value"
1099                                                           : ""));
1100
1101         if (!rx || !SvROK(ST(0))) {
1102             if (ix & UNDEF_FATAL)
1103                 Perl_croak_no_modify();
1104             else
1105                 XSRETURN_UNDEF;
1106         }
1107
1108         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1109
1110         PUTBACK;
1111         ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
1112                                     expect >= 3 ? ST(2) : NULL, flags | action);
1113         SPAGAIN;
1114
1115         if (ix & DISCARD) {
1116             /* Called with G_DISCARD, so our return stack state is thrown away.
1117                Hence if we were returned anything, free it immediately.  */
1118             SvREFCNT_dec(ret);
1119         } else {
1120             PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1121         }
1122         PUTBACK;
1123         return;
1124     }
1125 }
1126
1127
1128 XS(XS_NamedCapture_FIRSTKEY)
1129 {
1130     dVAR; dXSARGS;
1131     dXSI32;
1132     PERL_UNUSED_VAR(cv); /* -W */
1133     PERL_UNUSED_VAR(ax); /* -Wall */
1134     SP -= items;
1135     {
1136         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1137         U32 flags;
1138         SV *ret;
1139         const int expect = ix ? 2 : 1;
1140         const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
1141         if (items != expect)
1142             croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
1143
1144         if (!rx || !SvROK(ST(0)))
1145             XSRETURN_UNDEF;
1146
1147         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1148
1149         PUTBACK;
1150         ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
1151                                              expect >= 2 ? ST(1) : NULL,
1152                                              flags | action);
1153         SPAGAIN;
1154
1155         PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1156         PUTBACK;
1157         return;
1158     }
1159 }
1160
1161 /* is this still needed? */
1162 XS(XS_NamedCapture_flags)
1163 {
1164     dVAR; dXSARGS;
1165     PERL_UNUSED_VAR(cv); /* -W */
1166     PERL_UNUSED_VAR(ax); /* -Wall */
1167     SP -= items;
1168     {
1169         EXTEND(SP, 2);
1170         mPUSHu(RXapif_ONE);
1171         mPUSHu(RXapif_ALL);
1172         PUTBACK;
1173         return;
1174     }
1175 }
1176
1177 #include "vutil.h"
1178 #include "vxs.inc"
1179
1180 struct xsub_details {
1181     const char *name;
1182     XSUBADDR_t xsub;
1183     const char *proto;
1184     int ix;
1185 };
1186
1187 static const struct xsub_details these_details[] = {
1188     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
1189     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
1190     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 },
1191 #define VXS_XSUB_DETAILS
1192 #include "vxs.inc"
1193 #undef VXS_XSUB_DETAILS
1194     {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 },
1195     {"utf8::valid", XS_utf8_valid, NULL, 0 },
1196     {"utf8::encode", XS_utf8_encode, NULL, 0 },
1197     {"utf8::decode", XS_utf8_decode, NULL, 0 },
1198     {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 },
1199     {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 },
1200     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 },
1201     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 },
1202     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 },
1203     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 },
1204     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 },
1205     {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 },
1206     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 },
1207     {"re::is_regexp", XS_re_is_regexp, "$", 0 },
1208     {"re::regname", XS_re_regname, ";$$", 0 },
1209     {"re::regnames", XS_re_regnames, ";$", 0 },
1210     {"re::regnames_count", XS_re_regnames_count, "", 0 },
1211     {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 },
1212 #ifdef HAS_GETCWD
1213     {"Internals::getcwd", XS_Internals_getcwd, "", 0 },
1214 #endif
1215     {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
1216     {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },
1217     {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS },
1218     {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS },
1219     {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS },
1220     {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS },
1221     {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS },
1222     {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS },
1223     {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 },
1224     {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 },
1225     {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 },
1226 };
1227
1228 STATIC OP*
1229 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1230                                            GV* namegv,
1231                                            SV* protosv)
1232 {
1233     /* Optimizes out an identity function, i.e., one that just returns its
1234      * argument.  The passed in function is assumed to be an identity function,
1235      * with no checking.  This is designed to be called for utf8_to_native()
1236      * and native_to_utf8() on ASCII platforms, as they just return their
1237      * arguments, but it could work on any such function.
1238      *
1239      * The code is mostly just cargo-culted from Memoize::Lift */
1240
1241     OP *pushop, *argop;
1242     OP *parent;
1243     SV* prototype = newSVpvs("$");
1244
1245     PERL_UNUSED_ARG(protosv);
1246
1247     assert(entersubop->op_type == OP_ENTERSUB);
1248
1249     entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1250     parent = entersubop;
1251
1252     SvREFCNT_dec(prototype);
1253
1254     pushop = cUNOPx(entersubop)->op_first;
1255     if (! OpHAS_SIBLING(pushop)) {
1256         parent = pushop;
1257         pushop = cUNOPx(pushop)->op_first;
1258     }
1259     argop = OpSIBLING(pushop);
1260
1261     /* Carry on without doing the optimization if it is not something we're
1262      * expecting, so continues to work */
1263     if (   ! argop
1264         || ! OpHAS_SIBLING(argop)
1265         ||   OpHAS_SIBLING(OpSIBLING(argop))
1266     ) {
1267         return entersubop;
1268     }
1269
1270     /* cut argop from the subtree */
1271     (void)op_sibling_splice(parent, pushop, 1, NULL);
1272
1273     op_free(entersubop);
1274     return argop;
1275 }
1276
1277 void
1278 Perl_boot_core_UNIVERSAL(pTHX)
1279 {
1280     static const char file[] = __FILE__;
1281     const struct xsub_details *xsub = these_details;
1282     const struct xsub_details *end = C_ARRAY_END(these_details);
1283
1284     do {
1285         CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1286         XSANY.any_i32 = xsub->ix;
1287     } while (++xsub < end);
1288
1289 #ifndef EBCDIC
1290     { /* On ASCII platforms these functions just return their argument, so can
1291          be optimized away */
1292
1293         CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1294         CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1295
1296         cv_set_call_checker_flags(to_native_cv,
1297                             optimize_out_native_convert_function,
1298                             (SV*) to_native_cv, 0);
1299         cv_set_call_checker_flags(to_unicode_cv,
1300                             optimize_out_native_convert_function,
1301                             (SV*) to_unicode_cv, 0);
1302     }
1303 #endif
1304
1305     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1306     {
1307         CV * const cv =
1308             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1309         char ** cvfile = &CvFILE(cv);
1310         char * oldfile = *cvfile;
1311         CvDYNFILE_off(cv);
1312         *cvfile = (char *)file;
1313         Safefree(oldfile);
1314     }
1315 }
1316
1317 /*
1318  * ex: set ts=8 sts=4 sw=4 et:
1319  */