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_stashpvs("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)))) {
206 if (sv_isobject(sv)) {
207 classname = sv_ref(NULL,SvRV(sv),TRUE);
212 if (sv_eq(classname, namesv)) {
223 methodname = newSVpvs_flags("isa", SVs_TEMP);
224 /* ugly hack: use the SvSCREAM flag so S_method_common
225 * can figure out we're calling DOES() and not isa(),
226 * and report eventual errors correctly. --rgs */
227 SvSCREAM_on(methodname);
228 call_sv(methodname, G_SCALAR | G_METHOD);
231 does_it = SvTRUE( TOPs );
241 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
247 Perl_sv_does(pTHX_ SV *sv, const char *const name)
249 PERL_ARGS_ASSERT_SV_DOES;
250 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
254 =for apidoc sv_does_pv
256 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
263 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
265 PERL_ARGS_ASSERT_SV_DOES_PV;
266 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
270 =for apidoc sv_does_pvn
272 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
278 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
280 PERL_ARGS_ASSERT_SV_DOES_PVN;
282 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
286 =for apidoc croak_xs_usage
288 A specialised variant of C<croak()> for emitting the usage message for xsubs
290 croak_xs_usage(cv, "eee_yow");
292 works out the package name and subroutine name from C<cv>, and then calls
293 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
295 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
301 Perl_croak_xs_usage(const CV *const cv, const char *const params)
303 const GV *const gv = CvGV(cv);
305 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
308 const HV *const stash = GvSTASH(gv);
310 if (HvNAME_get(stash))
311 Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)",
312 HEKfARG(HvNAME_HEK(stash)),
313 HEKfARG(GvNAME_HEK(gv)),
316 Perl_croak_nocontext("Usage: %"HEKf"(%s)",
317 HEKfARG(GvNAME_HEK(gv)), params);
319 /* Pants. I don't think that it should be possible to get here. */
320 Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
330 croak_xs_usage(cv, "reference, kind");
332 SV * const sv = ST(0);
336 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
339 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
354 croak_xs_usage(cv, "object-ref, method");
360 /* Reject undef and empty string. Note that the string form takes
361 precedence here over the numeric form, as (!1)->foo treats the
362 invocant as the empty string, though it is a dualvar. */
363 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
369 sv = MUTABLE_SV(SvRV(sv));
372 else if (isGV_with_GP(sv) && GvIO(sv))
373 pkg = SvSTASH(GvIO(sv));
375 else if (isGV_with_GP(sv) && GvIO(sv))
376 pkg = SvSTASH(GvIO(sv));
377 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
378 pkg = SvSTASH(GvIO(iogv));
380 pkg = gv_stashsv(sv, 0);
382 pkg = gv_stashpv("UNIVERSAL", 0);
386 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
388 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
395 XS(XS_UNIVERSAL_DOES)
402 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
404 SV * const sv = ST(0);
405 if (sv_does_sv( sv, ST(1), 0 ))
412 XS(XS_UNIVERSAL_VERSION)
424 sv = MUTABLE_SV(SvRV(ST(0)));
426 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
430 pkg = gv_stashsv(ST(0), 0);
433 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
435 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
436 SV * const nsv = sv_newmortal();
439 if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
440 upg_version(sv, FALSE);
454 const HEK * const name = HvNAME_HEK(pkg);
456 "%"HEKf" does not define $%"HEKf
457 "::VERSION--version check failed",
458 HEKfARG(name), HEKfARG(name));
461 "%"SVf" defines neither package nor VERSION--version check failed",
466 if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
467 /* req may very well be R/O, so create a new object */
468 req = sv_2mortal( new_version(req) );
471 if ( vcmp( req, sv ) > 0 ) {
472 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
473 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
474 "this is only version %"SVf"",
475 HEKfARG(HvNAME_HEK(pkg)),
476 SVfARG(sv_2mortal(vnormal(req))),
477 SVfARG(sv_2mortal(vnormal(sv))));
479 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
480 "this is only version %"SVf,
481 HEKfARG(HvNAME_HEK(pkg)),
482 SVfARG(sv_2mortal(vstringify(req))),
483 SVfARG(sv_2mortal(vstringify(sv))));
489 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
490 ST(0) = sv_2mortal(vstringify(sv));
502 if (items > 3 || items < 1)
503 croak_xs_usage(cv, "class, version");
509 const char *classname;
511 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
512 const HV * stash = SvSTASH(SvRV(ST(0)));
513 classname = HvNAME(stash);
514 len = HvNAMELEN(stash);
515 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
518 classname = SvPV(ST(0), len);
519 flags = SvUTF8(ST(0));
522 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
523 /* create empty object */
527 else if ( items == 3 ) {
529 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
532 rv = new_version(vs);
533 if ( strnNE(classname,"version", len) ) /* inherited new() */
534 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
542 XS(XS_version_stringify)
547 croak_xs_usage(cv, "lobj, ...");
552 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
556 Perl_croak(aTHX_ "lobj is not of type version");
558 mPUSHs(vstringify(lobj));
565 XS(XS_version_numify)
570 croak_xs_usage(cv, "lobj, ...");
575 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
579 Perl_croak(aTHX_ "lobj is not of type version");
581 mPUSHs(vnumify(lobj));
588 XS(XS_version_normal)
593 croak_xs_usage(cv, "lobj, ...");
598 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
602 Perl_croak(aTHX_ "lobj is not of type version");
604 mPUSHs(vnormal(lobj));
616 croak_xs_usage(cv, "lobj, ...");
621 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
625 Perl_croak(aTHX_ "lobj is not of type version");
631 const IV swap = (IV)SvIV(ST(2));
633 if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
635 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
642 rs = newSViv(vcmp(rvs,lobj));
646 rs = newSViv(vcmp(lobj,rvs));
657 XS(XS_version_boolean)
662 croak_xs_usage(cv, "lobj, ...");
664 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
665 SV * const lobj = SvRV(ST(0));
668 sv_2mortal(new_version(
669 sv_2mortal(newSVpvs("0"))
678 Perl_croak(aTHX_ "lobj is not of type version");
686 croak_xs_usage(cv, "lobj, ...");
687 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
688 Perl_croak(aTHX_ "operation not supported with version object");
690 Perl_croak(aTHX_ "lobj is not of type version");
691 #ifndef HASATTRIBUTE_NORETURN
696 XS(XS_version_is_alpha)
701 croak_xs_usage(cv, "lobj");
703 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
704 SV * const lobj = ST(0);
705 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
713 Perl_croak(aTHX_ "lobj is not of type version");
726 const char * classname = "";
728 if ( items == 2 && SvOK(ST(1)) ) {
730 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
731 const HV * stash = SvSTASH(SvRV(ST(0)));
732 classname = HvNAME(stash);
733 len = HvNAMELEN(stash);
734 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
737 classname = SvPV(ST(0), len);
738 flags = SvUTF8(ST(0));
741 if ( !SvVOK(ver) ) { /* not already a v-string */
743 sv_setsv(rv,ver); /* make a duplicate */
744 upg_version(rv, TRUE);
746 rv = sv_2mortal(new_version(ver));
749 && strnNE(classname,"version", len) ) { /* inherited new() */
750 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
763 croak_xs_usage(cv, "lobj");
765 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
766 SV * const lobj = ST(0);
767 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
775 Perl_croak(aTHX_ "lobj is not of type version");
783 croak_xs_usage(cv, "sv");
785 SV * const sv = ST(0);
800 croak_xs_usage(cv, "sv");
802 SV * const sv = ST(0);
804 const char * const s = SvPV_const(sv,len);
805 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
818 croak_xs_usage(cv, "sv");
819 sv_utf8_encode(ST(0));
829 croak_xs_usage(cv, "sv");
831 SV * const sv = ST(0);
833 SvPV_force_nolen(sv);
834 RETVAL = sv_utf8_decode(sv);
836 ST(0) = boolSV(RETVAL);
846 croak_xs_usage(cv, "sv");
848 SV * const sv = ST(0);
852 RETVAL = sv_utf8_upgrade(sv);
853 XSprePUSH; PUSHi((IV)RETVAL);
858 XS(XS_utf8_downgrade)
862 if (items < 1 || items > 2)
863 croak_xs_usage(cv, "sv, failok=0");
865 SV * const sv = ST(0);
866 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
867 const bool RETVAL = sv_utf8_downgrade(sv, failok);
869 ST(0) = boolSV(RETVAL);
874 XS(XS_utf8_native_to_unicode)
878 const UV uv = SvUV(ST(0));
881 croak_xs_usage(cv, "sv");
883 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
887 XS(XS_utf8_unicode_to_native)
891 const UV uv = SvUV(ST(0));
894 croak_xs_usage(cv, "sv");
896 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
900 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
904 SV * const svz = ST(0);
908 /* [perl #77776] - called as &foo() not foo() */
910 croak_xs_usage(cv, "SCALAR[, ON]");
920 else if (items == 2) {
922 #ifdef PERL_OLD_COPY_ON_WRITE
923 if (SvIsCOW(sv)) sv_force_normal(sv);
926 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
927 /* for constant.pm; nobody else should be calling this
930 for (svp = AvARRAY(sv) + AvFILLp(sv)
933 if (*svp) SvPADTMP_on(*svp);
938 /* I hope you really know what you are doing. */
943 XSRETURN_UNDEF; /* Can't happen. */
945 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
949 SV * const svz = ST(0);
954 /* [perl #77776] - called as &foo() not foo() */
955 if ((items != 1 && items != 2) || !SvROK(svz))
956 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
960 /* I hope you really know what you are doing. */
961 /* idea is for SvREFCNT(sv) to be accessed only once */
962 refcnt = items == 2 ?
963 /* we free one ref on exit */
964 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
966 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
970 XS(XS_Internals_hv_clear_placehold)
975 if (items != 1 || !SvROK(ST(0)))
976 croak_xs_usage(cv, "hv");
978 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
979 hv_clear_placeholders(hv);
984 XS(XS_PerlIO_get_layers)
988 if (items < 1 || items % 2 == 0)
989 croak_xs_usage(cv, "filehandle[,args]");
996 bool details = FALSE;
1000 for (svp = MARK + 2; svp <= SP; svp += 2) {
1001 SV * const * const varp = svp;
1002 SV * const * const valp = svp + 1;
1004 const char * const key = SvPV_const(*varp, klen);
1008 if (klen == 5 && memEQ(key, "input", 5)) {
1009 input = SvTRUE(*valp);
1014 if (klen == 6 && memEQ(key, "output", 6)) {
1015 input = !SvTRUE(*valp);
1020 if (klen == 7 && memEQ(key, "details", 7)) {
1021 details = SvTRUE(*valp);
1028 "get_layers: unknown argument '%s'",
1037 gv = MAYBE_DEREF_GV(sv);
1039 if (!gv && !SvROK(sv))
1040 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1042 if (gv && (io = GvIO(gv))) {
1043 AV* const av = PerlIO_get_layers(aTHX_ input ?
1044 IoIFP(io) : IoOFP(io));
1046 const SSize_t last = av_len(av);
1049 for (i = last; i >= 0; i -= 3) {
1050 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1051 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1052 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1054 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1055 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1056 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1058 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
1060 /* Indents of 5? Yuck. */
1061 /* We know that PerlIO_get_layers creates a new SV for
1062 the name and flags, so we can just take a reference
1063 and "steal" it when we free the AV below. */
1065 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1068 ? newSVpvn_flags(SvPVX_const(*argsvp),
1070 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1074 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1080 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1084 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1086 PUSHs(&PL_sv_undef);
1089 const IV flags = SvIVX(*flgsvp);
1091 if (flags & PERLIO_F_UTF8) {
1092 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1114 PERL_UNUSED_VAR(cv);
1117 croak_xs_usage(cv, "sv");
1119 if (SvRXOK(ST(0))) {
1126 XS(XS_re_regnames_count)
1128 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1134 croak_xs_usage(cv, "");
1142 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1145 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1157 if (items < 1 || items > 2)
1158 croak_xs_usage(cv, "name[, all ]");
1163 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1168 if (items == 2 && SvTRUE(ST(1))) {
1173 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1176 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1194 croak_xs_usage(cv, "[all]");
1196 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1201 if (items == 1 && SvTRUE(ST(0))) {
1210 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1217 av = MUTABLE_AV(SvRV(ret));
1218 length = av_len(av);
1220 EXTEND(SP, length+1); /* better extend stack just once */
1221 for (i = 0; i <= length; i++) {
1222 entry = av_fetch(av, i, FALSE);
1225 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1227 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
1236 XS(XS_re_regexp_pattern)
1245 croak_xs_usage(cv, "sv");
1248 Checks if a reference is a regex or not. If the parameter is
1249 not a ref, or is not the result of a qr// then returns false
1250 in scalar context and an empty list in list context.
1251 Otherwise in list context it returns the pattern and the
1252 modifiers, in scalar context it returns the pattern just as it
1253 would if the qr// was stringified normally, regardless as
1254 to the class of the variable and any stringification overloads
1258 if ((re = SvRX(ST(0)))) /* assign deliberate */
1260 /* Houston, we have a regex! */
1263 if ( GIMME_V == G_ARRAY ) {
1265 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1271 we are in list context so stringify
1272 the modifiers that apply. We ignore "negative
1273 modifiers" in this scenario, and the default character set
1276 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1278 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1280 Copy(name, reflags + left, len, char);
1283 fptr = INT_PAT_MODS;
1284 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1285 >> RXf_PMf_STD_PMMOD_SHIFT);
1287 while((ch = *fptr++)) {
1288 if(match_flags & 1) {
1289 reflags[left++] = ch;
1294 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1295 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1297 /* return the pattern and the modifiers */
1299 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1302 /* Scalar, so use the string that Perl would return */
1303 /* return the pattern in (?msix:..) format */
1304 #if PERL_VERSION >= 11
1305 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1307 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1308 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1314 /* It ain't a regexp folks */
1315 if ( GIMME_V == G_ARRAY ) {
1316 /* return the empty list */
1319 /* Because of the (?:..) wrapping involved in a
1320 stringified pattern it is impossible to get a
1321 result for a real regexp that would evaluate to
1322 false. Therefore we can return PL_sv_no to signify
1323 that the object is not a regex, this means that one
1326 if (regex($might_be_a_regex) eq '(?:foo)') { }
1328 and not worry about undefined values.
1336 struct xsub_details {
1342 const struct xsub_details details[] = {
1343 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1344 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1345 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1346 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1347 {"version::()", XS_version_noop, NULL},
1348 {"version::new", XS_version_new, NULL},
1349 {"version::parse", XS_version_new, NULL},
1350 {"version::(\"\"", XS_version_stringify, NULL},
1351 {"version::stringify", XS_version_stringify, NULL},
1352 {"version::(0+", XS_version_numify, NULL},
1353 {"version::numify", XS_version_numify, NULL},
1354 {"version::normal", XS_version_normal, NULL},
1355 {"version::(cmp", XS_version_vcmp, NULL},
1356 {"version::(<=>", XS_version_vcmp, NULL},
1357 {"version::vcmp", XS_version_vcmp, NULL},
1358 {"version::(bool", XS_version_boolean, NULL},
1359 {"version::boolean", XS_version_boolean, NULL},
1360 {"version::(+", XS_version_noop, NULL},
1361 {"version::(-", XS_version_noop, NULL},
1362 {"version::(*", XS_version_noop, NULL},
1363 {"version::(/", XS_version_noop, NULL},
1364 {"version::(+=", XS_version_noop, NULL},
1365 {"version::(-=", XS_version_noop, NULL},
1366 {"version::(*=", XS_version_noop, NULL},
1367 {"version::(/=", XS_version_noop, NULL},
1368 {"version::(abs", XS_version_noop, NULL},
1369 {"version::(nomethod", XS_version_noop, NULL},
1370 {"version::noop", XS_version_noop, NULL},
1371 {"version::is_alpha", XS_version_is_alpha, NULL},
1372 {"version::qv", XS_version_qv, NULL},
1373 {"version::declare", XS_version_qv, NULL},
1374 {"version::is_qv", XS_version_is_qv, NULL},
1375 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1376 {"utf8::valid", XS_utf8_valid, NULL},
1377 {"utf8::encode", XS_utf8_encode, NULL},
1378 {"utf8::decode", XS_utf8_decode, NULL},
1379 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1380 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1381 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1382 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1383 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1384 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1385 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1386 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
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 const 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 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1410 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1411 Safefree(CvFILE(cv));
1412 CvFILE(cv) = (char *)file;
1419 * c-indentation-style: bsd
1421 * indent-tabs-mode: nil
1424 * ex: set ts=8 sts=4 sw=4 et: