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 if (SvIsCOW(sv)) sv_force_normal(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 = MUTABLE_GV(sv);
1010 if (SvROK(sv) && isGV(SvRV(sv)))
1011 gv = MUTABLE_GV(SvRV(sv));
1012 else if (SvPOKp(sv))
1013 gv = gv_fetchsv(sv, 0, SVt_PVIO);
1016 if (gv && (io = GvIO(gv))) {
1017 AV* const av = PerlIO_get_layers(aTHX_ input ?
1018 IoIFP(io) : IoOFP(io));
1020 const I32 last = av_len(av);
1023 for (i = last; i >= 0; i -= 3) {
1024 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1025 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1026 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1028 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1029 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1030 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1033 /* Indents of 5? Yuck. */
1034 /* We know that PerlIO_get_layers creates a new SV for
1035 the name and flags, so we can just take a reference
1036 and "steal" it when we free the AV below. */
1038 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1041 ? newSVpvn_flags(SvPVX_const(*argsvp),
1043 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1047 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1053 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1057 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1059 XPUSHs(&PL_sv_undef);
1062 const IV flags = SvIVX(*flgsvp);
1064 if (flags & PERLIO_F_UTF8) {
1065 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1082 XS(XS_Internals_hash_seed)
1085 /* Using dXSARGS would also have dITEM and dSP,
1086 * which define 2 unused local variables. */
1088 PERL_UNUSED_ARG(cv);
1089 PERL_UNUSED_VAR(mark);
1090 XSRETURN_UV(PERL_HASH_SEED);
1093 XS(XS_Internals_rehash_seed)
1096 /* Using dXSARGS would also have dITEM and dSP,
1097 * which define 2 unused local variables. */
1099 PERL_UNUSED_ARG(cv);
1100 PERL_UNUSED_VAR(mark);
1101 XSRETURN_UV(PL_rehash_seed);
1104 XS(XS_Internals_HvREHASH) /* Subject to change */
1108 PERL_UNUSED_ARG(cv);
1110 const HV * const hv = (const HV *) SvRV(ST(0));
1111 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1118 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1125 PERL_UNUSED_VAR(cv);
1128 croak_xs_usage(cv, "sv");
1130 if (SvRXOK(ST(0))) {
1137 XS(XS_re_regnames_count)
1139 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1145 croak_xs_usage(cv, "");
1153 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1156 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1168 if (items < 1 || items > 2)
1169 croak_xs_usage(cv, "name[, all ]");
1174 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1179 if (items == 2 && SvTRUE(ST(1))) {
1184 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1187 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1205 croak_xs_usage(cv, "[all]");
1207 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1212 if (items == 1 && SvTRUE(ST(0))) {
1221 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1228 av = MUTABLE_AV(SvRV(ret));
1229 length = av_len(av);
1231 for (i = 0; i <= length; i++) {
1232 entry = av_fetch(av, i, FALSE);
1235 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1237 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1246 XS(XS_re_regexp_pattern)
1253 croak_xs_usage(cv, "sv");
1258 Checks if a reference is a regex or not. If the parameter is
1259 not a ref, or is not the result of a qr// then returns false
1260 in scalar context and an empty list in list context.
1261 Otherwise in list context it returns the pattern and the
1262 modifiers, in scalar context it returns the pattern just as it
1263 would if the qr// was stringified normally, regardless as
1264 to the class of the variable and any stringification overloads
1268 if ((re = SvRX(ST(0)))) /* assign deliberate */
1270 /* Houston, we have a regex! */
1273 if ( GIMME_V == G_ARRAY ) {
1275 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1281 we are in list context so stringify
1282 the modifiers that apply. We ignore "negative
1283 modifiers" in this scenario, and the default character set
1286 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1288 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1290 Copy(name, reflags + left, len, char);
1293 fptr = INT_PAT_MODS;
1294 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1295 >> RXf_PMf_STD_PMMOD_SHIFT);
1297 while((ch = *fptr++)) {
1298 if(match_flags & 1) {
1299 reflags[left++] = ch;
1304 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1305 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1307 /* return the pattern and the modifiers */
1309 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1312 /* Scalar, so use the string that Perl would return */
1313 /* return the pattern in (?msix:..) format */
1314 #if PERL_VERSION >= 11
1315 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1317 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1318 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1324 /* It ain't a regexp folks */
1325 if ( GIMME_V == G_ARRAY ) {
1326 /* return the empty list */
1329 /* Because of the (?:..) wrapping involved in a
1330 stringified pattern it is impossible to get a
1331 result for a real regexp that would evaluate to
1332 false. Therefore we can return PL_sv_no to signify
1333 that the object is not a regex, this means that one
1336 if (regex($might_be_a_regex) eq '(?:foo)') { }
1338 and not worry about undefined values.
1346 struct xsub_details {
1352 struct xsub_details details[] = {
1353 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1354 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1355 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1356 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1357 {"version::()", XS_version_noop, NULL},
1358 {"version::new", XS_version_new, NULL},
1359 {"version::parse", XS_version_new, NULL},
1360 {"version::(\"\"", XS_version_stringify, NULL},
1361 {"version::stringify", XS_version_stringify, NULL},
1362 {"version::(0+", XS_version_numify, NULL},
1363 {"version::numify", XS_version_numify, NULL},
1364 {"version::normal", XS_version_normal, NULL},
1365 {"version::(cmp", XS_version_vcmp, NULL},
1366 {"version::(<=>", XS_version_vcmp, NULL},
1367 {"version::vcmp", XS_version_vcmp, NULL},
1368 {"version::(bool", XS_version_boolean, NULL},
1369 {"version::boolean", XS_version_boolean, 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::(+=", XS_version_noop, NULL},
1375 {"version::(-=", XS_version_noop, NULL},
1376 {"version::(*=", XS_version_noop, NULL},
1377 {"version::(/=", XS_version_noop, NULL},
1378 {"version::(abs", XS_version_noop, NULL},
1379 {"version::(nomethod", XS_version_noop, NULL},
1380 {"version::noop", XS_version_noop, NULL},
1381 {"version::is_alpha", XS_version_is_alpha, NULL},
1382 {"version::qv", XS_version_qv, NULL},
1383 {"version::declare", XS_version_qv, NULL},
1384 {"version::is_qv", XS_version_is_qv, NULL},
1385 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1386 {"utf8::valid", XS_utf8_valid, NULL},
1387 {"utf8::encode", XS_utf8_encode, NULL},
1388 {"utf8::decode", XS_utf8_decode, NULL},
1389 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1390 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1391 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1392 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1393 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1394 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1395 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1396 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1397 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1398 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1399 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1400 {"re::is_regexp", XS_re_is_regexp, "$"},
1401 {"re::regname", XS_re_regname, ";$$"},
1402 {"re::regnames", XS_re_regnames, ";$"},
1403 {"re::regnames_count", XS_re_regnames_count, ""},
1404 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1408 Perl_boot_core_UNIVERSAL(pTHX)
1411 static const char file[] = __FILE__;
1412 struct xsub_details *xsub = details;
1413 const struct xsub_details *end
1414 = details + sizeof(details) / sizeof(details[0]);
1417 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1418 } while (++xsub < end);
1420 /* register the overloading (type 'A') magic */
1421 PL_amagic_generation++;
1423 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1426 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1427 Safefree(CvFILE(cv));
1428 CvFILE(cv) = (char *)file;
1435 * c-indentation-style: bsd
1437 * indent-tabs-mode: t
1440 * ex: set ts=8 sts=4 sw=4 noet: