3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 * 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * '"The roots of those mountains must be roots indeed; there must be
13 * great secrets buried there which have not been discovered since the
14 * beginning."' --Gandalf, relating Gollum's history
16 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
19 /* This file contains the code that implements the functions in Perl's
20 * UNIVERSAL package, such as UNIVERSAL->can().
22 * It is also used to store XS functions that need to be present in
23 * miniperl for a lack of a better place to put them. It might be
24 * clever to move them to separate XS files which would then be pulled
25 * in by some to-be-written build process.
29 #define PERL_IN_UNIVERSAL_C
32 #if defined(USE_PERLIO)
33 #include "perliol.h" /* For the PERLIO_F_XXX */
37 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
38 * The main guts of traverse_isa was actually copied from gv_fetchmeth
41 #define PERL_ARGS_ASSERT_ISA_LOOKUP \
43 assert(namesv || name)
47 S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 flags)
49 const struct mro_meta *const meta = HvMROMETA(stash);
53 PERL_ARGS_ASSERT_ISA_LOOKUP;
56 (void)mro_get_linear_isa(stash);
60 if (hv_common(isa, namesv, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
61 HV_FETCH_ISEXISTS, NULL, 0)) {
62 /* Direct name lookup worked. */
66 /* A stash/class can go by many names (ie. User == main::User), so
67 we use the HvENAME in the stash itself, which is canonical, falling
68 back to HvNAME if necessary. */
69 our_stash = gv_stashsvpvn_cached(namesv, name, len, flags);
72 HEK *canon_name = HvENAME_HEK(our_stash);
73 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
75 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
76 HEK_FLAGS(canon_name),
77 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
85 #define PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN \
87 assert(namesv || name)
90 S_sv_derived_from_svpvn(pTHX_ SV *sv, SV *namesv, const char * name, const STRLEN len, U32 flags)
94 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN;
100 type = sv_reftype(sv,0);
103 name = SvPV_nolen(namesv);
104 if (strEQ(name, type))
112 stash = gv_stashsv(sv, 0);
115 if (stash && isa_lookup(stash, namesv, name, len, flags))
118 stash = gv_stashpvs("UNIVERSAL", 0);
119 return stash && isa_lookup(stash, namesv, name, len, flags);
123 =head1 SV Manipulation Functions
125 =for apidoc sv_derived_from_pvn
127 Returns a boolean indicating whether the SV is derived from the specified class
128 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
131 Currently, the only significant value for C<flags> is SVf_UTF8.
135 =for apidoc sv_derived_from_sv
137 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
138 of an SV instead of a string/length pair. This is the advised form.
145 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
147 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
148 return sv_derived_from_svpvn(sv, namesv, NULL, 0, flags);
152 =for apidoc sv_derived_from
154 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
160 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
162 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
163 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), 0);
167 =for apidoc sv_derived_from_pv
169 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
170 instead of a string/length pair.
177 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
179 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
180 return sv_derived_from_svpvn(sv, NULL, name, strlen(name), flags);
184 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
186 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
187 return sv_derived_from_svpvn(sv, NULL, name, len, flags);
191 =for apidoc sv_isa_sv
193 Returns a boolean indicating whether the SV is an object reference and is
194 derived from the specified class, respecting any C<isa()> method overloading
195 it may have. Returns false if C<sv> is not a reference to an object, or is
196 not derived from the specified class.
198 This is the function used to implement the behaviour of the C<isa> operator.
200 Does not invoke magic on C<sv>.
202 Not to be confused with the older C<sv_isa> function, which does not use an
203 overloaded C<isa()> method, nor will check subclassing.
210 Perl_sv_isa_sv(pTHX_ SV *sv, SV *namesv)
214 PERL_ARGS_ASSERT_SV_ISA_SV;
216 if(!SvROK(sv) || !SvOBJECT(SvRV(sv)))
219 /* This abuse of gv_fetchmeth_pv() with level = 1 skips the UNIVERSAL
221 * TODO: Consider if we want a NOUNIVERSAL flag for requesting this in a
224 isagv = gv_fetchmeth_pvn(SvSTASH(SvRV(sv)), "isa", 3, 1, 0);
227 CV *isacv = isGV(isagv) ? GvCV(isagv) : (CV *)isagv;
242 call_sv((SV *)isacv, G_SCALAR);
255 /* TODO: Support namesv being an HV ref to the stash directly? */
257 return sv_derived_from_sv(sv, namesv, 0);
261 =for apidoc sv_does_sv
263 Returns a boolean indicating whether the SV performs a specific, named role.
264 The SV can be a Perl object or the name of a Perl class.
272 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
279 PERL_ARGS_ASSERT_SV_DOES_SV;
280 PERL_UNUSED_ARG(flags);
287 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
292 if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
293 classname = sv_ref(NULL,SvRV(sv),TRUE);
298 if (sv_eq(classname, namesv)) {
309 /* create a PV with value "isa", but with a special address
310 * so that perl knows we're really doing "DOES" instead */
311 methodname = newSV_type(SVt_PV);
312 SvLEN_set(methodname, 0);
313 SvCUR_set(methodname, strlen(PL_isa_DOES));
314 SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
315 SvPOK_on(methodname);
316 sv_2mortal(methodname);
317 call_sv(methodname, G_SCALAR | G_METHOD);
320 does_it = SvTRUE_NN( TOPs );
330 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
336 Perl_sv_does(pTHX_ SV *sv, const char *const name)
338 PERL_ARGS_ASSERT_SV_DOES;
339 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
343 =for apidoc sv_does_pv
345 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
352 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
354 PERL_ARGS_ASSERT_SV_DOES_PV;
355 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
359 =for apidoc sv_does_pvn
361 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
367 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
369 PERL_ARGS_ASSERT_SV_DOES_PVN;
371 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
375 =for apidoc croak_xs_usage
377 A specialised variant of C<croak()> for emitting the usage message for xsubs
379 croak_xs_usage(cv, "eee_yow");
381 works out the package name and subroutine name from C<cv>, and then calls
382 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
384 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
391 Perl_croak_xs_usage(const CV *const cv, const char *const params)
393 /* Avoid CvGV as it requires aTHX. */
394 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
396 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
399 const HV *const stash = GvSTASH(gv);
401 if (HvNAME_get(stash))
402 /* diag_listed_as: SKIPME */
403 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
404 HEKfARG(HvNAME_HEK(stash)),
405 HEKfARG(GvNAME_HEK(gv)),
408 /* diag_listed_as: SKIPME */
409 Perl_croak_nocontext("Usage: %" HEKf "(%s)",
410 HEKfARG(GvNAME_HEK(gv)), params);
413 if ((gv = CvGV(cv))) goto got_gv;
415 /* Pants. I don't think that it should be possible to get here. */
416 /* diag_listed_as: SKIPME */
417 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
421 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
427 croak_xs_usage(cv, "reference, kind");
429 SV * const sv = ST(0);
433 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
436 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
441 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
451 croak_xs_usage(cv, "object-ref, method");
457 /* Reject undef and empty string. Note that the string form takes
458 precedence here over the numeric form, as (!1)->foo treats the
459 invocant as the empty string, though it is a dualvar. */
460 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
466 sv = MUTABLE_SV(SvRV(sv));
469 else if (isGV_with_GP(sv) && GvIO(sv))
470 pkg = SvSTASH(GvIO(sv));
472 else if (isGV_with_GP(sv) && GvIO(sv))
473 pkg = SvSTASH(GvIO(sv));
474 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
475 pkg = SvSTASH(GvIO(iogv));
477 pkg = gv_stashsv(sv, 0);
479 pkg = gv_stashpvs("UNIVERSAL", 0);
483 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
485 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
492 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
493 XS(XS_UNIVERSAL_DOES)
499 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
501 SV * const sv = ST(0);
502 if (sv_does_sv( sv, ST(1), 0 ))
509 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
514 croak_xs_usage(cv, "sv");
516 SV * const sv = ST(0);
526 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
531 croak_xs_usage(cv, "sv");
533 SV * const sv = ST(0);
535 const char * const s = SvPV_const(sv,len);
536 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
544 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
549 croak_xs_usage(cv, "sv");
550 sv_utf8_encode(ST(0));
555 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
560 croak_xs_usage(cv, "sv");
562 SV * const sv = ST(0);
564 SvPV_force_nolen(sv);
565 RETVAL = sv_utf8_decode(sv);
567 ST(0) = boolSV(RETVAL);
572 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
577 croak_xs_usage(cv, "sv");
579 SV * const sv = ST(0);
583 RETVAL = sv_utf8_upgrade(sv);
584 XSprePUSH; PUSHi((IV)RETVAL);
589 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
590 XS(XS_utf8_downgrade)
593 if (items < 1 || items > 2)
594 croak_xs_usage(cv, "sv, failok=0");
596 SV * const sv0 = ST(0);
597 SV * const sv1 = ST(1);
598 const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0;
599 const bool RETVAL = sv_utf8_downgrade(sv0, failok);
601 ST(0) = boolSV(RETVAL);
606 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
607 XS(XS_utf8_native_to_unicode)
610 const UV uv = SvUV(ST(0));
613 croak_xs_usage(cv, "sv");
615 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
619 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
620 XS(XS_utf8_unicode_to_native)
623 const UV uv = SvUV(ST(0));
626 croak_xs_usage(cv, "sv");
628 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
632 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
633 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
636 SV * const svz = ST(0);
639 /* [perl #77776] - called as &foo() not foo() */
641 croak_xs_usage(cv, "SCALAR[, ON]");
651 else if (items == 2) {
653 if (SvTRUE_NN(sv1)) {
654 SvFLAGS(sv) |= SVf_READONLY;
658 /* I hope you really know what you are doing. */
659 SvFLAGS(sv) &=~ SVf_READONLY;
663 XSRETURN_UNDEF; /* Can't happen. */
666 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
667 XS(XS_constant__make_const) /* This is dangerous stuff. */
670 SV * const svz = ST(0);
673 /* [perl #77776] - called as &foo() not foo() */
674 if (!SvROK(svz) || items != 1)
675 croak_xs_usage(cv, "SCALAR");
680 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
681 /* for constant.pm; nobody else should be calling this
684 for (svp = AvARRAY(sv) + AvFILLp(sv)
687 if (*svp) SvPADTMP_on(*svp);
692 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
693 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
696 SV * const svz = ST(0);
700 /* [perl #77776] - called as &foo() not foo() */
701 if ((items != 1 && items != 2) || !SvROK(svz))
702 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
706 /* I hope you really know what you are doing. */
707 /* idea is for SvREFCNT(sv) to be accessed only once */
708 refcnt = items == 2 ?
709 /* we free one ref on exit */
710 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
712 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
716 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
717 XS(XS_Internals_hv_clear_placehold)
721 if (items != 1 || !SvROK(ST(0)))
722 croak_xs_usage(cv, "hv");
724 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
725 hv_clear_placeholders(hv);
730 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
731 XS(XS_PerlIO_get_layers)
734 if (items < 1 || items % 2 == 0)
735 croak_xs_usage(cv, "filehandle[,args]");
736 #if defined(USE_PERLIO)
742 bool details = FALSE;
746 for (svp = MARK + 2; svp <= SP; svp += 2) {
747 SV * const * const varp = svp;
748 SV * const * const valp = svp + 1;
750 const char * const key = SvPV_const(*varp, klen);
754 if (memEQs(key, klen, "input")) {
755 input = SvTRUE(*valp);
760 if (memEQs(key, klen, "output")) {
761 input = !SvTRUE(*valp);
766 if (memEQs(key, klen, "details")) {
767 details = SvTRUE(*valp);
774 "get_layers: unknown argument '%s'",
783 gv = MAYBE_DEREF_GV(sv);
785 if (!gv && !SvROK(sv))
786 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
788 if (gv && (io = GvIO(gv))) {
789 AV* const av = PerlIO_get_layers(aTHX_ input ?
790 IoIFP(io) : IoOFP(io));
792 const SSize_t last = av_tindex(av);
795 for (i = last; i >= 0; i -= 3) {
796 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
797 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
798 SV * const * const flgsvp = av_fetch(av, i, FALSE);
800 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
801 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
802 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
804 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
806 /* Indents of 5? Yuck. */
807 /* We know that PerlIO_get_layers creates a new SV for
808 the name and flags, so we can just take a reference
809 and "steal" it when we free the AV below. */
811 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
814 ? newSVpvn_flags(SvPVX_const(*argsvp),
816 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
820 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
826 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
830 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
835 const IV flags = SvIVX(*flgsvp);
837 if (flags & PERLIO_F_UTF8) {
838 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
855 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
861 croak_xs_usage(cv, "sv");
870 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
871 XS(XS_re_regnames_count)
873 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
878 croak_xs_usage(cv, "");
883 ret = CALLREG_NAMED_BUFF_COUNT(rx);
886 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
890 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
898 if (items < 1 || items > 2)
899 croak_xs_usage(cv, "name[, all ]");
904 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
909 if (items == 2 && SvTRUE_NN(ST(1))) {
914 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
917 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
922 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
935 croak_xs_usage(cv, "[all]");
937 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
942 if (items == 1 && SvTRUE_NN(ST(0))) {
951 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
958 av = MUTABLE_AV(SvRV(ret));
959 length = av_tindex(av);
961 EXTEND(SP, length+1); /* better extend stack just once */
962 for (i = 0; i <= length; i++) {
963 entry = av_fetch(av, i, FALSE);
966 Perl_croak(aTHX_ "NULL array element in re::regnames()");
968 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
977 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
978 XS(XS_re_regexp_pattern)
982 U8 const gimme = GIMME_V;
987 croak_xs_usage(cv, "sv");
990 Checks if a reference is a regex or not. If the parameter is
991 not a ref, or is not the result of a qr// then returns false
992 in scalar context and an empty list in list context.
993 Otherwise in list context it returns the pattern and the
994 modifiers, in scalar context it returns the pattern just as it
995 would if the qr// was stringified normally, regardless as
996 to the class of the variable and any stringification overloads
1000 if ((re = SvRX(ST(0)))) /* assign deliberate */
1002 /* Houston, we have a regex! */
1005 if ( gimme == G_ARRAY ) {
1007 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1013 we are in list context so stringify
1014 the modifiers that apply. We ignore "negative
1015 modifiers" in this scenario, and the default character set
1018 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1020 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1022 Copy(name, reflags + left, len, char);
1025 fptr = INT_PAT_MODS;
1026 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1027 >> RXf_PMf_STD_PMMOD_SHIFT);
1029 while((ch = *fptr++)) {
1030 if(match_flags & 1) {
1031 reflags[left++] = ch;
1036 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1037 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1039 /* return the pattern and the modifiers */
1041 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1044 /* Scalar, so use the string that Perl would return */
1045 /* return the pattern in (?msixn:..) format */
1046 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1051 /* It ain't a regexp folks */
1052 if ( gimme == G_ARRAY ) {
1053 /* return the empty list */
1056 /* Because of the (?:..) wrapping involved in a
1057 stringified pattern it is impossible to get a
1058 result for a real regexp that would evaluate to
1059 false. Therefore we can return PL_sv_no to signify
1060 that the object is not a regex, this means that one
1063 if (regex($might_be_a_regex) eq '(?:foo)') { }
1065 and not worry about undefined values.
1070 NOT_REACHED; /* NOTREACHED */
1075 XS(XS_Internals_getcwd)
1078 SV *sv = sv_newmortal();
1081 croak_xs_usage(cv, "");
1083 (void)getcwd_sv(sv);
1092 XS(XS_NamedCapture_tie_it)
1097 croak_xs_usage(cv, "sv");
1100 GV * const gv = (GV *)sv;
1101 HV * const hv = GvHVn(gv);
1102 SV *rv = newSV_type(SVt_IV);
1103 const char *gv_name = GvNAME(gv);
1105 SvRV_set(rv, newSVuv(
1106 strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
1107 ? RXapif_ALL : RXapif_ONE));
1109 sv_bless(rv, GvSTASH(CvGV(cv)));
1111 sv_unmagic((SV *)hv, PERL_MAGIC_tied);
1112 sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
1113 SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
1118 XS(XS_NamedCapture_TIEHASH)
1122 croak_xs_usage(cv, "package, ...");
1124 const char * package = (const char *)SvPV_nolen(ST(0));
1125 UV flag = RXapif_ONE;
1129 const char *p = SvPV_const(*mark, len);
1130 if(memEQs(p, len, "all"))
1131 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
1134 ST(0) = sv_2mortal(newSV_type(SVt_IV));
1135 sv_setuv(newSVrv(ST(0), package), flag);
1140 /* These are tightly coupled to the RXapif_* flags defined in regexp.h */
1141 #define UNDEF_FATAL 0x80000
1142 #define DISCARD 0x40000
1143 #define EXPECT_SHIFT 24
1144 #define ACTION_MASK 0x000FF
1146 #define FETCH_ALIAS (RXapif_FETCH | (2 << EXPECT_SHIFT))
1147 #define STORE_ALIAS (RXapif_STORE | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1148 #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
1149 #define CLEAR_ALIAS (RXapif_CLEAR | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
1150 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
1151 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
1153 XS(XS_NamedCapture_FETCH)
1157 PERL_UNUSED_VAR(cv); /* -W */
1158 PERL_UNUSED_VAR(ax); /* -Wall */
1161 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1164 const U32 action = ix & ACTION_MASK;
1165 const int expect = ix >> EXPECT_SHIFT;
1166 if (items != expect)
1167 croak_xs_usage(cv, expect == 2 ? "$key"
1168 : (expect == 3 ? "$key, $value"
1171 if (!rx || !SvROK(ST(0))) {
1172 if (ix & UNDEF_FATAL)
1173 Perl_croak_no_modify();
1178 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1181 ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
1182 expect >= 3 ? ST(2) : NULL, flags | action);
1186 /* Called with G_DISCARD, so our return stack state is thrown away.
1187 Hence if we were returned anything, free it immediately. */
1190 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1198 XS(XS_NamedCapture_FIRSTKEY)
1202 PERL_UNUSED_VAR(cv); /* -W */
1203 PERL_UNUSED_VAR(ax); /* -Wall */
1206 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1209 const int expect = ix ? 2 : 1;
1210 const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
1211 if (items != expect)
1212 croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
1214 if (!rx || !SvROK(ST(0)))
1217 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
1220 ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
1221 expect >= 2 ? ST(1) : NULL,
1225 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1231 /* is this still needed? */
1232 XS(XS_NamedCapture_flags)
1235 PERL_UNUSED_VAR(cv); /* -W */
1236 PERL_UNUSED_VAR(ax); /* -Wall */
1250 struct xsub_details {
1257 static const struct xsub_details these_details[] = {
1258 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
1259 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
1260 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 },
1261 #define VXS_XSUB_DETAILS
1263 #undef VXS_XSUB_DETAILS
1264 {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 },
1265 {"utf8::valid", XS_utf8_valid, NULL, 0 },
1266 {"utf8::encode", XS_utf8_encode, NULL, 0 },
1267 {"utf8::decode", XS_utf8_decode, NULL, 0 },
1268 {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 },
1269 {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 },
1270 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 },
1271 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 },
1272 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 },
1273 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 },
1274 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 },
1275 {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 },
1276 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 },
1277 {"re::is_regexp", XS_re_is_regexp, "$", 0 },
1278 {"re::regname", XS_re_regname, ";$$", 0 },
1279 {"re::regnames", XS_re_regnames, ";$", 0 },
1280 {"re::regnames_count", XS_re_regnames_count, "", 0 },
1281 {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 },
1283 {"Internals::getcwd", XS_Internals_getcwd, "", 0 },
1285 {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
1286 {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },
1287 {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS },
1288 {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS },
1289 {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS },
1290 {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS },
1291 {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS },
1292 {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS },
1293 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 },
1294 {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 },
1295 {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 },
1299 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1303 /* Optimizes out an identity function, i.e., one that just returns its
1304 * argument. The passed in function is assumed to be an identity function,
1305 * with no checking. This is designed to be called for utf8_to_native()
1306 * and native_to_utf8() on ASCII platforms, as they just return their
1307 * arguments, but it could work on any such function.
1309 * The code is mostly just cargo-culted from Memoize::Lift */
1313 SV* prototype = newSVpvs("$");
1315 PERL_UNUSED_ARG(protosv);
1317 assert(entersubop->op_type == OP_ENTERSUB);
1319 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1320 parent = entersubop;
1322 SvREFCNT_dec(prototype);
1324 pushop = cUNOPx(entersubop)->op_first;
1325 if (! OpHAS_SIBLING(pushop)) {
1327 pushop = cUNOPx(pushop)->op_first;
1329 argop = OpSIBLING(pushop);
1331 /* Carry on without doing the optimization if it is not something we're
1332 * expecting, so continues to work */
1334 || ! OpHAS_SIBLING(argop)
1335 || OpHAS_SIBLING(OpSIBLING(argop))
1340 /* cut argop from the subtree */
1341 (void)op_sibling_splice(parent, pushop, 1, NULL);
1343 op_free(entersubop);
1348 Perl_boot_core_UNIVERSAL(pTHX)
1350 static const char file[] = __FILE__;
1351 const struct xsub_details *xsub = these_details;
1352 const struct xsub_details *end = C_ARRAY_END(these_details);
1355 CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1356 XSANY.any_i32 = xsub->ix;
1357 } while (++xsub < end);
1360 { /* On ASCII platforms these functions just return their argument, so can
1361 be optimized away */
1363 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1364 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1366 cv_set_call_checker_flags(to_native_cv,
1367 optimize_out_native_convert_function,
1368 (SV*) to_native_cv, 0);
1369 cv_set_call_checker_flags(to_unicode_cv,
1370 optimize_out_native_convert_function,
1371 (SV*) to_unicode_cv, 0);
1375 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1378 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1379 char ** cvfile = &CvFILE(cv);
1380 char * oldfile = *cvfile;
1382 *cvfile = (char *)file;
1388 * ex: set ts=8 sts=4 sw=4 et: