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 methodname = newSVpvs_flags("isa", SVs_TEMP);
226 /* ugly hack: use the SvSCREAM flag so S_method_common
227 * can figure out we're calling DOES() and not isa(),
228 * and report eventual errors correctly. --rgs */
229 SvSCREAM_on(methodname);
230 call_sv(methodname, G_SCALAR | G_METHOD);
233 does_it = SvTRUE( TOPs );
243 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
249 Perl_sv_does(pTHX_ SV *sv, const char *const name)
251 PERL_ARGS_ASSERT_SV_DOES;
252 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
256 =for apidoc sv_does_pv
258 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
265 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
267 PERL_ARGS_ASSERT_SV_DOES_PV;
268 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
272 =for apidoc sv_does_pvn
274 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
280 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
282 PERL_ARGS_ASSERT_SV_DOES_PVN;
284 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
288 =for apidoc croak_xs_usage
290 A specialised variant of C<croak()> for emitting the usage message for xsubs
292 croak_xs_usage(cv, "eee_yow");
294 works out the package name and subroutine name from C<cv>, and then calls
295 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
297 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk",
304 Perl_croak_xs_usage(const CV *const cv, const char *const params)
306 /* Avoid CvGV as it requires aTHX. */
307 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
309 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
312 const HV *const stash = GvSTASH(gv);
314 if (HvNAME_get(stash))
315 /* diag_listed_as: SKIPME */
316 Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)",
317 HEKfARG(HvNAME_HEK(stash)),
318 HEKfARG(GvNAME_HEK(gv)),
321 /* diag_listed_as: SKIPME */
322 Perl_croak_nocontext("Usage: %"HEKf"(%s)",
323 HEKfARG(GvNAME_HEK(gv)), params);
326 if ((gv = CvGV(cv))) goto got_gv;
328 /* Pants. I don't think that it should be possible to get here. */
329 /* diag_listed_as: SKIPME */
330 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
334 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
340 croak_xs_usage(cv, "reference, kind");
342 SV * const sv = ST(0);
346 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
349 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
354 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
364 croak_xs_usage(cv, "object-ref, method");
370 /* Reject undef and empty string. Note that the string form takes
371 precedence here over the numeric form, as (!1)->foo treats the
372 invocant as the empty string, though it is a dualvar. */
373 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
379 sv = MUTABLE_SV(SvRV(sv));
382 else if (isGV_with_GP(sv) && GvIO(sv))
383 pkg = SvSTASH(GvIO(sv));
385 else if (isGV_with_GP(sv) && GvIO(sv))
386 pkg = SvSTASH(GvIO(sv));
387 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
388 pkg = SvSTASH(GvIO(iogv));
390 pkg = gv_stashsv(sv, 0);
392 pkg = gv_stashpvs("UNIVERSAL", 0);
396 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
398 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
405 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
406 XS(XS_UNIVERSAL_DOES)
412 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
414 SV * const sv = ST(0);
415 if (sv_does_sv( sv, ST(1), 0 ))
422 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
427 croak_xs_usage(cv, "sv");
429 SV * const sv = ST(0);
439 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
444 croak_xs_usage(cv, "sv");
446 SV * const sv = ST(0);
448 const char * const s = SvPV_const(sv,len);
449 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
457 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
462 croak_xs_usage(cv, "sv");
463 sv_utf8_encode(ST(0));
468 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
473 croak_xs_usage(cv, "sv");
475 SV * const sv = ST(0);
477 SvPV_force_nolen(sv);
478 RETVAL = sv_utf8_decode(sv);
480 ST(0) = boolSV(RETVAL);
485 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
490 croak_xs_usage(cv, "sv");
492 SV * const sv = ST(0);
496 RETVAL = sv_utf8_upgrade(sv);
497 XSprePUSH; PUSHi((IV)RETVAL);
502 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
503 XS(XS_utf8_downgrade)
506 if (items < 1 || items > 2)
507 croak_xs_usage(cv, "sv, failok=0");
509 SV * const sv = ST(0);
510 const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
511 const bool RETVAL = sv_utf8_downgrade(sv, failok);
513 ST(0) = boolSV(RETVAL);
518 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
519 XS(XS_utf8_native_to_unicode)
522 const UV uv = SvUV(ST(0));
525 croak_xs_usage(cv, "sv");
527 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
531 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
532 XS(XS_utf8_unicode_to_native)
535 const UV uv = SvUV(ST(0));
538 croak_xs_usage(cv, "sv");
540 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
544 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
545 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
548 SV * const svz = ST(0);
552 /* [perl #77776] - called as &foo() not foo() */
554 croak_xs_usage(cv, "SCALAR[, ON]");
564 else if (items == 2) {
566 #ifdef PERL_OLD_COPY_ON_WRITE
567 if (SvIsCOW(sv)) sv_force_normal(sv);
569 SvFLAGS(sv) |= SVf_READONLY;
573 /* I hope you really know what you are doing. */
574 SvFLAGS(sv) &=~ SVf_READONLY;
578 XSRETURN_UNDEF; /* Can't happen. */
581 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
582 XS(XS_constant__make_const) /* This is dangerous stuff. */
585 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");
595 #ifdef PERL_OLD_COPY_ON_WRITE
596 if (SvIsCOW(sv)) sv_force_normal(sv);
599 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
600 /* for constant.pm; nobody else should be calling this
603 for (svp = AvARRAY(sv) + AvFILLp(sv)
606 if (*svp) SvPADTMP_on(*svp);
611 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
612 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
615 SV * const svz = ST(0);
620 /* [perl #77776] - called as &foo() not foo() */
621 if ((items != 1 && items != 2) || !SvROK(svz))
622 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
626 /* I hope you really know what you are doing. */
627 /* idea is for SvREFCNT(sv) to be accessed only once */
628 refcnt = items == 2 ?
629 /* we free one ref on exit */
630 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
632 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
636 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
637 XS(XS_Internals_hv_clear_placehold)
641 if (items != 1 || !SvROK(ST(0)))
642 croak_xs_usage(cv, "hv");
644 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
645 hv_clear_placeholders(hv);
650 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
651 XS(XS_PerlIO_get_layers)
654 if (items < 1 || items % 2 == 0)
655 croak_xs_usage(cv, "filehandle[,args]");
656 #if defined(USE_PERLIO)
662 bool details = FALSE;
666 for (svp = MARK + 2; svp <= SP; svp += 2) {
667 SV * const * const varp = svp;
668 SV * const * const valp = svp + 1;
670 const char * const key = SvPV_const(*varp, klen);
674 if (klen == 5 && memEQ(key, "input", 5)) {
675 input = SvTRUE(*valp);
680 if (klen == 6 && memEQ(key, "output", 6)) {
681 input = !SvTRUE(*valp);
686 if (klen == 7 && memEQ(key, "details", 7)) {
687 details = SvTRUE(*valp);
694 "get_layers: unknown argument '%s'",
703 gv = MAYBE_DEREF_GV(sv);
705 if (!gv && !SvROK(sv))
706 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
708 if (gv && (io = GvIO(gv))) {
709 AV* const av = PerlIO_get_layers(aTHX_ input ?
710 IoIFP(io) : IoOFP(io));
712 const SSize_t last = av_tindex(av);
715 for (i = last; i >= 0; i -= 3) {
716 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
717 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
718 SV * const * const flgsvp = av_fetch(av, i, FALSE);
720 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
721 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
722 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
724 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
726 /* Indents of 5? Yuck. */
727 /* We know that PerlIO_get_layers creates a new SV for
728 the name and flags, so we can just take a reference
729 and "steal" it when we free the AV below. */
731 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
734 ? newSVpvn_flags(SvPVX_const(*argsvp),
736 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
740 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
746 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
750 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
755 const IV flags = SvIVX(*flgsvp);
757 if (flags & PERLIO_F_UTF8) {
758 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
776 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
783 croak_xs_usage(cv, "sv");
792 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
793 XS(XS_re_regnames_count)
795 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
800 croak_xs_usage(cv, "");
808 ret = CALLREG_NAMED_BUFF_COUNT(rx);
811 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
815 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
823 if (items < 1 || items > 2)
824 croak_xs_usage(cv, "name[, all ]");
829 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
834 if (items == 2 && SvTRUE(ST(1))) {
839 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
842 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
847 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
860 croak_xs_usage(cv, "[all]");
862 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
867 if (items == 1 && SvTRUE(ST(0))) {
876 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
883 av = MUTABLE_AV(SvRV(ret));
884 length = av_tindex(av);
886 EXTEND(SP, length+1); /* better extend stack just once */
887 for (i = 0; i <= length; i++) {
888 entry = av_fetch(av, i, FALSE);
891 Perl_croak(aTHX_ "NULL array element in re::regnames()");
893 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
902 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
903 XS(XS_re_regexp_pattern)
907 I32 const gimme = GIMME_V;
912 croak_xs_usage(cv, "sv");
915 Checks if a reference is a regex or not. If the parameter is
916 not a ref, or is not the result of a qr// then returns false
917 in scalar context and an empty list in list context.
918 Otherwise in list context it returns the pattern and the
919 modifiers, in scalar context it returns the pattern just as it
920 would if the qr// was stringified normally, regardless as
921 to the class of the variable and any stringification overloads
925 if ((re = SvRX(ST(0)))) /* assign deliberate */
927 /* Houston, we have a regex! */
930 if ( gimme == G_ARRAY ) {
932 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
938 we are in list context so stringify
939 the modifiers that apply. We ignore "negative
940 modifiers" in this scenario, and the default character set
943 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
945 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
947 Copy(name, reflags + left, len, char);
951 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
952 >> RXf_PMf_STD_PMMOD_SHIFT);
954 while((ch = *fptr++)) {
955 if(match_flags & 1) {
956 reflags[left++] = ch;
961 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
962 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
964 /* return the pattern and the modifiers */
966 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
969 /* Scalar, so use the string that Perl would return */
970 /* return the pattern in (?msixn:..) format */
971 #if PERL_VERSION >= 11
972 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
974 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
975 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
981 /* It ain't a regexp folks */
982 if ( gimme == G_ARRAY ) {
983 /* return the empty list */
986 /* Because of the (?:..) wrapping involved in a
987 stringified pattern it is impossible to get a
988 result for a real regexp that would evaluate to
989 false. Therefore we can return PL_sv_no to signify
990 that the object is not a regex, this means that one
993 if (regex($might_be_a_regex) eq '(?:foo)') { }
995 and not worry about undefined values.
1000 NOT_REACHED; /* NOTREACHED */
1006 struct xsub_details {
1012 static const struct xsub_details details[] = {
1013 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1014 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1015 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1016 #define VXS_XSUB_DETAILS
1018 #undef VXS_XSUB_DETAILS
1019 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1020 {"utf8::valid", XS_utf8_valid, NULL},
1021 {"utf8::encode", XS_utf8_encode, NULL},
1022 {"utf8::decode", XS_utf8_decode, NULL},
1023 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1024 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1025 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1026 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1027 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1028 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
1029 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1030 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1031 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1032 {"re::is_regexp", XS_re_is_regexp, "$"},
1033 {"re::regname", XS_re_regname, ";$$"},
1034 {"re::regnames", XS_re_regnames, ";$"},
1035 {"re::regnames_count", XS_re_regnames_count, ""},
1036 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1040 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1044 /* Optimizes out an identity function, i.e., one that just returns its
1045 * argument. The passed in function is assumed to be an identity function,
1046 * with no checking. This is designed to be called for utf8_to_native()
1047 * and native_to_utf8() on ASCII platforms, as they just return their
1048 * arguments, but it could work on any such function.
1050 * The code is mostly just cargo-culted from Memoize::Lift */
1054 SV* prototype = newSVpvs("$");
1056 PERL_UNUSED_ARG(protosv);
1058 assert(entersubop->op_type == OP_ENTERSUB);
1060 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1061 parent = entersubop;
1063 SvREFCNT_dec(prototype);
1065 pushop = cUNOPx(entersubop)->op_first;
1066 if (! OpHAS_SIBLING(pushop)) {
1068 pushop = cUNOPx(pushop)->op_first;
1070 argop = OpSIBLING(pushop);
1072 /* Carry on without doing the optimization if it is not something we're
1073 * expecting, so continues to work */
1075 || ! OpHAS_SIBLING(argop)
1076 || OpHAS_SIBLING(OpSIBLING(argop))
1081 /* cut argop from the subtree */
1082 (void)op_sibling_splice(parent, pushop, 1, NULL);
1084 op_free(entersubop);
1089 Perl_boot_core_UNIVERSAL(pTHX)
1091 static const char file[] = __FILE__;
1092 const struct xsub_details *xsub = details;
1093 const struct xsub_details *end = C_ARRAY_END(details);
1096 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1097 } while (++xsub < end);
1100 { /* On ASCII platforms these functions just return their argument, so can
1101 be optimized away */
1103 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1104 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1106 cv_set_call_checker(to_native_cv,
1107 optimize_out_native_convert_function,
1108 (SV*) to_native_cv);
1109 cv_set_call_checker(to_unicode_cv,
1110 optimize_out_native_convert_function,
1111 (SV*) to_unicode_cv);
1115 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1118 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1119 char ** cvfile = &CvFILE(cv);
1120 char * oldfile = *cvfile;
1122 *cvfile = (char *)file;
1128 * ex: set ts=8 sts=4 sw=4 et: