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_Internals_hash_seed);
237 XS(XS_Internals_rehash_seed);
238 XS(XS_Internals_HvREHASH);
242 XS(XS_re_regnames_count);
243 XS(XS_re_regexp_pattern);
244 XS(XS_Tie_Hash_NamedCapture_FETCH);
245 XS(XS_Tie_Hash_NamedCapture_STORE);
246 XS(XS_Tie_Hash_NamedCapture_DELETE);
247 XS(XS_Tie_Hash_NamedCapture_CLEAR);
248 XS(XS_Tie_Hash_NamedCapture_EXISTS);
249 XS(XS_Tie_Hash_NamedCapture_FIRSTK);
250 XS(XS_Tie_Hash_NamedCapture_NEXTK);
251 XS(XS_Tie_Hash_NamedCapture_SCALAR);
252 XS(XS_Tie_Hash_NamedCapture_flags);
255 Perl_boot_core_UNIVERSAL(pTHX)
258 static const char file[] = __FILE__;
260 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
261 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
262 newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file);
263 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
265 /* register the overloading (type 'A') magic */
266 PL_amagic_generation++;
267 /* Make it findable via fetchmethod */
268 newXS("version::()", XS_version_noop, file);
269 newXS("version::new", XS_version_new, file);
270 newXS("version::(\"\"", XS_version_stringify, file);
271 newXS("version::stringify", XS_version_stringify, file);
272 newXS("version::(0+", XS_version_numify, file);
273 newXS("version::numify", XS_version_numify, file);
274 newXS("version::normal", XS_version_normal, file);
275 newXS("version::(cmp", XS_version_vcmp, file);
276 newXS("version::(<=>", XS_version_vcmp, file);
277 newXS("version::vcmp", XS_version_vcmp, file);
278 newXS("version::(bool", XS_version_boolean, file);
279 newXS("version::boolean", XS_version_boolean, file);
280 newXS("version::(nomethod", XS_version_noop, file);
281 newXS("version::noop", XS_version_noop, file);
282 newXS("version::is_alpha", XS_version_is_alpha, file);
283 newXS("version::qv", XS_version_qv, file);
285 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
286 newXS("utf8::valid", XS_utf8_valid, file);
287 newXS("utf8::encode", XS_utf8_encode, file);
288 newXS("utf8::decode", XS_utf8_decode, file);
289 newXS("utf8::upgrade", XS_utf8_upgrade, file);
290 newXS("utf8::downgrade", XS_utf8_downgrade, file);
291 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
292 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
293 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
294 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
295 newXSproto("Internals::hv_clear_placeholders",
296 XS_Internals_hv_clear_placehold, file, "\\%");
297 newXSproto("PerlIO::get_layers",
298 XS_PerlIO_get_layers, file, "*;@");
299 CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
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_PerlIO_get_layers)
933 if (items < 1 || items % 2 == 0)
934 croak_xs_usage(cv, "filehandle[,args]");
941 bool details = FALSE;
945 for (svp = MARK + 2; svp <= SP; svp += 2) {
946 SV * const * const varp = svp;
947 SV * const * const valp = svp + 1;
949 const char * const key = SvPV_const(*varp, klen);
953 if (klen == 5 && memEQ(key, "input", 5)) {
954 input = SvTRUE(*valp);
959 if (klen == 6 && memEQ(key, "output", 6)) {
960 input = !SvTRUE(*valp);
965 if (klen == 7 && memEQ(key, "details", 7)) {
966 details = SvTRUE(*valp);
973 "get_layers: unknown argument '%s'",
985 if (SvROK(sv) && isGV(SvRV(sv)))
986 gv = MUTABLE_GV(SvRV(sv));
988 gv = gv_fetchsv(sv, 0, SVt_PVIO);
991 if (gv && (io = GvIO(gv))) {
992 AV* const av = PerlIO_get_layers(aTHX_ input ?
993 IoIFP(io) : IoOFP(io));
995 const I32 last = av_len(av);
998 for (i = last; i >= 0; i -= 3) {
999 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1000 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1001 SV * const * const flgsvp = av_fetch(av, i, FALSE);
1003 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1004 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1005 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1008 /* Indents of 5? Yuck. */
1009 /* We know that PerlIO_get_layers creates a new SV for
1010 the name and flags, so we can just take a reference
1011 and "steal" it when we free the AV below. */
1013 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1016 ? newSVpvn_flags(SvPVX_const(*argsvp),
1018 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1022 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1028 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1032 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1034 XPUSHs(&PL_sv_undef);
1037 const IV flags = SvIVX(*flgsvp);
1039 if (flags & PERLIO_F_UTF8) {
1040 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1057 XS(XS_Internals_hash_seed)
1060 /* Using dXSARGS would also have dITEM and dSP,
1061 * which define 2 unused local variables. */
1063 PERL_UNUSED_ARG(cv);
1064 PERL_UNUSED_VAR(mark);
1065 XSRETURN_UV(PERL_HASH_SEED);
1068 XS(XS_Internals_rehash_seed)
1071 /* Using dXSARGS would also have dITEM and dSP,
1072 * which define 2 unused local variables. */
1074 PERL_UNUSED_ARG(cv);
1075 PERL_UNUSED_VAR(mark);
1076 XSRETURN_UV(PL_rehash_seed);
1079 XS(XS_Internals_HvREHASH) /* Subject to change */
1083 PERL_UNUSED_ARG(cv);
1085 const HV * const hv = (const HV *) SvRV(ST(0));
1086 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1093 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1100 PERL_UNUSED_VAR(cv);
1103 croak_xs_usage(cv, "sv");
1107 if (SvRXOK(ST(0))) {
1114 XS(XS_re_regnames_count)
1116 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1122 croak_xs_usage(cv, "");
1129 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1150 if (items < 1 || items > 2)
1151 croak_xs_usage(cv, "name[, all ]");
1155 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1160 if (items == 2 && SvTRUE(ST(1))) {
1165 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1188 croak_xs_usage(cv, "[all]");
1190 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1195 if (items == 1 && SvTRUE(ST(0))) {
1203 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1212 av = MUTABLE_AV(SvRV(ret));
1213 length = av_len(av);
1215 for (i = 0; i <= length; i++) {
1216 entry = av_fetch(av, i, FALSE);
1219 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1221 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1230 XS(XS_re_regexp_pattern)
1237 croak_xs_usage(cv, "sv");
1242 Checks if a reference is a regex or not. If the parameter is
1243 not a ref, or is not the result of a qr// then returns false
1244 in scalar context and an empty list in list context.
1245 Otherwise in list context it returns the pattern and the
1246 modifiers, in scalar context it returns the pattern just as it
1247 would if the qr// was stringified normally, regardless as
1248 to the class of the variable and any strigification overloads
1252 if ((re = SvRX(ST(0)))) /* assign deliberate */
1254 /* Housten, we have a regex! */
1259 if ( GIMME_V == G_ARRAY ) {
1261 we are in list context so stringify
1262 the modifiers that apply. We ignore "negative
1263 modifiers" in this scenario.
1266 const char *fptr = INT_PAT_MODS;
1268 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1269 >> RXf_PMf_STD_PMMOD_SHIFT);
1271 while((ch = *fptr++)) {
1272 if(match_flags & 1) {
1273 reflags[left++] = ch;
1278 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1279 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1281 /* return the pattern and the modifiers */
1283 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1286 /* Scalar, so use the string that Perl would return */
1287 /* return the pattern in (?msix:..) format */
1288 #if PERL_VERSION >= 11
1289 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1291 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1292 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1298 /* It ain't a regexp folks */
1299 if ( GIMME_V == G_ARRAY ) {
1300 /* return the empty list */
1303 /* Because of the (?:..) wrapping involved in a
1304 stringified pattern it is impossible to get a
1305 result for a real regexp that would evaluate to
1306 false. Therefore we can return PL_sv_no to signify
1307 that the object is not a regex, this means that one
1310 if (regex($might_be_a_regex) eq '(?:foo)') { }
1312 and not worry about undefined values.
1320 XS(XS_Tie_Hash_NamedCapture_FETCH)
1329 croak_xs_usage(cv, "$key, $flags");
1331 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1338 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1339 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1351 XS(XS_Tie_Hash_NamedCapture_STORE)
1359 croak_xs_usage(cv, "$key, $value, $flags");
1361 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1365 Perl_croak(aTHX_ "%s", PL_no_modify);
1372 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1373 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1376 XS(XS_Tie_Hash_NamedCapture_DELETE)
1380 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1384 croak_xs_usage(cv, "$key, $flags");
1387 Perl_croak(aTHX_ "%s", PL_no_modify);
1391 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1392 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1395 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1403 croak_xs_usage(cv, "$flags");
1405 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1408 Perl_croak(aTHX_ "%s", PL_no_modify);
1412 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1413 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1416 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1425 croak_xs_usage(cv, "$key, $flags");
1427 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1434 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1435 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1444 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1453 croak_xs_usage(cv, "");
1455 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1462 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1463 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1476 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1485 croak_xs_usage(cv, "$lastkey");
1487 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1494 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1495 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1507 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1516 croak_xs_usage(cv, "");
1518 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1525 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1526 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1539 XS(XS_Tie_Hash_NamedCapture_flags)
1545 croak_xs_usage(cv, "");
1547 mXPUSHu(RXapif_ONE);
1548 mXPUSHu(RXapif_ALL);
1556 * c-indentation-style: bsd
1558 * indent-tabs-mode: t
1561 * ex: set ts=8 sts=4 sw=4 noet: