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(pTHX_ 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(aTHX_ "Usage: %"HEKf"::%"HEKf"(%s)",
312 HEKfARG(HvNAME_HEK(stash)),
313 HEKfARG(GvNAME_HEK(gv)),
316 Perl_croak(aTHX_ "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(aTHX_ "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));
819 croak_xs_usage(cv, "sv");
821 SV * const sv = ST(0);
823 SvPV_force_nolen(sv);
824 RETVAL = sv_utf8_decode(sv);
825 ST(0) = boolSV(RETVAL);
835 croak_xs_usage(cv, "sv");
837 SV * const sv = ST(0);
841 RETVAL = sv_utf8_upgrade(sv);
842 XSprePUSH; PUSHi((IV)RETVAL);
847 XS(XS_utf8_downgrade)
851 if (items < 1 || items > 2)
852 croak_xs_usage(cv, "sv, failok=0");
854 SV * const sv = ST(0);
855 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
856 const bool RETVAL = sv_utf8_downgrade(sv, failok);
858 ST(0) = boolSV(RETVAL);
863 XS(XS_utf8_native_to_unicode)
867 const UV uv = SvUV(ST(0));
870 croak_xs_usage(cv, "sv");
872 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
876 XS(XS_utf8_unicode_to_native)
880 const UV uv = SvUV(ST(0));
883 croak_xs_usage(cv, "sv");
885 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
889 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
893 SV * const svz = ST(0);
897 /* [perl #77776] - called as &foo() not foo() */
899 croak_xs_usage(cv, "SCALAR[, ON]");
904 if (SvREADONLY(sv) && !SvIsCOW(sv))
909 else if (items == 2) {
911 if (SvIsCOW(sv)) sv_force_normal(sv);
916 /* I hope you really know what you are doing. */
917 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
921 XSRETURN_UNDEF; /* Can't happen. */
924 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
928 SV * const svz = ST(0);
932 /* [perl #77776] - called as &foo() not foo() */
934 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
939 XSRETURN_UV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
940 else if (items == 2) {
941 /* I hope you really know what you are doing. */
942 SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */
943 XSRETURN_UV(SvREFCNT(sv) - 1);
945 XSRETURN_UNDEF; /* Can't happen. */
948 XS(XS_Internals_hv_clear_placehold)
953 if (items != 1 || !SvROK(ST(0)))
954 croak_xs_usage(cv, "hv");
956 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
957 hv_clear_placeholders(hv);
962 XS(XS_PerlIO_get_layers)
966 if (items < 1 || items % 2 == 0)
967 croak_xs_usage(cv, "filehandle[,args]");
974 bool details = FALSE;
978 for (svp = MARK + 2; svp <= SP; svp += 2) {
979 SV * const * const varp = svp;
980 SV * const * const valp = svp + 1;
982 const char * const key = SvPV_const(*varp, klen);
986 if (klen == 5 && memEQ(key, "input", 5)) {
987 input = SvTRUE(*valp);
992 if (klen == 6 && memEQ(key, "output", 6)) {
993 input = !SvTRUE(*valp);
998 if (klen == 7 && memEQ(key, "details", 7)) {
999 details = SvTRUE(*valp);
1006 "get_layers: unknown argument '%s'",
1015 gv = MAYBE_DEREF_GV(sv);
1017 if (!gv && !SvROK(sv))
1018 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
1020 if (gv && (io = GvIO(gv))) {
1021 AV* const av = PerlIO_get_layers(aTHX_ input ?
1022 IoIFP(io) : IoOFP(io));
1024 const I32 last = av_len(av);
1027 for (i = last; i >= 0; i -= 3) {
1028 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1029 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1030 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1032 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1033 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1034 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1037 /* Indents of 5? Yuck. */
1038 /* We know that PerlIO_get_layers creates a new SV for
1039 the name and flags, so we can just take a reference
1040 and "steal" it when we free the AV below. */
1042 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1045 ? newSVpvn_flags(SvPVX_const(*argsvp),
1047 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1051 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1057 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1061 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1063 XPUSHs(&PL_sv_undef);
1066 const IV flags = SvIVX(*flgsvp);
1068 if (flags & PERLIO_F_UTF8) {
1069 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1086 XS(XS_Internals_hash_seed)
1089 /* Using dXSARGS would also have dITEM and dSP,
1090 * which define 2 unused local variables. */
1092 PERL_UNUSED_ARG(cv);
1093 PERL_UNUSED_VAR(mark);
1094 XSRETURN_UV(PERL_HASH_SEED);
1097 XS(XS_Internals_rehash_seed)
1100 /* Using dXSARGS would also have dITEM and dSP,
1101 * which define 2 unused local variables. */
1103 PERL_UNUSED_ARG(cv);
1104 PERL_UNUSED_VAR(mark);
1105 XSRETURN_UV(PL_rehash_seed);
1108 XS(XS_Internals_HvREHASH) /* Subject to change */
1112 PERL_UNUSED_ARG(cv);
1114 const HV * const hv = (const HV *) SvRV(ST(0));
1115 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1122 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1129 PERL_UNUSED_VAR(cv);
1132 croak_xs_usage(cv, "sv");
1134 if (SvRXOK(ST(0))) {
1141 XS(XS_re_regnames_count)
1143 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1149 croak_xs_usage(cv, "");
1157 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1160 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1172 if (items < 1 || items > 2)
1173 croak_xs_usage(cv, "name[, all ]");
1178 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1183 if (items == 2 && SvTRUE(ST(1))) {
1188 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1191 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1209 croak_xs_usage(cv, "[all]");
1211 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1216 if (items == 1 && SvTRUE(ST(0))) {
1225 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1232 av = MUTABLE_AV(SvRV(ret));
1233 length = av_len(av);
1235 for (i = 0; i <= length; i++) {
1236 entry = av_fetch(av, i, FALSE);
1239 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1241 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1250 XS(XS_re_regexp_pattern)
1257 croak_xs_usage(cv, "sv");
1262 Checks if a reference is a regex or not. If the parameter is
1263 not a ref, or is not the result of a qr// then returns false
1264 in scalar context and an empty list in list context.
1265 Otherwise in list context it returns the pattern and the
1266 modifiers, in scalar context it returns the pattern just as it
1267 would if the qr// was stringified normally, regardless as
1268 to the class of the variable and any stringification overloads
1272 if ((re = SvRX(ST(0)))) /* assign deliberate */
1274 /* Houston, we have a regex! */
1277 if ( GIMME_V == G_ARRAY ) {
1279 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1285 we are in list context so stringify
1286 the modifiers that apply. We ignore "negative
1287 modifiers" in this scenario, and the default character set
1290 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1292 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1294 Copy(name, reflags + left, len, char);
1297 fptr = INT_PAT_MODS;
1298 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1299 >> RXf_PMf_STD_PMMOD_SHIFT);
1301 while((ch = *fptr++)) {
1302 if(match_flags & 1) {
1303 reflags[left++] = ch;
1308 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1309 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1311 /* return the pattern and the modifiers */
1313 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1316 /* Scalar, so use the string that Perl would return */
1317 /* return the pattern in (?msix:..) format */
1318 #if PERL_VERSION >= 11
1319 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1321 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1322 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1328 /* It ain't a regexp folks */
1329 if ( GIMME_V == G_ARRAY ) {
1330 /* return the empty list */
1333 /* Because of the (?:..) wrapping involved in a
1334 stringified pattern it is impossible to get a
1335 result for a real regexp that would evaluate to
1336 false. Therefore we can return PL_sv_no to signify
1337 that the object is not a regex, this means that one
1340 if (regex($might_be_a_regex) eq '(?:foo)') { }
1342 and not worry about undefined values.
1350 struct xsub_details {
1356 struct xsub_details details[] = {
1357 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1358 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1359 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1360 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1361 {"version::()", XS_version_noop, NULL},
1362 {"version::new", XS_version_new, NULL},
1363 {"version::parse", XS_version_new, NULL},
1364 {"version::(\"\"", XS_version_stringify, NULL},
1365 {"version::stringify", XS_version_stringify, NULL},
1366 {"version::(0+", XS_version_numify, NULL},
1367 {"version::numify", XS_version_numify, NULL},
1368 {"version::normal", XS_version_normal, NULL},
1369 {"version::(cmp", XS_version_vcmp, NULL},
1370 {"version::(<=>", XS_version_vcmp, NULL},
1371 {"version::vcmp", XS_version_vcmp, NULL},
1372 {"version::(bool", XS_version_boolean, NULL},
1373 {"version::boolean", XS_version_boolean, NULL},
1374 {"version::(+", XS_version_noop, NULL},
1375 {"version::(-", XS_version_noop, NULL},
1376 {"version::(*", XS_version_noop, NULL},
1377 {"version::(/", XS_version_noop, NULL},
1378 {"version::(+=", XS_version_noop, NULL},
1379 {"version::(-=", XS_version_noop, NULL},
1380 {"version::(*=", XS_version_noop, NULL},
1381 {"version::(/=", XS_version_noop, NULL},
1382 {"version::(abs", XS_version_noop, NULL},
1383 {"version::(nomethod", XS_version_noop, NULL},
1384 {"version::noop", XS_version_noop, NULL},
1385 {"version::is_alpha", XS_version_is_alpha, NULL},
1386 {"version::qv", XS_version_qv, NULL},
1387 {"version::declare", XS_version_qv, NULL},
1388 {"version::is_qv", XS_version_is_qv, NULL},
1389 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1390 {"utf8::valid", XS_utf8_valid, NULL},
1391 {"utf8::encode", XS_utf8_encode, NULL},
1392 {"utf8::decode", XS_utf8_decode, NULL},
1393 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1394 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1395 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1396 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1397 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1398 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1399 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1400 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1401 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1402 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1403 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1404 {"re::is_regexp", XS_re_is_regexp, "$"},
1405 {"re::regname", XS_re_regname, ";$$"},
1406 {"re::regnames", XS_re_regnames, ";$"},
1407 {"re::regnames_count", XS_re_regnames_count, ""},
1408 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1412 Perl_boot_core_UNIVERSAL(pTHX)
1415 static const char file[] = __FILE__;
1416 struct xsub_details *xsub = details;
1417 const struct xsub_details *end
1418 = details + sizeof(details) / sizeof(details[0]);
1421 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1422 } while (++xsub < end);
1424 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1427 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1428 Safefree(CvFILE(cv));
1429 CvFILE(cv) = (char *)file;
1436 * c-indentation-style: bsd
1438 * indent-tabs-mode: nil
1441 * ex: set ts=8 sts=4 sw=4 et: