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)))) {
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));
353 croak_xs_usage(cv, "object-ref, method");
359 if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv))
366 sv = MUTABLE_SV(SvRV(sv));
371 pkg = gv_stashsv(sv, 0);
373 pkg = gv_stashpv("UNIVERSAL", 0);
377 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
379 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
386 XS(XS_UNIVERSAL_DOES)
393 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
395 SV * const sv = ST(0);
396 if (sv_does_sv( sv, ST(1), 0 ))
403 XS(XS_UNIVERSAL_VERSION)
415 sv = MUTABLE_SV(SvRV(ST(0)));
417 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
421 pkg = gv_stashsv(ST(0), 0);
424 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
426 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
427 SV * const nsv = sv_newmortal();
430 if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
431 upg_version(sv, FALSE);
445 const HEK * const name = HvNAME_HEK(pkg);
447 "%"HEKf" does not define $%"HEKf
448 "::VERSION--version check failed",
449 HEKfARG(name), HEKfARG(name));
452 "%"SVf" defines neither package nor VERSION--version check failed",
457 if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
458 /* req may very well be R/O, so create a new object */
459 req = sv_2mortal( new_version(req) );
462 if ( vcmp( req, sv ) > 0 ) {
463 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
464 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
465 "this is only version %"SVf"",
466 HEKfARG(HvNAME_HEK(pkg)),
467 SVfARG(sv_2mortal(vnormal(req))),
468 SVfARG(sv_2mortal(vnormal(sv))));
470 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
471 "this is only version %"SVf,
472 HEKfARG(HvNAME_HEK(pkg)),
473 SVfARG(sv_2mortal(vstringify(req))),
474 SVfARG(sv_2mortal(vstringify(sv))));
480 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
481 ST(0) = sv_2mortal(vstringify(sv));
494 croak_xs_usage(cv, "class, version");
500 const char *classname;
502 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
503 const HV * stash = SvSTASH(SvRV(ST(0)));
504 classname = HvNAME(stash);
505 len = HvNAMELEN(stash);
506 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
509 classname = SvPV(ST(0), len);
510 flags = SvUTF8(ST(0));
513 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
514 /* create empty object */
518 else if ( items == 3 ) {
520 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
523 rv = new_version(vs);
524 if ( strnNE(classname,"version", len) ) /* inherited new() */
525 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
533 XS(XS_version_stringify)
538 croak_xs_usage(cv, "lobj, ...");
543 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
547 Perl_croak(aTHX_ "lobj is not of type version");
549 mPUSHs(vstringify(lobj));
556 XS(XS_version_numify)
561 croak_xs_usage(cv, "lobj, ...");
566 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
570 Perl_croak(aTHX_ "lobj is not of type version");
572 mPUSHs(vnumify(lobj));
579 XS(XS_version_normal)
584 croak_xs_usage(cv, "lobj, ...");
589 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
593 Perl_croak(aTHX_ "lobj is not of type version");
595 mPUSHs(vnormal(lobj));
607 croak_xs_usage(cv, "lobj, ...");
612 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
616 Perl_croak(aTHX_ "lobj is not of type version");
622 const IV swap = (IV)SvIV(ST(2));
624 if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
626 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
633 rs = newSViv(vcmp(rvs,lobj));
637 rs = newSViv(vcmp(lobj,rvs));
648 XS(XS_version_boolean)
653 croak_xs_usage(cv, "lobj, ...");
655 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
656 SV * const lobj = SvRV(ST(0));
659 sv_2mortal(new_version(
660 sv_2mortal(newSVpvs("0"))
669 Perl_croak(aTHX_ "lobj is not of type version");
677 croak_xs_usage(cv, "lobj, ...");
678 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
679 Perl_croak(aTHX_ "operation not supported with version object");
681 Perl_croak(aTHX_ "lobj is not of type version");
682 #ifndef HASATTRIBUTE_NORETURN
687 XS(XS_version_is_alpha)
692 croak_xs_usage(cv, "lobj");
694 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
695 SV * const lobj = ST(0);
696 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
704 Perl_croak(aTHX_ "lobj is not of type version");
717 const char * classname = "";
719 if ( items == 2 && SvOK(ST(1)) ) {
721 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
722 const HV * stash = SvSTASH(SvRV(ST(0)));
723 classname = HvNAME(stash);
724 len = HvNAMELEN(stash);
725 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
728 classname = SvPV(ST(0), len);
729 flags = SvUTF8(ST(0));
732 if ( !SvVOK(ver) ) { /* not already a v-string */
734 sv_setsv(rv,ver); /* make a duplicate */
735 upg_version(rv, TRUE);
737 rv = sv_2mortal(new_version(ver));
740 && strnNE(classname,"version", len) ) { /* inherited new() */
741 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
754 croak_xs_usage(cv, "lobj");
756 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
757 SV * const lobj = ST(0);
758 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
766 Perl_croak(aTHX_ "lobj is not of type version");
774 croak_xs_usage(cv, "sv");
776 SV * const sv = ST(0);
791 croak_xs_usage(cv, "sv");
793 SV * const sv = ST(0);
795 const char * const s = SvPV_const(sv,len);
796 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
809 croak_xs_usage(cv, "sv");
810 sv_utf8_encode(ST(0));
820 croak_xs_usage(cv, "sv");
822 SV * const sv = ST(0);
824 SvPV_force_nolen(sv);
825 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);
1038 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
1040 /* Indents of 5? Yuck. */
1041 /* We know that PerlIO_get_layers creates a new SV for
1042 the name and flags, so we can just take a reference
1043 and "steal" it when we free the AV below. */
1045 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1048 ? newSVpvn_flags(SvPVX_const(*argsvp),
1050 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1054 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1060 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1064 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1066 PUSHs(&PL_sv_undef);
1069 const IV flags = SvIVX(*flgsvp);
1071 if (flags & PERLIO_F_UTF8) {
1072 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1089 XS(XS_Internals_hash_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(PERL_HASH_SEED);
1100 XS(XS_Internals_rehash_seed)
1103 /* Using dXSARGS would also have dITEM and dSP,
1104 * which define 2 unused local variables. */
1106 PERL_UNUSED_ARG(cv);
1107 PERL_UNUSED_VAR(mark);
1108 XSRETURN_UV(PL_rehash_seed);
1111 XS(XS_Internals_HvREHASH) /* Subject to change */
1115 PERL_UNUSED_ARG(cv);
1117 const HV * const hv = (const HV *) SvRV(ST(0));
1118 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1125 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1132 PERL_UNUSED_VAR(cv);
1135 croak_xs_usage(cv, "sv");
1137 if (SvRXOK(ST(0))) {
1144 XS(XS_re_regnames_count)
1146 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1152 croak_xs_usage(cv, "");
1160 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1163 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1175 if (items < 1 || items > 2)
1176 croak_xs_usage(cv, "name[, all ]");
1181 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1186 if (items == 2 && SvTRUE(ST(1))) {
1191 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1194 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1212 croak_xs_usage(cv, "[all]");
1214 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1219 if (items == 1 && SvTRUE(ST(0))) {
1228 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1235 av = MUTABLE_AV(SvRV(ret));
1236 length = av_len(av);
1238 EXTEND(SP, length+1); /* better extend stack just once */
1239 for (i = 0; i <= length; i++) {
1240 entry = av_fetch(av, i, FALSE);
1243 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1245 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
1254 XS(XS_re_regexp_pattern)
1261 croak_xs_usage(cv, "sv");
1266 Checks if a reference is a regex or not. If the parameter is
1267 not a ref, or is not the result of a qr// then returns false
1268 in scalar context and an empty list in list context.
1269 Otherwise in list context it returns the pattern and the
1270 modifiers, in scalar context it returns the pattern just as it
1271 would if the qr// was stringified normally, regardless as
1272 to the class of the variable and any stringification overloads
1276 if ((re = SvRX(ST(0)))) /* assign deliberate */
1278 /* Houston, we have a regex! */
1281 if ( GIMME_V == G_ARRAY ) {
1283 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1289 we are in list context so stringify
1290 the modifiers that apply. We ignore "negative
1291 modifiers" in this scenario, and the default character set
1294 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1296 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1298 Copy(name, reflags + left, len, char);
1301 fptr = INT_PAT_MODS;
1302 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1303 >> RXf_PMf_STD_PMMOD_SHIFT);
1305 while((ch = *fptr++)) {
1306 if(match_flags & 1) {
1307 reflags[left++] = ch;
1312 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1313 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1315 /* return the pattern and the modifiers */
1318 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1321 /* Scalar, so use the string that Perl would return */
1322 /* return the pattern in (?msix:..) format */
1323 #if PERL_VERSION >= 11
1324 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1326 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1327 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1333 /* It ain't a regexp folks */
1334 if ( GIMME_V == G_ARRAY ) {
1335 /* return the empty list */
1338 /* Because of the (?:..) wrapping involved in a
1339 stringified pattern it is impossible to get a
1340 result for a real regexp that would evaluate to
1341 false. Therefore we can return PL_sv_no to signify
1342 that the object is not a regex, this means that one
1345 if (regex($might_be_a_regex) eq '(?:foo)') { }
1347 and not worry about undefined values.
1355 struct xsub_details {
1361 const struct xsub_details details[] = {
1362 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1363 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1364 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1365 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1366 {"version::()", XS_version_noop, NULL},
1367 {"version::new", XS_version_new, NULL},
1368 {"version::parse", XS_version_new, NULL},
1369 {"version::(\"\"", XS_version_stringify, NULL},
1370 {"version::stringify", XS_version_stringify, NULL},
1371 {"version::(0+", XS_version_numify, NULL},
1372 {"version::numify", XS_version_numify, NULL},
1373 {"version::normal", XS_version_normal, NULL},
1374 {"version::(cmp", XS_version_vcmp, NULL},
1375 {"version::(<=>", XS_version_vcmp, NULL},
1376 {"version::vcmp", XS_version_vcmp, NULL},
1377 {"version::(bool", XS_version_boolean, NULL},
1378 {"version::boolean", XS_version_boolean, 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::(-=", XS_version_noop, NULL},
1385 {"version::(*=", XS_version_noop, NULL},
1386 {"version::(/=", XS_version_noop, NULL},
1387 {"version::(abs", XS_version_noop, NULL},
1388 {"version::(nomethod", XS_version_noop, NULL},
1389 {"version::noop", XS_version_noop, NULL},
1390 {"version::is_alpha", XS_version_is_alpha, NULL},
1391 {"version::qv", XS_version_qv, NULL},
1392 {"version::declare", XS_version_qv, NULL},
1393 {"version::is_qv", XS_version_is_qv, NULL},
1394 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1395 {"utf8::valid", XS_utf8_valid, NULL},
1396 {"utf8::encode", XS_utf8_encode, NULL},
1397 {"utf8::decode", XS_utf8_decode, NULL},
1398 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1399 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1400 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1401 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1402 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1403 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1404 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1405 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1406 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1407 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1408 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1409 {"re::is_regexp", XS_re_is_regexp, "$"},
1410 {"re::regname", XS_re_regname, ";$$"},
1411 {"re::regnames", XS_re_regnames, ";$"},
1412 {"re::regnames_count", XS_re_regnames_count, ""},
1413 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1417 Perl_boot_core_UNIVERSAL(pTHX)
1420 static const char file[] = __FILE__;
1421 const struct xsub_details *xsub = details;
1422 const struct xsub_details *end
1423 = details + sizeof(details) / sizeof(details[0]);
1426 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1427 } while (++xsub < end);
1429 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1432 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1433 Safefree(CvFILE(cv));
1434 CvFILE(cv) = (char *)file;
1441 * c-indentation-style: bsd
1443 * indent-tabs-mode: nil
1446 * ex: set ts=8 sts=4 sw=4 et: