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);
168 stash = gv_stashpv("UNIVERSAL", 0);
171 return stash ? isa_lookup(stash, name, len, flags) : FALSE;
175 =for apidoc sv_does_sv
177 Returns a boolean indicating whether the SV performs a specific, named role.
178 The SV can be a Perl object or the name of a Perl class.
186 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
193 PERL_ARGS_ASSERT_SV_DOES_SV;
194 PERL_UNUSED_ARG(flags);
201 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
202 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
207 if (sv_isobject(sv)) {
208 classname = sv_ref(NULL,SvRV(sv),TRUE);
213 if (sv_eq(classname, namesv)) {
224 methodname = newSVpvs_flags("isa", SVs_TEMP);
225 /* ugly hack: use the SvSCREAM flag so S_method_common
226 * can figure out we're calling DOES() and not isa(),
227 * and report eventual errors correctly. --rgs */
228 SvSCREAM_on(methodname);
229 call_sv(methodname, G_SCALAR | G_METHOD);
232 does_it = SvTRUE( TOPs );
242 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
248 Perl_sv_does(pTHX_ SV *sv, const char *const name)
250 PERL_ARGS_ASSERT_SV_DOES;
251 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
255 =for apidoc sv_does_pv
257 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
264 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
266 PERL_ARGS_ASSERT_SV_DOES_PV;
267 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
271 =for apidoc sv_does_pvn
273 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
279 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
281 PERL_ARGS_ASSERT_SV_DOES_PVN;
283 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
287 =for apidoc croak_xs_usage
289 A specialised variant of C<croak()> for emitting the usage message for xsubs
291 croak_xs_usage(cv, "eee_yow");
293 works out the package name and subroutine name from C<cv>, and then calls
294 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
296 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
302 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
304 const GV *const gv = CvGV(cv);
306 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
309 const HV *const stash = GvSTASH(gv);
311 if (HvNAME_get(stash))
312 Perl_croak(aTHX_ "Usage: %"HEKf"::%"HEKf"(%s)",
313 HEKfARG(HvNAME_HEK(stash)),
314 HEKfARG(GvNAME_HEK(gv)),
317 Perl_croak(aTHX_ "Usage: %"HEKf"(%s)",
318 HEKfARG(GvNAME_HEK(gv)), params);
320 /* Pants. I don't think that it should be possible to get here. */
321 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
331 croak_xs_usage(cv, "reference, kind");
333 SV * const sv = ST(0);
337 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
338 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
341 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
355 croak_xs_usage(cv, "object-ref, method");
361 if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv))
362 || (SvGMAGICAL(sv) && (SvNIOKp(sv) || (SvPOKp(sv) && SvCUR(sv))))))
368 sv = MUTABLE_SV(SvRV(sv));
373 pkg = gv_stashsv(sv, 0);
375 pkg = gv_stashpv("UNIVERSAL", 0);
379 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
381 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
388 XS(XS_UNIVERSAL_DOES)
395 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
397 SV * const sv = ST(0);
398 if (sv_does_sv( sv, ST(1), 0 ))
405 XS(XS_UNIVERSAL_VERSION)
417 sv = MUTABLE_SV(SvRV(ST(0)));
419 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
423 pkg = gv_stashsv(ST(0), 0);
426 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
428 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
429 SV * const nsv = sv_newmortal();
432 if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
433 upg_version(sv, FALSE);
447 const HEK * const name = HvNAME_HEK(pkg);
449 "%"HEKf" does not define $%"HEKf
450 "::VERSION--version check failed",
451 HEKfARG(name), HEKfARG(name));
454 "%"SVf" defines neither package nor VERSION--version check failed",
459 if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
460 /* req may very well be R/O, so create a new object */
461 req = sv_2mortal( new_version(req) );
464 if ( vcmp( req, sv ) > 0 ) {
465 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
466 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
467 "this is only version %"SVf"",
468 HEKfARG(HvNAME_HEK(pkg)),
469 SVfARG(sv_2mortal(vnormal(req))),
470 SVfARG(sv_2mortal(vnormal(sv))));
472 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
473 "this is only version %"SVf,
474 HEKfARG(HvNAME_HEK(pkg)),
475 SVfARG(sv_2mortal(vstringify(req))),
476 SVfARG(sv_2mortal(vstringify(sv))));
482 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
483 ST(0) = sv_2mortal(vstringify(sv));
496 croak_xs_usage(cv, "class, version");
502 const char *classname;
504 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
505 const HV * stash = SvSTASH(SvRV(ST(0)));
506 classname = HvNAME(stash);
507 len = HvNAMELEN(stash);
508 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
511 classname = SvPV(ST(0), len);
512 flags = SvUTF8(ST(0));
515 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
516 /* create empty object */
520 else if ( items == 3 ) {
522 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
525 rv = new_version(vs);
526 if ( strnNE(classname,"version", len) ) /* inherited new() */
527 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
535 XS(XS_version_stringify)
540 croak_xs_usage(cv, "lobj, ...");
545 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
549 Perl_croak(aTHX_ "lobj is not of type version");
551 mPUSHs(vstringify(lobj));
558 XS(XS_version_numify)
563 croak_xs_usage(cv, "lobj, ...");
568 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
572 Perl_croak(aTHX_ "lobj is not of type version");
574 mPUSHs(vnumify(lobj));
581 XS(XS_version_normal)
586 croak_xs_usage(cv, "lobj, ...");
591 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
595 Perl_croak(aTHX_ "lobj is not of type version");
597 mPUSHs(vnormal(lobj));
609 croak_xs_usage(cv, "lobj, ...");
614 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
618 Perl_croak(aTHX_ "lobj is not of type version");
624 const IV swap = (IV)SvIV(ST(2));
626 if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
628 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
635 rs = newSViv(vcmp(rvs,lobj));
639 rs = newSViv(vcmp(lobj,rvs));
650 XS(XS_version_boolean)
655 croak_xs_usage(cv, "lobj, ...");
657 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
658 SV * const lobj = SvRV(ST(0));
661 sv_2mortal(new_version(
662 sv_2mortal(newSVpvs("0"))
671 Perl_croak(aTHX_ "lobj is not of type version");
679 croak_xs_usage(cv, "lobj, ...");
680 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
681 Perl_croak(aTHX_ "operation not supported with version object");
683 Perl_croak(aTHX_ "lobj is not of type version");
684 #ifndef HASATTRIBUTE_NORETURN
689 XS(XS_version_is_alpha)
694 croak_xs_usage(cv, "lobj");
696 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
697 SV * const lobj = ST(0);
698 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
706 Perl_croak(aTHX_ "lobj is not of type version");
719 const char * classname = "";
721 if ( items == 2 && SvOK(ST(1)) ) {
723 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
724 const HV * stash = SvSTASH(SvRV(ST(0)));
725 classname = HvNAME(stash);
726 len = HvNAMELEN(stash);
727 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
730 classname = SvPV(ST(0), len);
731 flags = SvUTF8(ST(0));
734 if ( !SvVOK(ver) ) { /* not already a v-string */
736 sv_setsv(rv,ver); /* make a duplicate */
737 upg_version(rv, TRUE);
739 rv = sv_2mortal(new_version(ver));
742 && strnNE(classname,"version", len) ) { /* inherited new() */
743 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
756 croak_xs_usage(cv, "lobj");
758 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
759 SV * const lobj = ST(0);
760 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
768 Perl_croak(aTHX_ "lobj is not of type version");
776 croak_xs_usage(cv, "sv");
778 SV * const sv = ST(0);
793 croak_xs_usage(cv, "sv");
795 SV * const sv = ST(0);
797 const char * const s = SvPV_const(sv,len);
798 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
811 croak_xs_usage(cv, "sv");
812 sv_utf8_encode(ST(0));
821 croak_xs_usage(cv, "sv");
823 SV * const sv = ST(0);
825 SvPV_force_nolen(sv);
826 RETVAL = sv_utf8_decode(sv);
827 ST(0) = boolSV(RETVAL);
837 croak_xs_usage(cv, "sv");
839 SV * const sv = ST(0);
843 RETVAL = sv_utf8_upgrade(sv);
844 XSprePUSH; PUSHi((IV)RETVAL);
849 XS(XS_utf8_downgrade)
853 if (items < 1 || items > 2)
854 croak_xs_usage(cv, "sv, failok=0");
856 SV * const sv = ST(0);
857 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
858 const bool RETVAL = sv_utf8_downgrade(sv, failok);
860 ST(0) = boolSV(RETVAL);
865 XS(XS_utf8_native_to_unicode)
869 const UV uv = SvUV(ST(0));
872 croak_xs_usage(cv, "sv");
874 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
878 XS(XS_utf8_unicode_to_native)
882 const UV uv = SvUV(ST(0));
885 croak_xs_usage(cv, "sv");
887 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
891 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
895 SV * const svz = ST(0);
899 /* [perl #77776] - called as &foo() not foo() */
901 croak_xs_usage(cv, "SCALAR[, ON]");
906 if (SvREADONLY(sv) && !SvIsCOW(sv))
911 else if (items == 2) {
913 if (SvIsCOW(sv)) sv_force_normal(sv);
918 /* I hope you really know what you are doing. */
919 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
923 XSRETURN_UNDEF; /* Can't happen. */
926 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
930 SV * const svz = ST(0);
934 /* [perl #77776] - called as &foo() not foo() */
936 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
941 XSRETURN_UV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
942 else if (items == 2) {
943 /* I hope you really know what you are doing. */
944 SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */
945 XSRETURN_UV(SvREFCNT(sv) - 1);
947 XSRETURN_UNDEF; /* Can't happen. */
950 XS(XS_Internals_hv_clear_placehold)
955 if (items != 1 || !SvROK(ST(0)))
956 croak_xs_usage(cv, "hv");
958 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
959 hv_clear_placeholders(hv);
964 XS(XS_PerlIO_get_layers)
968 if (items < 1 || items % 2 == 0)
969 croak_xs_usage(cv, "filehandle[,args]");
976 bool details = FALSE;
980 for (svp = MARK + 2; svp <= SP; svp += 2) {
981 SV * const * const varp = svp;
982 SV * const * const valp = svp + 1;
984 const char * const key = SvPV_const(*varp, klen);
988 if (klen == 5 && memEQ(key, "input", 5)) {
989 input = SvTRUE(*valp);
994 if (klen == 6 && memEQ(key, "output", 6)) {
995 input = !SvTRUE(*valp);
1000 if (klen == 7 && memEQ(key, "details", 7)) {
1001 details = SvTRUE(*valp);
1008 "get_layers: unknown argument '%s'",
1017 gv = MAYBE_DEREF_GV(sv);
1019 if (!gv && !SvROK(sv))
1020 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1022 if (gv && (io = GvIO(gv))) {
1023 AV* const av = PerlIO_get_layers(aTHX_ input ?
1024 IoIFP(io) : IoOFP(io));
1026 const I32 last = av_len(av);
1029 for (i = last; i >= 0; i -= 3) {
1030 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1031 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1032 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1034 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1035 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1036 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1039 /* Indents of 5? Yuck. */
1040 /* We know that PerlIO_get_layers creates a new SV for
1041 the name and flags, so we can just take a reference
1042 and "steal" it when we free the AV below. */
1044 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1047 ? newSVpvn_flags(SvPVX_const(*argsvp),
1049 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1053 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1059 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1063 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1065 XPUSHs(&PL_sv_undef);
1068 const IV flags = SvIVX(*flgsvp);
1070 if (flags & PERLIO_F_UTF8) {
1071 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1088 XS(XS_Internals_hash_seed)
1091 /* Using dXSARGS would also have dITEM and dSP,
1092 * which define 2 unused local variables. */
1094 PERL_UNUSED_ARG(cv);
1095 PERL_UNUSED_VAR(mark);
1096 XSRETURN_UV(PERL_HASH_SEED);
1099 XS(XS_Internals_rehash_seed)
1102 /* Using dXSARGS would also have dITEM and dSP,
1103 * which define 2 unused local variables. */
1105 PERL_UNUSED_ARG(cv);
1106 PERL_UNUSED_VAR(mark);
1107 XSRETURN_UV(PL_rehash_seed);
1110 XS(XS_Internals_HvREHASH) /* Subject to change */
1114 PERL_UNUSED_ARG(cv);
1116 const HV * const hv = (const HV *) SvRV(ST(0));
1117 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1124 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
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 for (i = 0; i <= length; i++) {
1238 entry = av_fetch(av, i, FALSE);
1241 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1243 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1252 XS(XS_re_regexp_pattern)
1259 croak_xs_usage(cv, "sv");
1264 Checks if a reference is a regex or not. If the parameter is
1265 not a ref, or is not the result of a qr// then returns false
1266 in scalar context and an empty list in list context.
1267 Otherwise in list context it returns the pattern and the
1268 modifiers, in scalar context it returns the pattern just as it
1269 would if the qr// was stringified normally, regardless as
1270 to the class of the variable and any stringification overloads
1274 if ((re = SvRX(ST(0)))) /* assign deliberate */
1276 /* Houston, we have a regex! */
1279 if ( GIMME_V == G_ARRAY ) {
1281 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1287 we are in list context so stringify
1288 the modifiers that apply. We ignore "negative
1289 modifiers" in this scenario, and the default character set
1292 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1294 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1296 Copy(name, reflags + left, len, char);
1299 fptr = INT_PAT_MODS;
1300 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1301 >> RXf_PMf_STD_PMMOD_SHIFT);
1303 while((ch = *fptr++)) {
1304 if(match_flags & 1) {
1305 reflags[left++] = ch;
1310 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1311 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1313 /* return the pattern and the modifiers */
1315 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1318 /* Scalar, so use the string that Perl would return */
1319 /* return the pattern in (?msix:..) format */
1320 #if PERL_VERSION >= 11
1321 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1323 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1324 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1330 /* It ain't a regexp folks */
1331 if ( GIMME_V == G_ARRAY ) {
1332 /* return the empty list */
1335 /* Because of the (?:..) wrapping involved in a
1336 stringified pattern it is impossible to get a
1337 result for a real regexp that would evaluate to
1338 false. Therefore we can return PL_sv_no to signify
1339 that the object is not a regex, this means that one
1342 if (regex($might_be_a_regex) eq '(?:foo)') { }
1344 and not worry about undefined values.
1352 struct xsub_details {
1358 struct xsub_details details[] = {
1359 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1360 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1361 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1362 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1363 {"version::()", XS_version_noop, NULL},
1364 {"version::new", XS_version_new, NULL},
1365 {"version::parse", XS_version_new, NULL},
1366 {"version::(\"\"", XS_version_stringify, NULL},
1367 {"version::stringify", XS_version_stringify, NULL},
1368 {"version::(0+", XS_version_numify, NULL},
1369 {"version::numify", XS_version_numify, NULL},
1370 {"version::normal", XS_version_normal, NULL},
1371 {"version::(cmp", XS_version_vcmp, NULL},
1372 {"version::(<=>", XS_version_vcmp, NULL},
1373 {"version::vcmp", XS_version_vcmp, NULL},
1374 {"version::(bool", XS_version_boolean, NULL},
1375 {"version::boolean", XS_version_boolean, 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::(+=", XS_version_noop, NULL},
1381 {"version::(-=", XS_version_noop, NULL},
1382 {"version::(*=", XS_version_noop, NULL},
1383 {"version::(/=", XS_version_noop, NULL},
1384 {"version::(abs", XS_version_noop, NULL},
1385 {"version::(nomethod", XS_version_noop, NULL},
1386 {"version::noop", XS_version_noop, NULL},
1387 {"version::is_alpha", XS_version_is_alpha, NULL},
1388 {"version::qv", XS_version_qv, NULL},
1389 {"version::declare", XS_version_qv, NULL},
1390 {"version::is_qv", XS_version_is_qv, NULL},
1391 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1392 {"utf8::valid", XS_utf8_valid, NULL},
1393 {"utf8::encode", XS_utf8_encode, NULL},
1394 {"utf8::decode", XS_utf8_decode, NULL},
1395 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1396 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1397 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1398 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1399 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1400 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1401 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1402 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1403 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1404 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1405 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1406 {"re::is_regexp", XS_re_is_regexp, "$"},
1407 {"re::regname", XS_re_regname, ";$$"},
1408 {"re::regnames", XS_re_regnames, ";$"},
1409 {"re::regnames_count", XS_re_regnames_count, ""},
1410 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1414 Perl_boot_core_UNIVERSAL(pTHX)
1417 static const char file[] = __FILE__;
1418 struct xsub_details *xsub = details;
1419 const struct xsub_details *end
1420 = details + sizeof(details) / sizeof(details[0]);
1423 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1424 } while (++xsub < end);
1426 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1429 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1430 Safefree(CvFILE(cv));
1431 CvFILE(cv) = (char *)file;
1438 * c-indentation-style: bsd
1440 * indent-tabs-mode: nil
1443 * ex: set ts=8 sts=4 sw=4 et: