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 seperate 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 S_get_isa_hash(pTHX_ HV *const stash)
40 struct mro_meta *const meta = HvMROMETA(stash);
42 PERL_ARGS_ASSERT_GET_ISA_HASH;
45 AV *const isa = mro_get_linear_isa(stash);
47 HV *const isa_hash = newHV();
48 /* Linearisation didn't build it for us, so do it here. */
49 SV *const *svp = AvARRAY(isa);
50 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
51 const HEK *const canon_name = HvNAME_HEK(stash);
53 while (svp < svp_end) {
54 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
57 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
58 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
59 HV_FETCH_ISSTORE, &PL_sv_undef,
60 HEK_HASH(canon_name));
61 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
63 SvREADONLY_on(isa_hash);
72 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
73 * The main guts of traverse_isa was actually copied from gv_fetchmeth
77 S_isa_lookup(pTHX_ HV *stash, const char * const name)
80 const struct mro_meta *const meta = HvMROMETA(stash);
81 HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash);
82 STRLEN len = strlen(name);
85 PERL_ARGS_ASSERT_ISA_LOOKUP;
87 if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
89 HV_FETCH_ISEXISTS, NULL, 0)) {
90 /* Direct name lookup worked. */
94 /* A stash/class can go by many names (ie. User == main::User), so
95 we use the name in the stash itself, which is canonical. */
96 our_stash = gv_stashpvn(name, len, 0);
99 HEK *const canon_name = HvNAME_HEK(our_stash);
101 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
102 HEK_FLAGS(canon_name),
103 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
112 =head1 SV Manipulation Functions
114 =for apidoc sv_derived_from
116 Returns a boolean indicating whether the SV is derived from the specified class
117 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
124 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
129 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
136 type = sv_reftype(sv,0);
137 if (type && strEQ(type,name))
139 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
142 stash = gv_stashsv(sv, 0);
145 return stash ? isa_lookup(stash, name) : FALSE;
151 Returns a boolean indicating whether the SV performs a specific, named role.
152 The SV can be a Perl object or the name of a Perl class.
160 Perl_sv_does(pTHX_ SV *sv, const char *const name)
162 const char *classname;
167 PERL_ARGS_ASSERT_SV_DOES;
174 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
175 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
180 if (sv_isobject(sv)) {
181 classname = sv_reftype(SvRV(sv),TRUE);
183 classname = SvPV_nolen(sv);
186 if (strEQ(name,classname)) {
193 mXPUSHs(newSVpv(name, 0));
196 methodname = newSVpvs_flags("isa", SVs_TEMP);
197 /* ugly hack: use the SvSCREAM flag so S_method_common
198 * can figure out we're calling DOES() and not isa(),
199 * and report eventual errors correctly. --rgs */
200 SvSCREAM_on(methodname);
201 call_sv(methodname, G_SCALAR | G_METHOD);
204 does_it = SvTRUE( TOPs );
212 =for apidoc croak_xs_usage
214 A specialised variant of C<croak()> for emitting the usage message for xsubs
216 croak_xs_usage(cv, "eee_yow");
218 works out the package name and subroutine name from C<cv>, and then calls
219 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
221 Perl_croak(aTHX_ "Usage: %s::%s(%s)", "ouch" "awk", "eee_yow");
227 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
229 const GV *const gv = CvGV(cv);
231 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
234 const char *const gvname = GvNAME(gv);
235 const HV *const stash = GvSTASH(gv);
236 const char *const hvname = stash ? HvNAME_get(stash) : NULL;
239 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
241 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
243 /* Pants. I don't think that it should be possible to get here. */
244 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
254 croak_xs_usage(cv, "reference, kind");
256 SV * const sv = ST(0);
261 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
262 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
265 name = SvPV_nolen_const(ST(1));
267 ST(0) = boolSV(sv_derived_from(sv, name));
282 croak_xs_usage(cv, "object-ref, method");
288 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
289 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
292 name = SvPV_nolen_const(ST(1));
296 sv = MUTABLE_SV(SvRV(sv));
301 pkg = gv_stashsv(sv, 0);
305 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
307 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
314 XS(XS_UNIVERSAL_DOES)
321 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
323 SV * const sv = ST(0);
326 name = SvPV_nolen_const(ST(1));
327 if (sv_does( sv, name ))
334 XS(XS_UNIVERSAL_VERSION)
346 sv = MUTABLE_SV(SvRV(ST(0)));
348 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
352 pkg = gv_stashsv(ST(0), 0);
355 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
357 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
358 SV * const nsv = sv_newmortal();
361 if ( !sv_derived_from(sv, "version"))
362 upg_version(sv, FALSE);
375 const char * const name = HvNAME_get(pkg);
377 "%s does not define $%s::VERSION--version check failed",
381 "%s defines neither package nor VERSION--version check failed",
382 SvPVx_nolen_const(ST(0)) );
386 if ( !sv_derived_from(req, "version")) {
387 /* req may very well be R/O, so create a new object */
388 req = sv_2mortal( new_version(req) );
391 if ( vcmp( req, sv ) > 0 ) {
392 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
393 Perl_croak(aTHX_ "%s version %"SVf" required--"
394 "this is only version %"SVf"", HvNAME_get(pkg),
395 SVfARG(sv_2mortal(vnormal(req))),
396 SVfARG(sv_2mortal(vnormal(sv))));
398 Perl_croak(aTHX_ "%s version %"SVf" required--"
399 "this is only version %"SVf"", HvNAME_get(pkg),
400 SVfARG(sv_2mortal(vstringify(req))),
401 SVfARG(sv_2mortal(vstringify(sv))));
407 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
408 ST(0) = sv_2mortal(vstringify(sv));
421 croak_xs_usage(cv, "class, version");
426 const char * const classname =
427 sv_isobject(ST(0)) /* get the class if called as an object method */
428 ? HvNAME(SvSTASH(SvRV(ST(0))))
429 : (char *)SvPV_nolen(ST(0));
431 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
432 /* create empty object */
436 else if ( items == 3 ) {
438 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
441 rv = new_version(vs);
442 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
443 sv_bless(rv, gv_stashpv(classname, GV_ADD));
451 XS(XS_version_stringify)
456 croak_xs_usage(cv, "lobj, ...");
461 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
465 Perl_croak(aTHX_ "lobj is not of type version");
467 mPUSHs(vstringify(lobj));
474 XS(XS_version_numify)
479 croak_xs_usage(cv, "lobj, ...");
484 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
488 Perl_croak(aTHX_ "lobj is not of type version");
490 mPUSHs(vnumify(lobj));
497 XS(XS_version_normal)
502 croak_xs_usage(cv, "lobj, ...");
507 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
511 Perl_croak(aTHX_ "lobj is not of type version");
513 mPUSHs(vnormal(lobj));
525 croak_xs_usage(cv, "lobj, ...");
530 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
534 Perl_croak(aTHX_ "lobj is not of type version");
540 const IV swap = (IV)SvIV(ST(2));
542 if ( ! sv_derived_from(robj, "version") )
544 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
551 rs = newSViv(vcmp(rvs,lobj));
555 rs = newSViv(vcmp(lobj,rvs));
566 XS(XS_version_boolean)
571 croak_xs_usage(cv, "lobj, ...");
573 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
574 SV * const lobj = SvRV(ST(0));
575 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
581 Perl_croak(aTHX_ "lobj is not of type version");
589 croak_xs_usage(cv, "lobj, ...");
590 if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
591 Perl_croak(aTHX_ "operation not supported with version object");
593 Perl_croak(aTHX_ "lobj is not of type version");
594 #ifndef HASATTRIBUTE_NORETURN
599 XS(XS_version_is_alpha)
604 croak_xs_usage(cv, "lobj");
606 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
607 SV * const lobj = ST(0);
608 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
616 Perl_croak(aTHX_ "lobj is not of type version");
628 const char * classname = "";
629 if ( items == 2 && SvOK(ST(1)) ) {
630 /* getting called as object or class method */
633 sv_isobject(ST(0)) /* class called as an object method */
634 ? HvNAME_get(SvSTASH(SvRV(ST(0))))
635 : (char *)SvPV_nolen(ST(0));
637 if ( !SvVOK(ver) ) { /* not already a v-string */
639 sv_setsv(rv,ver); /* make a duplicate */
640 upg_version(rv, TRUE);
642 rv = sv_2mortal(new_version(ver));
644 if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
645 sv_bless(rv, gv_stashpv(classname, GV_ADD));
658 croak_xs_usage(cv, "lobj");
660 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
661 SV * const lobj = ST(0);
662 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
670 Perl_croak(aTHX_ "lobj is not of type version");
678 croak_xs_usage(cv, "sv");
680 SV * const sv = ST(0);
695 croak_xs_usage(cv, "sv");
697 SV * const sv = ST(0);
699 const char * const s = SvPV_const(sv,len);
700 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
713 croak_xs_usage(cv, "sv");
714 sv_utf8_encode(ST(0));
723 croak_xs_usage(cv, "sv");
725 SV * const sv = ST(0);
726 const bool RETVAL = sv_utf8_decode(sv);
727 ST(0) = boolSV(RETVAL);
738 croak_xs_usage(cv, "sv");
740 SV * const sv = ST(0);
744 RETVAL = sv_utf8_upgrade(sv);
745 XSprePUSH; PUSHi((IV)RETVAL);
750 XS(XS_utf8_downgrade)
754 if (items < 1 || items > 2)
755 croak_xs_usage(cv, "sv, failok=0");
757 SV * const sv = ST(0);
758 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
759 const bool RETVAL = sv_utf8_downgrade(sv, failok);
761 ST(0) = boolSV(RETVAL);
767 XS(XS_utf8_native_to_unicode)
771 const UV uv = SvUV(ST(0));
774 croak_xs_usage(cv, "sv");
776 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
780 XS(XS_utf8_unicode_to_native)
784 const UV uv = SvUV(ST(0));
787 croak_xs_usage(cv, "sv");
789 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
793 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
797 SV * const svz = ST(0);
801 /* [perl #77776] - called as &foo() not foo() */
803 croak_xs_usage(cv, "SCALAR[, ON]");
813 else if (items == 2) {
819 /* I hope you really know what you are doing. */
824 XSRETURN_UNDEF; /* Can't happen. */
827 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
831 SV * const svz = ST(0);
835 /* [perl #77776] - called as &foo() not foo() */
837 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
842 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
843 else if (items == 2) {
844 /* I hope you really know what you are doing. */
845 SvREFCNT(sv) = SvIV(ST(1));
846 XSRETURN_IV(SvREFCNT(sv));
848 XSRETURN_UNDEF; /* Can't happen. */
851 XS(XS_Internals_hv_clear_placehold)
856 if (items != 1 || !SvROK(ST(0)))
857 croak_xs_usage(cv, "hv");
859 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
860 hv_clear_placeholders(hv);
865 XS(XS_PerlIO_get_layers)
869 if (items < 1 || items % 2 == 0)
870 croak_xs_usage(cv, "filehandle[,args]");
877 bool details = FALSE;
881 for (svp = MARK + 2; svp <= SP; svp += 2) {
882 SV * const * const varp = svp;
883 SV * const * const valp = svp + 1;
885 const char * const key = SvPV_const(*varp, klen);
889 if (klen == 5 && memEQ(key, "input", 5)) {
890 input = SvTRUE(*valp);
895 if (klen == 6 && memEQ(key, "output", 6)) {
896 input = !SvTRUE(*valp);
901 if (klen == 7 && memEQ(key, "details", 7)) {
902 details = SvTRUE(*valp);
909 "get_layers: unknown argument '%s'",
921 if (SvROK(sv) && isGV(SvRV(sv)))
922 gv = MUTABLE_GV(SvRV(sv));
924 gv = gv_fetchsv(sv, 0, SVt_PVIO);
927 if (gv && (io = GvIO(gv))) {
928 AV* const av = PerlIO_get_layers(aTHX_ input ?
929 IoIFP(io) : IoOFP(io));
931 const I32 last = av_len(av);
934 for (i = last; i >= 0; i -= 3) {
935 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
936 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
937 SV * const * const flgsvp = av_fetch(av, i, FALSE);
939 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
940 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
941 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
944 /* Indents of 5? Yuck. */
945 /* We know that PerlIO_get_layers creates a new SV for
946 the name and flags, so we can just take a reference
947 and "steal" it when we free the AV below. */
949 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
952 ? newSVpvn_flags(SvPVX_const(*argsvp),
954 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
958 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
964 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
968 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
970 XPUSHs(&PL_sv_undef);
973 const IV flags = SvIVX(*flgsvp);
975 if (flags & PERLIO_F_UTF8) {
976 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
993 XS(XS_Internals_hash_seed)
996 /* Using dXSARGS would also have dITEM and dSP,
997 * which define 2 unused local variables. */
1000 PERL_UNUSED_VAR(mark);
1001 XSRETURN_UV(PERL_HASH_SEED);
1004 XS(XS_Internals_rehash_seed)
1007 /* Using dXSARGS would also have dITEM and dSP,
1008 * which define 2 unused local variables. */
1010 PERL_UNUSED_ARG(cv);
1011 PERL_UNUSED_VAR(mark);
1012 XSRETURN_UV(PL_rehash_seed);
1015 XS(XS_Internals_HvREHASH) /* Subject to change */
1019 PERL_UNUSED_ARG(cv);
1021 const HV * const hv = (const HV *) SvRV(ST(0));
1022 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1029 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1036 PERL_UNUSED_VAR(cv);
1039 croak_xs_usage(cv, "sv");
1043 if (SvRXOK(ST(0))) {
1050 XS(XS_re_regnames_count)
1052 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1058 croak_xs_usage(cv, "");
1065 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1086 if (items < 1 || items > 2)
1087 croak_xs_usage(cv, "name[, all ]");
1091 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1096 if (items == 2 && SvTRUE(ST(1))) {
1101 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1124 croak_xs_usage(cv, "[all]");
1126 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1131 if (items == 1 && SvTRUE(ST(0))) {
1139 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1148 av = MUTABLE_AV(SvRV(ret));
1149 length = av_len(av);
1151 for (i = 0; i <= length; i++) {
1152 entry = av_fetch(av, i, FALSE);
1155 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1157 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1166 XS(XS_re_regexp_pattern)
1173 croak_xs_usage(cv, "sv");
1178 Checks if a reference is a regex or not. If the parameter is
1179 not a ref, or is not the result of a qr// then returns false
1180 in scalar context and an empty list in list context.
1181 Otherwise in list context it returns the pattern and the
1182 modifiers, in scalar context it returns the pattern just as it
1183 would if the qr// was stringified normally, regardless as
1184 to the class of the variable and any strigification overloads
1188 if ((re = SvRX(ST(0)))) /* assign deliberate */
1190 /* Houston, we have a regex! */
1193 if ( GIMME_V == G_ARRAY ) {
1195 char reflags[sizeof(INT_PAT_MODS) + 1]; /* The +1 is for the charset
1202 we are in list context so stringify
1203 the modifiers that apply. We ignore "negative
1204 modifiers" in this scenario.
1207 if (RX_EXTFLAGS(re) & RXf_PMf_LOCALE) {
1208 reflags[left++] = LOCALE_PAT_MOD;
1210 else if (RX_EXTFLAGS(re) & RXf_PMf_UNICODE) {
1211 reflags[left++] = UNICODE_PAT_MOD;
1213 fptr = INT_PAT_MODS;
1214 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1215 >> RXf_PMf_STD_PMMOD_SHIFT);
1217 while((ch = *fptr++)) {
1218 if(match_flags & 1) {
1219 reflags[left++] = ch;
1224 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1225 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1227 /* return the pattern and the modifiers */
1229 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1232 /* Scalar, so use the string that Perl would return */
1233 /* return the pattern in (?msix:..) format */
1234 #if PERL_VERSION >= 11
1235 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1237 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1238 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1244 /* It ain't a regexp folks */
1245 if ( GIMME_V == G_ARRAY ) {
1246 /* return the empty list */
1249 /* Because of the (?:..) wrapping involved in a
1250 stringified pattern it is impossible to get a
1251 result for a real regexp that would evaluate to
1252 false. Therefore we can return PL_sv_no to signify
1253 that the object is not a regex, this means that one
1256 if (regex($might_be_a_regex) eq '(?:foo)') { }
1258 and not worry about undefined values.
1266 XS(XS_Tie_Hash_NamedCapture_FETCH)
1275 croak_xs_usage(cv, "$key, $flags");
1277 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1279 if (!rx || !SvROK(ST(0)))
1284 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1285 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1297 XS(XS_Tie_Hash_NamedCapture_STORE)
1305 croak_xs_usage(cv, "$key, $value, $flags");
1307 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1309 if (!rx || !SvROK(ST(0))) {
1311 Perl_croak_no_modify(aTHX);
1318 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1319 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1322 XS(XS_Tie_Hash_NamedCapture_DELETE)
1326 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1330 croak_xs_usage(cv, "$key, $flags");
1332 if (!rx || !SvROK(ST(0)))
1333 Perl_croak_no_modify(aTHX);
1337 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1338 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1341 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1349 croak_xs_usage(cv, "$flags");
1351 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1353 if (!rx || !SvROK(ST(0)))
1354 Perl_croak_no_modify(aTHX);
1358 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1359 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1362 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1371 croak_xs_usage(cv, "$key, $flags");
1373 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1375 if (!rx || !SvROK(ST(0)))
1380 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1381 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1390 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1399 croak_xs_usage(cv, "");
1401 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1403 if (!rx || !SvROK(ST(0)))
1408 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1409 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1422 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1431 croak_xs_usage(cv, "$lastkey");
1433 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1435 if (!rx || !SvROK(ST(0)))
1440 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1441 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1453 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1462 croak_xs_usage(cv, "");
1464 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1466 if (!rx || !SvROK(ST(0)))
1471 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1472 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1485 XS(XS_Tie_Hash_NamedCapture_flags)
1491 croak_xs_usage(cv, "");
1493 mXPUSHu(RXapif_ONE);
1494 mXPUSHu(RXapif_ALL);
1499 struct xsub_details {
1505 struct xsub_details details[] = {
1506 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1507 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1508 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1509 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1510 {"version::()", XS_version_noop, NULL},
1511 {"version::new", XS_version_new, NULL},
1512 {"version::parse", XS_version_new, NULL},
1513 {"version::(\"\"", XS_version_stringify, NULL},
1514 {"version::stringify", XS_version_stringify, NULL},
1515 {"version::(0+", XS_version_numify, NULL},
1516 {"version::numify", XS_version_numify, NULL},
1517 {"version::normal", XS_version_normal, NULL},
1518 {"version::(cmp", XS_version_vcmp, NULL},
1519 {"version::(<=>", XS_version_vcmp, NULL},
1520 {"version::vcmp", XS_version_vcmp, NULL},
1521 {"version::(bool", XS_version_boolean, NULL},
1522 {"version::boolean", XS_version_boolean, NULL},
1523 {"version::(nomethod", XS_version_noop, NULL},
1524 {"version::noop", XS_version_noop, NULL},
1525 {"version::is_alpha", XS_version_is_alpha, NULL},
1526 {"version::qv", XS_version_qv, NULL},
1527 {"version::declare", XS_version_qv, NULL},
1528 {"version::is_qv", XS_version_is_qv, NULL},
1529 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1530 {"utf8::valid", XS_utf8_valid, NULL},
1531 {"utf8::encode", XS_utf8_encode, NULL},
1532 {"utf8::decode", XS_utf8_decode, NULL},
1533 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1534 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1535 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1536 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1537 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1538 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1539 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1540 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1541 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1542 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1543 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1544 {"re::is_regexp", XS_re_is_regexp, "$"},
1545 {"re::regname", XS_re_regname, ";$$"},
1546 {"re::regnames", XS_re_regnames, ";$"},
1547 {"re::regnames_count", XS_re_regnames_count, ""},
1548 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1549 {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1550 {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1551 {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1552 {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1553 {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1554 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1555 {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1556 {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1557 {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
1561 Perl_boot_core_UNIVERSAL(pTHX)
1564 static const char file[] = __FILE__;
1565 struct xsub_details *xsub = details;
1566 const struct xsub_details *end
1567 = details + sizeof(details) / sizeof(details[0]);
1570 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1571 } while (++xsub < end);
1573 /* register the overloading (type 'A') magic */
1574 PL_amagic_generation++;
1576 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1577 CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1583 * c-indentation-style: bsd
1585 * indent-tabs-mode: t
1588 * ex: set ts=8 sts=4 sw=4 noet: