3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 * 2005, 2006, 2007, 2008 by Larry Wall and others
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.
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
16 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
19 /* This file contains the code that implements the functions in Perl's
20 * UNIVERSAL package, such as UNIVERSAL->can().
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.
29 #define PERL_IN_UNIVERSAL_C
33 #include "perliol.h" /* For the PERLIO_F_XXX */
37 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
38 * The main guts of traverse_isa was actually copied from gv_fetchmeth
42 S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
45 const struct mro_meta *const meta = HvMROMETA(stash);
49 PERL_ARGS_ASSERT_ISA_LOOKUP;
52 (void)mro_get_linear_isa(stash);
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. */
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);
68 HEK *canon_name = HvENAME_HEK(our_stash);
69 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
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))) {
82 =head1 SV Manipulation Functions
84 =for apidoc sv_derived_from_pvn
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
90 Currently, the only significant value for C<flags> is SVf_UTF8.
94 =for apidoc sv_derived_from_sv
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.
104 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
108 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
109 namepv = SvPV(namesv, namelen);
112 return sv_derived_from_pvn(sv, namepv, namelen, flags);
116 =for apidoc sv_derived_from
118 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
124 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
126 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
127 return sv_derived_from_pvn(sv, name, strlen(name), 0);
131 =for apidoc sv_derived_from_pv
133 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
134 instead of a string/length pair.
141 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
143 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
144 return sv_derived_from_pvn(sv, name, strlen(name), flags);
148 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
153 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
160 type = sv_reftype(sv,0);
161 if (type && strEQ(type,name))
168 stash = gv_stashsv(sv, 0);
171 if (stash && isa_lookup(stash, name, len, flags))
174 stash = gv_stashpvs("UNIVERSAL", 0);
175 return stash && isa_lookup(stash, name, len, flags);
179 =for apidoc sv_does_sv
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.
190 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
197 PERL_ARGS_ASSERT_SV_DOES_SV;
198 PERL_UNUSED_ARG(flags);
205 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
210 if (sv_isobject(sv)) {
211 classname = sv_ref(NULL,SvRV(sv),TRUE);
216 if (sv_eq(classname, namesv)) {
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);
235 does_it = SvTRUE( TOPs );
245 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
251 Perl_sv_does(pTHX_ SV *sv, const char *const name)
253 PERL_ARGS_ASSERT_SV_DOES;
254 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
258 =for apidoc sv_does_pv
260 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
267 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
269 PERL_ARGS_ASSERT_SV_DOES_PV;
270 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
274 =for apidoc sv_does_pvn
276 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
282 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
284 PERL_ARGS_ASSERT_SV_DOES_PVN;
286 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
290 =for apidoc croak_xs_usage
292 A specialised variant of C<croak()> for emitting the usage message for xsubs
294 croak_xs_usage(cv, "eee_yow");
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:
299 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
305 Perl_croak_xs_usage(const CV *const cv, const char *const params)
307 const GV *const gv = CvGV(cv);
309 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
312 const HV *const stash = GvSTASH(gv);
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)),
321 /* diag_listed_as: SKIPME */
322 Perl_croak_nocontext("Usage: %"HEKf"(%s)",
323 HEKfARG(GvNAME_HEK(gv)), params);
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);
337 croak_xs_usage(cv, "reference, kind");
339 SV * const sv = ST(0);
343 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
346 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
361 croak_xs_usage(cv, "object-ref, method");
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)))
376 sv = MUTABLE_SV(SvRV(sv));
379 else if (isGV_with_GP(sv) && GvIO(sv))
380 pkg = SvSTASH(GvIO(sv));
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));
387 pkg = gv_stashsv(sv, 0);
389 pkg = gv_stashpv("UNIVERSAL", 0);
393 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
395 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
402 XS(XS_UNIVERSAL_DOES)
409 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
411 SV * const sv = ST(0);
412 if (sv_does_sv( sv, ST(1), 0 ))
419 XS(XS_UNIVERSAL_VERSION)
431 sv = MUTABLE_SV(SvRV(ST(0)));
433 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
437 pkg = gv_stashsv(ST(0), 0);
440 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
442 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
443 SV * const nsv = sv_newmortal();
446 if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
447 upg_version(sv, FALSE);
461 const HEK * const name = HvNAME_HEK(pkg);
463 "%"HEKf" does not define $%"HEKf
464 "::VERSION--version check failed",
465 HEKfARG(name), HEKfARG(name));
468 "%"SVf" defines neither package nor VERSION--version check failed",
473 if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
474 /* req may very well be R/O, so create a new object */
475 req = sv_2mortal( new_version(req) );
478 if ( vcmp( req, sv ) > 0 ) {
479 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
480 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
481 "this is only version %"SVf"",
482 HEKfARG(HvNAME_HEK(pkg)),
483 SVfARG(sv_2mortal(vnormal(req))),
484 SVfARG(sv_2mortal(vnormal(sv))));
486 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
487 "this is only version %"SVf,
488 HEKfARG(HvNAME_HEK(pkg)),
489 SVfARG(sv_2mortal(vstringify(req))),
490 SVfARG(sv_2mortal(vstringify(sv))));
496 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
497 ST(0) = sv_2mortal(vstringify(sv));
509 if (items > 3 || items < 1)
510 croak_xs_usage(cv, "class, version");
516 const char *classname;
519 /* Just in case this is something like a tied hash */
522 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
523 const HV * stash = SvSTASH(SvRV(ST(0)));
524 classname = HvNAME(stash);
525 len = HvNAMELEN(stash);
526 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
529 classname = SvPV(ST(0), len);
530 flags = SvUTF8(ST(0));
533 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
534 /* create empty object */
538 else if ( items == 3 ) {
540 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
543 rv = new_version(vs);
544 if ( strnNE(classname,"version", len) ) /* inherited new() */
545 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
553 XS(XS_version_stringify)
558 croak_xs_usage(cv, "lobj, ...");
563 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
567 Perl_croak(aTHX_ "lobj is not of type version");
569 mPUSHs(vstringify(lobj));
576 XS(XS_version_numify)
581 croak_xs_usage(cv, "lobj, ...");
586 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
590 Perl_croak(aTHX_ "lobj is not of type version");
592 mPUSHs(vnumify(lobj));
599 XS(XS_version_normal)
604 croak_xs_usage(cv, "lobj, ...");
609 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
613 Perl_croak(aTHX_ "lobj is not of type version");
615 mPUSHs(vnormal(lobj));
627 croak_xs_usage(cv, "lobj, ...");
632 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
636 Perl_croak(aTHX_ "lobj is not of type version");
642 const IV swap = (IV)SvIV(ST(2));
644 if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
646 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
653 rs = newSViv(vcmp(rvs,lobj));
657 rs = newSViv(vcmp(lobj,rvs));
668 XS(XS_version_boolean)
673 croak_xs_usage(cv, "lobj, ...");
675 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
676 SV * const lobj = SvRV(ST(0));
679 sv_2mortal(new_version(
680 sv_2mortal(newSVpvs("0"))
689 Perl_croak(aTHX_ "lobj is not of type version");
697 croak_xs_usage(cv, "lobj, ...");
698 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
699 Perl_croak(aTHX_ "operation not supported with version object");
701 Perl_croak(aTHX_ "lobj is not of type version");
702 #ifndef HASATTRIBUTE_NORETURN
707 XS(XS_version_is_alpha)
712 croak_xs_usage(cv, "lobj");
714 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
715 SV * const lobj = ST(0);
716 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
724 Perl_croak(aTHX_ "lobj is not of type version");
737 const char * classname = "";
745 Perl_croak(aTHX_ "Invalid version format (version required)");
747 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
748 const HV * stash = SvSTASH(SvRV(ST(0)));
749 classname = HvNAME(stash);
750 len = HvNAMELEN(stash);
751 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
754 classname = SvPV(ST(0), len);
755 flags = SvUTF8(ST(0));
758 if ( !SvVOK(ver) ) { /* not already a v-string */
760 sv_setsv(rv,ver); /* make a duplicate */
761 upg_version(rv, TRUE);
763 rv = sv_2mortal(new_version(ver));
766 && strnNE(classname,"version", len) ) { /* inherited new() */
767 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
780 croak_xs_usage(cv, "lobj");
782 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
783 SV * const lobj = ST(0);
784 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
792 Perl_croak(aTHX_ "lobj is not of type version");
800 croak_xs_usage(cv, "sv");
802 SV * const sv = ST(0);
817 croak_xs_usage(cv, "sv");
819 SV * const sv = ST(0);
821 const char * const s = SvPV_const(sv,len);
822 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
835 croak_xs_usage(cv, "sv");
836 sv_utf8_encode(ST(0));
846 croak_xs_usage(cv, "sv");
848 SV * const sv = ST(0);
850 SvPV_force_nolen(sv);
851 RETVAL = sv_utf8_decode(sv);
853 ST(0) = boolSV(RETVAL);
863 croak_xs_usage(cv, "sv");
865 SV * const sv = ST(0);
869 RETVAL = sv_utf8_upgrade(sv);
870 XSprePUSH; PUSHi((IV)RETVAL);
875 XS(XS_utf8_downgrade)
879 if (items < 1 || items > 2)
880 croak_xs_usage(cv, "sv, failok=0");
882 SV * const sv = ST(0);
883 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
884 const bool RETVAL = sv_utf8_downgrade(sv, failok);
886 ST(0) = boolSV(RETVAL);
891 XS(XS_utf8_native_to_unicode)
895 const UV uv = SvUV(ST(0));
898 croak_xs_usage(cv, "sv");
900 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
904 XS(XS_utf8_unicode_to_native)
908 const UV uv = SvUV(ST(0));
911 croak_xs_usage(cv, "sv");
913 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
917 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
921 SV * const svz = ST(0);
925 /* [perl #77776] - called as &foo() not foo() */
927 croak_xs_usage(cv, "SCALAR[, ON]");
937 else if (items == 2) {
939 #ifdef PERL_OLD_COPY_ON_WRITE
940 if (SvIsCOW(sv)) sv_force_normal(sv);
943 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
944 /* for constant.pm; nobody else should be calling this
947 for (svp = AvARRAY(sv) + AvFILLp(sv)
950 if (*svp) SvPADTMP_on(*svp);
955 /* I hope you really know what you are doing. */
960 XSRETURN_UNDEF; /* Can't happen. */
962 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
966 SV * const svz = ST(0);
971 /* [perl #77776] - called as &foo() not foo() */
972 if ((items != 1 && items != 2) || !SvROK(svz))
973 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
977 /* I hope you really know what you are doing. */
978 /* idea is for SvREFCNT(sv) to be accessed only once */
979 refcnt = items == 2 ?
980 /* we free one ref on exit */
981 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
983 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
987 XS(XS_Internals_hv_clear_placehold)
992 if (items != 1 || !SvROK(ST(0)))
993 croak_xs_usage(cv, "hv");
995 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
996 hv_clear_placeholders(hv);
1001 XS(XS_PerlIO_get_layers)
1005 if (items < 1 || items % 2 == 0)
1006 croak_xs_usage(cv, "filehandle[,args]");
1013 bool details = FALSE;
1017 for (svp = MARK + 2; svp <= SP; svp += 2) {
1018 SV * const * const varp = svp;
1019 SV * const * const valp = svp + 1;
1021 const char * const key = SvPV_const(*varp, klen);
1025 if (klen == 5 && memEQ(key, "input", 5)) {
1026 input = SvTRUE(*valp);
1031 if (klen == 6 && memEQ(key, "output", 6)) {
1032 input = !SvTRUE(*valp);
1037 if (klen == 7 && memEQ(key, "details", 7)) {
1038 details = SvTRUE(*valp);
1045 "get_layers: unknown argument '%s'",
1054 gv = MAYBE_DEREF_GV(sv);
1056 if (!gv && !SvROK(sv))
1057 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1059 if (gv && (io = GvIO(gv))) {
1060 AV* const av = PerlIO_get_layers(aTHX_ input ?
1061 IoIFP(io) : IoOFP(io));
1063 const SSize_t last = av_len(av);
1066 for (i = last; i >= 0; i -= 3) {
1067 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1068 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1069 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1071 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1072 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1073 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1075 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
1077 /* Indents of 5? Yuck. */
1078 /* We know that PerlIO_get_layers creates a new SV for
1079 the name and flags, so we can just take a reference
1080 and "steal" it when we free the AV below. */
1082 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1085 ? newSVpvn_flags(SvPVX_const(*argsvp),
1087 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1091 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1097 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1101 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1103 PUSHs(&PL_sv_undef);
1106 const IV flags = SvIVX(*flgsvp);
1108 if (flags & PERLIO_F_UTF8) {
1109 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1131 PERL_UNUSED_VAR(cv);
1134 croak_xs_usage(cv, "sv");
1136 if (SvRXOK(ST(0))) {
1143 XS(XS_re_regnames_count)
1145 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1151 croak_xs_usage(cv, "");
1159 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1162 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1174 if (items < 1 || items > 2)
1175 croak_xs_usage(cv, "name[, all ]");
1180 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1185 if (items == 2 && SvTRUE(ST(1))) {
1190 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1193 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1211 croak_xs_usage(cv, "[all]");
1213 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1218 if (items == 1 && SvTRUE(ST(0))) {
1227 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1234 av = MUTABLE_AV(SvRV(ret));
1235 length = av_len(av);
1237 EXTEND(SP, length+1); /* better extend stack just once */
1238 for (i = 0; i <= length; i++) {
1239 entry = av_fetch(av, i, FALSE);
1242 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1244 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
1253 XS(XS_re_regexp_pattern)
1262 croak_xs_usage(cv, "sv");
1265 Checks if a reference is a regex or not. If the parameter is
1266 not a ref, or is not the result of a qr// then returns false
1267 in scalar context and an empty list in list context.
1268 Otherwise in list context it returns the pattern and the
1269 modifiers, in scalar context it returns the pattern just as it
1270 would if the qr// was stringified normally, regardless as
1271 to the class of the variable and any stringification overloads
1275 if ((re = SvRX(ST(0)))) /* assign deliberate */
1277 /* Houston, we have a regex! */
1280 if ( GIMME_V == G_ARRAY ) {
1282 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1288 we are in list context so stringify
1289 the modifiers that apply. We ignore "negative
1290 modifiers" in this scenario, and the default character set
1293 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1295 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1297 Copy(name, reflags + left, len, char);
1300 fptr = INT_PAT_MODS;
1301 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1302 >> RXf_PMf_STD_PMMOD_SHIFT);
1304 while((ch = *fptr++)) {
1305 if(match_flags & 1) {
1306 reflags[left++] = ch;
1311 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1312 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1314 /* return the pattern and the modifiers */
1316 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1319 /* Scalar, so use the string that Perl would return */
1320 /* return the pattern in (?msix:..) format */
1321 #if PERL_VERSION >= 11
1322 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1324 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1325 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1331 /* It ain't a regexp folks */
1332 if ( GIMME_V == G_ARRAY ) {
1333 /* return the empty list */
1336 /* Because of the (?:..) wrapping involved in a
1337 stringified pattern it is impossible to get a
1338 result for a real regexp that would evaluate to
1339 false. Therefore we can return PL_sv_no to signify
1340 that the object is not a regex, this means that one
1343 if (regex($might_be_a_regex) eq '(?:foo)') { }
1345 and not worry about undefined values.
1353 struct xsub_details {
1359 static const struct xsub_details details[] = {
1360 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1361 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1362 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1363 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1364 {"version::()", XS_version_noop, NULL},
1365 {"version::new", XS_version_new, NULL},
1366 {"version::parse", XS_version_new, NULL},
1367 {"version::(\"\"", XS_version_stringify, NULL},
1368 {"version::stringify", XS_version_stringify, NULL},
1369 {"version::(0+", XS_version_numify, NULL},
1370 {"version::numify", XS_version_numify, NULL},
1371 {"version::normal", XS_version_normal, NULL},
1372 {"version::(cmp", XS_version_vcmp, NULL},
1373 {"version::(<=>", XS_version_vcmp, NULL},
1374 {"version::vcmp", XS_version_vcmp, NULL},
1375 {"version::(bool", XS_version_boolean, NULL},
1376 {"version::boolean", XS_version_boolean, NULL},
1377 {"version::(+", XS_version_noop, NULL},
1378 {"version::(-", XS_version_noop, NULL},
1379 {"version::(*", XS_version_noop, NULL},
1380 {"version::(/", XS_version_noop, NULL},
1381 {"version::(+=", XS_version_noop, NULL},
1382 {"version::(-=", XS_version_noop, NULL},
1383 {"version::(*=", XS_version_noop, NULL},
1384 {"version::(/=", XS_version_noop, NULL},
1385 {"version::(abs", XS_version_noop, NULL},
1386 {"version::(nomethod", XS_version_noop, NULL},
1387 {"version::noop", XS_version_noop, NULL},
1388 {"version::is_alpha", XS_version_is_alpha, NULL},
1389 {"version::qv", XS_version_qv, NULL},
1390 {"version::declare", XS_version_qv, NULL},
1391 {"version::is_qv", XS_version_is_qv, NULL},
1392 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1393 {"utf8::valid", XS_utf8_valid, NULL},
1394 {"utf8::encode", XS_utf8_encode, NULL},
1395 {"utf8::decode", XS_utf8_decode, NULL},
1396 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1397 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1398 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1399 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1400 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1401 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1402 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1403 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1404 {"re::is_regexp", XS_re_is_regexp, "$"},
1405 {"re::regname", XS_re_regname, ";$$"},
1406 {"re::regnames", XS_re_regnames, ";$"},
1407 {"re::regnames_count", XS_re_regnames_count, ""},
1408 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1412 Perl_boot_core_UNIVERSAL(pTHX)
1415 static const char file[] = __FILE__;
1416 const struct xsub_details *xsub = details;
1417 const struct xsub_details *end
1418 = details + sizeof(details) / sizeof(details[0]);
1421 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1422 } while (++xsub < end);
1424 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1427 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1428 Safefree(CvFILE(cv));
1429 CvFILE(cv) = (char *)file;
1436 * c-indentation-style: bsd
1438 * indent-tabs-mode: nil
1441 * ex: set ts=8 sts=4 sw=4 et: