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");
1041 if (SvRXOK(ST(0))) {
1048 XS(XS_re_regnames_count)
1050 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1056 croak_xs_usage(cv, "");
1064 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1067 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1079 if (items < 1 || items > 2)
1080 croak_xs_usage(cv, "name[, all ]");
1085 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1090 if (items == 2 && SvTRUE(ST(1))) {
1095 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1098 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1116 croak_xs_usage(cv, "[all]");
1118 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1123 if (items == 1 && SvTRUE(ST(0))) {
1132 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1139 av = MUTABLE_AV(SvRV(ret));
1140 length = av_len(av);
1142 for (i = 0; i <= length; i++) {
1143 entry = av_fetch(av, i, FALSE);
1146 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1148 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1157 XS(XS_re_regexp_pattern)
1164 croak_xs_usage(cv, "sv");
1169 Checks if a reference is a regex or not. If the parameter is
1170 not a ref, or is not the result of a qr// then returns false
1171 in scalar context and an empty list in list context.
1172 Otherwise in list context it returns the pattern and the
1173 modifiers, in scalar context it returns the pattern just as it
1174 would if the qr// was stringified normally, regardless as
1175 to the class of the variable and any strigification overloads
1179 if ((re = SvRX(ST(0)))) /* assign deliberate */
1181 /* Houston, we have a regex! */
1184 if ( GIMME_V == G_ARRAY ) {
1186 char reflags[sizeof(INT_PAT_MODS) + 1]; /* The +1 is for the charset
1193 we are in list context so stringify
1194 the modifiers that apply. We ignore "negative
1195 modifiers" in this scenario.
1198 if (RX_EXTFLAGS(re) & RXf_PMf_LOCALE) {
1199 reflags[left++] = LOCALE_PAT_MOD;
1201 else if (RX_EXTFLAGS(re) & RXf_PMf_UNICODE) {
1202 reflags[left++] = UNICODE_PAT_MOD;
1204 fptr = INT_PAT_MODS;
1205 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1206 >> RXf_PMf_STD_PMMOD_SHIFT);
1208 while((ch = *fptr++)) {
1209 if(match_flags & 1) {
1210 reflags[left++] = ch;
1215 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1216 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1218 /* return the pattern and the modifiers */
1220 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1223 /* Scalar, so use the string that Perl would return */
1224 /* return the pattern in (?msix:..) format */
1225 #if PERL_VERSION >= 11
1226 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1228 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1229 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1235 /* It ain't a regexp folks */
1236 if ( GIMME_V == G_ARRAY ) {
1237 /* return the empty list */
1240 /* Because of the (?:..) wrapping involved in a
1241 stringified pattern it is impossible to get a
1242 result for a real regexp that would evaluate to
1243 false. Therefore we can return PL_sv_no to signify
1244 that the object is not a regex, this means that one
1247 if (regex($might_be_a_regex) eq '(?:foo)') { }
1249 and not worry about undefined values.
1258 S_named_capture_common(pTHX_ CV *const cv, const bool fatal, const int expect,
1259 const bool discard, const U32 action)
1267 if (items != expect)
1268 croak_xs_usage(cv, expect == 2 ? "$key"
1269 : (expect == 3 ? "$key, $value" : ""));
1271 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1273 if (!rx || !SvROK(ST(0))) {
1275 Perl_croak_no_modify(aTHX);
1283 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1284 ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
1285 expect >= 3 ? ST(2) : NULL, flags | action);
1288 /* Called with G_DISCARD, so our return stack state is thrown away.
1289 Hence if we were returned anything, free it immediately. */
1295 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1299 XS(XS_Tie_Hash_NamedCapture_FETCH)
1301 S_named_capture_common(aTHX_ cv, FALSE, 2, FALSE, RXapif_FETCH);
1304 XS(XS_Tie_Hash_NamedCapture_STORE)
1306 S_named_capture_common(aTHX_ cv, TRUE, 3, TRUE, RXapif_STORE);
1309 XS(XS_Tie_Hash_NamedCapture_DELETE)
1311 S_named_capture_common(aTHX_ cv, TRUE, 2, FALSE, RXapif_DELETE);
1314 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1316 S_named_capture_common(aTHX_ cv, TRUE, 1, TRUE, RXapif_CLEAR);
1319 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1321 S_named_capture_common(aTHX_ cv, FALSE, 2, FALSE, RXapif_EXISTS);
1325 S_named_capture_iter_common(pTHX_ CV *const cv, const int expect,
1334 if (items != expect)
1335 croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
1337 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1339 if (!rx || !SvROK(ST(0)))
1345 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1346 ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
1350 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1354 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1356 S_named_capture_iter_common(aTHX_ cv, 1, RXapif_FIRSTKEY);
1359 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1361 S_named_capture_iter_common(aTHX_ cv, 2, RXapif_NEXTKEY);
1364 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1366 S_named_capture_common(aTHX_ cv, FALSE, 1, FALSE, RXapif_SCALAR);
1369 struct xsub_details {
1375 struct xsub_details details[] = {
1376 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1377 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1378 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1379 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1380 {"version::()", XS_version_noop, NULL},
1381 {"version::new", XS_version_new, NULL},
1382 {"version::parse", XS_version_new, NULL},
1383 {"version::(\"\"", XS_version_stringify, NULL},
1384 {"version::stringify", XS_version_stringify, NULL},
1385 {"version::(0+", XS_version_numify, NULL},
1386 {"version::numify", XS_version_numify, NULL},
1387 {"version::normal", XS_version_normal, NULL},
1388 {"version::(cmp", XS_version_vcmp, NULL},
1389 {"version::(<=>", XS_version_vcmp, NULL},
1390 {"version::vcmp", XS_version_vcmp, NULL},
1391 {"version::(bool", XS_version_boolean, NULL},
1392 {"version::boolean", XS_version_boolean, NULL},
1393 {"version::(nomethod", XS_version_noop, NULL},
1394 {"version::noop", XS_version_noop, NULL},
1395 {"version::is_alpha", XS_version_is_alpha, NULL},
1396 {"version::qv", XS_version_qv, NULL},
1397 {"version::declare", XS_version_qv, NULL},
1398 {"version::is_qv", XS_version_is_qv, NULL},
1399 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1400 {"utf8::valid", XS_utf8_valid, NULL},
1401 {"utf8::encode", XS_utf8_encode, NULL},
1402 {"utf8::decode", XS_utf8_decode, NULL},
1403 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1404 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1405 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1406 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1407 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1408 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1409 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1410 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1411 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1412 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1413 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1414 {"re::is_regexp", XS_re_is_regexp, "$"},
1415 {"re::regname", XS_re_regname, ";$$"},
1416 {"re::regnames", XS_re_regnames, ";$"},
1417 {"re::regnames_count", XS_re_regnames_count, ""},
1418 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1419 {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1420 {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1421 {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1422 {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1423 {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1424 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1425 {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1426 {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1430 Perl_boot_core_UNIVERSAL(pTHX)
1433 static const char file[] = __FILE__;
1434 struct xsub_details *xsub = details;
1435 const struct xsub_details *end
1436 = details + sizeof(details) / sizeof(details[0]);
1439 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1440 } while (++xsub < end);
1442 /* register the overloading (type 'A') magic */
1443 PL_amagic_generation++;
1445 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1446 CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1452 * c-indentation-style: bsd
1454 * indent-tabs-mode: t
1457 * ex: set ts=8 sts=4 sw=4 noet: