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));
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));
493 if (items > 3 || items < 1)
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. */
925 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
929 SV * const svz = ST(0);
934 /* [perl #77776] - called as &foo() not foo() */
935 if ((items != 1 && items != 2) || !SvROK(svz))
936 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
940 /* I hope you really know what you are doing. */
941 /* idea is for SvREFCNT(sv) to be accessed only once */
942 refcnt = items == 2 ?
943 /* we free one ref on exit */
944 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
946 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
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));
1094 PERL_UNUSED_VAR(cv);
1097 croak_xs_usage(cv, "sv");
1099 if (SvRXOK(ST(0))) {
1106 XS(XS_re_regnames_count)
1108 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1114 croak_xs_usage(cv, "");
1122 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1125 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1137 if (items < 1 || items > 2)
1138 croak_xs_usage(cv, "name[, all ]");
1143 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1148 if (items == 2 && SvTRUE(ST(1))) {
1153 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1156 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1174 croak_xs_usage(cv, "[all]");
1176 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1181 if (items == 1 && SvTRUE(ST(0))) {
1190 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1197 av = MUTABLE_AV(SvRV(ret));
1198 length = av_len(av);
1200 EXTEND(SP, length+1); /* better extend stack just once */
1201 for (i = 0; i <= length; i++) {
1202 entry = av_fetch(av, i, FALSE);
1205 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1207 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
1216 XS(XS_re_regexp_pattern)
1225 croak_xs_usage(cv, "sv");
1228 Checks if a reference is a regex or not. If the parameter is
1229 not a ref, or is not the result of a qr// then returns false
1230 in scalar context and an empty list in list context.
1231 Otherwise in list context it returns the pattern and the
1232 modifiers, in scalar context it returns the pattern just as it
1233 would if the qr// was stringified normally, regardless as
1234 to the class of the variable and any stringification overloads
1238 if ((re = SvRX(ST(0)))) /* assign deliberate */
1240 /* Houston, we have a regex! */
1243 if ( GIMME_V == G_ARRAY ) {
1245 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1251 we are in list context so stringify
1252 the modifiers that apply. We ignore "negative
1253 modifiers" in this scenario, and the default character set
1256 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1258 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1260 Copy(name, reflags + left, len, char);
1263 fptr = INT_PAT_MODS;
1264 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1265 >> RXf_PMf_STD_PMMOD_SHIFT);
1267 while((ch = *fptr++)) {
1268 if(match_flags & 1) {
1269 reflags[left++] = ch;
1274 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1275 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1277 /* return the pattern and the modifiers */
1279 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1282 /* Scalar, so use the string that Perl would return */
1283 /* return the pattern in (?msix:..) format */
1284 #if PERL_VERSION >= 11
1285 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1287 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1288 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1294 /* It ain't a regexp folks */
1295 if ( GIMME_V == G_ARRAY ) {
1296 /* return the empty list */
1299 /* Because of the (?:..) wrapping involved in a
1300 stringified pattern it is impossible to get a
1301 result for a real regexp that would evaluate to
1302 false. Therefore we can return PL_sv_no to signify
1303 that the object is not a regex, this means that one
1306 if (regex($might_be_a_regex) eq '(?:foo)') { }
1308 and not worry about undefined values.
1316 struct xsub_details {
1322 const struct xsub_details details[] = {
1323 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1324 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1325 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1326 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1327 {"version::()", XS_version_noop, NULL},
1328 {"version::new", XS_version_new, NULL},
1329 {"version::parse", XS_version_new, NULL},
1330 {"version::(\"\"", XS_version_stringify, NULL},
1331 {"version::stringify", XS_version_stringify, NULL},
1332 {"version::(0+", XS_version_numify, NULL},
1333 {"version::numify", XS_version_numify, NULL},
1334 {"version::normal", XS_version_normal, NULL},
1335 {"version::(cmp", XS_version_vcmp, NULL},
1336 {"version::(<=>", XS_version_vcmp, NULL},
1337 {"version::vcmp", XS_version_vcmp, NULL},
1338 {"version::(bool", XS_version_boolean, NULL},
1339 {"version::boolean", XS_version_boolean, NULL},
1340 {"version::(+", XS_version_noop, NULL},
1341 {"version::(-", XS_version_noop, NULL},
1342 {"version::(*", XS_version_noop, NULL},
1343 {"version::(/", XS_version_noop, NULL},
1344 {"version::(+=", XS_version_noop, NULL},
1345 {"version::(-=", XS_version_noop, NULL},
1346 {"version::(*=", XS_version_noop, NULL},
1347 {"version::(/=", XS_version_noop, NULL},
1348 {"version::(abs", XS_version_noop, NULL},
1349 {"version::(nomethod", XS_version_noop, NULL},
1350 {"version::noop", XS_version_noop, NULL},
1351 {"version::is_alpha", XS_version_is_alpha, NULL},
1352 {"version::qv", XS_version_qv, NULL},
1353 {"version::declare", XS_version_qv, NULL},
1354 {"version::is_qv", XS_version_is_qv, NULL},
1355 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1356 {"utf8::valid", XS_utf8_valid, NULL},
1357 {"utf8::encode", XS_utf8_encode, NULL},
1358 {"utf8::decode", XS_utf8_decode, NULL},
1359 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1360 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1361 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1362 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1363 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1364 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1365 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1366 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1367 {"re::is_regexp", XS_re_is_regexp, "$"},
1368 {"re::regname", XS_re_regname, ";$$"},
1369 {"re::regnames", XS_re_regnames, ";$"},
1370 {"re::regnames_count", XS_re_regnames_count, ""},
1371 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1375 Perl_boot_core_UNIVERSAL(pTHX)
1378 static const char file[] = __FILE__;
1379 const struct xsub_details *xsub = details;
1380 const struct xsub_details *end
1381 = details + sizeof(details) / sizeof(details[0]);
1384 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1385 } while (++xsub < end);
1387 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1390 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1391 Safefree(CvFILE(cv));
1392 CvFILE(cv) = (char *)file;
1399 * c-indentation-style: bsd
1401 * indent-tabs-mode: nil
1404 * ex: set ts=8 sts=4 sw=4 et: