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 char reflags[sizeof(INT_PAT_MODS)];
1195 if ( GIMME_V == G_ARRAY ) {
1197 we are in list context so stringify
1198 the modifiers that apply. We ignore "negative
1199 modifiers" in this scenario.
1202 const char *fptr = INT_PAT_MODS;
1204 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1205 >> RXf_PMf_STD_PMMOD_SHIFT);
1207 while((ch = *fptr++)) {
1208 if(match_flags & 1) {
1209 reflags[left++] = ch;
1214 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1215 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1217 /* return the pattern and the modifiers */
1219 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1222 /* Scalar, so use the string that Perl would return */
1223 /* return the pattern in (?msix:..) format */
1224 #if PERL_VERSION >= 11
1225 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1227 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1228 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1234 /* It ain't a regexp folks */
1235 if ( GIMME_V == G_ARRAY ) {
1236 /* return the empty list */
1239 /* Because of the (?:..) wrapping involved in a
1240 stringified pattern it is impossible to get a
1241 result for a real regexp that would evaluate to
1242 false. Therefore we can return PL_sv_no to signify
1243 that the object is not a regex, this means that one
1246 if (regex($might_be_a_regex) eq '(?:foo)') { }
1248 and not worry about undefined values.
1256 XS(XS_Tie_Hash_NamedCapture_FETCH)
1265 croak_xs_usage(cv, "$key, $flags");
1267 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1269 if (!rx || !SvROK(ST(0)))
1274 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1275 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1287 XS(XS_Tie_Hash_NamedCapture_STORE)
1295 croak_xs_usage(cv, "$key, $value, $flags");
1297 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1299 if (!rx || !SvROK(ST(0))) {
1301 Perl_croak_no_modify(aTHX);
1308 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1309 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1312 XS(XS_Tie_Hash_NamedCapture_DELETE)
1316 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1320 croak_xs_usage(cv, "$key, $flags");
1322 if (!rx || !SvROK(ST(0)))
1323 Perl_croak_no_modify(aTHX);
1327 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1328 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1331 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1339 croak_xs_usage(cv, "$flags");
1341 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1343 if (!rx || !SvROK(ST(0)))
1344 Perl_croak_no_modify(aTHX);
1348 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1349 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1352 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1361 croak_xs_usage(cv, "$key, $flags");
1363 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1365 if (!rx || !SvROK(ST(0)))
1370 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1371 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1380 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1389 croak_xs_usage(cv, "");
1391 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1393 if (!rx || !SvROK(ST(0)))
1398 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1399 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1412 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1421 croak_xs_usage(cv, "$lastkey");
1423 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1425 if (!rx || !SvROK(ST(0)))
1430 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1431 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1443 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1452 croak_xs_usage(cv, "");
1454 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1456 if (!rx || !SvROK(ST(0)))
1461 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1462 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1475 XS(XS_Tie_Hash_NamedCapture_flags)
1481 croak_xs_usage(cv, "");
1483 mXPUSHu(RXapif_ONE);
1484 mXPUSHu(RXapif_ALL);
1489 struct xsub_details {
1495 struct xsub_details details[] = {
1496 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1497 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1498 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1499 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1500 {"version::()", XS_version_noop, NULL},
1501 {"version::new", XS_version_new, NULL},
1502 {"version::parse", XS_version_new, NULL},
1503 {"version::(\"\"", XS_version_stringify, NULL},
1504 {"version::stringify", XS_version_stringify, NULL},
1505 {"version::(0+", XS_version_numify, NULL},
1506 {"version::numify", XS_version_numify, NULL},
1507 {"version::normal", XS_version_normal, NULL},
1508 {"version::(cmp", XS_version_vcmp, NULL},
1509 {"version::(<=>", XS_version_vcmp, NULL},
1510 {"version::vcmp", XS_version_vcmp, NULL},
1511 {"version::(bool", XS_version_boolean, NULL},
1512 {"version::boolean", XS_version_boolean, NULL},
1513 {"version::(nomethod", XS_version_noop, NULL},
1514 {"version::noop", XS_version_noop, NULL},
1515 {"version::is_alpha", XS_version_is_alpha, NULL},
1516 {"version::qv", XS_version_qv, NULL},
1517 {"version::declare", XS_version_qv, NULL},
1518 {"version::is_qv", XS_version_is_qv, NULL},
1519 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1520 {"utf8::valid", XS_utf8_valid, NULL},
1521 {"utf8::encode", XS_utf8_encode, NULL},
1522 {"utf8::decode", XS_utf8_decode, NULL},
1523 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1524 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1525 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1526 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1527 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1528 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1529 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1530 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1531 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1532 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1533 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1534 {"re::is_regexp", XS_re_is_regexp, "$"},
1535 {"re::regname", XS_re_regname, ";$$"},
1536 {"re::regnames", XS_re_regnames, ";$"},
1537 {"re::regnames_count", XS_re_regnames_count, ""},
1538 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1539 {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1540 {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1541 {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1542 {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1543 {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1544 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1545 {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1546 {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1547 {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
1551 Perl_boot_core_UNIVERSAL(pTHX)
1554 static const char file[] = __FILE__;
1555 struct xsub_details *xsub = details;
1556 const struct xsub_details *end
1557 = details + sizeof(details) / sizeof(details[0]);
1560 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1561 } while (++xsub < end);
1563 /* register the overloading (type 'A') magic */
1564 PL_amagic_generation++;
1566 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1567 CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1573 * c-indentation-style: bsd
1575 * indent-tabs-mode: t
1578 * ex: set ts=8 sts=4 sw=4 noet: