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 *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 *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);
973 ? sv_2mortal(newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp)))
976 ? sv_2mortal(newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp)))
979 mXPUSHi(SvIVX(*flgsvp));
981 XPUSHs(&PL_sv_undef);
986 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
990 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf,
993 XPUSHs(&PL_sv_undef);
996 const IV flags = SvIVX(*flgsvp);
998 if (flags & PERLIO_F_UTF8) {
999 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1016 XS(XS_Internals_hash_seed)
1019 /* Using dXSARGS would also have dITEM and dSP,
1020 * which define 2 unused local variables. */
1022 PERL_UNUSED_ARG(cv);
1023 PERL_UNUSED_VAR(mark);
1024 XSRETURN_UV(PERL_HASH_SEED);
1027 XS(XS_Internals_rehash_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(PL_rehash_seed);
1038 XS(XS_Internals_HvREHASH) /* Subject to change */
1042 PERL_UNUSED_ARG(cv);
1044 const HV * const hv = (HV *) SvRV(ST(0));
1045 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1052 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1059 PERL_UNUSED_VAR(cv);
1062 Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1066 if (SvRXOK(ST(0))) {
1073 XS(XS_re_regnames_count)
1075 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1079 PERL_UNUSED_ARG(cv);
1082 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1089 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1109 PERL_UNUSED_ARG(cv);
1111 if (items < 1 || items > 2)
1112 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1116 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1121 if (items == 2 && SvTRUE(ST(1))) {
1126 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1132 XPUSHs(SvREFCNT_inc(ret));
1150 PERL_UNUSED_ARG(cv);
1153 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1155 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1160 if (items == 1 && SvTRUE(ST(0))) {
1168 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1177 av = (AV*)SvRV(ret);
1178 length = av_len(av);
1180 for (i = 0; i <= length; i++) {
1181 entry = av_fetch(av, i, FALSE);
1184 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1192 XS(XS_re_regexp_pattern)
1197 PERL_UNUSED_ARG(cv);
1200 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regexp_pattern", "sv");
1205 Checks if a reference is a regex or not. If the parameter is
1206 not a ref, or is not the result of a qr// then returns false
1207 in scalar context and an empty list in list context.
1208 Otherwise in list context it returns the pattern and the
1209 modifiers, in scalar context it returns the pattern just as it
1210 would if the qr// was stringified normally, regardless as
1211 to the class of the variable and any strigification overloads
1215 if ((re = SvRX(ST(0)))) /* assign deliberate */
1217 /* Housten, we have a regex! */
1222 if ( GIMME_V == G_ARRAY ) {
1224 we are in list context so stringify
1225 the modifiers that apply. We ignore "negative
1226 modifiers" in this scenario.
1229 const char *fptr = INT_PAT_MODS;
1231 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1232 >> RXf_PMf_STD_PMMOD_SHIFT);
1234 while((ch = *fptr++)) {
1235 if(match_flags & 1) {
1236 reflags[left++] = ch;
1241 pattern = sv_2mortal(newSVpvn(RX_PRECOMP(re),RX_PRELEN(re)));
1245 /* return the pattern and the modifiers */
1247 XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
1250 /* Scalar, so use the string that Perl would return */
1251 /* return the pattern in (?msix:..) format */
1252 #if PERL_VERSION >= 11
1253 pattern = sv_2mortal(newSVsv((SV*)re));
1255 pattern = sv_2mortal(newSVpvn(RX_WRAPPED(re),RX_WRAPLEN(re)));
1263 /* It ain't a regexp folks */
1264 if ( GIMME_V == G_ARRAY ) {
1265 /* return the empty list */
1268 /* Because of the (?:..) wrapping involved in a
1269 stringified pattern it is impossible to get a
1270 result for a real regexp that would evaluate to
1271 false. Therefore we can return PL_sv_no to signify
1272 that the object is not a regex, this means that one
1275 if (regex($might_be_a_regex) eq '(?:foo)') { }
1277 and not worry about undefined values.
1285 XS(XS_Tie_Hash_NamedCapture_FETCH)
1292 PERL_UNUSED_ARG(cv);
1295 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)");
1297 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1304 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1305 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1313 XPUSHs(SvREFCNT_inc(ret));
1320 XS(XS_Tie_Hash_NamedCapture_STORE)
1326 PERL_UNUSED_ARG(cv);
1329 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($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;
1352 PERL_UNUSED_ARG(cv);
1355 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)");
1358 Perl_croak(aTHX_ PL_no_modify);
1362 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1363 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1366 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1372 PERL_UNUSED_ARG(cv);
1375 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)");
1377 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1380 Perl_croak(aTHX_ PL_no_modify);
1384 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1385 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1388 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1395 PERL_UNUSED_ARG(cv);
1398 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)");
1400 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1407 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1408 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1417 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1424 PERL_UNUSED_ARG(cv);
1427 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()");
1429 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1436 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1437 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1442 XPUSHs(SvREFCNT_inc(ret));
1450 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1457 PERL_UNUSED_ARG(cv);
1460 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)");
1462 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1469 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1470 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1482 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1489 PERL_UNUSED_ARG(cv);
1492 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()");
1494 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1501 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1502 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1515 XS(XS_Tie_Hash_NamedCapture_flags)
1519 PERL_UNUSED_ARG(cv);
1522 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::flags()");
1524 mXPUSHu(RXapif_ONE);
1525 mXPUSHu(RXapif_ALL);
1533 * c-indentation-style: bsd
1535 * indent-tabs-mode: t
1538 * ex: set ts=8 sts=4 sw=4 noet: