4 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
5 * 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * '"The roots of those mountains must be roots indeed; there must be
14 * great secrets buried there which have not been discovered since the
15 * beginning."' --Gandalf, relating Gollum's history
17 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
20 /* This file contains the code that implements the functions in Perl's
21 * UNIVERSAL package, such as UNIVERSAL->can().
23 * It is also used to store XS functions that need to be present in
24 * miniperl for a lack of a better place to put them. It might be
25 * clever to move them to separate XS files which would then be pulled
26 * in by some to-be-written build process.
30 #define PERL_IN_UNIVERSAL_C
33 #if defined(USE_PERLIO)
34 #include "perliol.h" /* For the PERLIO_F_XXX */
38 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
39 * The main guts of traverse_isa was actually copied from gv_fetchmeth
42 #define PERL_ARGS_ASSERT_ISA_LOOKUP \
44 assert(namesv || name)
48 S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 flags)
50 const struct mro_meta *const meta = HvMROMETA(stash);
54 PERL_ARGS_ASSERT_ISA_LOOKUP;
57 (void)mro_get_linear_isa(stash);
61 if (hv_common(isa, namesv, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
62 HV_FETCH_ISEXISTS, NULL, 0)) {
63 /* Direct name lookup worked. */
67 /* A stash/class can go by many names (ie. User == main::User), so
68 we use the HvENAME in the stash itself, which is canonical, falling
69 back to HvNAME if necessary. */
70 our_stash = gv_stashsvpvn_cached(namesv, name, len, flags);
73 HEK *canon_name = HvENAME_HEK(our_stash);
74 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
76 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
77 HEK_FLAGS(canon_name),
78 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
86 #define PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN \
88 assert(namesv || name)
91 S_sv_derived_from_svpvn(pTHX_ SV *sv, SV *namesv, const char * name, const STRLEN len, U32 flags)
95 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN;
101 type = sv_reftype(sv,0);
104 name = SvPV_nolen(namesv);
105 if (strEQ(name, type))
113 stash = gv_stashsv(sv, 0);
116 if (stash && isa_lookup(stash, namesv, name, len, flags))
119 stash = gv_stashpvs("UNIVERSAL", 0);
120 return stash && isa_lookup(stash, namesv, name, len, flags);
124 =for apidoc_section $SV
126 =for apidoc sv_derived_from_pvn
128 Returns a boolean indicating whether the SV is derived from the specified class
129 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
132 Currently, the only significant value for C<flags> is SVf_UTF8.
136 =for apidoc sv_derived_from_sv
138 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
139 of an SV instead of a string/length pair. This is the advised form.
146 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
148 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
149 return sv_derived_from_svpvn(sv, namesv, NULL, 0, flags);
153 =for apidoc sv_derived_from
155 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
161 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
163 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
164 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), 0);
168 =for apidoc sv_derived_from_pv
170 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
171 instead of a string/length pair.
178 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
180 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
181 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), flags);
185 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
187 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
188 return sv_derived_from_svpvn(sv, NULL, name, len, flags);
192 =for apidoc sv_isa_sv
194 Returns a boolean indicating whether the SV is an object reference and is
195 derived from the specified class, respecting any C<isa()> method overloading
196 it may have. Returns false if C<sv> is not a reference to an object, or is
197 not derived from the specified class.
199 This is the function used to implement the behaviour of the C<isa> operator.
201 Does not invoke magic on C<sv>.
203 Not to be confused with the older C<sv_isa> function, which does not use an
204 overloaded C<isa()> method, nor will check subclassing.
211 Perl_sv_isa_sv(pTHX_ SV *sv, SV *namesv)
215 PERL_ARGS_ASSERT_SV_ISA_SV;
217 if(!SvROK(sv) || !SvOBJECT(SvRV(sv)))
220 isagv = gv_fetchmeth_pvn(SvSTASH(SvRV(sv)), "isa", 3, -1, GV_NOUNIVERSAL);
223 CV *isacv = isGV(isagv) ? GvCV(isagv) : (CV *)isagv;
238 call_sv((SV *)isacv, G_SCALAR);
251 /* TODO: Support namesv being an HV ref to the stash directly? */
253 return sv_derived_from_sv(sv, namesv, 0);
257 =for apidoc sv_does_sv
259 Returns a boolean indicating whether the SV performs a specific, named role.
260 The SV can be a Perl object or the name of a Perl class.
268 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
275 PERL_ARGS_ASSERT_SV_DOES_SV;
276 PERL_UNUSED_ARG(flags);
283 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
288 if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
289 classname = sv_ref(NULL,SvRV(sv),TRUE);
294 if (sv_eq(classname, namesv)) {
305 /* create a PV with value "isa", but with a special address
306 * so that perl knows we're really doing "DOES" instead */
307 methodname = newSV_type_mortal(SVt_PV);
308 SvLEN_set(methodname, 0);
309 SvCUR_set(methodname, strlen(PL_isa_DOES));
310 SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
311 SvPOK_on(methodname);
312 call_sv(methodname, G_SCALAR | G_METHOD);
315 does_it = SvTRUE_NN( TOPs );
325 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
331 Perl_sv_does(pTHX_ SV *sv, const char *const name)
333 PERL_ARGS_ASSERT_SV_DOES;
334 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
338 =for apidoc sv_does_pv
340 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
347 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
349 PERL_ARGS_ASSERT_SV_DOES_PV;
350 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
354 =for apidoc sv_does_pvn
356 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
362 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
364 PERL_ARGS_ASSERT_SV_DOES_PVN;
366 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
370 =for apidoc croak_xs_usage
372 A specialised variant of C<croak()> for emitting the usage message for xsubs
374 croak_xs_usage(cv, "eee_yow");
376 works out the package name and subroutine name from C<cv>, and then calls
377 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
379 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
386 Perl_croak_xs_usage(const CV *const cv, const char *const params)
388 /* Avoid CvGV as it requires aTHX. */
389 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
391 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
394 const HV *const stash = GvSTASH(gv);
396 if (HvNAME_get(stash))
397 /* diag_listed_as: SKIPME */
398 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
399 HEKfARG(HvNAME_HEK(stash)),
400 HEKfARG(GvNAME_HEK(gv)),
403 /* diag_listed_as: SKIPME */
404 Perl_croak_nocontext("Usage: %" HEKf "(%s)",
405 HEKfARG(GvNAME_HEK(gv)), params);
408 if ((gv = CvGV(cv))) goto got_gv;
410 /* Pants. I don't think that it should be possible to get here. */
411 /* diag_listed_as: SKIPME */
412 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
416 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
422 croak_xs_usage(cv, "reference, kind");
424 SV * const sv = ST(0);
428 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
431 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
436 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
446 croak_xs_usage(cv, "object-ref, method");
452 /* Reject undef and empty string. Note that the string form takes
453 precedence here over the numeric form, as (!1)->foo treats the
454 invocant as the empty string, though it is a dualvar. */
455 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
461 sv = MUTABLE_SV(SvRV(sv));
464 else if (isGV_with_GP(sv) && GvIO(sv))
465 pkg = SvSTASH(GvIO(sv));
467 else if (isGV_with_GP(sv) && GvIO(sv))
468 pkg = SvSTASH(GvIO(sv));
469 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
470 pkg = SvSTASH(GvIO(iogv));
472 pkg = gv_stashsv(sv, 0);
474 pkg = gv_stashpvs("UNIVERSAL", 0);
478 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
480 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
487 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
488 XS(XS_UNIVERSAL_DOES)
494 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
496 SV * const sv = ST(0);
497 if (sv_does_sv( sv, ST(1), 0 ))
504 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
509 croak_xs_usage(cv, "sv");
511 SV * const sv = ST(0);
521 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
526 croak_xs_usage(cv, "sv");
528 SV * const sv = ST(0);
530 const char * const s = SvPV_const(sv,len);
531 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
539 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
544 croak_xs_usage(cv, "sv");
545 sv_utf8_encode(ST(0));
550 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
555 croak_xs_usage(cv, "sv");
557 SV * const sv = ST(0);
559 SvPV_force_nolen(sv);
560 RETVAL = sv_utf8_decode(sv);
562 ST(0) = boolSV(RETVAL);
567 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
572 croak_xs_usage(cv, "sv");
574 SV * const sv = ST(0);
578 RETVAL = sv_utf8_upgrade(sv);
579 XSprePUSH; PUSHi((IV)RETVAL);
584 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
585 XS(XS_utf8_downgrade)
588 if (items < 1 || items > 2)
589 croak_xs_usage(cv, "sv, failok=0");
591 SV * const sv0 = ST(0);
592 SV * const sv1 = ST(1);
593 const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0;
594 const bool RETVAL = sv_utf8_downgrade(sv0, failok);
596 ST(0) = boolSV(RETVAL);
601 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
602 XS(XS_utf8_native_to_unicode)
605 const UV uv = SvUV(ST(0));
608 croak_xs_usage(cv, "sv");
610 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
614 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
615 XS(XS_utf8_unicode_to_native)
618 const UV uv = SvUV(ST(0));
621 croak_xs_usage(cv, "sv");
623 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
627 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
628 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
631 SV * const svz = ST(0);
634 /* [perl #77776] - called as &foo() not foo() */
636 croak_xs_usage(cv, "SCALAR[, ON]");
646 else if (items == 2) {
648 if (SvTRUE_NN(sv1)) {
649 SvFLAGS(sv) |= SVf_READONLY;
653 /* I hope you really know what you are doing. */
654 SvFLAGS(sv) &=~ SVf_READONLY;
658 XSRETURN_UNDEF; /* Can't happen. */
661 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
662 XS(XS_constant__make_const) /* This is dangerous stuff. */
665 SV * const svz = ST(0);
668 /* [perl #77776] - called as &foo() not foo() */
669 if (!SvROK(svz) || items != 1)
670 croak_xs_usage(cv, "SCALAR");
675 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
676 /* for constant.pm; nobody else should be calling this
679 for (svp = AvARRAY(sv) + AvFILLp(sv)
682 if (*svp) SvPADTMP_on(*svp);
687 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
688 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
691 SV * const svz = ST(0);
695 /* [perl #77776] - called as &foo() not foo() */
696 if ((items != 1 && items != 2) || !SvROK(svz))
697 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
701 /* I hope you really know what you are doing. */
702 /* idea is for SvREFCNT(sv) to be accessed only once */
703 refcnt = items == 2 ?
704 /* we free one ref on exit */
705 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
707 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
711 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
712 XS(XS_Internals_hv_clear_placehold)
716 if (items != 1 || !SvROK(ST(0)))
717 croak_xs_usage(cv, "hv");
719 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
720 hv_clear_placeholders(hv);
725 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
726 XS(XS_PerlIO_get_layers)
729 if (items < 1 || items % 2 == 0)
730 croak_xs_usage(cv, "filehandle[,args]");
731 #if defined(USE_PERLIO)
737 bool details = FALSE;
741 for (svp = MARK + 2; svp <= SP; svp += 2) {
742 SV * const * const varp = svp;
743 SV * const * const valp = svp + 1;
745 const char * const key = SvPV_const(*varp, klen);
749 if (memEQs(key, klen, "input")) {
750 input = SvTRUE(*valp);
755 if (memEQs(key, klen, "output")) {
756 input = !SvTRUE(*valp);
761 if (memEQs(key, klen, "details")) {
762 details = SvTRUE(*valp);
769 "get_layers: unknown argument '%s'",
778 gv = MAYBE_DEREF_GV(sv);
780 if (!gv && !SvROK(sv))
781 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
783 if (gv && (io = GvIO(gv))) {
784 AV* const av = PerlIO_get_layers(aTHX_ input ?
785 IoIFP(io) : IoOFP(io));
787 const SSize_t last = av_top_index(av);
790 for (i = last; i >= 0; i -= 3) {
791 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
792 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
793 SV * const * const flgsvp = av_fetch(av, i, FALSE);
795 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
796 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
797 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
799 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
801 /* Indents of 5? Yuck. */
802 /* We know that PerlIO_get_layers creates a new SV for
803 the name and flags, so we can just take a reference
804 and "steal" it when we free the AV below. */
806 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
809 ? newSVpvn_flags(SvPVX_const(*argsvp),
811 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
815 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
821 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
825 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
830 const IV flags = SvIVX(*flgsvp);
832 if (flags & PERLIO_F_UTF8) {
833 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
850 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
856 croak_xs_usage(cv, "sv");
865 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
866 XS(XS_re_regnames_count)
868 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
873 croak_xs_usage(cv, "");
878 ret = CALLREG_NAMED_BUFF_COUNT(rx);
881 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
885 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
893 if (items < 1 || items > 2)
894 croak_xs_usage(cv, "name[, all ]");
899 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
904 if (items == 2 && SvTRUE_NN(ST(1))) {
909 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
912 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
917 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
930 croak_xs_usage(cv, "[all]");
932 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
937 if (items == 1 && SvTRUE_NN(ST(0))) {
946 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
953 av = MUTABLE_AV(SvRV(ret));
954 length = av_count(av);
956 EXTEND(SP, length); /* better extend stack just once */
957 for (i = 0; i < length; i++) {
958 entry = av_fetch(av, i, FALSE);
961 Perl_croak(aTHX_ "NULL array element in re::regnames()");
963 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
972 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
973 XS(XS_re_regexp_pattern)
977 U8 const gimme = GIMME_V;
982 croak_xs_usage(cv, "sv");
985 Checks if a reference is a regex or not. If the parameter is
986 not a ref, or is not the result of a qr// then returns false
987 in scalar context and an empty list in list context.
988 Otherwise in list context it returns the pattern and the
989 modifiers, in scalar context it returns the pattern just as it
990 would if the qr// was stringified normally, regardless as
991 to the class of the variable and any stringification overloads
995 if ((re = SvRX(ST(0)))) /* assign deliberate */
997 /* Houston, we have a regex! */
1000 if ( gimme == G_LIST ) {
1002 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1008 we are in list context so stringify
1009 the modifiers that apply. We ignore "negative
1010 modifiers" in this scenario, and the default character set
1013 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1015 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1017 Copy(name, reflags + left, len, char);
1020 fptr = INT_PAT_MODS;
1021 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1022 >> RXf_PMf_STD_PMMOD_SHIFT);
1024 while((ch = *fptr++)) {
1025 if(match_flags & 1) {
1026 reflags[left++] = ch;
1031 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1032 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1034 /* return the pattern and the modifiers */
1036 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1039 /* Scalar, so use the string that Perl would return */
1040 /* return the pattern in (?msixn:..) format */
1041 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1046 /* It ain't a regexp folks */
1047 if ( gimme == G_LIST ) {
1048 /* return the empty list */
1051 /* Because of the (?:..) wrapping involved in a
1052 stringified pattern it is impossible to get a
1053 result for a real regexp that would evaluate to
1054 false. Therefore we can return PL_sv_no to signify
1055 that the object is not a regex, this means that one
1058 if (regex($might_be_a_regex) eq '(?:foo)') { }
1060 and not worry about undefined values.
1065 NOT_REACHED; /* NOTREACHED */
1068 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
1070 XS(XS_Internals_getcwd)
1073 SV *sv = sv_newmortal();
1076 croak_xs_usage(cv, "");
1078 (void)getcwd_sv(sv);
1087 XS(XS_NamedCapture_tie_it)
1092 croak_xs_usage(cv, "sv");
1095 GV * const gv = (GV *)sv;
1096 HV * const hv = GvHVn(gv);
1097 SV *rv = newSV_type(SVt_IV);
1098 const char *gv_name = GvNAME(gv);
1100 sv_setrv_noinc(rv, newSVuv(
1101 strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
1102 ? RXapif_ALL : RXapif_ONE));
1103 sv_bless(rv, GvSTASH(CvGV(cv)));
1105 sv_unmagic((SV *)hv, PERL_MAGIC_tied);
1106 sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
1107 SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
1112 XS(XS_NamedCapture_TIEHASH)
1116 croak_xs_usage(cv, "package, ...");
1118 const char * package = (const char *)SvPV_nolen(ST(0));
1119 UV flag = RXapif_ONE;
1123 const char *p = SvPV_const(*mark, len);
1124 if(memEQs(p, len, "all"))
1125 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
1128 ST(0) = newSV_type_mortal(SVt_IV);
1129 sv_setuv(newSVrv(ST(0), package), flag);
1134 /* These are tightly coupled to the RXapif_* flags defined in regexp.h */
1135 #define UNDEF_FATAL 0x80000
1136 #define DISCARD 0x40000
1137 #define EXPECT_SHIFT 24
1138 #define ACTION_MASK 0x000FF
1140 #define FETCH_ALIAS (RXapif_FETCH | (2 << EXPECT_SHIFT))
1141 #define STORE_ALIAS (RXapif_STORE | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1142 #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
1143 #define CLEAR_ALIAS (RXapif_CLEAR | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1144 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
1145 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
1147 XS(XS_NamedCapture_FETCH)
1151 PERL_UNUSED_VAR(cv); /* -W */
1152 PERL_UNUSED_VAR(ax); /* -Wall */
1155 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1158 const U32 action = ix & ACTION_MASK;
1159 const int expect = ix >> EXPECT_SHIFT;
1160 if (items != expect)
1161 croak_xs_usage(cv, expect == 2 ? "$key"
1162 : (expect == 3 ? "$key, $value"
1165 if (!rx || !SvROK(ST(0))) {
1166 if (ix & UNDEF_FATAL)
1167 Perl_croak_no_modify();
1172 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1175 ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
1176 expect >= 3 ? ST(2) : NULL, flags | action);
1180 /* Called with G_DISCARD, so our return stack state is thrown away.
1181 Hence if we were returned anything, free it immediately. */
1184 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1192 XS(XS_NamedCapture_FIRSTKEY)
1196 PERL_UNUSED_VAR(cv); /* -W */
1197 PERL_UNUSED_VAR(ax); /* -Wall */
1200 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1203 const int expect = ix ? 2 : 1;
1204 const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
1205 if (items != expect)
1206 croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
1208 if (!rx || !SvROK(ST(0)))
1211 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1214 ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
1215 expect >= 2 ? ST(1) : NULL,
1219 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1225 /* is this still needed? */
1226 XS(XS_NamedCapture_flags)
1229 PERL_UNUSED_VAR(cv); /* -W */
1230 PERL_UNUSED_VAR(ax); /* -Wall */
1244 struct xsub_details {
1251 static const struct xsub_details these_details[] = {
1252 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
1253 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
1254 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 },
1255 #define VXS_XSUB_DETAILS
1257 #undef VXS_XSUB_DETAILS
1258 {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 },
1259 {"utf8::valid", XS_utf8_valid, NULL, 0 },
1260 {"utf8::encode", XS_utf8_encode, NULL, 0 },
1261 {"utf8::decode", XS_utf8_decode, NULL, 0 },
1262 {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 },
1263 {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 },
1264 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 },
1265 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 },
1266 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 },
1267 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 },
1268 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 },
1269 {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 },
1270 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 },
1271 {"re::is_regexp", XS_re_is_regexp, "$", 0 },
1272 {"re::regname", XS_re_regname, ";$$", 0 },
1273 {"re::regnames", XS_re_regnames, ";$", 0 },
1274 {"re::regnames_count", XS_re_regnames_count, "", 0 },
1275 {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 },
1276 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
1277 {"Internals::getcwd", XS_Internals_getcwd, "", 0 },
1279 {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
1280 {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },
1281 {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS },
1282 {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS },
1283 {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS },
1284 {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS },
1285 {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS },
1286 {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS },
1287 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 },
1288 {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 },
1289 {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 },
1293 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1297 /* Optimizes out an identity function, i.e., one that just returns its
1298 * argument. The passed in function is assumed to be an identity function,
1299 * with no checking. This is designed to be called for utf8_to_native()
1300 * and native_to_utf8() on ASCII platforms, as they just return their
1301 * arguments, but it could work on any such function.
1303 * The code is mostly just cargo-culted from Memoize::Lift */
1307 SV* prototype = newSVpvs("$");
1309 PERL_UNUSED_ARG(protosv);
1311 assert(entersubop->op_type == OP_ENTERSUB);
1313 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1314 parent = entersubop;
1316 SvREFCNT_dec(prototype);
1318 pushop = cUNOPx(entersubop)->op_first;
1319 if (! OpHAS_SIBLING(pushop)) {
1321 pushop = cUNOPx(pushop)->op_first;
1323 argop = OpSIBLING(pushop);
1325 /* Carry on without doing the optimization if it is not something we're
1326 * expecting, so continues to work */
1328 || ! OpHAS_SIBLING(argop)
1329 || OpHAS_SIBLING(OpSIBLING(argop))
1334 /* cut argop from the subtree */
1335 (void)op_sibling_splice(parent, pushop, 1, NULL);
1337 op_free(entersubop);
1342 Perl_boot_core_UNIVERSAL(pTHX)
1344 static const char file[] = __FILE__;
1345 const struct xsub_details *xsub = these_details;
1346 const struct xsub_details *end = C_ARRAY_END(these_details);
1349 CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1350 XSANY.any_i32 = xsub->ix;
1351 } while (++xsub < end);
1354 { /* On ASCII platforms these functions just return their argument, so can
1355 be optimized away */
1357 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1358 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1360 cv_set_call_checker_flags(to_native_cv,
1361 optimize_out_native_convert_function,
1362 (SV*) to_native_cv, 0);
1363 cv_set_call_checker_flags(to_unicode_cv,
1364 optimize_out_native_convert_function,
1365 (SV*) to_unicode_cv, 0);
1369 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1372 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1373 char ** cvfile = &CvFILE(cv);
1374 char * oldfile = *cvfile;
1376 *cvfile = (char *)file;
1382 * ex: set ts=8 sts=4 sw=4 et: