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 /* Reject undef and empty string. Note that the string form takes
360 precedence here over the numeric form, as (!1)->foo treats the
361 invocant as the empty string, though it is a dualvar. */
362 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
368 sv = MUTABLE_SV(SvRV(sv));
371 else if (isGV_with_GP(sv) && GvIO(sv))
372 pkg = SvSTASH(GvIO(sv));
374 else if (isGV_with_GP(sv) && GvIO(sv))
375 pkg = SvSTASH(GvIO(sv));
377 pkg = gv_stashsv(sv, 0);
379 pkg = gv_stashpv("UNIVERSAL", 0);
383 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
385 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
392 XS(XS_UNIVERSAL_DOES)
399 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
401 SV * const sv = ST(0);
402 if (sv_does_sv( sv, ST(1), 0 ))
409 XS(XS_UNIVERSAL_VERSION)
421 sv = MUTABLE_SV(SvRV(ST(0)));
423 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
427 pkg = gv_stashsv(ST(0), 0);
430 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
432 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
433 SV * const nsv = sv_newmortal();
436 if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
437 upg_version(sv, FALSE);
451 const HEK * const name = HvNAME_HEK(pkg);
453 "%"HEKf" does not define $%"HEKf
454 "::VERSION--version check failed",
455 HEKfARG(name), HEKfARG(name));
458 "%"SVf" defines neither package nor VERSION--version check failed",
463 if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
464 /* req may very well be R/O, so create a new object */
465 req = sv_2mortal( new_version(req) );
468 if ( vcmp( req, sv ) > 0 ) {
469 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
470 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
471 "this is only version %"SVf"",
472 HEKfARG(HvNAME_HEK(pkg)),
473 SVfARG(sv_2mortal(vnormal(req))),
474 SVfARG(sv_2mortal(vnormal(sv))));
476 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
477 "this is only version %"SVf,
478 HEKfARG(HvNAME_HEK(pkg)),
479 SVfARG(sv_2mortal(vstringify(req))),
480 SVfARG(sv_2mortal(vstringify(sv))));
486 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
487 ST(0) = sv_2mortal(vstringify(sv));
499 if (items > 3 || items < 1)
500 croak_xs_usage(cv, "class, version");
506 const char *classname;
508 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
509 const HV * stash = SvSTASH(SvRV(ST(0)));
510 classname = HvNAME(stash);
511 len = HvNAMELEN(stash);
512 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
515 classname = SvPV(ST(0), len);
516 flags = SvUTF8(ST(0));
519 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
520 /* create empty object */
524 else if ( items == 3 ) {
526 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
529 rv = new_version(vs);
530 if ( strnNE(classname,"version", len) ) /* inherited new() */
531 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
539 XS(XS_version_stringify)
544 croak_xs_usage(cv, "lobj, ...");
549 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
553 Perl_croak(aTHX_ "lobj is not of type version");
555 mPUSHs(vstringify(lobj));
562 XS(XS_version_numify)
567 croak_xs_usage(cv, "lobj, ...");
572 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
576 Perl_croak(aTHX_ "lobj is not of type version");
578 mPUSHs(vnumify(lobj));
585 XS(XS_version_normal)
590 croak_xs_usage(cv, "lobj, ...");
595 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
599 Perl_croak(aTHX_ "lobj is not of type version");
601 mPUSHs(vnormal(lobj));
613 croak_xs_usage(cv, "lobj, ...");
618 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
622 Perl_croak(aTHX_ "lobj is not of type version");
628 const IV swap = (IV)SvIV(ST(2));
630 if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
632 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
639 rs = newSViv(vcmp(rvs,lobj));
643 rs = newSViv(vcmp(lobj,rvs));
654 XS(XS_version_boolean)
659 croak_xs_usage(cv, "lobj, ...");
661 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
662 SV * const lobj = SvRV(ST(0));
665 sv_2mortal(new_version(
666 sv_2mortal(newSVpvs("0"))
675 Perl_croak(aTHX_ "lobj is not of type version");
683 croak_xs_usage(cv, "lobj, ...");
684 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
685 Perl_croak(aTHX_ "operation not supported with version object");
687 Perl_croak(aTHX_ "lobj is not of type version");
688 #ifndef HASATTRIBUTE_NORETURN
693 XS(XS_version_is_alpha)
698 croak_xs_usage(cv, "lobj");
700 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
701 SV * const lobj = ST(0);
702 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
710 Perl_croak(aTHX_ "lobj is not of type version");
723 const char * classname = "";
725 if ( items == 2 && SvOK(ST(1)) ) {
727 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
728 const HV * stash = SvSTASH(SvRV(ST(0)));
729 classname = HvNAME(stash);
730 len = HvNAMELEN(stash);
731 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
734 classname = SvPV(ST(0), len);
735 flags = SvUTF8(ST(0));
738 if ( !SvVOK(ver) ) { /* not already a v-string */
740 sv_setsv(rv,ver); /* make a duplicate */
741 upg_version(rv, TRUE);
743 rv = sv_2mortal(new_version(ver));
746 && strnNE(classname,"version", len) ) { /* inherited new() */
747 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
760 croak_xs_usage(cv, "lobj");
762 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
763 SV * const lobj = ST(0);
764 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
772 Perl_croak(aTHX_ "lobj is not of type version");
780 croak_xs_usage(cv, "sv");
782 SV * const sv = ST(0);
797 croak_xs_usage(cv, "sv");
799 SV * const sv = ST(0);
801 const char * const s = SvPV_const(sv,len);
802 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
815 croak_xs_usage(cv, "sv");
816 sv_utf8_encode(ST(0));
826 croak_xs_usage(cv, "sv");
828 SV * const sv = ST(0);
830 SvPV_force_nolen(sv);
831 RETVAL = sv_utf8_decode(sv);
833 ST(0) = boolSV(RETVAL);
843 croak_xs_usage(cv, "sv");
845 SV * const sv = ST(0);
849 RETVAL = sv_utf8_upgrade(sv);
850 XSprePUSH; PUSHi((IV)RETVAL);
855 XS(XS_utf8_downgrade)
859 if (items < 1 || items > 2)
860 croak_xs_usage(cv, "sv, failok=0");
862 SV * const sv = ST(0);
863 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
864 const bool RETVAL = sv_utf8_downgrade(sv, failok);
866 ST(0) = boolSV(RETVAL);
871 XS(XS_utf8_native_to_unicode)
875 const UV uv = SvUV(ST(0));
878 croak_xs_usage(cv, "sv");
880 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
884 XS(XS_utf8_unicode_to_native)
888 const UV uv = SvUV(ST(0));
891 croak_xs_usage(cv, "sv");
893 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
897 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
901 SV * const svz = ST(0);
905 /* [perl #77776] - called as &foo() not foo() */
907 croak_xs_usage(cv, "SCALAR[, ON]");
912 if (SvREADONLY(sv) && !SvIsCOW(sv))
917 else if (items == 2) {
919 if (SvIsCOW(sv)) sv_force_normal(sv);
924 /* I hope you really know what you are doing. */
925 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
929 XSRETURN_UNDEF; /* Can't happen. */
931 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
935 SV * const svz = ST(0);
940 /* [perl #77776] - called as &foo() not foo() */
941 if ((items != 1 && items != 2) || !SvROK(svz))
942 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
946 /* I hope you really know what you are doing. */
947 /* idea is for SvREFCNT(sv) to be accessed only once */
948 refcnt = items == 2 ?
949 /* we free one ref on exit */
950 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
952 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
956 XS(XS_Internals_hv_clear_placehold)
961 if (items != 1 || !SvROK(ST(0)))
962 croak_xs_usage(cv, "hv");
964 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
965 hv_clear_placeholders(hv);
970 XS(XS_PerlIO_get_layers)
974 if (items < 1 || items % 2 == 0)
975 croak_xs_usage(cv, "filehandle[,args]");
982 bool details = FALSE;
986 for (svp = MARK + 2; svp <= SP; svp += 2) {
987 SV * const * const varp = svp;
988 SV * const * const valp = svp + 1;
990 const char * const key = SvPV_const(*varp, klen);
994 if (klen == 5 && memEQ(key, "input", 5)) {
995 input = SvTRUE(*valp);
1000 if (klen == 6 && memEQ(key, "output", 6)) {
1001 input = !SvTRUE(*valp);
1006 if (klen == 7 && memEQ(key, "details", 7)) {
1007 details = SvTRUE(*valp);
1014 "get_layers: unknown argument '%s'",
1023 gv = MAYBE_DEREF_GV(sv);
1025 if (!gv && !SvROK(sv))
1026 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1028 if (gv && (io = GvIO(gv))) {
1029 AV* const av = PerlIO_get_layers(aTHX_ input ?
1030 IoIFP(io) : IoOFP(io));
1032 const I32 last = av_len(av);
1035 for (i = last; i >= 0; i -= 3) {
1036 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1037 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1038 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1040 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1041 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1042 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1044 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
1046 /* Indents of 5? Yuck. */
1047 /* We know that PerlIO_get_layers creates a new SV for
1048 the name and flags, so we can just take a reference
1049 and "steal" it when we free the AV below. */
1051 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1054 ? newSVpvn_flags(SvPVX_const(*argsvp),
1056 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1060 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1066 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1070 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1072 PUSHs(&PL_sv_undef);
1075 const IV flags = SvIVX(*flgsvp);
1077 if (flags & PERLIO_F_UTF8) {
1078 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1100 PERL_UNUSED_VAR(cv);
1103 croak_xs_usage(cv, "sv");
1105 if (SvRXOK(ST(0))) {
1112 XS(XS_re_regnames_count)
1114 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1120 croak_xs_usage(cv, "");
1128 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1131 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1143 if (items < 1 || items > 2)
1144 croak_xs_usage(cv, "name[, all ]");
1149 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1154 if (items == 2 && SvTRUE(ST(1))) {
1159 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1162 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1180 croak_xs_usage(cv, "[all]");
1182 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1187 if (items == 1 && SvTRUE(ST(0))) {
1196 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1203 av = MUTABLE_AV(SvRV(ret));
1204 length = av_len(av);
1206 EXTEND(SP, length+1); /* better extend stack just once */
1207 for (i = 0; i <= length; i++) {
1208 entry = av_fetch(av, i, FALSE);
1211 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1213 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
1222 XS(XS_re_regexp_pattern)
1231 croak_xs_usage(cv, "sv");
1234 Checks if a reference is a regex or not. If the parameter is
1235 not a ref, or is not the result of a qr// then returns false
1236 in scalar context and an empty list in list context.
1237 Otherwise in list context it returns the pattern and the
1238 modifiers, in scalar context it returns the pattern just as it
1239 would if the qr// was stringified normally, regardless as
1240 to the class of the variable and any stringification overloads
1244 if ((re = SvRX(ST(0)))) /* assign deliberate */
1246 /* Houston, we have a regex! */
1249 if ( GIMME_V == G_ARRAY ) {
1251 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1257 we are in list context so stringify
1258 the modifiers that apply. We ignore "negative
1259 modifiers" in this scenario, and the default character set
1262 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1264 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1266 Copy(name, reflags + left, len, char);
1269 fptr = INT_PAT_MODS;
1270 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1271 >> RXf_PMf_STD_PMMOD_SHIFT);
1273 while((ch = *fptr++)) {
1274 if(match_flags & 1) {
1275 reflags[left++] = ch;
1280 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1281 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1283 /* return the pattern and the modifiers */
1285 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1288 /* Scalar, so use the string that Perl would return */
1289 /* return the pattern in (?msix:..) format */
1290 #if PERL_VERSION >= 11
1291 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1293 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1294 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1300 /* It ain't a regexp folks */
1301 if ( GIMME_V == G_ARRAY ) {
1302 /* return the empty list */
1305 /* Because of the (?:..) wrapping involved in a
1306 stringified pattern it is impossible to get a
1307 result for a real regexp that would evaluate to
1308 false. Therefore we can return PL_sv_no to signify
1309 that the object is not a regex, this means that one
1312 if (regex($might_be_a_regex) eq '(?:foo)') { }
1314 and not worry about undefined values.
1322 struct xsub_details {
1328 const struct xsub_details details[] = {
1329 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1330 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1331 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1332 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1333 {"version::()", XS_version_noop, NULL},
1334 {"version::new", XS_version_new, NULL},
1335 {"version::parse", XS_version_new, NULL},
1336 {"version::(\"\"", XS_version_stringify, NULL},
1337 {"version::stringify", XS_version_stringify, NULL},
1338 {"version::(0+", XS_version_numify, NULL},
1339 {"version::numify", XS_version_numify, NULL},
1340 {"version::normal", XS_version_normal, NULL},
1341 {"version::(cmp", XS_version_vcmp, NULL},
1342 {"version::(<=>", XS_version_vcmp, NULL},
1343 {"version::vcmp", XS_version_vcmp, NULL},
1344 {"version::(bool", XS_version_boolean, NULL},
1345 {"version::boolean", XS_version_boolean, NULL},
1346 {"version::(+", XS_version_noop, NULL},
1347 {"version::(-", XS_version_noop, NULL},
1348 {"version::(*", XS_version_noop, NULL},
1349 {"version::(/", XS_version_noop, NULL},
1350 {"version::(+=", XS_version_noop, NULL},
1351 {"version::(-=", XS_version_noop, NULL},
1352 {"version::(*=", XS_version_noop, NULL},
1353 {"version::(/=", XS_version_noop, NULL},
1354 {"version::(abs", XS_version_noop, NULL},
1355 {"version::(nomethod", XS_version_noop, NULL},
1356 {"version::noop", XS_version_noop, NULL},
1357 {"version::is_alpha", XS_version_is_alpha, NULL},
1358 {"version::qv", XS_version_qv, NULL},
1359 {"version::declare", XS_version_qv, NULL},
1360 {"version::is_qv", XS_version_is_qv, NULL},
1361 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1362 {"utf8::valid", XS_utf8_valid, NULL},
1363 {"utf8::encode", XS_utf8_encode, NULL},
1364 {"utf8::decode", XS_utf8_decode, NULL},
1365 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1366 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1367 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1368 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1369 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1370 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1371 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1372 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1373 {"re::is_regexp", XS_re_is_regexp, "$"},
1374 {"re::regname", XS_re_regname, ";$$"},
1375 {"re::regnames", XS_re_regnames, ";$"},
1376 {"re::regnames_count", XS_re_regnames_count, ""},
1377 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1381 Perl_boot_core_UNIVERSAL(pTHX)
1384 static const char file[] = __FILE__;
1385 const struct xsub_details *xsub = details;
1386 const struct xsub_details *end
1387 = details + sizeof(details) / sizeof(details[0]);
1390 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1391 } while (++xsub < end);
1393 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1396 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1397 Safefree(CvFILE(cv));
1398 CvFILE(cv) = (char *)file;
1405 * c-indentation-style: bsd
1407 * indent-tabs-mode: nil
1410 * ex: set ts=8 sts=4 sw=4 et: