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);
307 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
309 SV * const sv = ST(0);
314 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
315 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
318 name = SvPV_nolen_const(ST(1));
320 ST(0) = boolSV(sv_derived_from(sv, name));
336 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
342 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
343 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
346 name = SvPV_nolen_const(ST(1));
355 pkg = gv_stashsv(sv, 0);
359 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
361 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
368 XS(XS_UNIVERSAL_DOES)
375 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
377 SV * const sv = ST(0);
380 name = SvPV_nolen_const(ST(1));
381 if (sv_does( sv, name ))
388 XS(XS_UNIVERSAL_VERSION)
400 sv = (SV*)SvRV(ST(0));
402 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
406 pkg = gv_stashsv(ST(0), 0);
409 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
411 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
412 SV * const nsv = sv_newmortal();
415 if ( !sv_derived_from(sv, "version"))
416 upg_version(sv, FALSE);
420 sv = (SV*)&PL_sv_undef;
429 const char * const name = HvNAME_get(pkg);
431 "%s does not define $%s::VERSION--version check failed",
435 "%s defines neither package nor VERSION--version check failed",
436 SvPVx_nolen_const(ST(0)) );
440 if ( !sv_derived_from(req, "version")) {
441 /* req may very well be R/O, so create a new object */
442 req = sv_2mortal( new_version(req) );
445 if ( vcmp( req, sv ) > 0 ) {
446 if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) {
447 Perl_croak(aTHX_ "%s version %"SVf" required--"
448 "this is only version %"SVf"", HvNAME_get(pkg),
449 SVfARG(vnormal(req)),
450 SVfARG(vnormal(sv)));
452 Perl_croak(aTHX_ "%s version %"SVf" required--"
453 "this is only version %"SVf"", HvNAME_get(pkg),
454 SVfARG(vstringify(req)),
455 SVfARG(vstringify(sv)));
461 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
462 ST(0) = vstringify(sv);
476 Perl_croak(aTHX_ "Usage: version::new(class, version)");
481 const char * const classname =
482 sv_isobject(ST(0)) /* get the class if called as an object method */
483 ? HvNAME(SvSTASH(SvRV(ST(0))))
484 : (char *)SvPV_nolen(ST(0));
486 if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
487 /* create empty object */
491 else if ( items == 3 ) {
493 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
496 rv = new_version(vs);
497 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
498 sv_bless(rv, gv_stashpv(classname, GV_ADD));
506 XS(XS_version_stringify)
512 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
517 if (sv_derived_from(ST(0), "version")) {
521 Perl_croak(aTHX_ "lobj is not of type version");
523 mPUSHs(vstringify(lobj));
530 XS(XS_version_numify)
536 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
541 if (sv_derived_from(ST(0), "version")) {
545 Perl_croak(aTHX_ "lobj is not of type version");
547 mPUSHs(vnumify(lobj));
554 XS(XS_version_normal)
560 Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
565 if (sv_derived_from(ST(0), "version")) {
569 Perl_croak(aTHX_ "lobj is not of type version");
571 mPUSHs(vnormal(lobj));
584 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
589 if (sv_derived_from(ST(0), "version")) {
593 Perl_croak(aTHX_ "lobj is not of type version");
599 const IV swap = (IV)SvIV(ST(2));
601 if ( ! sv_derived_from(robj, "version") )
603 robj = new_version(robj);
609 rs = newSViv(vcmp(rvs,lobj));
613 rs = newSViv(vcmp(lobj,rvs));
624 XS(XS_version_boolean)
630 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
632 if (sv_derived_from(ST(0), "version")) {
633 SV * const lobj = SvRV(ST(0));
634 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
640 Perl_croak(aTHX_ "lobj is not of type version");
649 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
650 if (sv_derived_from(ST(0), "version"))
651 Perl_croak(aTHX_ "operation not supported with version object");
653 Perl_croak(aTHX_ "lobj is not of type version");
654 #ifndef HASATTRIBUTE_NORETURN
659 XS(XS_version_is_alpha)
665 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
667 if (sv_derived_from(ST(0), "version")) {
668 SV * const lobj = ST(0);
669 if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
677 Perl_croak(aTHX_ "lobj is not of type version");
686 Perl_croak(aTHX_ "Usage: version::qv(ver)");
690 if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
691 SV * const rv = sv_newmortal();
692 sv_setsv(rv,ver); /* make a duplicate */
693 upg_version(rv, TRUE);
698 mPUSHs(new_version(ver));
712 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
714 const SV * const sv = ST(0);
729 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
731 SV * const sv = ST(0);
733 const char * const s = SvPV_const(sv,len);
734 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
748 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
749 sv_utf8_encode(ST(0));
759 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
761 SV * const sv = ST(0);
762 const bool RETVAL = sv_utf8_decode(sv);
763 ST(0) = boolSV(RETVAL);
775 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
777 SV * const sv = ST(0);
781 RETVAL = sv_utf8_upgrade(sv);
782 XSprePUSH; PUSHi((IV)RETVAL);
787 XS(XS_utf8_downgrade)
792 if (items < 1 || items > 2)
793 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
795 SV * const sv = ST(0);
796 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
797 const bool RETVAL = sv_utf8_downgrade(sv, failok);
799 ST(0) = boolSV(RETVAL);
805 XS(XS_utf8_native_to_unicode)
809 const UV uv = SvUV(ST(0));
813 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
815 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
819 XS(XS_utf8_unicode_to_native)
823 const UV uv = SvUV(ST(0));
827 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
829 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
833 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
837 SV * const sv = SvRV(ST(0));
846 else if (items == 2) {
852 /* I hope you really know what you are doing. */
857 XSRETURN_UNDEF; /* Can't happen. */
860 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
864 SV * const sv = SvRV(ST(0));
868 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
869 else if (items == 2) {
870 /* I hope you really know what you are doing. */
871 SvREFCNT(sv) = SvIV(ST(1));
872 XSRETURN_IV(SvREFCNT(sv));
874 XSRETURN_UNDEF; /* Can't happen. */
877 XS(XS_Internals_hv_clear_placehold)
884 Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
886 HV * const hv = (HV *) SvRV(ST(0));
887 hv_clear_placeholders(hv);
892 XS(XS_Regexp_DESTROY)
898 XS(XS_PerlIO_get_layers)
903 if (items < 1 || items % 2 == 0)
904 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(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 = (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 Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1077 if (SvRXOK(ST(0))) {
1084 XS(XS_re_regnames_count)
1086 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1090 PERL_UNUSED_ARG(cv);
1093 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1100 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1120 PERL_UNUSED_ARG(cv);
1122 if (items < 1 || items > 2)
1123 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1127 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1132 if (items == 2 && SvTRUE(ST(1))) {
1137 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1143 XPUSHs(SvREFCNT_inc(ret));
1161 PERL_UNUSED_ARG(cv);
1164 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1166 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1171 if (items == 1 && SvTRUE(ST(0))) {
1179 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1188 av = (AV*)SvRV(ret);
1189 length = av_len(av);
1191 for (i = 0; i <= length; i++) {
1192 entry = av_fetch(av, i, FALSE);
1195 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1203 XS(XS_re_regexp_pattern)
1208 PERL_UNUSED_ARG(cv);
1211 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regexp_pattern", "sv");
1216 Checks if a reference is a regex or not. If the parameter is
1217 not a ref, or is not the result of a qr// then returns false
1218 in scalar context and an empty list in list context.
1219 Otherwise in list context it returns the pattern and the
1220 modifiers, in scalar context it returns the pattern just as it
1221 would if the qr// was stringified normally, regardless as
1222 to the class of the variable and any strigification overloads
1226 if ((re = SvRX(ST(0)))) /* assign deliberate */
1228 /* Housten, we have a regex! */
1233 if ( GIMME_V == G_ARRAY ) {
1235 we are in list context so stringify
1236 the modifiers that apply. We ignore "negative
1237 modifiers" in this scenario.
1240 const char *fptr = INT_PAT_MODS;
1242 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1243 >> RXf_PMf_STD_PMMOD_SHIFT);
1245 while((ch = *fptr++)) {
1246 if(match_flags & 1) {
1247 reflags[left++] = ch;
1252 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1253 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1255 /* return the pattern and the modifiers */
1257 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1260 /* Scalar, so use the string that Perl would return */
1261 /* return the pattern in (?msix:..) format */
1262 #if PERL_VERSION >= 11
1263 pattern = sv_2mortal(newSVsv((SV*)re));
1265 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1266 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1272 /* It ain't a regexp folks */
1273 if ( GIMME_V == G_ARRAY ) {
1274 /* return the empty list */
1277 /* Because of the (?:..) wrapping involved in a
1278 stringified pattern it is impossible to get a
1279 result for a real regexp that would evaluate to
1280 false. Therefore we can return PL_sv_no to signify
1281 that the object is not a regex, this means that one
1284 if (regex($might_be_a_regex) eq '(?:foo)') { }
1286 and not worry about undefined values.
1294 XS(XS_Tie_Hash_NamedCapture_FETCH)
1301 PERL_UNUSED_ARG(cv);
1304 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)");
1306 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1313 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1314 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1322 XPUSHs(SvREFCNT_inc(ret));
1329 XS(XS_Tie_Hash_NamedCapture_STORE)
1335 PERL_UNUSED_ARG(cv);
1338 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)");
1340 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1344 Perl_croak(aTHX_ PL_no_modify);
1351 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1352 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1355 XS(XS_Tie_Hash_NamedCapture_DELETE)
1359 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1361 PERL_UNUSED_ARG(cv);
1364 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)");
1367 Perl_croak(aTHX_ PL_no_modify);
1371 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1372 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1375 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1381 PERL_UNUSED_ARG(cv);
1384 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)");
1386 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1389 Perl_croak(aTHX_ PL_no_modify);
1393 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1394 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1397 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1404 PERL_UNUSED_ARG(cv);
1407 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)");
1409 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1416 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1417 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1426 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1433 PERL_UNUSED_ARG(cv);
1436 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()");
1438 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1445 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1446 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1451 XPUSHs(SvREFCNT_inc(ret));
1459 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1466 PERL_UNUSED_ARG(cv);
1469 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)");
1471 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1478 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1479 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1491 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1498 PERL_UNUSED_ARG(cv);
1501 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()");
1503 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1510 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1511 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1524 XS(XS_Tie_Hash_NamedCapture_flags)
1528 PERL_UNUSED_ARG(cv);
1531 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::flags()");
1533 mXPUSHu(RXapif_ONE);
1534 mXPUSHu(RXapif_ALL);
1542 * c-indentation-style: bsd
1544 * indent-tabs-mode: t
1547 * ex: set ts=8 sts=4 sw=4 noet: