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;
157 if (SvROK(sv)) { /* hugdo: */
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)
414 sv = MUTABLE_SV(SvRV(ST(0)));
416 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
420 pkg = gv_stashsv(ST(0), 0);
423 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
425 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
426 ret = sv_newmortal();
431 sv = ret = &PL_sv_undef;
440 const HEK * const name = HvNAME_HEK(pkg);
442 "%"HEKf" does not define $%"HEKf
443 "::VERSION--version check failed",
444 HEKfARG(name), HEKfARG(name));
447 "%"SVf" defines neither package nor VERSION--version check failed",
452 if ( !sv_derived_from(sv, "version"))
453 upg_version(sv, FALSE);
455 if ( !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))));
488 croak_xs_usage(cv, "class, version");
494 const char *classname;
496 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
497 const HV * stash = SvSTASH(SvRV(ST(0)));
498 classname = HvNAME(stash);
499 len = HvNAMELEN(stash);
500 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
503 classname = SvPV(ST(0), len);
504 flags = SvUTF8(ST(0));
507 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
508 /* create empty object */
512 else if ( items == 3 ) {
514 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
517 rv = new_version(vs);
518 if ( strnNE(classname,"version", len) ) /* inherited new() */
519 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
527 XS(XS_version_stringify)
532 croak_xs_usage(cv, "lobj, ...");
537 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
541 Perl_croak(aTHX_ "lobj is not of type version");
543 mPUSHs(vstringify(lobj));
550 XS(XS_version_numify)
555 croak_xs_usage(cv, "lobj, ...");
560 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
564 Perl_croak(aTHX_ "lobj is not of type version");
566 mPUSHs(vnumify(lobj));
573 XS(XS_version_normal)
578 croak_xs_usage(cv, "lobj, ...");
583 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
587 Perl_croak(aTHX_ "lobj is not of type version");
589 mPUSHs(vnormal(lobj));
601 croak_xs_usage(cv, "lobj, ...");
606 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
610 Perl_croak(aTHX_ "lobj is not of type version");
616 const IV swap = (IV)SvIV(ST(2));
618 if ( ! sv_derived_from(robj, "version") )
620 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
627 rs = newSViv(vcmp(rvs,lobj));
631 rs = newSViv(vcmp(lobj,rvs));
642 XS(XS_version_boolean)
647 croak_xs_usage(cv, "lobj, ...");
649 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
650 SV * const lobj = SvRV(ST(0));
651 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
657 Perl_croak(aTHX_ "lobj is not of type version");
665 croak_xs_usage(cv, "lobj, ...");
666 if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
667 Perl_croak(aTHX_ "operation not supported with version object");
669 Perl_croak(aTHX_ "lobj is not of type version");
670 #ifndef HASATTRIBUTE_NORETURN
675 XS(XS_version_is_alpha)
680 croak_xs_usage(cv, "lobj");
682 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
683 SV * const lobj = ST(0);
684 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
692 Perl_croak(aTHX_ "lobj is not of type version");
705 const char * classname = "";
707 if ( items == 2 && SvOK(ST(1)) ) {
709 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
710 const HV * stash = SvSTASH(SvRV(ST(0)));
711 classname = HvNAME(stash);
712 len = HvNAMELEN(stash);
713 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
716 classname = SvPV(ST(0), len);
717 flags = SvUTF8(ST(0));
720 if ( !SvVOK(ver) ) { /* not already a v-string */
722 sv_setsv(rv,ver); /* make a duplicate */
723 upg_version(rv, TRUE);
725 rv = sv_2mortal(new_version(ver));
728 && strnNE(classname,"version", len) ) { /* inherited new() */
729 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
742 croak_xs_usage(cv, "lobj");
744 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
745 SV * const lobj = ST(0);
746 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
754 Perl_croak(aTHX_ "lobj is not of type version");
762 croak_xs_usage(cv, "sv");
764 SV * const sv = ST(0);
779 croak_xs_usage(cv, "sv");
781 SV * const sv = ST(0);
783 const char * const s = SvPV_const(sv,len);
784 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
797 croak_xs_usage(cv, "sv");
798 sv_utf8_encode(ST(0));
807 croak_xs_usage(cv, "sv");
809 SV * const sv = ST(0);
811 if (SvIsCOW(sv)) sv_force_normal(sv);
812 RETVAL = sv_utf8_decode(sv);
813 ST(0) = boolSV(RETVAL);
823 croak_xs_usage(cv, "sv");
825 SV * const sv = ST(0);
829 RETVAL = sv_utf8_upgrade(sv);
830 XSprePUSH; PUSHi((IV)RETVAL);
835 XS(XS_utf8_downgrade)
839 if (items < 1 || items > 2)
840 croak_xs_usage(cv, "sv, failok=0");
842 SV * const sv = ST(0);
843 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
844 const bool RETVAL = sv_utf8_downgrade(sv, failok);
846 ST(0) = boolSV(RETVAL);
851 XS(XS_utf8_native_to_unicode)
855 const UV uv = SvUV(ST(0));
858 croak_xs_usage(cv, "sv");
860 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
864 XS(XS_utf8_unicode_to_native)
868 const UV uv = SvUV(ST(0));
871 croak_xs_usage(cv, "sv");
873 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
877 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
881 SV * const svz = ST(0);
885 /* [perl #77776] - called as &foo() not foo() */
887 croak_xs_usage(cv, "SCALAR[, ON]");
892 if (SvREADONLY(sv) && !SvIsCOW(sv))
897 else if (items == 2) {
899 if (SvIsCOW(sv)) sv_force_normal(sv);
904 /* I hope you really know what you are doing. */
905 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
909 XSRETURN_UNDEF; /* Can't happen. */
912 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
916 SV * const svz = ST(0);
920 /* [perl #77776] - called as &foo() not foo() */
922 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
927 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
928 else if (items == 2) {
929 /* I hope you really know what you are doing. */
930 SvREFCNT(sv) = SvIV(ST(1));
931 XSRETURN_IV(SvREFCNT(sv));
933 XSRETURN_UNDEF; /* Can't happen. */
936 XS(XS_Internals_hv_clear_placehold)
941 if (items != 1 || !SvROK(ST(0)))
942 croak_xs_usage(cv, "hv");
944 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
945 hv_clear_placeholders(hv);
950 XS(XS_PerlIO_get_layers)
954 if (items < 1 || items % 2 == 0)
955 croak_xs_usage(cv, "filehandle[,args]");
962 bool details = FALSE;
966 for (svp = MARK + 2; svp <= SP; svp += 2) {
967 SV * const * const varp = svp;
968 SV * const * const valp = svp + 1;
970 const char * const key = SvPV_const(*varp, klen);
974 if (klen == 5 && memEQ(key, "input", 5)) {
975 input = SvTRUE(*valp);
980 if (klen == 6 && memEQ(key, "output", 6)) {
981 input = !SvTRUE(*valp);
986 if (klen == 7 && memEQ(key, "details", 7)) {
987 details = SvTRUE(*valp);
994 "get_layers: unknown argument '%s'",
1003 gv = MUTABLE_GV(sv);
1006 if (SvROK(sv) && isGV(SvRV(sv)))
1007 gv = MUTABLE_GV(SvRV(sv));
1008 else if (SvPOKp(sv))
1009 gv = gv_fetchsv(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::(nomethod", XS_version_noop, NULL},
1367 {"version::noop", XS_version_noop, NULL},
1368 {"version::is_alpha", XS_version_is_alpha, NULL},
1369 {"version::qv", XS_version_qv, NULL},
1370 {"version::declare", XS_version_qv, NULL},
1371 {"version::is_qv", XS_version_is_qv, NULL},
1372 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1373 {"utf8::valid", XS_utf8_valid, NULL},
1374 {"utf8::encode", XS_utf8_encode, NULL},
1375 {"utf8::decode", XS_utf8_decode, NULL},
1376 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1377 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1378 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1379 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1380 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1381 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1382 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1383 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1384 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1385 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1386 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1387 {"re::is_regexp", XS_re_is_regexp, "$"},
1388 {"re::regname", XS_re_regname, ";$$"},
1389 {"re::regnames", XS_re_regnames, ";$"},
1390 {"re::regnames_count", XS_re_regnames_count, ""},
1391 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1395 Perl_boot_core_UNIVERSAL(pTHX)
1398 static const char file[] = __FILE__;
1399 struct xsub_details *xsub = details;
1400 const struct xsub_details *end
1401 = details + sizeof(details) / sizeof(details[0]);
1404 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1405 } while (++xsub < end);
1407 /* register the overloading (type 'A') magic */
1408 PL_amagic_generation++;
1410 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1413 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1414 Safefree(CvFILE(cv));
1415 CvFILE(cv) = (char *)file;
1422 * c-indentation-style: bsd
1424 * indent-tabs-mode: t
1427 * ex: set ts=8 sts=4 sw=4 noet: