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");
1018 XS(XS_mauve_reftype)
1023 PERL_UNUSED_VAR(cv);
1026 croak_xs_usage(cv, "sv");
1037 char *type= (char *)sv_reftype_len(SvRV(sv),FALSE,&len);
1038 XPUSHs(sv_2mortal(newSVpv(type,len)));
1042 XS(XS_mauve_refaddr)
1047 PERL_UNUSED_VAR(cv);
1050 croak_xs_usage(cv, "sv");
1060 XPUSHs(sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))));
1064 XS(XS_mauve_blessed)
1069 PERL_UNUSED_VAR(cv);
1072 croak_xs_usage(cv, "sv");
1079 if ( SvROK(sv) && SvOBJECT(SvRV(sv)) ) {
1081 char *type= (char *)sv_reftype_len(SvRV(sv),TRUE,&len);
1082 XPUSHs(sv_2mortal(newSVpv(type,len)));
1084 XPUSHs(sv_2mortal(newSVpv("",0)));
1093 PERL_UNUSED_VAR(cv);
1096 croak_xs_usage(cv, "sv");
1112 croak_xs_usage(cv, "sv");
1117 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
1127 PERL_UNUSED_VAR(cv);
1130 croak_xs_usage(cv, "sv");
1134 if (SvRXOK(ST(0))) {
1141 XS(XS_re_regnames_count)
1143 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1149 croak_xs_usage(cv, "");
1156 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1177 if (items < 1 || items > 2)
1178 croak_xs_usage(cv, "name[, all ]");
1182 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1187 if (items == 2 && SvTRUE(ST(1))) {
1192 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1215 croak_xs_usage(cv, "[all]");
1217 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1222 if (items == 1 && SvTRUE(ST(0))) {
1230 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1239 av = MUTABLE_AV(SvRV(ret));
1240 length = av_len(av);
1242 for (i = 0; i <= length; i++) {
1243 entry = av_fetch(av, i, FALSE);
1246 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1248 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1257 XS(XS_re_regexp_pattern)
1264 croak_xs_usage(cv, "sv");
1269 Checks if a reference is a regex or not. If the parameter is
1270 not a ref, or is not the result of a qr// then returns false
1271 in scalar context and an empty list in list context.
1272 Otherwise in list context it returns the pattern and the
1273 modifiers, in scalar context it returns the pattern just as it
1274 would if the qr// was stringified normally, regardless as
1275 to the class of the variable and any strigification overloads
1279 if ((re = SvRX(ST(0)))) /* assign deliberate */
1281 /* Houston, we have a regex! */
1284 char reflags[sizeof(INT_PAT_MODS)];
1286 if ( GIMME_V == G_ARRAY ) {
1288 we are in list context so stringify
1289 the modifiers that apply. We ignore "negative
1290 modifiers" in this scenario.
1293 const char *fptr = INT_PAT_MODS;
1295 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1296 >> RXf_PMf_STD_PMMOD_SHIFT);
1298 while((ch = *fptr++)) {
1299 if(match_flags & 1) {
1300 reflags[left++] = ch;
1305 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1306 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1308 /* return the pattern and the modifiers */
1310 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1313 /* Scalar, so use the string that Perl would return */
1314 /* return the pattern in (?msix:..) format */
1315 #if PERL_VERSION >= 11
1316 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1318 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1319 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1325 /* It ain't a regexp folks */
1326 if ( GIMME_V == G_ARRAY ) {
1327 /* return the empty list */
1330 /* Because of the (?:..) wrapping involved in a
1331 stringified pattern it is impossible to get a
1332 result for a real regexp that would evaluate to
1333 false. Therefore we can return PL_sv_no to signify
1334 that the object is not a regex, this means that one
1337 if (regex($might_be_a_regex) eq '(?:foo)') { }
1339 and not worry about undefined values.
1347 XS(XS_Tie_Hash_NamedCapture_FETCH)
1356 croak_xs_usage(cv, "$key, $flags");
1358 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1360 if (!rx || !SvROK(ST(0)))
1365 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1366 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1378 XS(XS_Tie_Hash_NamedCapture_STORE)
1386 croak_xs_usage(cv, "$key, $value, $flags");
1388 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1390 if (!rx || !SvROK(ST(0))) {
1392 Perl_croak_no_modify(aTHX);
1399 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1400 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1403 XS(XS_Tie_Hash_NamedCapture_DELETE)
1407 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1411 croak_xs_usage(cv, "$key, $flags");
1413 if (!rx || !SvROK(ST(0)))
1414 Perl_croak_no_modify(aTHX);
1418 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1419 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1422 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1430 croak_xs_usage(cv, "$flags");
1432 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1434 if (!rx || !SvROK(ST(0)))
1435 Perl_croak_no_modify(aTHX);
1439 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1440 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1443 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1452 croak_xs_usage(cv, "$key, $flags");
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_EXISTS(rx, ST(1), flags);
1471 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1480 croak_xs_usage(cv, "");
1482 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1484 if (!rx || !SvROK(ST(0)))
1489 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1490 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1503 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1512 croak_xs_usage(cv, "$lastkey");
1514 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1516 if (!rx || !SvROK(ST(0)))
1521 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1522 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1534 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1543 croak_xs_usage(cv, "");
1545 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1547 if (!rx || !SvROK(ST(0)))
1552 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1553 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1566 XS(XS_Tie_Hash_NamedCapture_flags)
1572 croak_xs_usage(cv, "");
1574 mXPUSHu(RXapif_ONE);
1575 mXPUSHu(RXapif_ALL);
1580 struct xsub_details {
1586 struct xsub_details details[] = {
1587 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1588 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1589 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1590 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1591 {"version::()", XS_version_noop, NULL},
1592 {"version::new", XS_version_new, NULL},
1593 {"version::parse", XS_version_new, NULL},
1594 {"version::(\"\"", XS_version_stringify, NULL},
1595 {"version::stringify", XS_version_stringify, NULL},
1596 {"version::(0+", XS_version_numify, NULL},
1597 {"version::numify", XS_version_numify, NULL},
1598 {"version::normal", XS_version_normal, NULL},
1599 {"version::(cmp", XS_version_vcmp, NULL},
1600 {"version::(<=>", XS_version_vcmp, NULL},
1601 {"version::vcmp", XS_version_vcmp, NULL},
1602 {"version::(bool", XS_version_boolean, NULL},
1603 {"version::boolean", XS_version_boolean, NULL},
1604 {"version::(nomethod", XS_version_noop, NULL},
1605 {"version::noop", XS_version_noop, NULL},
1606 {"version::is_alpha", XS_version_is_alpha, NULL},
1607 {"version::qv", XS_version_qv, NULL},
1608 {"version::declare", XS_version_qv, NULL},
1609 {"version::is_qv", XS_version_is_qv, NULL},
1610 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1611 {"utf8::valid", XS_utf8_valid, NULL},
1612 {"utf8::encode", XS_utf8_encode, NULL},
1613 {"utf8::decode", XS_utf8_decode, NULL},
1614 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1615 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1616 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1617 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1618 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1619 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1620 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1621 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1622 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1623 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1624 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1625 {"re::is_regexp", XS_re_is_regexp, "$"},
1626 {"re::regname", XS_re_regname, ";$$"},
1627 {"re::regnames", XS_re_regnames, ";$"},
1628 {"re::regnames_count", XS_re_regnames_count, ""},
1629 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1630 {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1631 {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1632 {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1633 {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1634 {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1635 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1636 {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1637 {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1638 {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
1639 ,{"mauve::reftype", XS_mauve_reftype, "$"}
1640 ,{"mauve::refaddr", XS_mauve_refaddr, "$"}
1641 ,{"mauve::blessed", XS_mauve_blessed, "$"}
1642 ,{"mauve::weaken", XS_mauve_weaken, "$"}
1643 ,{"mauve::isweak", XS_mauve_isweak, "$"}
1647 Perl_boot_core_UNIVERSAL(pTHX)
1650 static const char file[] = __FILE__;
1651 struct xsub_details *xsub = details;
1652 const struct xsub_details *end
1653 = details + sizeof(details) / sizeof(details[0]);
1656 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1657 } while (++xsub < end);
1659 /* register the overloading (type 'A') magic */
1660 PL_amagic_generation++;
1662 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1663 CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1669 * c-indentation-style: bsd
1671 * indent-tabs-mode: t
1674 * ex: set ts=8 sts=4 sw=4 noet: