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