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