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 sv = SvRV(ST(0));
806 else if (items == 2) {
812 /* I hope you really know what you are doing. */
817 XSRETURN_UNDEF; /* Can't happen. */
820 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
824 SV * const sv = SvRV(ST(0));
828 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
829 else if (items == 2) {
830 /* I hope you really know what you are doing. */
831 SvREFCNT(sv) = SvIV(ST(1));
832 XSRETURN_IV(SvREFCNT(sv));
834 XSRETURN_UNDEF; /* Can't happen. */
837 XS(XS_Internals_hv_clear_placehold)
843 croak_xs_usage(cv, "hv");
845 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
846 hv_clear_placeholders(hv);
851 XS(XS_PerlIO_get_layers)
855 if (items < 1 || items % 2 == 0)
856 croak_xs_usage(cv, "filehandle[,args]");
863 bool details = FALSE;
867 for (svp = MARK + 2; svp <= SP; svp += 2) {
868 SV * const * const varp = svp;
869 SV * const * const valp = svp + 1;
871 const char * const key = SvPV_const(*varp, klen);
875 if (klen == 5 && memEQ(key, "input", 5)) {
876 input = SvTRUE(*valp);
881 if (klen == 6 && memEQ(key, "output", 6)) {
882 input = !SvTRUE(*valp);
887 if (klen == 7 && memEQ(key, "details", 7)) {
888 details = SvTRUE(*valp);
895 "get_layers: unknown argument '%s'",
907 if (SvROK(sv) && isGV(SvRV(sv)))
908 gv = MUTABLE_GV(SvRV(sv));
910 gv = gv_fetchsv(sv, 0, SVt_PVIO);
913 if (gv && (io = GvIO(gv))) {
914 AV* const av = PerlIO_get_layers(aTHX_ input ?
915 IoIFP(io) : IoOFP(io));
917 const I32 last = av_len(av);
920 for (i = last; i >= 0; i -= 3) {
921 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
922 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
923 SV * const * const flgsvp = av_fetch(av, i, FALSE);
925 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
926 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
927 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
930 /* Indents of 5? Yuck. */
931 /* We know that PerlIO_get_layers creates a new SV for
932 the name and flags, so we can just take a reference
933 and "steal" it when we free the AV below. */
935 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
938 ? newSVpvn_flags(SvPVX_const(*argsvp),
940 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
944 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
950 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
954 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
956 XPUSHs(&PL_sv_undef);
959 const IV flags = SvIVX(*flgsvp);
961 if (flags & PERLIO_F_UTF8) {
962 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
979 XS(XS_Internals_hash_seed)
982 /* Using dXSARGS would also have dITEM and dSP,
983 * which define 2 unused local variables. */
986 PERL_UNUSED_VAR(mark);
987 XSRETURN_UV(PERL_HASH_SEED);
990 XS(XS_Internals_rehash_seed)
993 /* Using dXSARGS would also have dITEM and dSP,
994 * which define 2 unused local variables. */
997 PERL_UNUSED_VAR(mark);
998 XSRETURN_UV(PL_rehash_seed);
1001 XS(XS_Internals_HvREHASH) /* Subject to change */
1005 PERL_UNUSED_ARG(cv);
1007 const HV * const hv = (const HV *) SvRV(ST(0));
1008 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1015 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1022 PERL_UNUSED_VAR(cv);
1025 croak_xs_usage(cv, "sv");
1029 if (SvRXOK(ST(0))) {
1036 XS(XS_re_regnames_count)
1038 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1044 croak_xs_usage(cv, "");
1051 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1072 if (items < 1 || items > 2)
1073 croak_xs_usage(cv, "name[, all ]");
1077 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1082 if (items == 2 && SvTRUE(ST(1))) {
1087 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1110 croak_xs_usage(cv, "[all]");
1112 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1117 if (items == 1 && SvTRUE(ST(0))) {
1125 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1134 av = MUTABLE_AV(SvRV(ret));
1135 length = av_len(av);
1137 for (i = 0; i <= length; i++) {
1138 entry = av_fetch(av, i, FALSE);
1141 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1143 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1152 XS(XS_re_regexp_pattern)
1159 croak_xs_usage(cv, "sv");
1164 Checks if a reference is a regex or not. If the parameter is
1165 not a ref, or is not the result of a qr// then returns false
1166 in scalar context and an empty list in list context.
1167 Otherwise in list context it returns the pattern and the
1168 modifiers, in scalar context it returns the pattern just as it
1169 would if the qr// was stringified normally, regardless as
1170 to the class of the variable and any strigification overloads
1174 if ((re = SvRX(ST(0)))) /* assign deliberate */
1176 /* Houston, we have a regex! */
1179 char reflags[sizeof(INT_PAT_MODS)];
1181 if ( GIMME_V == G_ARRAY ) {
1183 we are in list context so stringify
1184 the modifiers that apply. We ignore "negative
1185 modifiers" in this scenario.
1188 const char *fptr = INT_PAT_MODS;
1190 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1191 >> RXf_PMf_STD_PMMOD_SHIFT);
1193 while((ch = *fptr++)) {
1194 if(match_flags & 1) {
1195 reflags[left++] = ch;
1200 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1201 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1203 /* return the pattern and the modifiers */
1205 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1208 /* Scalar, so use the string that Perl would return */
1209 /* return the pattern in (?msix:..) format */
1210 #if PERL_VERSION >= 11
1211 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1213 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1214 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1220 /* It ain't a regexp folks */
1221 if ( GIMME_V == G_ARRAY ) {
1222 /* return the empty list */
1225 /* Because of the (?:..) wrapping involved in a
1226 stringified pattern it is impossible to get a
1227 result for a real regexp that would evaluate to
1228 false. Therefore we can return PL_sv_no to signify
1229 that the object is not a regex, this means that one
1232 if (regex($might_be_a_regex) eq '(?:foo)') { }
1234 and not worry about undefined values.
1242 XS(XS_Tie_Hash_NamedCapture_FETCH)
1251 croak_xs_usage(cv, "$key, $flags");
1253 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1255 if (!rx || !SvROK(ST(0)))
1260 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1261 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1273 XS(XS_Tie_Hash_NamedCapture_STORE)
1281 croak_xs_usage(cv, "$key, $value, $flags");
1283 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1285 if (!rx || !SvROK(ST(0))) {
1287 Perl_croak_no_modify(aTHX);
1294 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1295 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1298 XS(XS_Tie_Hash_NamedCapture_DELETE)
1302 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1306 croak_xs_usage(cv, "$key, $flags");
1308 if (!rx || !SvROK(ST(0)))
1309 Perl_croak_no_modify(aTHX);
1313 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1314 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1317 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1325 croak_xs_usage(cv, "$flags");
1327 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1329 if (!rx || !SvROK(ST(0)))
1330 Perl_croak_no_modify(aTHX);
1334 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1335 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1338 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1347 croak_xs_usage(cv, "$key, $flags");
1349 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1351 if (!rx || !SvROK(ST(0)))
1356 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1357 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1366 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1375 croak_xs_usage(cv, "");
1377 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1379 if (!rx || !SvROK(ST(0)))
1384 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1385 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1398 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1407 croak_xs_usage(cv, "$lastkey");
1409 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1411 if (!rx || !SvROK(ST(0)))
1416 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1417 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1429 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1438 croak_xs_usage(cv, "");
1440 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1442 if (!rx || !SvROK(ST(0)))
1447 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1448 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1461 XS(XS_Tie_Hash_NamedCapture_flags)
1467 croak_xs_usage(cv, "");
1469 mXPUSHu(RXapif_ONE);
1470 mXPUSHu(RXapif_ALL);
1475 struct xsub_details {
1481 struct xsub_details details[] = {
1482 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1483 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1484 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1485 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1486 {"version::()", XS_version_noop, NULL},
1487 {"version::new", XS_version_new, NULL},
1488 {"version::parse", XS_version_new, NULL},
1489 {"version::(\"\"", XS_version_stringify, NULL},
1490 {"version::stringify", XS_version_stringify, NULL},
1491 {"version::(0+", XS_version_numify, NULL},
1492 {"version::numify", XS_version_numify, NULL},
1493 {"version::normal", XS_version_normal, NULL},
1494 {"version::(cmp", XS_version_vcmp, NULL},
1495 {"version::(<=>", XS_version_vcmp, NULL},
1496 {"version::vcmp", XS_version_vcmp, NULL},
1497 {"version::(bool", XS_version_boolean, NULL},
1498 {"version::boolean", XS_version_boolean, NULL},
1499 {"version::(nomethod", XS_version_noop, NULL},
1500 {"version::noop", XS_version_noop, NULL},
1501 {"version::is_alpha", XS_version_is_alpha, NULL},
1502 {"version::qv", XS_version_qv, NULL},
1503 {"version::declare", XS_version_qv, NULL},
1504 {"version::is_qv", XS_version_is_qv, NULL},
1505 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1506 {"utf8::valid", XS_utf8_valid, NULL},
1507 {"utf8::encode", XS_utf8_encode, NULL},
1508 {"utf8::decode", XS_utf8_decode, NULL},
1509 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1510 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1511 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1512 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1513 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1514 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1515 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1516 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1517 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1518 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1519 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1520 {"re::is_regexp", XS_re_is_regexp, "$"},
1521 {"re::regname", XS_re_regname, ";$$"},
1522 {"re::regnames", XS_re_regnames, ";$"},
1523 {"re::regnames_count", XS_re_regnames_count, ""},
1524 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1525 {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1526 {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1527 {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1528 {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1529 {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1530 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1531 {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1532 {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1533 {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
1537 Perl_boot_core_UNIVERSAL(pTHX)
1540 static const char file[] = __FILE__;
1541 struct xsub_details *xsub = details;
1542 const struct xsub_details *end
1543 = details + sizeof(details) / sizeof(details[0]);
1546 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1547 } while (++xsub < end);
1549 /* register the overloading (type 'A') magic */
1550 PL_amagic_generation++;
1552 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1553 CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1559 * c-indentation-style: bsd
1561 * indent-tabs-mode: t
1564 * ex: set ts=8 sts=4 sw=4 noet: