3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 * 2005, 2006, 2007 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 story
17 /* This file contains the code that implements the functions in Perl's
18 * UNIVERSAL package, such as UNIVERSAL->can().
20 * It is also used to store XS functions that need to be present in
21 * miniperl for a lack of a better place to put them. It might be
22 * clever to move them to seperate XS files which would then be pulled
23 * in by some to-be-written build process.
27 #define PERL_IN_UNIVERSAL_C
31 #include "perliol.h" /* For the PERLIO_F_XXX */
35 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
36 * The main guts of traverse_isa was actually copied from gv_fetchmeth
40 S_isa_lookup(pTHX_ HV *stash, const char * const name, const HV* const name_stash)
48 PERL_ARGS_ASSERT_ISA_LOOKUP;
50 /* A stash/class can go by many names (ie. User == main::User), so
51 we compare the stash itself just in case */
52 if (name_stash && ((const HV *)stash == name_stash))
55 hvname = HvNAME_get(stash);
57 if (strEQ(hvname, name))
60 if (strEQ(name, "UNIVERSAL"))
63 stash_linear_isa = mro_get_linear_isa(stash);
64 svp = AvARRAY(stash_linear_isa) + 1;
65 items = AvFILLp(stash_linear_isa);
67 SV* const basename_sv = *svp++;
68 HV* const basestash = gv_stashsv(basename_sv, 0);
70 if (ckWARN(WARN_SYNTAX))
71 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
72 "Can't locate package %"SVf" for the parents of %s",
73 SVfARG(basename_sv), hvname);
76 if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
84 =head1 SV Manipulation Functions
86 =for apidoc sv_derived_from
88 Returns a boolean indicating whether the SV is derived from the specified class
89 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
96 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
101 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
108 type = sv_reftype(sv,0);
109 if (type && strEQ(type,name))
111 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
114 stash = gv_stashsv(sv, 0);
118 HV * const name_stash = gv_stashpv(name, 0);
119 return isa_lookup(stash, name, name_stash);
129 Returns a boolean indicating whether the SV performs a specific, named role.
130 The SV can be a Perl object or the name of a Perl class.
138 Perl_sv_does(pTHX_ SV *sv, const char *const name)
140 const char *classname;
145 PERL_ARGS_ASSERT_SV_DOES;
152 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
153 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
156 if (sv_isobject(sv)) {
157 classname = sv_reftype(SvRV(sv),TRUE);
159 classname = SvPV_nolen(sv);
162 if (strEQ(name,classname))
167 mXPUSHs(newSVpv(name, 0));
170 methodname = newSVpvs_flags("isa", SVs_TEMP);
171 /* ugly hack: use the SvSCREAM flag so S_method_common
172 * can figure out we're calling DOES() and not isa(),
173 * and report eventual errors correctly. --rgs */
174 SvSCREAM_on(methodname);
175 call_sv(methodname, G_SCALAR | G_METHOD);
178 does_it = SvTRUE( TOPs );
185 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
186 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
187 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
188 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
190 XS(XS_version_stringify);
191 XS(XS_version_numify);
192 XS(XS_version_normal);
194 XS(XS_version_boolean);
195 #ifdef HASATTRIBUTE_NORETURN
196 XS(XS_version_noop) __attribute__noreturn__;
200 XS(XS_version_is_alpha);
207 XS(XS_utf8_downgrade);
208 XS(XS_utf8_unicode_to_native);
209 XS(XS_utf8_native_to_unicode);
210 XS(XS_Internals_SvREADONLY);
211 XS(XS_Internals_SvREFCNT);
212 XS(XS_Internals_hv_clear_placehold);
213 XS(XS_PerlIO_get_layers);
214 XS(XS_Regexp_DESTROY);
215 XS(XS_Internals_hash_seed);
216 XS(XS_Internals_rehash_seed);
217 XS(XS_Internals_HvREHASH);
218 XS(XS_Internals_inc_sub_generation);
222 XS(XS_re_regnames_count);
223 XS(XS_re_regexp_pattern);
224 XS(XS_Tie_Hash_NamedCapture_FETCH);
225 XS(XS_Tie_Hash_NamedCapture_STORE);
226 XS(XS_Tie_Hash_NamedCapture_DELETE);
227 XS(XS_Tie_Hash_NamedCapture_CLEAR);
228 XS(XS_Tie_Hash_NamedCapture_EXISTS);
229 XS(XS_Tie_Hash_NamedCapture_FIRSTK);
230 XS(XS_Tie_Hash_NamedCapture_NEXTK);
231 XS(XS_Tie_Hash_NamedCapture_SCALAR);
232 XS(XS_Tie_Hash_NamedCapture_flags);
235 Perl_boot_core_UNIVERSAL(pTHX)
238 static const char file[] = __FILE__;
240 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
241 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
242 newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file);
243 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
245 /* register the overloading (type 'A') magic */
246 PL_amagic_generation++;
247 /* Make it findable via fetchmethod */
248 newXS("version::()", XS_version_noop, file);
249 newXS("version::new", XS_version_new, file);
250 newXS("version::(\"\"", XS_version_stringify, file);
251 newXS("version::stringify", XS_version_stringify, file);
252 newXS("version::(0+", XS_version_numify, file);
253 newXS("version::numify", XS_version_numify, file);
254 newXS("version::normal", XS_version_normal, file);
255 newXS("version::(cmp", XS_version_vcmp, file);
256 newXS("version::(<=>", XS_version_vcmp, file);
257 newXS("version::vcmp", XS_version_vcmp, file);
258 newXS("version::(bool", XS_version_boolean, file);
259 newXS("version::boolean", XS_version_boolean, file);
260 newXS("version::(nomethod", XS_version_noop, file);
261 newXS("version::noop", XS_version_noop, file);
262 newXS("version::is_alpha", XS_version_is_alpha, file);
263 newXS("version::qv", XS_version_qv, file);
265 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
266 newXS("utf8::valid", XS_utf8_valid, file);
267 newXS("utf8::encode", XS_utf8_encode, file);
268 newXS("utf8::decode", XS_utf8_decode, file);
269 newXS("utf8::upgrade", XS_utf8_upgrade, file);
270 newXS("utf8::downgrade", XS_utf8_downgrade, file);
271 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
272 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
273 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
274 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
275 newXSproto("Internals::hv_clear_placeholders",
276 XS_Internals_hv_clear_placehold, file, "\\%");
277 newXSproto("PerlIO::get_layers",
278 XS_PerlIO_get_layers, file, "*;@");
279 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
280 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
281 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
282 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
283 newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
284 newXSproto("re::regname", XS_re_regname, file, ";$$");
285 newXSproto("re::regnames", XS_re_regnames, file, ";$");
286 newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
287 newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
288 newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
289 newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
290 newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
291 newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
292 newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
293 newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file);
294 newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file);
295 newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
296 newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
300 =for apidoc croak_xs_usage
302 A specialised variant of C<croak()> for emitting the usage message for xsubs
304 croak_xs_usage(cv, "eee_yow");
306 works out the package name and subroutine name from C<cv>, and then calls
307 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
309 Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow");
315 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
317 const GV *const gv = CvGV(cv);
319 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
322 const char *const gvname = GvNAME(gv);
323 const HV *const stash = GvSTASH(gv);
324 const char *const hvname = stash ? HvNAME_get(stash) : NULL;
327 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
329 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
331 /* Pants. I don't think that it should be possible to get here. */
332 Perl_croak(aTHX_ "Usage: CODE(%"UVXf")(%s)", (UV)cv, params);
342 croak_xs_usage(cv, "reference, kind");
344 SV * const sv = ST(0);
349 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
350 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
353 name = SvPV_nolen_const(ST(1));
355 ST(0) = boolSV(sv_derived_from(sv, name));
370 croak_xs_usage(cv, "object-ref, method");
376 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
377 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
380 name = SvPV_nolen_const(ST(1));
389 pkg = gv_stashsv(sv, 0);
393 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
395 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
402 XS(XS_UNIVERSAL_DOES)
409 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
411 SV * const sv = ST(0);
414 name = SvPV_nolen_const(ST(1));
415 if (sv_does( sv, name ))
422 XS(XS_UNIVERSAL_VERSION)
434 sv = (SV*)SvRV(ST(0));
436 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
440 pkg = gv_stashsv(ST(0), 0);
443 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
445 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
446 SV * const nsv = sv_newmortal();
449 if ( !sv_derived_from(sv, "version"))
450 upg_version(sv, FALSE);
454 sv = (SV*)&PL_sv_undef;
463 const char * const name = HvNAME_get(pkg);
465 "%s does not define $%s::VERSION--version check failed",
469 "%s defines neither package nor VERSION--version check failed",
470 SvPVx_nolen_const(ST(0)) );
474 if ( !sv_derived_from(req, "version")) {
475 /* req may very well be R/O, so create a new object */
476 req = sv_2mortal( new_version(req) );
479 if ( vcmp( req, sv ) > 0 ) {
480 if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) {
481 Perl_croak(aTHX_ "%s version %"SVf" required--"
482 "this is only version %"SVf"", HvNAME_get(pkg),
483 SVfARG(vnormal(req)),
484 SVfARG(vnormal(sv)));
486 Perl_croak(aTHX_ "%s version %"SVf" required--"
487 "this is only version %"SVf"", HvNAME_get(pkg),
488 SVfARG(vstringify(req)),
489 SVfARG(vstringify(sv)));
495 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
496 ST(0) = vstringify(sv);
509 croak_xs_usage(cv, "class, version");
514 const char * const classname =
515 sv_isobject(ST(0)) /* get the class if called as an object method */
516 ? HvNAME(SvSTASH(SvRV(ST(0))))
517 : (char *)SvPV_nolen(ST(0));
519 if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
520 /* create empty object */
524 else if ( items == 3 ) {
526 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
529 rv = new_version(vs);
530 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
531 sv_bless(rv, gv_stashpv(classname, GV_ADD));
539 XS(XS_version_stringify)
544 croak_xs_usage(cv, "lobj, ...");
549 if (sv_derived_from(ST(0), "version")) {
553 Perl_croak(aTHX_ "lobj is not of type version");
555 mPUSHs(vstringify(lobj));
562 XS(XS_version_numify)
567 croak_xs_usage(cv, "lobj, ...");
572 if (sv_derived_from(ST(0), "version")) {
576 Perl_croak(aTHX_ "lobj is not of type version");
578 mPUSHs(vnumify(lobj));
585 XS(XS_version_normal)
590 croak_xs_usage(cv, "lobj, ...");
595 if (sv_derived_from(ST(0), "version")) {
599 Perl_croak(aTHX_ "lobj is not of type version");
601 mPUSHs(vnormal(lobj));
613 croak_xs_usage(cv, "lobj, ...");
618 if (sv_derived_from(ST(0), "version")) {
622 Perl_croak(aTHX_ "lobj is not of type version");
628 const IV swap = (IV)SvIV(ST(2));
630 if ( ! sv_derived_from(robj, "version") )
632 robj = new_version(robj);
638 rs = newSViv(vcmp(rvs,lobj));
642 rs = newSViv(vcmp(lobj,rvs));
653 XS(XS_version_boolean)
658 croak_xs_usage(cv, "lobj, ...");
660 if (sv_derived_from(ST(0), "version")) {
661 SV * const lobj = SvRV(ST(0));
662 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
668 Perl_croak(aTHX_ "lobj is not of type version");
676 croak_xs_usage(cv, "lobj, ...");
677 if (sv_derived_from(ST(0), "version"))
678 Perl_croak(aTHX_ "operation not supported with version object");
680 Perl_croak(aTHX_ "lobj is not of type version");
681 #ifndef HASATTRIBUTE_NORETURN
686 XS(XS_version_is_alpha)
691 croak_xs_usage(cv, "lobj");
693 if (sv_derived_from(ST(0), "version")) {
694 SV * const lobj = ST(0);
695 if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
703 Perl_croak(aTHX_ "lobj is not of type version");
711 croak_xs_usage(cv, "ver");
715 if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
716 SV * const rv = sv_newmortal();
717 sv_setsv(rv,ver); /* make a duplicate */
718 upg_version(rv, TRUE);
723 mPUSHs(new_version(ver));
736 croak_xs_usage(cv, "sv");
738 const SV * const sv = ST(0);
752 croak_xs_usage(cv, "sv");
754 SV * const sv = ST(0);
756 const char * const s = SvPV_const(sv,len);
757 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
770 croak_xs_usage(cv, "sv");
771 sv_utf8_encode(ST(0));
780 croak_xs_usage(cv, "sv");
782 SV * const sv = ST(0);
783 const bool RETVAL = sv_utf8_decode(sv);
784 ST(0) = boolSV(RETVAL);
795 croak_xs_usage(cv, "sv");
797 SV * const sv = ST(0);
801 RETVAL = sv_utf8_upgrade(sv);
802 XSprePUSH; PUSHi((IV)RETVAL);
807 XS(XS_utf8_downgrade)
811 if (items < 1 || items > 2)
812 croak_xs_usage(cv, "sv, failok=0");
814 SV * const sv = ST(0);
815 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
816 const bool RETVAL = sv_utf8_downgrade(sv, failok);
818 ST(0) = boolSV(RETVAL);
824 XS(XS_utf8_native_to_unicode)
828 const UV uv = SvUV(ST(0));
831 croak_xs_usage(cv, "sv");
833 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
837 XS(XS_utf8_unicode_to_native)
841 const UV uv = SvUV(ST(0));
844 croak_xs_usage(cv, "sv");
846 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
850 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
854 SV * const sv = SvRV(ST(0));
863 else if (items == 2) {
869 /* I hope you really know what you are doing. */
874 XSRETURN_UNDEF; /* Can't happen. */
877 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
881 SV * const sv = SvRV(ST(0));
885 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
886 else if (items == 2) {
887 /* I hope you really know what you are doing. */
888 SvREFCNT(sv) = SvIV(ST(1));
889 XSRETURN_IV(SvREFCNT(sv));
891 XSRETURN_UNDEF; /* Can't happen. */
894 XS(XS_Internals_hv_clear_placehold)
900 croak_xs_usage(cv, "hv");
902 HV * const hv = (HV *) SvRV(ST(0));
903 hv_clear_placeholders(hv);
908 XS(XS_Regexp_DESTROY)
914 XS(XS_PerlIO_get_layers)
918 if (items < 1 || items % 2 == 0)
919 croak_xs_usage(cv, "filehandle[,args]");
926 bool details = FALSE;
930 for (svp = MARK + 2; svp <= SP; svp += 2) {
931 SV * const * const varp = svp;
932 SV * const * const valp = svp + 1;
934 const char * const key = SvPV_const(*varp, klen);
938 if (klen == 5 && memEQ(key, "input", 5)) {
939 input = SvTRUE(*valp);
944 if (klen == 6 && memEQ(key, "output", 6)) {
945 input = !SvTRUE(*valp);
950 if (klen == 7 && memEQ(key, "details", 7)) {
951 details = SvTRUE(*valp);
958 "get_layers: unknown argument '%s'",
970 if (SvROK(sv) && isGV(SvRV(sv)))
973 gv = gv_fetchsv(sv, 0, SVt_PVIO);
976 if (gv && (io = GvIO(gv))) {
977 AV* const av = PerlIO_get_layers(aTHX_ input ?
978 IoIFP(io) : IoOFP(io));
980 const I32 last = av_len(av);
983 for (i = last; i >= 0; i -= 3) {
984 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
985 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
986 SV * const * const flgsvp = av_fetch(av, i, FALSE);
988 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
989 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
990 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
993 /* Indents of 5? Yuck. */
994 /* We know that PerlIO_get_layers creates a new SV for
995 the name and flags, so we can just take a reference
996 and "steal" it when we free the AV below. */
998 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1001 ? newSVpvn_flags(SvPVX_const(*argsvp),
1003 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1007 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1013 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1017 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1019 XPUSHs(&PL_sv_undef);
1022 const IV flags = SvIVX(*flgsvp);
1024 if (flags & PERLIO_F_UTF8) {
1025 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1042 XS(XS_Internals_hash_seed)
1045 /* Using dXSARGS would also have dITEM and dSP,
1046 * which define 2 unused local variables. */
1048 PERL_UNUSED_ARG(cv);
1049 PERL_UNUSED_VAR(mark);
1050 XSRETURN_UV(PERL_HASH_SEED);
1053 XS(XS_Internals_rehash_seed)
1056 /* Using dXSARGS would also have dITEM and dSP,
1057 * which define 2 unused local variables. */
1059 PERL_UNUSED_ARG(cv);
1060 PERL_UNUSED_VAR(mark);
1061 XSRETURN_UV(PL_rehash_seed);
1064 XS(XS_Internals_HvREHASH) /* Subject to change */
1069 const HV * const hv = (HV *) SvRV(ST(0));
1070 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1077 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1084 PERL_UNUSED_VAR(cv);
1087 croak_xs_usage(cv, "sv");
1091 if (SvRXOK(ST(0))) {
1098 XS(XS_re_regnames_count)
1100 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1106 croak_xs_usage(cv, "");
1113 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1134 if (items < 1 || items > 2)
1135 croak_xs_usage(cv, "name[, all ]");
1139 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1144 if (items == 2 && SvTRUE(ST(1))) {
1149 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1155 XPUSHs(SvREFCNT_inc(ret));
1175 croak_xs_usage(cv, "[all]");
1177 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1182 if (items == 1 && SvTRUE(ST(0))) {
1190 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1199 av = (AV*)SvRV(ret);
1200 length = av_len(av);
1202 for (i = 0; i <= length; i++) {
1203 entry = av_fetch(av, i, FALSE);
1206 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1214 XS(XS_re_regexp_pattern)
1221 croak_xs_usage(cv, "sv");
1226 Checks if a reference is a regex or not. If the parameter is
1227 not a ref, or is not the result of a qr// then returns false
1228 in scalar context and an empty list in list context.
1229 Otherwise in list context it returns the pattern and the
1230 modifiers, in scalar context it returns the pattern just as it
1231 would if the qr// was stringified normally, regardless as
1232 to the class of the variable and any strigification overloads
1236 if ((re = SvRX(ST(0)))) /* assign deliberate */
1238 /* Housten, we have a regex! */
1243 if ( GIMME_V == G_ARRAY ) {
1245 we are in list context so stringify
1246 the modifiers that apply. We ignore "negative
1247 modifiers" in this scenario.
1250 const char *fptr = INT_PAT_MODS;
1252 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1253 >> RXf_PMf_STD_PMMOD_SHIFT);
1255 while((ch = *fptr++)) {
1256 if(match_flags & 1) {
1257 reflags[left++] = ch;
1262 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1263 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1265 /* return the pattern and the modifiers */
1267 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1270 /* Scalar, so use the string that Perl would return */
1271 /* return the pattern in (?msix:..) format */
1272 #if PERL_VERSION >= 11
1273 pattern = sv_2mortal(newSVsv((SV*)re));
1275 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1276 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1282 /* It ain't a regexp folks */
1283 if ( GIMME_V == G_ARRAY ) {
1284 /* return the empty list */
1287 /* Because of the (?:..) wrapping involved in a
1288 stringified pattern it is impossible to get a
1289 result for a real regexp that would evaluate to
1290 false. Therefore we can return PL_sv_no to signify
1291 that the object is not a regex, this means that one
1294 if (regex($might_be_a_regex) eq '(?:foo)') { }
1296 and not worry about undefined values.
1304 XS(XS_Tie_Hash_NamedCapture_FETCH)
1313 croak_xs_usage(cv, "$key, $flags");
1315 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1322 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1323 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1331 XPUSHs(SvREFCNT_inc(ret));
1338 XS(XS_Tie_Hash_NamedCapture_STORE)
1346 croak_xs_usage(cv, "$key, $value, $flags");
1348 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1352 Perl_croak(aTHX_ PL_no_modify);
1359 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1360 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1363 XS(XS_Tie_Hash_NamedCapture_DELETE)
1367 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1371 croak_xs_usage(cv, "$key, $flags");
1374 Perl_croak(aTHX_ PL_no_modify);
1378 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1379 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1382 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1390 croak_xs_usage(cv, "$flags");
1392 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1395 Perl_croak(aTHX_ PL_no_modify);
1399 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1400 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1403 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1412 croak_xs_usage(cv, "$key, $flags");
1414 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1421 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1422 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1431 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1440 croak_xs_usage(cv, "");
1442 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1449 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1450 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1455 XPUSHs(SvREFCNT_inc(ret));
1463 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1472 croak_xs_usage(cv, "$lastkey");
1474 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1481 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1482 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1494 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1503 croak_xs_usage(cv, "");
1505 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1512 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1513 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1526 XS(XS_Tie_Hash_NamedCapture_flags)
1532 croak_xs_usage(cv, "");
1534 mXPUSHu(RXapif_ONE);
1535 mXPUSHu(RXapif_ALL);
1543 * c-indentation-style: bsd
1545 * indent-tabs-mode: t
1548 * ex: set ts=8 sts=4 sw=4 noet: