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