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 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)
43 const struct mro_meta *const meta = HvMROMETA(stash);
44 HV *const isa = meta->isa ? meta->isa : Perl_get_isa_hash(aTHX_ stash);
45 STRLEN len = strlen(name);
48 PERL_ARGS_ASSERT_ISA_LOOKUP;
50 if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
52 HV_FETCH_ISEXISTS, NULL, 0)) {
53 /* Direct name lookup worked. */
57 /* A stash/class can go by many names (ie. User == main::User), so
58 we use the name in the stash itself, which is canonical. */
59 our_stash = gv_stashpvn(name, len, 0);
62 HEK *const canon_name = HvNAME_HEK(our_stash);
64 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
65 HEK_FLAGS(canon_name),
66 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
75 =head1 SV Manipulation Functions
77 =for apidoc sv_derived_from
79 Returns a boolean indicating whether the SV is derived from the specified class
80 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
87 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
92 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
99 type = sv_reftype(sv,0);
100 if (type && strEQ(type,name))
102 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
105 stash = gv_stashsv(sv, 0);
108 return stash ? isa_lookup(stash, name) : FALSE;
114 Returns a boolean indicating whether the SV performs a specific, named role.
115 The SV can be a Perl object or the name of a Perl class.
123 Perl_sv_does(pTHX_ SV *sv, const char *const name)
125 const char *classname;
130 PERL_ARGS_ASSERT_SV_DOES;
137 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
138 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
141 if (sv_isobject(sv)) {
142 classname = sv_reftype(SvRV(sv),TRUE);
144 classname = SvPV_nolen(sv);
147 if (strEQ(name,classname))
152 mXPUSHs(newSVpv(name, 0));
155 methodname = newSVpvs_flags("isa", SVs_TEMP);
156 /* ugly hack: use the SvSCREAM flag so S_method_common
157 * can figure out we're calling DOES() and not isa(),
158 * and report eventual errors correctly. --rgs */
159 SvSCREAM_on(methodname);
160 call_sv(methodname, G_SCALAR | G_METHOD);
163 does_it = SvTRUE( TOPs );
170 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
171 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
172 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
173 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
175 XS(XS_version_stringify);
176 XS(XS_version_numify);
177 XS(XS_version_normal);
179 XS(XS_version_boolean);
180 #ifdef HASATTRIBUTE_NORETURN
181 XS(XS_version_noop) __attribute__noreturn__;
185 XS(XS_version_is_alpha);
192 XS(XS_utf8_downgrade);
193 XS(XS_utf8_unicode_to_native);
194 XS(XS_utf8_native_to_unicode);
195 XS(XS_Internals_SvREADONLY);
196 XS(XS_Internals_SvREFCNT);
197 XS(XS_Internals_hv_clear_placehold);
198 XS(XS_PerlIO_get_layers);
199 XS(XS_Regexp_DESTROY);
200 XS(XS_Internals_hash_seed);
201 XS(XS_Internals_rehash_seed);
202 XS(XS_Internals_HvREHASH);
203 XS(XS_Internals_inc_sub_generation);
207 XS(XS_re_regnames_count);
208 XS(XS_re_regexp_pattern);
209 XS(XS_Tie_Hash_NamedCapture_FETCH);
210 XS(XS_Tie_Hash_NamedCapture_STORE);
211 XS(XS_Tie_Hash_NamedCapture_DELETE);
212 XS(XS_Tie_Hash_NamedCapture_CLEAR);
213 XS(XS_Tie_Hash_NamedCapture_EXISTS);
214 XS(XS_Tie_Hash_NamedCapture_FIRSTK);
215 XS(XS_Tie_Hash_NamedCapture_NEXTK);
216 XS(XS_Tie_Hash_NamedCapture_SCALAR);
217 XS(XS_Tie_Hash_NamedCapture_flags);
220 Perl_boot_core_UNIVERSAL(pTHX)
223 static const char file[] = __FILE__;
225 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
226 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
227 newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file);
228 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
230 /* register the overloading (type 'A') magic */
231 PL_amagic_generation++;
232 /* Make it findable via fetchmethod */
233 newXS("version::()", XS_version_noop, file);
234 newXS("version::new", XS_version_new, file);
235 newXS("version::(\"\"", XS_version_stringify, file);
236 newXS("version::stringify", XS_version_stringify, file);
237 newXS("version::(0+", XS_version_numify, file);
238 newXS("version::numify", XS_version_numify, file);
239 newXS("version::normal", XS_version_normal, file);
240 newXS("version::(cmp", XS_version_vcmp, file);
241 newXS("version::(<=>", XS_version_vcmp, file);
242 newXS("version::vcmp", XS_version_vcmp, file);
243 newXS("version::(bool", XS_version_boolean, file);
244 newXS("version::boolean", XS_version_boolean, file);
245 newXS("version::(nomethod", XS_version_noop, file);
246 newXS("version::noop", XS_version_noop, file);
247 newXS("version::is_alpha", XS_version_is_alpha, file);
248 newXS("version::qv", XS_version_qv, file);
250 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
251 newXS("utf8::valid", XS_utf8_valid, file);
252 newXS("utf8::encode", XS_utf8_encode, file);
253 newXS("utf8::decode", XS_utf8_decode, file);
254 newXS("utf8::upgrade", XS_utf8_upgrade, file);
255 newXS("utf8::downgrade", XS_utf8_downgrade, file);
256 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
257 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
258 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
259 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
260 newXSproto("Internals::hv_clear_placeholders",
261 XS_Internals_hv_clear_placehold, file, "\\%");
262 newXSproto("PerlIO::get_layers",
263 XS_PerlIO_get_layers, file, "*;@");
264 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
265 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
266 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
267 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
268 newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
269 newXSproto("re::regname", XS_re_regname, file, ";$$");
270 newXSproto("re::regnames", XS_re_regnames, file, ";$");
271 newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
272 newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
273 newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
274 newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
275 newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
276 newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
277 newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
278 newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file);
279 newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file);
280 newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
281 newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
285 =for apidoc croak_xs_usage
287 A specialised variant of C<croak()> for emitting the usage message for xsubs
289 croak_xs_usage(cv, "eee_yow");
291 works out the package name and subroutine name from C<cv>, and then calls
292 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
294 Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow");
300 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
302 const GV *const gv = CvGV(cv);
304 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
307 const char *const gvname = GvNAME(gv);
308 const HV *const stash = GvSTASH(gv);
309 const char *const hvname = stash ? HvNAME_get(stash) : NULL;
312 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
314 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
316 /* Pants. I don't think that it should be possible to get here. */
317 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
327 croak_xs_usage(cv, "reference, kind");
329 SV * const sv = ST(0);
334 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
335 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
338 name = SvPV_nolen_const(ST(1));
340 ST(0) = boolSV(sv_derived_from(sv, name));
355 croak_xs_usage(cv, "object-ref, method");
361 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
362 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
365 name = SvPV_nolen_const(ST(1));
374 pkg = gv_stashsv(sv, 0);
378 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
380 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
387 XS(XS_UNIVERSAL_DOES)
394 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
396 SV * const sv = ST(0);
399 name = SvPV_nolen_const(ST(1));
400 if (sv_does( sv, name ))
407 XS(XS_UNIVERSAL_VERSION)
419 sv = (SV*)SvRV(ST(0));
421 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
425 pkg = gv_stashsv(ST(0), 0);
428 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
430 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
431 SV * const nsv = sv_newmortal();
434 if ( !sv_derived_from(sv, "version"))
435 upg_version(sv, FALSE);
439 sv = (SV*)&PL_sv_undef;
448 const char * const name = HvNAME_get(pkg);
450 "%s does not define $%s::VERSION--version check failed",
454 "%s defines neither package nor VERSION--version check failed",
455 SvPVx_nolen_const(ST(0)) );
459 if ( !sv_derived_from(req, "version")) {
460 /* req may very well be R/O, so create a new object */
461 req = sv_2mortal( new_version(req) );
464 if ( vcmp( req, sv ) > 0 ) {
465 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
466 Perl_croak(aTHX_ "%s version %"SVf" required--"
467 "this is only version %"SVf"", HvNAME_get(pkg),
468 SVfARG(vnormal(req)),
469 SVfARG(vnormal(sv)));
471 Perl_croak(aTHX_ "%s version %"SVf" required--"
472 "this is only version %"SVf"", HvNAME_get(pkg),
473 SVfARG(vstringify(req)),
474 SVfARG(vstringify(sv)));
480 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
481 ST(0) = vstringify(sv);
494 croak_xs_usage(cv, "class, version");
499 const char * const classname =
500 sv_isobject(ST(0)) /* get the class if called as an object method */
501 ? HvNAME(SvSTASH(SvRV(ST(0))))
502 : (char *)SvPV_nolen(ST(0));
504 if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
505 /* create empty object */
509 else if ( items == 3 ) {
511 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
514 rv = new_version(vs);
515 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
516 sv_bless(rv, gv_stashpv(classname, GV_ADD));
524 XS(XS_version_stringify)
529 croak_xs_usage(cv, "lobj, ...");
534 if (sv_derived_from(ST(0), "version")) {
538 Perl_croak(aTHX_ "lobj is not of type version");
540 mPUSHs(vstringify(lobj));
547 XS(XS_version_numify)
552 croak_xs_usage(cv, "lobj, ...");
557 if (sv_derived_from(ST(0), "version")) {
561 Perl_croak(aTHX_ "lobj is not of type version");
563 mPUSHs(vnumify(lobj));
570 XS(XS_version_normal)
575 croak_xs_usage(cv, "lobj, ...");
580 if (sv_derived_from(ST(0), "version")) {
584 Perl_croak(aTHX_ "lobj is not of type version");
586 mPUSHs(vnormal(lobj));
598 croak_xs_usage(cv, "lobj, ...");
603 if (sv_derived_from(ST(0), "version")) {
607 Perl_croak(aTHX_ "lobj is not of type version");
613 const IV swap = (IV)SvIV(ST(2));
615 if ( ! sv_derived_from(robj, "version") )
617 robj = new_version(robj);
623 rs = newSViv(vcmp(rvs,lobj));
627 rs = newSViv(vcmp(lobj,rvs));
638 XS(XS_version_boolean)
643 croak_xs_usage(cv, "lobj, ...");
645 if (sv_derived_from(ST(0), "version")) {
646 SV * const lobj = SvRV(ST(0));
647 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
653 Perl_croak(aTHX_ "lobj is not of type version");
661 croak_xs_usage(cv, "lobj, ...");
662 if (sv_derived_from(ST(0), "version"))
663 Perl_croak(aTHX_ "operation not supported with version object");
665 Perl_croak(aTHX_ "lobj is not of type version");
666 #ifndef HASATTRIBUTE_NORETURN
671 XS(XS_version_is_alpha)
676 croak_xs_usage(cv, "lobj");
678 if (sv_derived_from(ST(0), "version")) {
679 SV * const lobj = ST(0);
680 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
688 Perl_croak(aTHX_ "lobj is not of type version");
696 croak_xs_usage(cv, "ver");
700 if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
701 SV * const rv = sv_newmortal();
702 sv_setsv(rv,ver); /* make a duplicate */
703 upg_version(rv, TRUE);
708 mPUSHs(new_version(ver));
721 croak_xs_usage(cv, "sv");
723 const SV * const sv = ST(0);
737 croak_xs_usage(cv, "sv");
739 SV * const sv = ST(0);
741 const char * const s = SvPV_const(sv,len);
742 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
755 croak_xs_usage(cv, "sv");
756 sv_utf8_encode(ST(0));
765 croak_xs_usage(cv, "sv");
767 SV * const sv = ST(0);
768 const bool RETVAL = sv_utf8_decode(sv);
769 ST(0) = boolSV(RETVAL);
780 croak_xs_usage(cv, "sv");
782 SV * const sv = ST(0);
786 RETVAL = sv_utf8_upgrade(sv);
787 XSprePUSH; PUSHi((IV)RETVAL);
792 XS(XS_utf8_downgrade)
796 if (items < 1 || items > 2)
797 croak_xs_usage(cv, "sv, failok=0");
799 SV * const sv = ST(0);
800 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
801 const bool RETVAL = sv_utf8_downgrade(sv, failok);
803 ST(0) = boolSV(RETVAL);
809 XS(XS_utf8_native_to_unicode)
813 const UV uv = SvUV(ST(0));
816 croak_xs_usage(cv, "sv");
818 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
822 XS(XS_utf8_unicode_to_native)
826 const UV uv = SvUV(ST(0));
829 croak_xs_usage(cv, "sv");
831 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
835 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
839 SV * const sv = SvRV(ST(0));
848 else if (items == 2) {
854 /* I hope you really know what you are doing. */
859 XSRETURN_UNDEF; /* Can't happen. */
862 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
866 SV * const sv = SvRV(ST(0));
870 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
871 else if (items == 2) {
872 /* I hope you really know what you are doing. */
873 SvREFCNT(sv) = SvIV(ST(1));
874 XSRETURN_IV(SvREFCNT(sv));
876 XSRETURN_UNDEF; /* Can't happen. */
879 XS(XS_Internals_hv_clear_placehold)
885 croak_xs_usage(cv, "hv");
887 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
888 hv_clear_placeholders(hv);
893 XS(XS_Regexp_DESTROY)
899 XS(XS_PerlIO_get_layers)
903 if (items < 1 || items % 2 == 0)
904 croak_xs_usage(cv, "filehandle[,args]");
911 bool details = FALSE;
915 for (svp = MARK + 2; svp <= SP; svp += 2) {
916 SV * const * const varp = svp;
917 SV * const * const valp = svp + 1;
919 const char * const key = SvPV_const(*varp, klen);
923 if (klen == 5 && memEQ(key, "input", 5)) {
924 input = SvTRUE(*valp);
929 if (klen == 6 && memEQ(key, "output", 6)) {
930 input = !SvTRUE(*valp);
935 if (klen == 7 && memEQ(key, "details", 7)) {
936 details = SvTRUE(*valp);
943 "get_layers: unknown argument '%s'",
955 if (SvROK(sv) && isGV(SvRV(sv)))
958 gv = gv_fetchsv(sv, 0, SVt_PVIO);
961 if (gv && (io = GvIO(gv))) {
962 AV* const av = PerlIO_get_layers(aTHX_ input ?
963 IoIFP(io) : IoOFP(io));
965 const I32 last = av_len(av);
968 for (i = last; i >= 0; i -= 3) {
969 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
970 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
971 SV * const * const flgsvp = av_fetch(av, i, FALSE);
973 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
974 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
975 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
978 /* Indents of 5? Yuck. */
979 /* We know that PerlIO_get_layers creates a new SV for
980 the name and flags, so we can just take a reference
981 and "steal" it when we free the AV below. */
983 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
986 ? newSVpvn_flags(SvPVX_const(*argsvp),
988 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
992 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
998 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1002 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1004 XPUSHs(&PL_sv_undef);
1007 const IV flags = SvIVX(*flgsvp);
1009 if (flags & PERLIO_F_UTF8) {
1010 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1027 XS(XS_Internals_hash_seed)
1030 /* Using dXSARGS would also have dITEM and dSP,
1031 * which define 2 unused local variables. */
1033 PERL_UNUSED_ARG(cv);
1034 PERL_UNUSED_VAR(mark);
1035 XSRETURN_UV(PERL_HASH_SEED);
1038 XS(XS_Internals_rehash_seed)
1041 /* Using dXSARGS would also have dITEM and dSP,
1042 * which define 2 unused local variables. */
1044 PERL_UNUSED_ARG(cv);
1045 PERL_UNUSED_VAR(mark);
1046 XSRETURN_UV(PL_rehash_seed);
1049 XS(XS_Internals_HvREHASH) /* Subject to change */
1053 PERL_UNUSED_ARG(cv);
1055 const HV * const hv = (const HV *) SvRV(ST(0));
1056 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1063 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1070 PERL_UNUSED_VAR(cv);
1073 croak_xs_usage(cv, "sv");
1077 if (SvRXOK(ST(0))) {
1084 XS(XS_re_regnames_count)
1086 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1092 croak_xs_usage(cv, "");
1099 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1120 if (items < 1 || items > 2)
1121 croak_xs_usage(cv, "name[, all ]");
1125 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1130 if (items == 2 && SvTRUE(ST(1))) {
1135 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1158 croak_xs_usage(cv, "[all]");
1160 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1165 if (items == 1 && SvTRUE(ST(0))) {
1173 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1182 av = (AV*)SvRV(ret);
1183 length = av_len(av);
1185 for (i = 0; i <= length; i++) {
1186 entry = av_fetch(av, i, FALSE);
1189 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1191 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1200 XS(XS_re_regexp_pattern)
1207 croak_xs_usage(cv, "sv");
1212 Checks if a reference is a regex or not. If the parameter is
1213 not a ref, or is not the result of a qr// then returns false
1214 in scalar context and an empty list in list context.
1215 Otherwise in list context it returns the pattern and the
1216 modifiers, in scalar context it returns the pattern just as it
1217 would if the qr// was stringified normally, regardless as
1218 to the class of the variable and any strigification overloads
1222 if ((re = SvRX(ST(0)))) /* assign deliberate */
1224 /* Housten, we have a regex! */
1229 if ( GIMME_V == G_ARRAY ) {
1231 we are in list context so stringify
1232 the modifiers that apply. We ignore "negative
1233 modifiers" in this scenario.
1236 const char *fptr = INT_PAT_MODS;
1238 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1239 >> RXf_PMf_STD_PMMOD_SHIFT);
1241 while((ch = *fptr++)) {
1242 if(match_flags & 1) {
1243 reflags[left++] = ch;
1248 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1249 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1251 /* return the pattern and the modifiers */
1253 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1256 /* Scalar, so use the string that Perl would return */
1257 /* return the pattern in (?msix:..) format */
1258 #if PERL_VERSION >= 11
1259 pattern = sv_2mortal(newSVsv((SV*)re));
1261 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1262 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1268 /* It ain't a regexp folks */
1269 if ( GIMME_V == G_ARRAY ) {
1270 /* return the empty list */
1273 /* Because of the (?:..) wrapping involved in a
1274 stringified pattern it is impossible to get a
1275 result for a real regexp that would evaluate to
1276 false. Therefore we can return PL_sv_no to signify
1277 that the object is not a regex, this means that one
1280 if (regex($might_be_a_regex) eq '(?:foo)') { }
1282 and not worry about undefined values.
1290 XS(XS_Tie_Hash_NamedCapture_FETCH)
1299 croak_xs_usage(cv, "$key, $flags");
1301 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1308 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1309 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1321 XS(XS_Tie_Hash_NamedCapture_STORE)
1329 croak_xs_usage(cv, "$key, $value, $flags");
1331 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1335 Perl_croak(aTHX_ PL_no_modify);
1342 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1343 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1346 XS(XS_Tie_Hash_NamedCapture_DELETE)
1350 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1354 croak_xs_usage(cv, "$key, $flags");
1357 Perl_croak(aTHX_ PL_no_modify);
1361 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1362 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1365 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1373 croak_xs_usage(cv, "$flags");
1375 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1378 Perl_croak(aTHX_ PL_no_modify);
1382 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1383 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1386 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1395 croak_xs_usage(cv, "$key, $flags");
1397 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1404 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1405 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1414 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1423 croak_xs_usage(cv, "");
1425 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1432 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1433 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1446 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1455 croak_xs_usage(cv, "$lastkey");
1457 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1464 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1465 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1477 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1486 croak_xs_usage(cv, "");
1488 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1495 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1496 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1509 XS(XS_Tie_Hash_NamedCapture_flags)
1515 croak_xs_usage(cv, "");
1517 mXPUSHu(RXapif_ONE);
1518 mXPUSHu(RXapif_ALL);
1526 * c-indentation-style: bsd
1528 * indent-tabs-mode: t
1531 * ex: set ts=8 sts=4 sw=4 noet: