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 /* A stash/class can go by many names (ie. User == main::User), so
49 we compare the stash itself just in case */
50 if (name_stash && ((const HV *)stash == name_stash))
53 hvname = HvNAME_get(stash);
55 if (strEQ(hvname, name))
58 if (strEQ(name, "UNIVERSAL"))
61 stash_linear_isa = mro_get_linear_isa(stash);
62 svp = AvARRAY(stash_linear_isa) + 1;
63 items = AvFILLp(stash_linear_isa);
65 SV* const basename_sv = *svp++;
66 HV* const basestash = gv_stashsv(basename_sv, 0);
68 if (ckWARN(WARN_SYNTAX))
69 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
70 "Can't locate package %"SVf" for the parents of %s",
71 SVfARG(basename_sv), hvname);
74 if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
82 =head1 SV Manipulation Functions
84 =for apidoc sv_derived_from
86 Returns a boolean indicating whether the SV is derived from the specified class
87 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
94 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
104 type = sv_reftype(sv,0);
105 if (type && strEQ(type,name))
107 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
110 stash = gv_stashsv(sv, 0);
114 HV * const name_stash = gv_stashpv(name, 0);
115 return isa_lookup(stash, name, name_stash);
125 Returns a boolean indicating whether the SV performs a specific, named role.
126 The SV can be a Perl object or the name of a Perl class.
134 Perl_sv_does(pTHX_ SV *sv, const char *const name)
136 const char *classname;
146 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
147 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
150 if (sv_isobject(sv)) {
151 classname = sv_reftype(SvRV(sv),TRUE);
153 classname = SvPV_nolen(sv);
156 if (strEQ(name,classname))
161 mXPUSHs(newSVpv(name, 0));
164 methodname = newSVpvs_flags("isa", SVs_TEMP);
165 /* ugly hack: use the SvSCREAM flag so S_method_common
166 * can figure out we're calling DOES() and not isa(),
167 * and report eventual errors correctly. --rgs */
168 SvSCREAM_on(methodname);
169 call_sv(methodname, G_SCALAR | G_METHOD);
172 does_it = SvTRUE( TOPs );
179 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
180 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
181 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
182 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
184 XS(XS_version_stringify);
185 XS(XS_version_numify);
186 XS(XS_version_normal);
188 XS(XS_version_boolean);
189 #ifdef HASATTRIBUTE_NORETURN
190 XS(XS_version_noop) __attribute__noreturn__;
194 XS(XS_version_is_alpha);
201 XS(XS_utf8_downgrade);
202 XS(XS_utf8_unicode_to_native);
203 XS(XS_utf8_native_to_unicode);
204 XS(XS_Internals_SvREADONLY);
205 XS(XS_Internals_SvREFCNT);
206 XS(XS_Internals_hv_clear_placehold);
207 XS(XS_PerlIO_get_layers);
208 XS(XS_Regexp_DESTROY);
209 XS(XS_Internals_hash_seed);
210 XS(XS_Internals_rehash_seed);
211 XS(XS_Internals_HvREHASH);
212 XS(XS_Internals_inc_sub_generation);
216 XS(XS_re_regnames_count);
217 XS(XS_re_regexp_pattern);
218 XS(XS_Tie_Hash_NamedCapture_FETCH);
219 XS(XS_Tie_Hash_NamedCapture_STORE);
220 XS(XS_Tie_Hash_NamedCapture_DELETE);
221 XS(XS_Tie_Hash_NamedCapture_CLEAR);
222 XS(XS_Tie_Hash_NamedCapture_EXISTS);
223 XS(XS_Tie_Hash_NamedCapture_FIRSTK);
224 XS(XS_Tie_Hash_NamedCapture_NEXTK);
225 XS(XS_Tie_Hash_NamedCapture_SCALAR);
226 XS(XS_Tie_Hash_NamedCapture_flags);
229 Perl_boot_core_UNIVERSAL(pTHX)
232 static const char file[] = __FILE__;
234 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
235 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
236 newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file);
237 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
239 /* register the overloading (type 'A') magic */
240 PL_amagic_generation++;
241 /* Make it findable via fetchmethod */
242 newXS("version::()", XS_version_noop, file);
243 newXS("version::new", XS_version_new, file);
244 newXS("version::(\"\"", XS_version_stringify, file);
245 newXS("version::stringify", XS_version_stringify, file);
246 newXS("version::(0+", XS_version_numify, file);
247 newXS("version::numify", XS_version_numify, file);
248 newXS("version::normal", XS_version_normal, file);
249 newXS("version::(cmp", XS_version_vcmp, file);
250 newXS("version::(<=>", XS_version_vcmp, file);
251 newXS("version::vcmp", XS_version_vcmp, file);
252 newXS("version::(bool", XS_version_boolean, file);
253 newXS("version::boolean", XS_version_boolean, file);
254 newXS("version::(nomethod", XS_version_noop, file);
255 newXS("version::noop", XS_version_noop, file);
256 newXS("version::is_alpha", XS_version_is_alpha, file);
257 newXS("version::qv", XS_version_qv, file);
259 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
260 newXS("utf8::valid", XS_utf8_valid, file);
261 newXS("utf8::encode", XS_utf8_encode, file);
262 newXS("utf8::decode", XS_utf8_decode, file);
263 newXS("utf8::upgrade", XS_utf8_upgrade, file);
264 newXS("utf8::downgrade", XS_utf8_downgrade, file);
265 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
266 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
267 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
268 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
269 newXSproto("Internals::hv_clear_placeholders",
270 XS_Internals_hv_clear_placehold, file, "\\%");
271 newXSproto("PerlIO::get_layers",
272 XS_PerlIO_get_layers, file, "*;@");
273 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
274 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
275 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
276 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
277 newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
278 newXSproto("re::regname", XS_re_regname, file, ";$$");
279 newXSproto("re::regnames", XS_re_regnames, file, ";$");
280 newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
281 newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
282 newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
283 newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
284 newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
285 newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
286 newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
287 newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file);
288 newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file);
289 newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
290 newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
301 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
303 SV * const sv = ST(0);
308 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
309 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
312 name = SvPV_nolen_const(ST(1));
314 ST(0) = boolSV(sv_derived_from(sv, name));
330 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
336 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
337 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
340 name = SvPV_nolen_const(ST(1));
349 pkg = gv_stashsv(sv, 0);
353 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
355 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
362 XS(XS_UNIVERSAL_DOES)
369 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
371 SV * const sv = ST(0);
374 name = SvPV_nolen_const(ST(1));
375 if (sv_does( sv, name ))
382 XS(XS_UNIVERSAL_VERSION)
394 sv = (SV*)SvRV(ST(0));
396 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
400 pkg = gv_stashsv(ST(0), 0);
403 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
405 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
406 SV * const nsv = sv_newmortal();
409 if ( !sv_derived_from(sv, "version"))
410 upg_version(sv, FALSE);
414 sv = (SV*)&PL_sv_undef;
423 const char * const name = HvNAME_get(pkg);
425 "%s does not define $%s::VERSION--version check failed",
429 "%s defines neither package nor VERSION--version check failed",
430 SvPVx_nolen_const(ST(0)) );
434 if ( !sv_derived_from(req, "version")) {
435 /* req may very well be R/O, so create a new object */
436 req = sv_2mortal( new_version(req) );
439 if ( vcmp( req, sv ) > 0 ) {
440 if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) {
441 Perl_croak(aTHX_ "%s version %"SVf" required--"
442 "this is only version %"SVf"", HvNAME_get(pkg),
443 SVfARG(vnormal(req)),
444 SVfARG(vnormal(sv)));
446 Perl_croak(aTHX_ "%s version %"SVf" required--"
447 "this is only version %"SVf"", HvNAME_get(pkg),
448 SVfARG(vstringify(req)),
449 SVfARG(vstringify(sv)));
455 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
456 ST(0) = vstringify(sv);
470 Perl_croak(aTHX_ "Usage: version::new(class, version)");
475 const char * const classname =
476 sv_isobject(ST(0)) /* get the class if called as an object method */
477 ? HvNAME(SvSTASH(SvRV(ST(0))))
478 : (char *)SvPV_nolen(ST(0));
480 if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
481 /* create empty object */
485 else if ( items == 3 ) {
487 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
490 rv = new_version(vs);
491 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
492 sv_bless(rv, gv_stashpv(classname, GV_ADD));
500 XS(XS_version_stringify)
506 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
511 if (sv_derived_from(ST(0), "version")) {
515 Perl_croak(aTHX_ "lobj is not of type version");
517 mPUSHs(vstringify(lobj));
524 XS(XS_version_numify)
530 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
535 if (sv_derived_from(ST(0), "version")) {
539 Perl_croak(aTHX_ "lobj is not of type version");
541 mPUSHs(vnumify(lobj));
548 XS(XS_version_normal)
554 Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
559 if (sv_derived_from(ST(0), "version")) {
563 Perl_croak(aTHX_ "lobj is not of type version");
565 mPUSHs(vnormal(lobj));
578 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
583 if (sv_derived_from(ST(0), "version")) {
587 Perl_croak(aTHX_ "lobj is not of type version");
593 const IV swap = (IV)SvIV(ST(2));
595 if ( ! sv_derived_from(robj, "version") )
597 robj = new_version(robj);
603 rs = newSViv(vcmp(rvs,lobj));
607 rs = newSViv(vcmp(lobj,rvs));
618 XS(XS_version_boolean)
624 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
626 if (sv_derived_from(ST(0), "version")) {
627 SV * const lobj = SvRV(ST(0));
628 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
634 Perl_croak(aTHX_ "lobj is not of type version");
643 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
644 if (sv_derived_from(ST(0), "version"))
645 Perl_croak(aTHX_ "operation not supported with version object");
647 Perl_croak(aTHX_ "lobj is not of type version");
648 #ifndef HASATTRIBUTE_NORETURN
653 XS(XS_version_is_alpha)
659 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
661 if (sv_derived_from(ST(0), "version")) {
662 SV * const lobj = ST(0);
663 if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
671 Perl_croak(aTHX_ "lobj is not of type version");
680 Perl_croak(aTHX_ "Usage: version::qv(ver)");
684 if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
685 SV * const rv = sv_newmortal();
686 sv_setsv(rv,ver); /* make a duplicate */
687 upg_version(rv, TRUE);
692 mPUSHs(new_version(ver));
706 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
708 const SV * const sv = ST(0);
723 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
725 SV * const sv = ST(0);
727 const char * const s = SvPV_const(sv,len);
728 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
742 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
743 sv_utf8_encode(ST(0));
753 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
755 SV * const sv = ST(0);
756 const bool RETVAL = sv_utf8_decode(sv);
757 ST(0) = boolSV(RETVAL);
769 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
771 SV * const sv = ST(0);
775 RETVAL = sv_utf8_upgrade(sv);
776 XSprePUSH; PUSHi((IV)RETVAL);
781 XS(XS_utf8_downgrade)
786 if (items < 1 || items > 2)
787 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
789 SV * const sv = ST(0);
790 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
791 const bool RETVAL = sv_utf8_downgrade(sv, failok);
793 ST(0) = boolSV(RETVAL);
799 XS(XS_utf8_native_to_unicode)
803 const UV uv = SvUV(ST(0));
807 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
809 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
813 XS(XS_utf8_unicode_to_native)
817 const UV uv = SvUV(ST(0));
821 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
823 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
827 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
831 SV * const sv = SvRV(ST(0));
840 else if (items == 2) {
846 /* I hope you really know what you are doing. */
851 XSRETURN_UNDEF; /* Can't happen. */
854 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
858 SV * const sv = SvRV(ST(0));
862 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
863 else if (items == 2) {
864 /* I hope you really know what you are doing. */
865 SvREFCNT(sv) = SvIV(ST(1));
866 XSRETURN_IV(SvREFCNT(sv));
868 XSRETURN_UNDEF; /* Can't happen. */
871 XS(XS_Internals_hv_clear_placehold)
878 Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
880 HV * const hv = (HV *) SvRV(ST(0));
881 hv_clear_placeholders(hv);
886 XS(XS_Regexp_DESTROY)
892 XS(XS_PerlIO_get_layers)
897 if (items < 1 || items % 2 == 0)
898 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
905 bool details = FALSE;
909 for (svp = MARK + 2; svp <= SP; svp += 2) {
910 SV * const * const varp = svp;
911 SV * const * const valp = svp + 1;
913 const char * const key = SvPV_const(*varp, klen);
917 if (klen == 5 && memEQ(key, "input", 5)) {
918 input = SvTRUE(*valp);
923 if (klen == 6 && memEQ(key, "output", 6)) {
924 input = !SvTRUE(*valp);
929 if (klen == 7 && memEQ(key, "details", 7)) {
930 details = SvTRUE(*valp);
937 "get_layers: unknown argument '%s'",
949 if (SvROK(sv) && isGV(SvRV(sv)))
952 gv = gv_fetchsv(sv, 0, SVt_PVIO);
955 if (gv && (io = GvIO(gv))) {
956 AV* const av = PerlIO_get_layers(aTHX_ input ?
957 IoIFP(io) : IoOFP(io));
959 const I32 last = av_len(av);
962 for (i = last; i >= 0; i -= 3) {
963 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
964 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
965 SV * const * const flgsvp = av_fetch(av, i, FALSE);
967 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
968 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
969 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
972 /* Indents of 5? Yuck. */
973 /* We know that PerlIO_get_layers creates a new SV for
974 the name and flags, so we can just take a reference
975 and "steal" it when we free the AV below. */
977 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
980 ? newSVpvn_flags(SvPVX_const(*argsvp),
982 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
986 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
992 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
996 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
998 XPUSHs(&PL_sv_undef);
1001 const IV flags = SvIVX(*flgsvp);
1003 if (flags & PERLIO_F_UTF8) {
1004 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1021 XS(XS_Internals_hash_seed)
1024 /* Using dXSARGS would also have dITEM and dSP,
1025 * which define 2 unused local variables. */
1027 PERL_UNUSED_ARG(cv);
1028 PERL_UNUSED_VAR(mark);
1029 XSRETURN_UV(PERL_HASH_SEED);
1032 XS(XS_Internals_rehash_seed)
1035 /* Using dXSARGS would also have dITEM and dSP,
1036 * which define 2 unused local variables. */
1038 PERL_UNUSED_ARG(cv);
1039 PERL_UNUSED_VAR(mark);
1040 XSRETURN_UV(PL_rehash_seed);
1043 XS(XS_Internals_HvREHASH) /* Subject to change */
1047 PERL_UNUSED_ARG(cv);
1049 const HV * const hv = (HV *) SvRV(ST(0));
1050 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1057 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1064 PERL_UNUSED_VAR(cv);
1067 Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1071 if (SvRXOK(ST(0))) {
1078 XS(XS_re_regnames_count)
1080 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1084 PERL_UNUSED_ARG(cv);
1087 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1094 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1114 PERL_UNUSED_ARG(cv);
1116 if (items < 1 || items > 2)
1117 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1121 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1126 if (items == 2 && SvTRUE(ST(1))) {
1131 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1137 XPUSHs(SvREFCNT_inc(ret));
1155 PERL_UNUSED_ARG(cv);
1158 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[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()");
1197 XS(XS_re_regexp_pattern)
1202 PERL_UNUSED_ARG(cv);
1205 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regexp_pattern", "sv");
1210 Checks if a reference is a regex or not. If the parameter is
1211 not a ref, or is not the result of a qr// then returns false
1212 in scalar context and an empty list in list context.
1213 Otherwise in list context it returns the pattern and the
1214 modifiers, in scalar context it returns the pattern just as it
1215 would if the qr// was stringified normally, regardless as
1216 to the class of the variable and any strigification overloads
1220 if ((re = SvRX(ST(0)))) /* assign deliberate */
1222 /* Housten, we have a regex! */
1227 if ( GIMME_V == G_ARRAY ) {
1229 we are in list context so stringify
1230 the modifiers that apply. We ignore "negative
1231 modifiers" in this scenario.
1234 const char *fptr = INT_PAT_MODS;
1236 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1237 >> RXf_PMf_STD_PMMOD_SHIFT);
1239 while((ch = *fptr++)) {
1240 if(match_flags & 1) {
1241 reflags[left++] = ch;
1246 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1247 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1249 /* return the pattern and the modifiers */
1251 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1254 /* Scalar, so use the string that Perl would return */
1255 /* return the pattern in (?msix:..) format */
1256 #if PERL_VERSION >= 11
1257 pattern = sv_2mortal(newSVsv((SV*)re));
1259 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1260 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1266 /* It ain't a regexp folks */
1267 if ( GIMME_V == G_ARRAY ) {
1268 /* return the empty list */
1271 /* Because of the (?:..) wrapping involved in a
1272 stringified pattern it is impossible to get a
1273 result for a real regexp that would evaluate to
1274 false. Therefore we can return PL_sv_no to signify
1275 that the object is not a regex, this means that one
1278 if (regex($might_be_a_regex) eq '(?:foo)') { }
1280 and not worry about undefined values.
1288 XS(XS_Tie_Hash_NamedCapture_FETCH)
1295 PERL_UNUSED_ARG(cv);
1298 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)");
1300 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1307 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1308 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1316 XPUSHs(SvREFCNT_inc(ret));
1323 XS(XS_Tie_Hash_NamedCapture_STORE)
1329 PERL_UNUSED_ARG(cv);
1332 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)");
1334 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1338 Perl_croak(aTHX_ PL_no_modify);
1345 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1346 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1349 XS(XS_Tie_Hash_NamedCapture_DELETE)
1353 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1355 PERL_UNUSED_ARG(cv);
1358 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)");
1361 Perl_croak(aTHX_ PL_no_modify);
1365 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1366 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1369 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1375 PERL_UNUSED_ARG(cv);
1378 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)");
1380 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1383 Perl_croak(aTHX_ PL_no_modify);
1387 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1388 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1391 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1398 PERL_UNUSED_ARG(cv);
1401 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)");
1403 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1410 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1411 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1420 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1427 PERL_UNUSED_ARG(cv);
1430 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()");
1432 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1439 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1440 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1445 XPUSHs(SvREFCNT_inc(ret));
1453 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1460 PERL_UNUSED_ARG(cv);
1463 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)");
1465 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1472 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1473 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1485 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1492 PERL_UNUSED_ARG(cv);
1495 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()");
1497 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1504 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1505 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1518 XS(XS_Tie_Hash_NamedCapture_flags)
1522 PERL_UNUSED_ARG(cv);
1525 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::flags()");
1527 mXPUSHu(RXapif_ONE);
1528 mXPUSHu(RXapif_ALL);
1536 * c-indentation-style: bsd
1538 * indent-tabs-mode: t
1541 * ex: set ts=8 sts=4 sw=4 noet: