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) || (SvPOK(sv) && SvCUR(sv))
360 || (SvGMAGICAL(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));
655 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
661 Perl_croak(aTHX_ "lobj is not of type version");
669 croak_xs_usage(cv, "lobj, ...");
670 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
671 Perl_croak(aTHX_ "operation not supported with version object");
673 Perl_croak(aTHX_ "lobj is not of type version");
674 #ifndef HASATTRIBUTE_NORETURN
679 XS(XS_version_is_alpha)
684 croak_xs_usage(cv, "lobj");
686 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
687 SV * const lobj = ST(0);
688 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
696 Perl_croak(aTHX_ "lobj is not of type version");
709 const char * classname = "";
711 if ( items == 2 && SvOK(ST(1)) ) {
713 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
714 const HV * stash = SvSTASH(SvRV(ST(0)));
715 classname = HvNAME(stash);
716 len = HvNAMELEN(stash);
717 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
720 classname = SvPV(ST(0), len);
721 flags = SvUTF8(ST(0));
724 if ( !SvVOK(ver) ) { /* not already a v-string */
726 sv_setsv(rv,ver); /* make a duplicate */
727 upg_version(rv, TRUE);
729 rv = sv_2mortal(new_version(ver));
732 && strnNE(classname,"version", len) ) { /* inherited new() */
733 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
746 croak_xs_usage(cv, "lobj");
748 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
749 SV * const lobj = ST(0);
750 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
758 Perl_croak(aTHX_ "lobj is not of type version");
766 croak_xs_usage(cv, "sv");
768 SV * const sv = ST(0);
783 croak_xs_usage(cv, "sv");
785 SV * const sv = ST(0);
787 const char * const s = SvPV_const(sv,len);
788 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
801 croak_xs_usage(cv, "sv");
802 sv_utf8_encode(ST(0));
811 croak_xs_usage(cv, "sv");
813 SV * const sv = ST(0);
815 SvPV_force_nolen(sv);
816 RETVAL = sv_utf8_decode(sv);
817 ST(0) = boolSV(RETVAL);
827 croak_xs_usage(cv, "sv");
829 SV * const sv = ST(0);
833 RETVAL = sv_utf8_upgrade(sv);
834 XSprePUSH; PUSHi((IV)RETVAL);
839 XS(XS_utf8_downgrade)
843 if (items < 1 || items > 2)
844 croak_xs_usage(cv, "sv, failok=0");
846 SV * const sv = ST(0);
847 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
848 const bool RETVAL = sv_utf8_downgrade(sv, failok);
850 ST(0) = boolSV(RETVAL);
855 XS(XS_utf8_native_to_unicode)
859 const UV uv = SvUV(ST(0));
862 croak_xs_usage(cv, "sv");
864 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
868 XS(XS_utf8_unicode_to_native)
872 const UV uv = SvUV(ST(0));
875 croak_xs_usage(cv, "sv");
877 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
881 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
885 SV * const svz = ST(0);
889 /* [perl #77776] - called as &foo() not foo() */
891 croak_xs_usage(cv, "SCALAR[, ON]");
896 if (SvREADONLY(sv) && !SvIsCOW(sv))
901 else if (items == 2) {
903 if (SvIsCOW(sv)) sv_force_normal(sv);
908 /* I hope you really know what you are doing. */
909 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
913 XSRETURN_UNDEF; /* Can't happen. */
916 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
920 SV * const svz = ST(0);
924 /* [perl #77776] - called as &foo() not foo() */
926 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
931 XSRETURN_UV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
932 else if (items == 2) {
933 /* I hope you really know what you are doing. */
934 SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */
935 XSRETURN_UV(SvREFCNT(sv) - 1);
937 XSRETURN_UNDEF; /* Can't happen. */
940 XS(XS_Internals_hv_clear_placehold)
945 if (items != 1 || !SvROK(ST(0)))
946 croak_xs_usage(cv, "hv");
948 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
949 hv_clear_placeholders(hv);
954 XS(XS_PerlIO_get_layers)
958 if (items < 1 || items % 2 == 0)
959 croak_xs_usage(cv, "filehandle[,args]");
966 bool details = FALSE;
970 for (svp = MARK + 2; svp <= SP; svp += 2) {
971 SV * const * const varp = svp;
972 SV * const * const valp = svp + 1;
974 const char * const key = SvPV_const(*varp, klen);
978 if (klen == 5 && memEQ(key, "input", 5)) {
979 input = SvTRUE(*valp);
984 if (klen == 6 && memEQ(key, "output", 6)) {
985 input = !SvTRUE(*valp);
990 if (klen == 7 && memEQ(key, "details", 7)) {
991 details = SvTRUE(*valp);
998 "get_layers: unknown argument '%s'",
1007 gv = MAYBE_DEREF_GV(sv);
1009 if (!gv && !SvROK(sv))
1010 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1012 if (gv && (io = GvIO(gv))) {
1013 AV* const av = PerlIO_get_layers(aTHX_ input ?
1014 IoIFP(io) : IoOFP(io));
1016 const I32 last = av_len(av);
1019 for (i = last; i >= 0; i -= 3) {
1020 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1021 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1022 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1024 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1025 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1026 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1029 /* Indents of 5? Yuck. */
1030 /* We know that PerlIO_get_layers creates a new SV for
1031 the name and flags, so we can just take a reference
1032 and "steal" it when we free the AV below. */
1034 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1037 ? newSVpvn_flags(SvPVX_const(*argsvp),
1039 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1043 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1049 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1053 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1055 XPUSHs(&PL_sv_undef);
1058 const IV flags = SvIVX(*flgsvp);
1060 if (flags & PERLIO_F_UTF8) {
1061 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1078 XS(XS_Internals_hash_seed)
1081 /* Using dXSARGS would also have dITEM and dSP,
1082 * which define 2 unused local variables. */
1084 PERL_UNUSED_ARG(cv);
1085 PERL_UNUSED_VAR(mark);
1086 XSRETURN_UV(PERL_HASH_SEED);
1089 XS(XS_Internals_rehash_seed)
1092 /* Using dXSARGS would also have dITEM and dSP,
1093 * which define 2 unused local variables. */
1095 PERL_UNUSED_ARG(cv);
1096 PERL_UNUSED_VAR(mark);
1097 XSRETURN_UV(PL_rehash_seed);
1100 XS(XS_Internals_HvREHASH) /* Subject to change */
1104 PERL_UNUSED_ARG(cv);
1106 const HV * const hv = (const HV *) SvRV(ST(0));
1107 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1114 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1121 PERL_UNUSED_VAR(cv);
1124 croak_xs_usage(cv, "sv");
1126 if (SvRXOK(ST(0))) {
1133 XS(XS_re_regnames_count)
1135 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1141 croak_xs_usage(cv, "");
1149 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1152 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1164 if (items < 1 || items > 2)
1165 croak_xs_usage(cv, "name[, all ]");
1170 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1175 if (items == 2 && SvTRUE(ST(1))) {
1180 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1183 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1201 croak_xs_usage(cv, "[all]");
1203 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1208 if (items == 1 && SvTRUE(ST(0))) {
1217 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1224 av = MUTABLE_AV(SvRV(ret));
1225 length = av_len(av);
1227 for (i = 0; i <= length; i++) {
1228 entry = av_fetch(av, i, FALSE);
1231 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1233 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1242 XS(XS_re_regexp_pattern)
1249 croak_xs_usage(cv, "sv");
1254 Checks if a reference is a regex or not. If the parameter is
1255 not a ref, or is not the result of a qr// then returns false
1256 in scalar context and an empty list in list context.
1257 Otherwise in list context it returns the pattern and the
1258 modifiers, in scalar context it returns the pattern just as it
1259 would if the qr// was stringified normally, regardless as
1260 to the class of the variable and any stringification overloads
1264 if ((re = SvRX(ST(0)))) /* assign deliberate */
1266 /* Houston, we have a regex! */
1269 if ( GIMME_V == G_ARRAY ) {
1271 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1277 we are in list context so stringify
1278 the modifiers that apply. We ignore "negative
1279 modifiers" in this scenario, and the default character set
1282 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1284 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1286 Copy(name, reflags + left, len, char);
1289 fptr = INT_PAT_MODS;
1290 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1291 >> RXf_PMf_STD_PMMOD_SHIFT);
1293 while((ch = *fptr++)) {
1294 if(match_flags & 1) {
1295 reflags[left++] = ch;
1300 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1301 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1303 /* return the pattern and the modifiers */
1305 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1308 /* Scalar, so use the string that Perl would return */
1309 /* return the pattern in (?msix:..) format */
1310 #if PERL_VERSION >= 11
1311 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1313 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1314 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1320 /* It ain't a regexp folks */
1321 if ( GIMME_V == G_ARRAY ) {
1322 /* return the empty list */
1325 /* Because of the (?:..) wrapping involved in a
1326 stringified pattern it is impossible to get a
1327 result for a real regexp that would evaluate to
1328 false. Therefore we can return PL_sv_no to signify
1329 that the object is not a regex, this means that one
1332 if (regex($might_be_a_regex) eq '(?:foo)') { }
1334 and not worry about undefined values.
1342 struct xsub_details {
1348 struct xsub_details details[] = {
1349 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1350 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1351 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1352 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1353 {"version::()", XS_version_noop, NULL},
1354 {"version::new", XS_version_new, NULL},
1355 {"version::parse", XS_version_new, NULL},
1356 {"version::(\"\"", XS_version_stringify, NULL},
1357 {"version::stringify", XS_version_stringify, NULL},
1358 {"version::(0+", XS_version_numify, NULL},
1359 {"version::numify", XS_version_numify, NULL},
1360 {"version::normal", XS_version_normal, NULL},
1361 {"version::(cmp", XS_version_vcmp, NULL},
1362 {"version::(<=>", XS_version_vcmp, NULL},
1363 {"version::vcmp", XS_version_vcmp, NULL},
1364 {"version::(bool", XS_version_boolean, NULL},
1365 {"version::boolean", XS_version_boolean, NULL},
1366 {"version::(+", XS_version_noop, NULL},
1367 {"version::(-", XS_version_noop, NULL},
1368 {"version::(*", XS_version_noop, NULL},
1369 {"version::(/", XS_version_noop, NULL},
1370 {"version::(+=", XS_version_noop, NULL},
1371 {"version::(-=", XS_version_noop, NULL},
1372 {"version::(*=", XS_version_noop, NULL},
1373 {"version::(/=", XS_version_noop, NULL},
1374 {"version::(abs", XS_version_noop, NULL},
1375 {"version::(nomethod", XS_version_noop, NULL},
1376 {"version::noop", XS_version_noop, NULL},
1377 {"version::is_alpha", XS_version_is_alpha, NULL},
1378 {"version::qv", XS_version_qv, NULL},
1379 {"version::declare", XS_version_qv, NULL},
1380 {"version::is_qv", XS_version_is_qv, NULL},
1381 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1382 {"utf8::valid", XS_utf8_valid, NULL},
1383 {"utf8::encode", XS_utf8_encode, NULL},
1384 {"utf8::decode", XS_utf8_decode, NULL},
1385 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1386 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1387 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1388 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1389 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1390 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1391 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1392 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1393 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1394 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1395 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1396 {"re::is_regexp", XS_re_is_regexp, "$"},
1397 {"re::regname", XS_re_regname, ";$$"},
1398 {"re::regnames", XS_re_regnames, ";$"},
1399 {"re::regnames_count", XS_re_regnames_count, ""},
1400 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1404 Perl_boot_core_UNIVERSAL(pTHX)
1407 static const char file[] = __FILE__;
1408 struct xsub_details *xsub = details;
1409 const struct xsub_details *end
1410 = details + sizeof(details) / sizeof(details[0]);
1413 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1414 } while (++xsub < end);
1416 /* register the overloading (type 'A') magic */
1417 PL_amagic_generation++;
1419 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1422 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1423 Safefree(CvFILE(cv));
1424 CvFILE(cv) = (char *)file;
1431 * c-indentation-style: bsd
1433 * indent-tabs-mode: t
1436 * ex: set ts=8 sts=4 sw=4 noet: