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))
163 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
166 stash = gv_stashsv(sv, 0);
169 return stash ? isa_lookup(stash, name, len, flags) : FALSE;
173 =for apidoc sv_does_sv
175 Returns a boolean indicating whether the SV performs a specific, named role.
176 The SV can be a Perl object or the name of a Perl class.
184 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
191 PERL_ARGS_ASSERT_SV_DOES_SV;
192 PERL_UNUSED_ARG(flags);
199 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
200 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
205 if (sv_isobject(sv)) {
206 classname = sv_ref(NULL,SvRV(sv),TRUE);
211 if (sv_eq(classname, namesv)) {
222 methodname = newSVpvs_flags("isa", SVs_TEMP);
223 /* ugly hack: use the SvSCREAM flag so S_method_common
224 * can figure out we're calling DOES() and not isa(),
225 * and report eventual errors correctly. --rgs */
226 SvSCREAM_on(methodname);
227 call_sv(methodname, G_SCALAR | G_METHOD);
230 does_it = SvTRUE( TOPs );
240 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
246 Perl_sv_does(pTHX_ SV *sv, const char *const name)
248 PERL_ARGS_ASSERT_SV_DOES;
249 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
253 =for apidoc sv_does_pv
255 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
262 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
264 PERL_ARGS_ASSERT_SV_DOES_PV;
265 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
269 =for apidoc sv_does_pvn
271 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
277 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
279 PERL_ARGS_ASSERT_SV_DOES_PVN;
281 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
285 =for apidoc croak_xs_usage
287 A specialised variant of C<croak()> for emitting the usage message for xsubs
289 croak_xs_usage(cv, "eee_yow");
291 works out the package name and subroutine name from C<cv>, and then calls
292 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
294 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
300 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
302 const GV *const gv = CvGV(cv);
304 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
307 const HV *const stash = GvSTASH(gv);
309 if (HvNAME_get(stash))
310 Perl_croak(aTHX_ "Usage: %"HEKf"::%"HEKf"(%s)",
311 HEKfARG(HvNAME_HEK(stash)),
312 HEKfARG(GvNAME_HEK(gv)),
315 Perl_croak(aTHX_ "Usage: %"HEKf"(%s)",
316 HEKfARG(GvNAME_HEK(gv)), params);
318 /* Pants. I don't think that it should be possible to get here. */
319 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
329 croak_xs_usage(cv, "reference, kind");
331 SV * const sv = ST(0);
335 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
336 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
339 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
353 croak_xs_usage(cv, "object-ref, method");
359 if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv))
360 || (SvGMAGICAL(sv) && (SvNIOKp(sv) || (SvPOKp(sv) && SvCUR(sv))))))
366 sv = MUTABLE_SV(SvRV(sv));
371 pkg = gv_stashsv(sv, 0);
375 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
377 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
384 XS(XS_UNIVERSAL_DOES)
391 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
393 SV * const sv = ST(0);
394 if (sv_does_sv( sv, ST(1), 0 ))
401 XS(XS_UNIVERSAL_VERSION)
413 sv = MUTABLE_SV(SvRV(ST(0)));
415 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
419 pkg = gv_stashsv(ST(0), 0);
422 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
424 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
425 SV * const nsv = sv_newmortal();
428 if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
429 upg_version(sv, FALSE);
443 const HEK * const name = HvNAME_HEK(pkg);
445 "%"HEKf" does not define $%"HEKf
446 "::VERSION--version check failed",
447 HEKfARG(name), HEKfARG(name));
450 "%"SVf" defines neither package nor VERSION--version check failed",
455 if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
456 /* req may very well be R/O, so create a new object */
457 req = sv_2mortal( new_version(req) );
460 if ( vcmp( req, sv ) > 0 ) {
461 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
462 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
463 "this is only version %"SVf"",
464 HEKfARG(HvNAME_HEK(pkg)),
465 SVfARG(sv_2mortal(vnormal(req))),
466 SVfARG(sv_2mortal(vnormal(sv))));
468 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
469 "this is only version %"SVf,
470 HEKfARG(HvNAME_HEK(pkg)),
471 SVfARG(sv_2mortal(vstringify(req))),
472 SVfARG(sv_2mortal(vstringify(sv))));
478 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
479 ST(0) = sv_2mortal(vstringify(sv));
492 croak_xs_usage(cv, "class, version");
498 const char *classname;
500 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
501 const HV * stash = SvSTASH(SvRV(ST(0)));
502 classname = HvNAME(stash);
503 len = HvNAMELEN(stash);
504 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
507 classname = SvPV(ST(0), len);
508 flags = SvUTF8(ST(0));
511 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
512 /* create empty object */
516 else if ( items == 3 ) {
518 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
521 rv = new_version(vs);
522 if ( strnNE(classname,"version", len) ) /* inherited new() */
523 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
531 XS(XS_version_stringify)
536 croak_xs_usage(cv, "lobj, ...");
541 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
545 Perl_croak(aTHX_ "lobj is not of type version");
547 mPUSHs(vstringify(lobj));
554 XS(XS_version_numify)
559 croak_xs_usage(cv, "lobj, ...");
564 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
568 Perl_croak(aTHX_ "lobj is not of type version");
570 mPUSHs(vnumify(lobj));
577 XS(XS_version_normal)
582 croak_xs_usage(cv, "lobj, ...");
587 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
591 Perl_croak(aTHX_ "lobj is not of type version");
593 mPUSHs(vnormal(lobj));
605 croak_xs_usage(cv, "lobj, ...");
610 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
614 Perl_croak(aTHX_ "lobj is not of type version");
620 const IV swap = (IV)SvIV(ST(2));
622 if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
624 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
631 rs = newSViv(vcmp(rvs,lobj));
635 rs = newSViv(vcmp(lobj,rvs));
646 XS(XS_version_boolean)
651 croak_xs_usage(cv, "lobj, ...");
653 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
654 SV * const lobj = SvRV(ST(0));
657 sv_2mortal(new_version(
658 sv_2mortal(newSVpvs("0"))
667 Perl_croak(aTHX_ "lobj is not of type version");
675 croak_xs_usage(cv, "lobj, ...");
676 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
677 Perl_croak(aTHX_ "operation not supported with version object");
679 Perl_croak(aTHX_ "lobj is not of type version");
680 #ifndef HASATTRIBUTE_NORETURN
685 XS(XS_version_is_alpha)
690 croak_xs_usage(cv, "lobj");
692 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
693 SV * const lobj = ST(0);
694 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
702 Perl_croak(aTHX_ "lobj is not of type version");
715 const char * classname = "";
717 if ( items == 2 && SvOK(ST(1)) ) {
719 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
720 const HV * stash = SvSTASH(SvRV(ST(0)));
721 classname = HvNAME(stash);
722 len = HvNAMELEN(stash);
723 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
726 classname = SvPV(ST(0), len);
727 flags = SvUTF8(ST(0));
730 if ( !SvVOK(ver) ) { /* not already a v-string */
732 sv_setsv(rv,ver); /* make a duplicate */
733 upg_version(rv, TRUE);
735 rv = sv_2mortal(new_version(ver));
738 && strnNE(classname,"version", len) ) { /* inherited new() */
739 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
752 croak_xs_usage(cv, "lobj");
754 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
755 SV * const lobj = ST(0);
756 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
764 Perl_croak(aTHX_ "lobj is not of type version");
772 croak_xs_usage(cv, "sv");
774 SV * const sv = ST(0);
789 croak_xs_usage(cv, "sv");
791 SV * const sv = ST(0);
793 const char * const s = SvPV_const(sv,len);
794 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
807 croak_xs_usage(cv, "sv");
808 sv_utf8_encode(ST(0));
817 croak_xs_usage(cv, "sv");
819 SV * const sv = ST(0);
821 SvPV_force_nolen(sv);
822 RETVAL = sv_utf8_decode(sv);
823 ST(0) = boolSV(RETVAL);
833 croak_xs_usage(cv, "sv");
835 SV * const sv = ST(0);
839 RETVAL = sv_utf8_upgrade(sv);
840 XSprePUSH; PUSHi((IV)RETVAL);
845 XS(XS_utf8_downgrade)
849 if (items < 1 || items > 2)
850 croak_xs_usage(cv, "sv, failok=0");
852 SV * const sv = ST(0);
853 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
854 const bool RETVAL = sv_utf8_downgrade(sv, failok);
856 ST(0) = boolSV(RETVAL);
861 XS(XS_utf8_native_to_unicode)
865 const UV uv = SvUV(ST(0));
868 croak_xs_usage(cv, "sv");
870 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
874 XS(XS_utf8_unicode_to_native)
878 const UV uv = SvUV(ST(0));
881 croak_xs_usage(cv, "sv");
883 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
887 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
891 SV * const svz = ST(0);
895 /* [perl #77776] - called as &foo() not foo() */
897 croak_xs_usage(cv, "SCALAR[, ON]");
902 if (SvREADONLY(sv) && !SvIsCOW(sv))
907 else if (items == 2) {
909 if (SvIsCOW(sv)) sv_force_normal(sv);
914 /* I hope you really know what you are doing. */
915 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
919 XSRETURN_UNDEF; /* Can't happen. */
922 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
926 SV * const svz = ST(0);
930 /* [perl #77776] - called as &foo() not foo() */
932 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
937 XSRETURN_UV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
938 else if (items == 2) {
939 /* I hope you really know what you are doing. */
940 SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */
941 XSRETURN_UV(SvREFCNT(sv) - 1);
943 XSRETURN_UNDEF; /* Can't happen. */
946 XS(XS_Internals_hv_clear_placehold)
951 if (items != 1 || !SvROK(ST(0)))
952 croak_xs_usage(cv, "hv");
954 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
955 hv_clear_placeholders(hv);
960 XS(XS_PerlIO_get_layers)
964 if (items < 1 || items % 2 == 0)
965 croak_xs_usage(cv, "filehandle[,args]");
972 bool details = FALSE;
976 for (svp = MARK + 2; svp <= SP; svp += 2) {
977 SV * const * const varp = svp;
978 SV * const * const valp = svp + 1;
980 const char * const key = SvPV_const(*varp, klen);
984 if (klen == 5 && memEQ(key, "input", 5)) {
985 input = SvTRUE(*valp);
990 if (klen == 6 && memEQ(key, "output", 6)) {
991 input = !SvTRUE(*valp);
996 if (klen == 7 && memEQ(key, "details", 7)) {
997 details = SvTRUE(*valp);
1004 "get_layers: unknown argument '%s'",
1013 gv = MAYBE_DEREF_GV(sv);
1015 if (!gv && !SvROK(sv))
1016 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1018 if (gv && (io = GvIO(gv))) {
1019 AV* const av = PerlIO_get_layers(aTHX_ input ?
1020 IoIFP(io) : IoOFP(io));
1022 const I32 last = av_len(av);
1025 for (i = last; i >= 0; i -= 3) {
1026 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1027 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1028 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1030 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1031 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1032 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1035 /* Indents of 5? Yuck. */
1036 /* We know that PerlIO_get_layers creates a new SV for
1037 the name and flags, so we can just take a reference
1038 and "steal" it when we free the AV below. */
1040 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1043 ? newSVpvn_flags(SvPVX_const(*argsvp),
1045 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1049 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1055 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1059 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1061 XPUSHs(&PL_sv_undef);
1064 const IV flags = SvIVX(*flgsvp);
1066 if (flags & PERLIO_F_UTF8) {
1067 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1084 XS(XS_Internals_hash_seed)
1087 /* Using dXSARGS would also have dITEM and dSP,
1088 * which define 2 unused local variables. */
1090 PERL_UNUSED_ARG(cv);
1091 PERL_UNUSED_VAR(mark);
1092 XSRETURN_UV(PERL_HASH_SEED);
1095 XS(XS_Internals_rehash_seed)
1098 /* Using dXSARGS would also have dITEM and dSP,
1099 * which define 2 unused local variables. */
1101 PERL_UNUSED_ARG(cv);
1102 PERL_UNUSED_VAR(mark);
1103 XSRETURN_UV(PL_rehash_seed);
1106 XS(XS_Internals_HvREHASH) /* Subject to change */
1110 PERL_UNUSED_ARG(cv);
1112 const HV * const hv = (const HV *) SvRV(ST(0));
1113 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1120 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1127 PERL_UNUSED_VAR(cv);
1130 croak_xs_usage(cv, "sv");
1132 if (SvRXOK(ST(0))) {
1139 XS(XS_re_regnames_count)
1141 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1147 croak_xs_usage(cv, "");
1155 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1158 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1170 if (items < 1 || items > 2)
1171 croak_xs_usage(cv, "name[, all ]");
1176 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1181 if (items == 2 && SvTRUE(ST(1))) {
1186 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1189 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1207 croak_xs_usage(cv, "[all]");
1209 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1214 if (items == 1 && SvTRUE(ST(0))) {
1223 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1230 av = MUTABLE_AV(SvRV(ret));
1231 length = av_len(av);
1233 for (i = 0; i <= length; i++) {
1234 entry = av_fetch(av, i, FALSE);
1237 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1239 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1248 XS(XS_re_regexp_pattern)
1255 croak_xs_usage(cv, "sv");
1260 Checks if a reference is a regex or not. If the parameter is
1261 not a ref, or is not the result of a qr// then returns false
1262 in scalar context and an empty list in list context.
1263 Otherwise in list context it returns the pattern and the
1264 modifiers, in scalar context it returns the pattern just as it
1265 would if the qr// was stringified normally, regardless as
1266 to the class of the variable and any stringification overloads
1270 if ((re = SvRX(ST(0)))) /* assign deliberate */
1272 /* Houston, we have a regex! */
1275 if ( GIMME_V == G_ARRAY ) {
1277 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1283 we are in list context so stringify
1284 the modifiers that apply. We ignore "negative
1285 modifiers" in this scenario, and the default character set
1288 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1290 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1292 Copy(name, reflags + left, len, char);
1295 fptr = INT_PAT_MODS;
1296 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1297 >> RXf_PMf_STD_PMMOD_SHIFT);
1299 while((ch = *fptr++)) {
1300 if(match_flags & 1) {
1301 reflags[left++] = ch;
1306 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1307 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1309 /* return the pattern and the modifiers */
1311 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1314 /* Scalar, so use the string that Perl would return */
1315 /* return the pattern in (?msix:..) format */
1316 #if PERL_VERSION >= 11
1317 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1319 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1320 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1326 /* It ain't a regexp folks */
1327 if ( GIMME_V == G_ARRAY ) {
1328 /* return the empty list */
1331 /* Because of the (?:..) wrapping involved in a
1332 stringified pattern it is impossible to get a
1333 result for a real regexp that would evaluate to
1334 false. Therefore we can return PL_sv_no to signify
1335 that the object is not a regex, this means that one
1338 if (regex($might_be_a_regex) eq '(?:foo)') { }
1340 and not worry about undefined values.
1348 struct xsub_details {
1354 struct xsub_details details[] = {
1355 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1356 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1357 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1358 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1359 {"version::()", XS_version_noop, NULL},
1360 {"version::new", XS_version_new, NULL},
1361 {"version::parse", XS_version_new, NULL},
1362 {"version::(\"\"", XS_version_stringify, NULL},
1363 {"version::stringify", XS_version_stringify, NULL},
1364 {"version::(0+", XS_version_numify, NULL},
1365 {"version::numify", XS_version_numify, NULL},
1366 {"version::normal", XS_version_normal, NULL},
1367 {"version::(cmp", XS_version_vcmp, NULL},
1368 {"version::(<=>", XS_version_vcmp, NULL},
1369 {"version::vcmp", XS_version_vcmp, NULL},
1370 {"version::(bool", XS_version_boolean, NULL},
1371 {"version::boolean", XS_version_boolean, NULL},
1372 {"version::(+", XS_version_noop, NULL},
1373 {"version::(-", XS_version_noop, NULL},
1374 {"version::(*", XS_version_noop, NULL},
1375 {"version::(/", XS_version_noop, NULL},
1376 {"version::(+=", XS_version_noop, NULL},
1377 {"version::(-=", XS_version_noop, NULL},
1378 {"version::(*=", XS_version_noop, NULL},
1379 {"version::(/=", XS_version_noop, NULL},
1380 {"version::(abs", XS_version_noop, NULL},
1381 {"version::(nomethod", XS_version_noop, NULL},
1382 {"version::noop", XS_version_noop, NULL},
1383 {"version::is_alpha", XS_version_is_alpha, NULL},
1384 {"version::qv", XS_version_qv, NULL},
1385 {"version::declare", XS_version_qv, NULL},
1386 {"version::is_qv", XS_version_is_qv, NULL},
1387 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1388 {"utf8::valid", XS_utf8_valid, NULL},
1389 {"utf8::encode", XS_utf8_encode, NULL},
1390 {"utf8::decode", XS_utf8_decode, NULL},
1391 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1392 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1393 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1394 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1395 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1396 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1397 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1398 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1399 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1400 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1401 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1402 {"re::is_regexp", XS_re_is_regexp, "$"},
1403 {"re::regname", XS_re_regname, ";$$"},
1404 {"re::regnames", XS_re_regnames, ";$"},
1405 {"re::regnames_count", XS_re_regnames_count, ""},
1406 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1410 Perl_boot_core_UNIVERSAL(pTHX)
1413 static const char file[] = __FILE__;
1414 struct xsub_details *xsub = details;
1415 const struct xsub_details *end
1416 = details + sizeof(details) / sizeof(details[0]);
1419 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1420 } while (++xsub < end);
1422 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1425 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1426 Safefree(CvFILE(cv));
1427 CvFILE(cv) = (char *)file;
1434 * c-indentation-style: bsd
1436 * indent-tabs-mode: nil
1439 * ex: set ts=8 sts=4 sw=4 et: