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
42 S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
44 const struct mro_meta *const meta = HvMROMETA(stash);
48 PERL_ARGS_ASSERT_ISA_LOOKUP;
51 (void)mro_get_linear_isa(stash);
55 if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
56 HV_FETCH_ISEXISTS, NULL, 0)) {
57 /* Direct name lookup worked. */
61 /* A stash/class can go by many names (ie. User == main::User), so
62 we use the HvENAME in the stash itself, which is canonical, falling
63 back to HvNAME if necessary. */
64 our_stash = gv_stashpvn(name, len, flags);
67 HEK *canon_name = HvENAME_HEK(our_stash);
68 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
70 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
71 HEK_FLAGS(canon_name),
72 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
81 =head1 SV Manipulation Functions
83 =for apidoc sv_derived_from_pvn
85 Returns a boolean indicating whether the SV is derived from the specified class
86 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
89 Currently, the only significant value for C<flags> is SVf_UTF8.
93 =for apidoc sv_derived_from_sv
95 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
96 of an SV instead of a string/length pair.
103 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
107 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
108 namepv = SvPV(namesv, namelen);
111 return sv_derived_from_pvn(sv, namepv, namelen, flags);
115 =for apidoc sv_derived_from
117 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
123 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
125 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
126 return sv_derived_from_pvn(sv, name, strlen(name), 0);
130 =for apidoc sv_derived_from_pv
132 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
133 instead of a string/length pair.
140 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
142 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
143 return sv_derived_from_pvn(sv, name, strlen(name), flags);
147 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
151 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
158 type = sv_reftype(sv,0);
159 if (type && strEQ(type,name))
166 stash = gv_stashsv(sv, 0);
169 if (stash && isa_lookup(stash, name, len, flags))
172 stash = gv_stashpvs("UNIVERSAL", 0);
173 return stash && isa_lookup(stash, name, len, flags);
177 =for apidoc sv_does_sv
179 Returns a boolean indicating whether the SV performs a specific, named role.
180 The SV can be a Perl object or the name of a Perl class.
188 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
195 PERL_ARGS_ASSERT_SV_DOES_SV;
196 PERL_UNUSED_ARG(flags);
203 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
208 if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
209 classname = sv_ref(NULL,SvRV(sv),TRUE);
214 if (sv_eq(classname, namesv)) {
225 /* create a PV with value "isa", but with a special address
226 * so that perl knows we're really doing "DOES" instead */
227 methodname = newSV_type(SVt_PV);
228 SvLEN_set(methodname, 0);
229 SvCUR_set(methodname, strlen(PL_isa_DOES));
230 SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
231 SvPOK_on(methodname);
232 sv_2mortal(methodname);
233 call_sv(methodname, G_SCALAR | G_METHOD);
236 does_it = SvTRUE_NN( TOPs );
246 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
252 Perl_sv_does(pTHX_ SV *sv, const char *const name)
254 PERL_ARGS_ASSERT_SV_DOES;
255 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
259 =for apidoc sv_does_pv
261 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
268 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
270 PERL_ARGS_ASSERT_SV_DOES_PV;
271 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
275 =for apidoc sv_does_pvn
277 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
283 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
285 PERL_ARGS_ASSERT_SV_DOES_PVN;
287 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
291 =for apidoc croak_xs_usage
293 A specialised variant of C<croak()> for emitting the usage message for xsubs
295 croak_xs_usage(cv, "eee_yow");
297 works out the package name and subroutine name from C<cv>, and then calls
298 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
300 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
307 Perl_croak_xs_usage(const CV *const cv, const char *const params)
309 /* Avoid CvGV as it requires aTHX. */
310 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
312 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
315 const HV *const stash = GvSTASH(gv);
317 if (HvNAME_get(stash))
318 /* diag_listed_as: SKIPME */
319 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
320 HEKfARG(HvNAME_HEK(stash)),
321 HEKfARG(GvNAME_HEK(gv)),
324 /* diag_listed_as: SKIPME */
325 Perl_croak_nocontext("Usage: %" HEKf "(%s)",
326 HEKfARG(GvNAME_HEK(gv)), params);
329 if ((gv = CvGV(cv))) goto got_gv;
331 /* Pants. I don't think that it should be possible to get here. */
332 /* diag_listed_as: SKIPME */
333 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
337 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
343 croak_xs_usage(cv, "reference, kind");
345 SV * const sv = ST(0);
349 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
352 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
357 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
367 croak_xs_usage(cv, "object-ref, method");
373 /* Reject undef and empty string. Note that the string form takes
374 precedence here over the numeric form, as (!1)->foo treats the
375 invocant as the empty string, though it is a dualvar. */
376 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
382 sv = MUTABLE_SV(SvRV(sv));
385 else if (isGV_with_GP(sv) && GvIO(sv))
386 pkg = SvSTASH(GvIO(sv));
388 else if (isGV_with_GP(sv) && GvIO(sv))
389 pkg = SvSTASH(GvIO(sv));
390 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
391 pkg = SvSTASH(GvIO(iogv));
393 pkg = gv_stashsv(sv, 0);
395 pkg = gv_stashpvs("UNIVERSAL", 0);
399 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
401 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
408 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
409 XS(XS_UNIVERSAL_DOES)
415 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
417 SV * const sv = ST(0);
418 if (sv_does_sv( sv, ST(1), 0 ))
425 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
430 croak_xs_usage(cv, "sv");
432 SV * const sv = ST(0);
442 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
447 croak_xs_usage(cv, "sv");
449 SV * const sv = ST(0);
451 const char * const s = SvPV_const(sv,len);
452 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
460 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
465 croak_xs_usage(cv, "sv");
466 sv_utf8_encode(ST(0));
471 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
476 croak_xs_usage(cv, "sv");
478 SV * const sv = ST(0);
480 SvPV_force_nolen(sv);
481 RETVAL = sv_utf8_decode(sv);
483 ST(0) = boolSV(RETVAL);
488 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
493 croak_xs_usage(cv, "sv");
495 SV * const sv = ST(0);
499 RETVAL = sv_utf8_upgrade(sv);
500 XSprePUSH; PUSHi((IV)RETVAL);
505 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
506 XS(XS_utf8_downgrade)
509 if (items < 1 || items > 2)
510 croak_xs_usage(cv, "sv, failok=0");
512 SV * const sv0 = ST(0);
513 SV * const sv1 = ST(1);
514 const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0;
515 const bool RETVAL = sv_utf8_downgrade(sv0, failok);
517 ST(0) = boolSV(RETVAL);
522 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
523 XS(XS_utf8_native_to_unicode)
526 const UV uv = SvUV(ST(0));
529 croak_xs_usage(cv, "sv");
531 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
535 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
536 XS(XS_utf8_unicode_to_native)
539 const UV uv = SvUV(ST(0));
542 croak_xs_usage(cv, "sv");
544 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
548 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
549 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
552 SV * const svz = ST(0);
555 /* [perl #77776] - called as &foo() not foo() */
557 croak_xs_usage(cv, "SCALAR[, ON]");
567 else if (items == 2) {
569 if (SvTRUE_NN(sv1)) {
570 SvFLAGS(sv) |= SVf_READONLY;
574 /* I hope you really know what you are doing. */
575 SvFLAGS(sv) &=~ SVf_READONLY;
579 XSRETURN_UNDEF; /* Can't happen. */
582 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
583 XS(XS_constant__make_const) /* This is dangerous stuff. */
586 SV * const svz = ST(0);
589 /* [perl #77776] - called as &foo() not foo() */
590 if (!SvROK(svz) || items != 1)
591 croak_xs_usage(cv, "SCALAR");
596 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
597 /* for constant.pm; nobody else should be calling this
600 for (svp = AvARRAY(sv) + AvFILLp(sv)
603 if (*svp) SvPADTMP_on(*svp);
608 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
609 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
612 SV * const svz = ST(0);
616 /* [perl #77776] - called as &foo() not foo() */
617 if ((items != 1 && items != 2) || !SvROK(svz))
618 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
622 /* I hope you really know what you are doing. */
623 /* idea is for SvREFCNT(sv) to be accessed only once */
624 refcnt = items == 2 ?
625 /* we free one ref on exit */
626 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
628 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
632 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
633 XS(XS_Internals_hv_clear_placehold)
637 if (items != 1 || !SvROK(ST(0)))
638 croak_xs_usage(cv, "hv");
640 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
641 hv_clear_placeholders(hv);
646 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
647 XS(XS_PerlIO_get_layers)
650 if (items < 1 || items % 2 == 0)
651 croak_xs_usage(cv, "filehandle[,args]");
652 #if defined(USE_PERLIO)
658 bool details = FALSE;
662 for (svp = MARK + 2; svp <= SP; svp += 2) {
663 SV * const * const varp = svp;
664 SV * const * const valp = svp + 1;
666 const char * const key = SvPV_const(*varp, klen);
670 if (memEQs(key, klen, "input")) {
671 input = SvTRUE(*valp);
676 if (memEQs(key, klen, "output")) {
677 input = !SvTRUE(*valp);
682 if (memEQs(key, klen, "details")) {
683 details = SvTRUE(*valp);
690 "get_layers: unknown argument '%s'",
699 gv = MAYBE_DEREF_GV(sv);
701 if (!gv && !SvROK(sv))
702 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
704 if (gv && (io = GvIO(gv))) {
705 AV* const av = PerlIO_get_layers(aTHX_ input ?
706 IoIFP(io) : IoOFP(io));
708 const SSize_t last = av_tindex(av);
711 for (i = last; i >= 0; i -= 3) {
712 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
713 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
714 SV * const * const flgsvp = av_fetch(av, i, FALSE);
716 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
717 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
718 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
720 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
722 /* Indents of 5? Yuck. */
723 /* We know that PerlIO_get_layers creates a new SV for
724 the name and flags, so we can just take a reference
725 and "steal" it when we free the AV below. */
727 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
730 ? newSVpvn_flags(SvPVX_const(*argsvp),
732 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
736 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
742 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
746 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
751 const IV flags = SvIVX(*flgsvp);
753 if (flags & PERLIO_F_UTF8) {
754 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
771 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
777 croak_xs_usage(cv, "sv");
786 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
787 XS(XS_re_regnames_count)
789 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
794 croak_xs_usage(cv, "");
799 ret = CALLREG_NAMED_BUFF_COUNT(rx);
802 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
806 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
814 if (items < 1 || items > 2)
815 croak_xs_usage(cv, "name[, all ]");
820 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
825 if (items == 2 && SvTRUE_NN(ST(1))) {
830 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
833 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
838 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
851 croak_xs_usage(cv, "[all]");
853 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
858 if (items == 1 && SvTRUE_NN(ST(0))) {
867 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
874 av = MUTABLE_AV(SvRV(ret));
875 length = av_tindex(av);
877 EXTEND(SP, length+1); /* better extend stack just once */
878 for (i = 0; i <= length; i++) {
879 entry = av_fetch(av, i, FALSE);
882 Perl_croak(aTHX_ "NULL array element in re::regnames()");
884 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
893 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
894 XS(XS_re_regexp_pattern)
898 U8 const gimme = GIMME_V;
903 croak_xs_usage(cv, "sv");
906 Checks if a reference is a regex or not. If the parameter is
907 not a ref, or is not the result of a qr// then returns false
908 in scalar context and an empty list in list context.
909 Otherwise in list context it returns the pattern and the
910 modifiers, in scalar context it returns the pattern just as it
911 would if the qr// was stringified normally, regardless as
912 to the class of the variable and any stringification overloads
916 if ((re = SvRX(ST(0)))) /* assign deliberate */
918 /* Houston, we have a regex! */
921 if ( gimme == G_ARRAY ) {
923 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
929 we are in list context so stringify
930 the modifiers that apply. We ignore "negative
931 modifiers" in this scenario, and the default character set
934 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
936 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
938 Copy(name, reflags + left, len, char);
942 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
943 >> RXf_PMf_STD_PMMOD_SHIFT);
945 while((ch = *fptr++)) {
946 if(match_flags & 1) {
947 reflags[left++] = ch;
952 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
953 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
955 /* return the pattern and the modifiers */
957 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
960 /* Scalar, so use the string that Perl would return */
961 /* return the pattern in (?msixn:..) format */
962 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
967 /* It ain't a regexp folks */
968 if ( gimme == G_ARRAY ) {
969 /* return the empty list */
972 /* Because of the (?:..) wrapping involved in a
973 stringified pattern it is impossible to get a
974 result for a real regexp that would evaluate to
975 false. Therefore we can return PL_sv_no to signify
976 that the object is not a regex, this means that one
979 if (regex($might_be_a_regex) eq '(?:foo)') { }
981 and not worry about undefined values.
986 NOT_REACHED; /* NOTREACHED */
992 struct xsub_details {
998 static const struct xsub_details these_details[] = {
999 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1000 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1001 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1002 #define VXS_XSUB_DETAILS
1004 #undef VXS_XSUB_DETAILS
1005 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1006 {"utf8::valid", XS_utf8_valid, NULL},
1007 {"utf8::encode", XS_utf8_encode, NULL},
1008 {"utf8::decode", XS_utf8_decode, NULL},
1009 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1010 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1011 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1012 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1013 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1014 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1015 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1016 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
1017 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1018 {"re::is_regexp", XS_re_is_regexp, "$"},
1019 {"re::regname", XS_re_regname, ";$$"},
1020 {"re::regnames", XS_re_regnames, ";$"},
1021 {"re::regnames_count", XS_re_regnames_count, ""},
1022 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1026 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1030 /* Optimizes out an identity function, i.e., one that just returns its
1031 * argument. The passed in function is assumed to be an identity function,
1032 * with no checking. This is designed to be called for utf8_to_native()
1033 * and native_to_utf8() on ASCII platforms, as they just return their
1034 * arguments, but it could work on any such function.
1036 * The code is mostly just cargo-culted from Memoize::Lift */
1040 SV* prototype = newSVpvs("$");
1042 PERL_UNUSED_ARG(protosv);
1044 assert(entersubop->op_type == OP_ENTERSUB);
1046 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1047 parent = entersubop;
1049 SvREFCNT_dec(prototype);
1051 pushop = cUNOPx(entersubop)->op_first;
1052 if (! OpHAS_SIBLING(pushop)) {
1054 pushop = cUNOPx(pushop)->op_first;
1056 argop = OpSIBLING(pushop);
1058 /* Carry on without doing the optimization if it is not something we're
1059 * expecting, so continues to work */
1061 || ! OpHAS_SIBLING(argop)
1062 || OpHAS_SIBLING(OpSIBLING(argop))
1067 /* cut argop from the subtree */
1068 (void)op_sibling_splice(parent, pushop, 1, NULL);
1070 op_free(entersubop);
1075 Perl_boot_core_UNIVERSAL(pTHX)
1077 static const char file[] = __FILE__;
1078 const struct xsub_details *xsub = these_details;
1079 const struct xsub_details *end = C_ARRAY_END(these_details);
1082 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1083 } while (++xsub < end);
1086 { /* On ASCII platforms these functions just return their argument, so can
1087 be optimized away */
1089 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1090 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1092 cv_set_call_checker_flags(to_native_cv,
1093 optimize_out_native_convert_function,
1094 (SV*) to_native_cv, 0);
1095 cv_set_call_checker_flags(to_unicode_cv,
1096 optimize_out_native_convert_function,
1097 (SV*) to_unicode_cv, 0);
1101 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1104 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1105 char ** cvfile = &CvFILE(cv);
1106 char * oldfile = *cvfile;
1108 *cvfile = (char *)file;
1114 * ex: set ts=8 sts=4 sw=4 et: