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))))
178 if (sv_isobject(sv)) {
179 classname = sv_reftype(SvRV(sv),TRUE);
181 classname = SvPV_nolen(sv);
184 if (strEQ(name,classname))
189 mXPUSHs(newSVpv(name, 0));
192 methodname = newSVpvs_flags("isa", SVs_TEMP);
193 /* ugly hack: use the SvSCREAM flag so S_method_common
194 * can figure out we're calling DOES() and not isa(),
195 * and report eventual errors correctly. --rgs */
196 SvSCREAM_on(methodname);
197 call_sv(methodname, G_SCALAR | G_METHOD);
200 does_it = SvTRUE( TOPs );
207 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
208 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
209 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
210 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
212 XS(XS_version_stringify);
213 XS(XS_version_numify);
214 XS(XS_version_normal);
216 XS(XS_version_boolean);
217 #ifdef HASATTRIBUTE_NORETURN
218 XS(XS_version_noop) __attribute__noreturn__;
222 XS(XS_version_is_alpha);
229 XS(XS_utf8_downgrade);
230 XS(XS_utf8_unicode_to_native);
231 XS(XS_utf8_native_to_unicode);
232 XS(XS_Internals_SvREADONLY);
233 XS(XS_Internals_SvREFCNT);
234 XS(XS_Internals_hv_clear_placehold);
235 XS(XS_PerlIO_get_layers);
236 XS(XS_Regexp_DESTROY);
237 XS(XS_Internals_hash_seed);
238 XS(XS_Internals_rehash_seed);
239 XS(XS_Internals_HvREHASH);
243 XS(XS_re_regnames_count);
244 XS(XS_re_regexp_pattern);
245 XS(XS_Tie_Hash_NamedCapture_FETCH);
246 XS(XS_Tie_Hash_NamedCapture_STORE);
247 XS(XS_Tie_Hash_NamedCapture_DELETE);
248 XS(XS_Tie_Hash_NamedCapture_CLEAR);
249 XS(XS_Tie_Hash_NamedCapture_EXISTS);
250 XS(XS_Tie_Hash_NamedCapture_FIRSTK);
251 XS(XS_Tie_Hash_NamedCapture_NEXTK);
252 XS(XS_Tie_Hash_NamedCapture_SCALAR);
253 XS(XS_Tie_Hash_NamedCapture_flags);
256 Perl_boot_core_UNIVERSAL(pTHX)
259 static const char file[] = __FILE__;
261 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
262 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
263 newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file);
264 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
266 /* register the overloading (type 'A') magic */
267 PL_amagic_generation++;
268 /* Make it findable via fetchmethod */
269 newXS("version::()", XS_version_noop, file);
270 newXS("version::new", XS_version_new, file);
271 newXS("version::(\"\"", XS_version_stringify, file);
272 newXS("version::stringify", XS_version_stringify, file);
273 newXS("version::(0+", XS_version_numify, file);
274 newXS("version::numify", XS_version_numify, file);
275 newXS("version::normal", XS_version_normal, file);
276 newXS("version::(cmp", XS_version_vcmp, file);
277 newXS("version::(<=>", XS_version_vcmp, file);
278 newXS("version::vcmp", XS_version_vcmp, file);
279 newXS("version::(bool", XS_version_boolean, file);
280 newXS("version::boolean", XS_version_boolean, file);
281 newXS("version::(nomethod", XS_version_noop, file);
282 newXS("version::noop", XS_version_noop, file);
283 newXS("version::is_alpha", XS_version_is_alpha, file);
284 newXS("version::qv", XS_version_qv, file);
286 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
287 newXS("utf8::valid", XS_utf8_valid, file);
288 newXS("utf8::encode", XS_utf8_encode, file);
289 newXS("utf8::decode", XS_utf8_decode, file);
290 newXS("utf8::upgrade", XS_utf8_upgrade, file);
291 newXS("utf8::downgrade", XS_utf8_downgrade, file);
292 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
293 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
294 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
295 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
296 newXSproto("Internals::hv_clear_placeholders",
297 XS_Internals_hv_clear_placehold, file, "\\%");
298 newXSproto("PerlIO::get_layers",
299 XS_PerlIO_get_layers, file, "*;@");
300 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
301 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
302 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
303 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
304 newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
305 newXSproto("re::regname", XS_re_regname, file, ";$$");
306 newXSproto("re::regnames", XS_re_regnames, file, ";$");
307 newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
308 newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
309 newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
310 newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
311 newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
312 newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
313 newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
314 newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file);
315 newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file);
316 newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
317 newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
321 =for apidoc croak_xs_usage
323 A specialised variant of C<croak()> for emitting the usage message for xsubs
325 croak_xs_usage(cv, "eee_yow");
327 works out the package name and subroutine name from C<cv>, and then calls
328 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
330 Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow");
336 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
338 const GV *const gv = CvGV(cv);
340 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
343 const char *const gvname = GvNAME(gv);
344 const HV *const stash = GvSTASH(gv);
345 const char *const hvname = stash ? HvNAME_get(stash) : NULL;
348 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
350 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
352 /* Pants. I don't think that it should be possible to get here. */
353 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
363 croak_xs_usage(cv, "reference, kind");
365 SV * const sv = ST(0);
370 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
371 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
374 name = SvPV_nolen_const(ST(1));
376 ST(0) = boolSV(sv_derived_from(sv, name));
391 croak_xs_usage(cv, "object-ref, method");
397 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
398 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
401 name = SvPV_nolen_const(ST(1));
405 sv = MUTABLE_SV(SvRV(sv));
410 pkg = gv_stashsv(sv, 0);
414 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
416 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
423 XS(XS_UNIVERSAL_DOES)
430 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
432 SV * const sv = ST(0);
435 name = SvPV_nolen_const(ST(1));
436 if (sv_does( sv, name ))
443 XS(XS_UNIVERSAL_VERSION)
455 sv = MUTABLE_SV(SvRV(ST(0)));
457 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
461 pkg = gv_stashsv(ST(0), 0);
464 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
466 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
467 SV * const nsv = sv_newmortal();
470 if ( !sv_derived_from(sv, "version"))
471 upg_version(sv, FALSE);
484 const char * const name = HvNAME_get(pkg);
486 "%s does not define $%s::VERSION--version check failed",
490 "%s defines neither package nor VERSION--version check failed",
491 SvPVx_nolen_const(ST(0)) );
495 if ( !sv_derived_from(req, "version")) {
496 /* req may very well be R/O, so create a new object */
497 req = sv_2mortal( new_version(req) );
500 if ( vcmp( req, sv ) > 0 ) {
501 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
502 Perl_croak(aTHX_ "%s version %"SVf" required--"
503 "this is only version %"SVf"", HvNAME_get(pkg),
504 SVfARG(vnormal(req)),
505 SVfARG(vnormal(sv)));
507 Perl_croak(aTHX_ "%s version %"SVf" required--"
508 "this is only version %"SVf"", HvNAME_get(pkg),
509 SVfARG(vstringify(req)),
510 SVfARG(vstringify(sv)));
516 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
517 ST(0) = vstringify(sv);
530 croak_xs_usage(cv, "class, version");
535 const char * const classname =
536 sv_isobject(ST(0)) /* get the class if called as an object method */
537 ? HvNAME(SvSTASH(SvRV(ST(0))))
538 : (char *)SvPV_nolen(ST(0));
540 if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
541 /* create empty object */
545 else if ( items == 3 ) {
547 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
550 rv = new_version(vs);
551 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
552 sv_bless(rv, gv_stashpv(classname, GV_ADD));
560 XS(XS_version_stringify)
565 croak_xs_usage(cv, "lobj, ...");
570 if (sv_derived_from(ST(0), "version")) {
574 Perl_croak(aTHX_ "lobj is not of type version");
576 mPUSHs(vstringify(lobj));
583 XS(XS_version_numify)
588 croak_xs_usage(cv, "lobj, ...");
593 if (sv_derived_from(ST(0), "version")) {
597 Perl_croak(aTHX_ "lobj is not of type version");
599 mPUSHs(vnumify(lobj));
606 XS(XS_version_normal)
611 croak_xs_usage(cv, "lobj, ...");
616 if (sv_derived_from(ST(0), "version")) {
620 Perl_croak(aTHX_ "lobj is not of type version");
622 mPUSHs(vnormal(lobj));
634 croak_xs_usage(cv, "lobj, ...");
639 if (sv_derived_from(ST(0), "version")) {
643 Perl_croak(aTHX_ "lobj is not of type version");
649 const IV swap = (IV)SvIV(ST(2));
651 if ( ! sv_derived_from(robj, "version") )
653 robj = new_version(robj);
659 rs = newSViv(vcmp(rvs,lobj));
663 rs = newSViv(vcmp(lobj,rvs));
674 XS(XS_version_boolean)
679 croak_xs_usage(cv, "lobj, ...");
681 if (sv_derived_from(ST(0), "version")) {
682 SV * const lobj = SvRV(ST(0));
683 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
689 Perl_croak(aTHX_ "lobj is not of type version");
697 croak_xs_usage(cv, "lobj, ...");
698 if (sv_derived_from(ST(0), "version"))
699 Perl_croak(aTHX_ "operation not supported with version object");
701 Perl_croak(aTHX_ "lobj is not of type version");
702 #ifndef HASATTRIBUTE_NORETURN
707 XS(XS_version_is_alpha)
712 croak_xs_usage(cv, "lobj");
714 if (sv_derived_from(ST(0), "version")) {
715 SV * const lobj = ST(0);
716 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
724 Perl_croak(aTHX_ "lobj is not of type version");
732 croak_xs_usage(cv, "ver");
736 if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
737 SV * const rv = sv_newmortal();
738 sv_setsv(rv,ver); /* make a duplicate */
739 upg_version(rv, TRUE);
744 mPUSHs(new_version(ver));
757 croak_xs_usage(cv, "sv");
759 const SV * const sv = ST(0);
773 croak_xs_usage(cv, "sv");
775 SV * const sv = ST(0);
777 const char * const s = SvPV_const(sv,len);
778 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
791 croak_xs_usage(cv, "sv");
792 sv_utf8_encode(ST(0));
801 croak_xs_usage(cv, "sv");
803 SV * const sv = ST(0);
804 const bool RETVAL = sv_utf8_decode(sv);
805 ST(0) = boolSV(RETVAL);
816 croak_xs_usage(cv, "sv");
818 SV * const sv = ST(0);
822 RETVAL = sv_utf8_upgrade(sv);
823 XSprePUSH; PUSHi((IV)RETVAL);
828 XS(XS_utf8_downgrade)
832 if (items < 1 || items > 2)
833 croak_xs_usage(cv, "sv, failok=0");
835 SV * const sv = ST(0);
836 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
837 const bool RETVAL = sv_utf8_downgrade(sv, failok);
839 ST(0) = boolSV(RETVAL);
845 XS(XS_utf8_native_to_unicode)
849 const UV uv = SvUV(ST(0));
852 croak_xs_usage(cv, "sv");
854 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
858 XS(XS_utf8_unicode_to_native)
862 const UV uv = SvUV(ST(0));
865 croak_xs_usage(cv, "sv");
867 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
871 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
875 SV * const sv = SvRV(ST(0));
884 else if (items == 2) {
890 /* I hope you really know what you are doing. */
895 XSRETURN_UNDEF; /* Can't happen. */
898 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
902 SV * const sv = SvRV(ST(0));
906 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
907 else if (items == 2) {
908 /* I hope you really know what you are doing. */
909 SvREFCNT(sv) = SvIV(ST(1));
910 XSRETURN_IV(SvREFCNT(sv));
912 XSRETURN_UNDEF; /* Can't happen. */
915 XS(XS_Internals_hv_clear_placehold)
921 croak_xs_usage(cv, "hv");
923 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
924 hv_clear_placeholders(hv);
929 XS(XS_Regexp_DESTROY)
935 XS(XS_PerlIO_get_layers)
939 if (items < 1 || items % 2 == 0)
940 croak_xs_usage(cv, "filehandle[,args]");
947 bool details = FALSE;
951 for (svp = MARK + 2; svp <= SP; svp += 2) {
952 SV * const * const varp = svp;
953 SV * const * const valp = svp + 1;
955 const char * const key = SvPV_const(*varp, klen);
959 if (klen == 5 && memEQ(key, "input", 5)) {
960 input = SvTRUE(*valp);
965 if (klen == 6 && memEQ(key, "output", 6)) {
966 input = !SvTRUE(*valp);
971 if (klen == 7 && memEQ(key, "details", 7)) {
972 details = SvTRUE(*valp);
979 "get_layers: unknown argument '%s'",
991 if (SvROK(sv) && isGV(SvRV(sv)))
992 gv = MUTABLE_GV(SvRV(sv));
994 gv = gv_fetchsv(sv, 0, SVt_PVIO);
997 if (gv && (io = GvIO(gv))) {
998 AV* const av = PerlIO_get_layers(aTHX_ input ?
999 IoIFP(io) : IoOFP(io));
1001 const I32 last = av_len(av);
1004 for (i = last; i >= 0; i -= 3) {
1005 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1006 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1007 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1009 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1010 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1011 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1014 /* Indents of 5? Yuck. */
1015 /* We know that PerlIO_get_layers creates a new SV for
1016 the name and flags, so we can just take a reference
1017 and "steal" it when we free the AV below. */
1019 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1022 ? newSVpvn_flags(SvPVX_const(*argsvp),
1024 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1028 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1034 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1038 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1040 XPUSHs(&PL_sv_undef);
1043 const IV flags = SvIVX(*flgsvp);
1045 if (flags & PERLIO_F_UTF8) {
1046 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1063 XS(XS_Internals_hash_seed)
1066 /* Using dXSARGS would also have dITEM and dSP,
1067 * which define 2 unused local variables. */
1069 PERL_UNUSED_ARG(cv);
1070 PERL_UNUSED_VAR(mark);
1071 XSRETURN_UV(PERL_HASH_SEED);
1074 XS(XS_Internals_rehash_seed)
1077 /* Using dXSARGS would also have dITEM and dSP,
1078 * which define 2 unused local variables. */
1080 PERL_UNUSED_ARG(cv);
1081 PERL_UNUSED_VAR(mark);
1082 XSRETURN_UV(PL_rehash_seed);
1085 XS(XS_Internals_HvREHASH) /* Subject to change */
1089 PERL_UNUSED_ARG(cv);
1091 const HV * const hv = (const HV *) SvRV(ST(0));
1092 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1099 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1106 PERL_UNUSED_VAR(cv);
1109 croak_xs_usage(cv, "sv");
1113 if (SvRXOK(ST(0))) {
1120 XS(XS_re_regnames_count)
1122 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1128 croak_xs_usage(cv, "");
1135 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1156 if (items < 1 || items > 2)
1157 croak_xs_usage(cv, "name[, all ]");
1161 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1166 if (items == 2 && SvTRUE(ST(1))) {
1171 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1194 croak_xs_usage(cv, "[all]");
1196 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1201 if (items == 1 && SvTRUE(ST(0))) {
1209 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1218 av = MUTABLE_AV(SvRV(ret));
1219 length = av_len(av);
1221 for (i = 0; i <= length; i++) {
1222 entry = av_fetch(av, i, FALSE);
1225 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1227 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1236 XS(XS_re_regexp_pattern)
1243 croak_xs_usage(cv, "sv");
1248 Checks if a reference is a regex or not. If the parameter is
1249 not a ref, or is not the result of a qr// then returns false
1250 in scalar context and an empty list in list context.
1251 Otherwise in list context it returns the pattern and the
1252 modifiers, in scalar context it returns the pattern just as it
1253 would if the qr// was stringified normally, regardless as
1254 to the class of the variable and any strigification overloads
1258 if ((re = SvRX(ST(0)))) /* assign deliberate */
1260 /* Housten, we have a regex! */
1265 if ( GIMME_V == G_ARRAY ) {
1267 we are in list context so stringify
1268 the modifiers that apply. We ignore "negative
1269 modifiers" in this scenario.
1272 const char *fptr = INT_PAT_MODS;
1274 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1275 >> RXf_PMf_STD_PMMOD_SHIFT);
1277 while((ch = *fptr++)) {
1278 if(match_flags & 1) {
1279 reflags[left++] = ch;
1284 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1285 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1287 /* return the pattern and the modifiers */
1289 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1292 /* Scalar, so use the string that Perl would return */
1293 /* return the pattern in (?msix:..) format */
1294 #if PERL_VERSION >= 11
1295 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1297 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1298 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1304 /* It ain't a regexp folks */
1305 if ( GIMME_V == G_ARRAY ) {
1306 /* return the empty list */
1309 /* Because of the (?:..) wrapping involved in a
1310 stringified pattern it is impossible to get a
1311 result for a real regexp that would evaluate to
1312 false. Therefore we can return PL_sv_no to signify
1313 that the object is not a regex, this means that one
1316 if (regex($might_be_a_regex) eq '(?:foo)') { }
1318 and not worry about undefined values.
1326 XS(XS_Tie_Hash_NamedCapture_FETCH)
1335 croak_xs_usage(cv, "$key, $flags");
1337 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1344 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1345 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1357 XS(XS_Tie_Hash_NamedCapture_STORE)
1365 croak_xs_usage(cv, "$key, $value, $flags");
1367 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1371 Perl_croak(aTHX_ "%s", PL_no_modify);
1378 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1379 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1382 XS(XS_Tie_Hash_NamedCapture_DELETE)
1386 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1390 croak_xs_usage(cv, "$key, $flags");
1393 Perl_croak(aTHX_ "%s", PL_no_modify);
1397 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1398 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1401 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1409 croak_xs_usage(cv, "$flags");
1411 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1414 Perl_croak(aTHX_ "%s", PL_no_modify);
1418 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1419 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1422 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1431 croak_xs_usage(cv, "$key, $flags");
1433 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1440 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1441 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1450 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1459 croak_xs_usage(cv, "");
1461 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1468 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1469 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1482 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1491 croak_xs_usage(cv, "$lastkey");
1493 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1500 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1501 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1513 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1522 croak_xs_usage(cv, "");
1524 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1531 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1532 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1545 XS(XS_Tie_Hash_NamedCapture_flags)
1551 croak_xs_usage(cv, "");
1553 mXPUSHu(RXapif_ONE);
1554 mXPUSHu(RXapif_ALL);
1562 * c-indentation-style: bsd
1564 * indent-tabs-mode: t
1567 * ex: set ts=8 sts=4 sw=4 noet: