X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8687a6e6de7ce658ece8673ad56c37d0a1d8cbca..02b54f9d07226e99a30271314e02617d5629b511:/mathoms.c diff --git a/mathoms.c b/mathoms.c index 3604d41..dba2459 100644 --- a/mathoms.c +++ b/mathoms.c @@ -24,7 +24,7 @@ * versions of Perl which we cannot completely remove from the core * code. There are two reasons functions should be here: * - * 1) A function has been been replaced by a macro within a minor release, + * 1) A function has been replaced by a macro within a minor release, * so XS modules compiled against an older release will expect to * still be able to link against the function * 2) A function Perl_foo(...) with #define foo Perl_foo(aTHX_ ...) @@ -32,6 +32,9 @@ * but XS code may still explicitly use the long form, i.e. * Perl_foo(aTHX_ ...) * + * This file can't just be cleaned out periodically, because that would break + * builds with -DPERL_NO_SHORT_NAMES + * * NOTE: ALL FUNCTIONS IN THIS FILE should have an entry with the 'b' flag in * embed.fnc. * @@ -46,14 +49,11 @@ * * and add the 'b' flag in embed.fnc. * - * REMEMBER to update makedef.pl when adding a function to mathoms.c whose - * name doesn't begin with "Perl_". - * * The compilation of this file can be suppressed; see INSTALL * * Some blurb for perlapi.pod: -=head1 Obsolete backwards compatibility functions + head1 Obsolete backwards compatibility functions Some of these are also deprecated. You can exclude these from your compiled Perl by adding this option to Configure: @@ -74,6 +74,10 @@ C<-Accflags='-DNO_MATHOMS'> */ #else +/* The functions in this file should be able to call other deprecated functions + * without a compiler warning */ +GCC_DIAG_IGNORE(-Wdeprecated-declarations) + /* ref() is now a macro using Perl_doref; * this version provided for binary compatibility only. */ @@ -84,6 +88,7 @@ Perl_ref(pTHX_ OP *o, I32 type) } /* +=for apidoc_section $SV =for apidoc sv_unref Unsets the RV status of the SV, and decrements the reference count of @@ -103,6 +108,7 @@ Perl_sv_unref(pTHX_ SV *sv) } /* +=for apidoc_section $tainting =for apidoc sv_taint Taint an SV. Use C instead. @@ -166,6 +172,7 @@ Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp) } /* +=for apidoc_section $SV =for apidoc sv_2pv_nolen Like C, but doesn't return the length too. You should usually @@ -182,6 +189,7 @@ Perl_sv_2pv_nolen(pTHX_ SV *sv) } /* +=for apidoc_section $SV =for apidoc sv_2pvbyte_nolen Return a pointer to the byte-encoded representation of the SV. @@ -201,6 +209,7 @@ Perl_sv_2pvbyte_nolen(pTHX_ SV *sv) } /* +=for apidoc_section $SV =for apidoc sv_2pvutf8_nolen Return a pointer to the UTF-8-encoded representation of the SV. @@ -220,6 +229,7 @@ Perl_sv_2pvutf8_nolen(pTHX_ SV *sv) } /* +=for apidoc_section $SV =for apidoc sv_force_normal Undo various types of fakery on an SV: if the PV is a shared string, make @@ -242,11 +252,11 @@ Perl_sv_force_normal(pTHX_ SV *sv) */ void -Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr) +Perl_sv_setsv(pTHX_ SV *dsv, SV *ssv) { PERL_ARGS_ASSERT_SV_SETSV; - sv_setsv_flags(dstr, sstr, SV_GMAGIC); + sv_setsv_flags(dsv, ssv, SV_GMAGIC); } /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags(); @@ -261,20 +271,12 @@ Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); } -/* -=for apidoc sv_catpvn_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - void -Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len) +Perl_sv_catpvn_mg(pTHX_ SV *dsv, const char *sstr, STRLEN len) { PERL_ARGS_ASSERT_SV_CATPVN_MG; - sv_catpvn_flags(sv,ptr,len,SV_GMAGIC|SV_SMAGIC); + sv_catpvn_flags(dsv,sstr,len,SV_GMAGIC|SV_SMAGIC); } /* sv_catsv() is now a macro using Perl_sv_catsv_flags(); @@ -282,130 +284,30 @@ Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len) */ void -Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr) +Perl_sv_catsv(pTHX_ SV *dsv, SV *sstr) { PERL_ARGS_ASSERT_SV_CATSV; - sv_catsv_flags(dstr, sstr, SV_GMAGIC); + sv_catsv_flags(dsv, sstr, SV_GMAGIC); } -/* -=for apidoc sv_catsv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - void -Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv) +Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *sstr) { PERL_ARGS_ASSERT_SV_CATSV_MG; - sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC); -} - -/* -=for apidoc sv_iv - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -IV -Perl_sv_iv(pTHX_ SV *sv) -{ - PERL_ARGS_ASSERT_SV_IV; - - if (SvIOK(sv)) { - if (SvIsUV(sv)) - return (IV)SvUVX(sv); - return SvIVX(sv); - } - return sv_2iv(sv); -} - -/* -=for apidoc sv_uv - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -UV -Perl_sv_uv(pTHX_ SV *sv) -{ - PERL_ARGS_ASSERT_SV_UV; - - if (SvIOK(sv)) { - if (SvIsUV(sv)) - return SvUVX(sv); - return (UV)SvIVX(sv); - } - return sv_2uv(sv); -} - -/* -=for apidoc sv_nv - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -NV -Perl_sv_nv(pTHX_ SV *sv) -{ - PERL_ARGS_ASSERT_SV_NV; - - if (SvNOK(sv)) - return SvNVX(sv); - return sv_2nv(sv); + sv_catsv_flags(dsv,sstr,SV_GMAGIC|SV_SMAGIC); } /* +=for apidoc_section $SV =for apidoc sv_pv Use the C macro instead -=for apidoc sv_pvn - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - =cut */ -char * -Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) -{ - PERL_ARGS_ASSERT_SV_PVN; - - if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); - } - return sv_2pv(sv, lp); -} - - -char * -Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp) -{ - PERL_ARGS_ASSERT_SV_PVN_NOMG; - - if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); - } - return sv_2pv_flags(sv, lp, 0); -} - /* sv_pv() is now a macro using SvPV_nolen(); * this function provided for binary compatibility only */ @@ -442,67 +344,36 @@ Perl_sv_pvbyte(pTHX_ SV *sv) { PERL_ARGS_ASSERT_SV_PVBYTE; - sv_utf8_downgrade(sv, FALSE); + (void)sv_utf8_downgrade(sv, FALSE); return sv_pv(sv); } /* +=for apidoc_section $SV =for apidoc sv_pvbyte Use C instead. -=for apidoc sv_pvbyten - -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. - =cut */ -char * -Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) -{ - PERL_ARGS_ASSERT_SV_PVBYTEN; - - sv_utf8_downgrade(sv, FALSE); - return sv_pvn(sv,lp); -} - -/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pvutf8(pTHX_ SV *sv) -{ - PERL_ARGS_ASSERT_SV_PVUTF8; - - sv_utf8_upgrade(sv); - return sv_pv(sv); -} - /* +=for apidoc_section $SV =for apidoc sv_pvutf8 Use the C macro instead -=for apidoc sv_pvutf8n - -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. - =cut */ + char * -Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) +Perl_sv_pvutf8(pTHX_ SV *sv) { - PERL_ARGS_ASSERT_SV_PVUTF8N; + PERL_ARGS_ASSERT_SV_PVUTF8; sv_utf8_upgrade(sv); - return sv_pvn(sv,lp); + return sv_pv(sv); } /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags(); @@ -517,41 +388,6 @@ Perl_sv_utf8_upgrade(pTHX_ SV *sv) return sv_utf8_upgrade_flags(sv, SV_GMAGIC); } -int -Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) -{ - int ret = 0; - va_list(arglist); - - /* Easier to special case this here than in embed.pl. (Look at what it - generates for proto.h) */ -#ifdef PERL_IMPLICIT_CONTEXT - PERL_ARGS_ASSERT_FPRINTF_NOCONTEXT; -#endif - - va_start(arglist, format); - ret = PerlIO_vprintf(stream, format, arglist); - va_end(arglist); - return ret; -} - -int -Perl_printf_nocontext(const char *format, ...) -{ - dTHX; - va_list(arglist); - int ret = 0; - -#ifdef PERL_IMPLICIT_CONTEXT - PERL_ARGS_ASSERT_PRINTF_NOCONTEXT; -#endif - - va_start(arglist, format); - ret = PerlIO_vprintf(PerlIO_stdout(), format, arglist); - va_end(arglist); - return ret; -} - #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) /* * This hack is to force load of "huge" support from libm.a @@ -569,24 +405,6 @@ Perl_huge(void) } #endif -/* compatibility with versions <= 5.003. */ -void -Perl_gv_fullname(pTHX_ SV *sv, const GV *gv) -{ - PERL_ARGS_ASSERT_GV_FULLNAME; - - gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); -} - -/* compatibility with versions <= 5.003. */ -void -Perl_gv_efullname(pTHX_ SV *sv, const GV *gv) -{ - PERL_ARGS_ASSERT_GV_EFULLNAME; - - gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); -} - void Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix) { @@ -604,6 +422,7 @@ Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix) } /* +=for apidoc_section $GV =for apidoc gv_fetchmethod See L. @@ -637,42 +456,12 @@ Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how) bool Perl_do_open(pTHX_ GV *gv, const char *name, I32 len, int as_raw, - int rawmode, int rawperm, PerlIO *supplied_fp) + int rawmode, int rawperm, PerlIO *supplied_fp) { PERL_ARGS_ASSERT_DO_OPEN; return do_openn(gv, name, len, as_raw, rawmode, rawperm, - supplied_fp, (SV **) NULL, 0); -} - -bool -Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len, int -as_raw, - int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, - I32 num_svs) -{ - PERL_ARGS_ASSERT_DO_OPEN9; - - PERL_UNUSED_ARG(num_svs); - return do_openn(gv, name, len, as_raw, rawmode, rawperm, - supplied_fp, &svs, 1); -} - -int -Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) -{ - /* The old body of this is now in non-LAYER part of perlio.c - * This is a stub for any XS code which might have been calling it. - */ - const char *name = ":raw"; - - PERL_ARGS_ASSERT_DO_BINMODE; - -#ifdef PERLIO_USING_CRLF - if (!(mode & O_BINARY)) - name = ":crlf"; -#endif - return PerlIO_binmode(aTHX_ fp, iotype, mode, name); + supplied_fp, (SV **) NULL, 0); } #ifndef OS2 @@ -685,15 +474,8 @@ Perl_do_aexec(pTHX_ SV *really, SV **mark, SV **sp) } #endif -/* Backwards compatibility. */ -int -Perl_init_i18nl14n(pTHX_ int printwarn) -{ - return init_i18nl10n(printwarn); -} - bool -Perl_is_utf8_string_loc(const U8 *s, STRLEN len, const U8 **ep) +Perl_is_utf8_string_loc(const U8 *s, const STRLEN len, const U8 **ep) { PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC; @@ -701,6 +483,7 @@ Perl_is_utf8_string_loc(const U8 *s, STRLEN len, const U8 **ep) } /* +=for apidoc_section $SV =for apidoc sv_nolocking Dummy routine which "locks" an SV when there is no locking module present. @@ -721,6 +504,7 @@ Perl_sv_nolocking(pTHX_ SV *sv) /* +=for apidoc_section $SV =for apidoc sv_nounlocking Dummy routine which "unlocks" an SV when there is no locking module present. @@ -730,6 +514,10 @@ potentially warn under some level of strict-ness. "Superseded" by C. =cut + +PERL_UNLOCK_HOOK in intrpvar.h is the macro that refers to this, and guarantees +that mathoms gets loaded. + */ void @@ -740,65 +528,6 @@ Perl_sv_nounlocking(pTHX_ SV *sv) } void -Perl_save_long(pTHX_ long int *longp) -{ - PERL_ARGS_ASSERT_SAVE_LONG; - - SSCHECK(3); - SSPUSHLONG(*longp); - SSPUSHPTR(longp); - SSPUSHUV(SAVEt_LONG); -} - -void -Perl_save_iv(pTHX_ IV *ivp) -{ - PERL_ARGS_ASSERT_SAVE_IV; - - SSCHECK(3); - SSPUSHIV(*ivp); - SSPUSHPTR(ivp); - SSPUSHUV(SAVEt_IV); -} - -void -Perl_save_nogv(pTHX_ GV *gv) -{ - PERL_ARGS_ASSERT_SAVE_NOGV; - - SSCHECK(2); - SSPUSHPTR(gv); - SSPUSHUV(SAVEt_NSTAB); -} - -void -Perl_save_list(pTHX_ SV **sarg, I32 maxsarg) -{ - I32 i; - - PERL_ARGS_ASSERT_SAVE_LIST; - - for (i = 1; i <= maxsarg; i++) { - SV *sv; - SvGETMAGIC(sarg[i]); - sv = newSV(0); - sv_setsv_nomg(sv,sarg[i]); - SSCHECK(3); - SSPUSHPTR(sarg[i]); /* remember the pointer */ - SSPUSHPTR(sv); /* remember the value */ - SSPUSHUV(SAVEt_ITEM); - } -} - -/* -=for apidoc sv_usepvn_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len) { PERL_ARGS_ASSERT_SV_USEPVN_MG; @@ -806,15 +535,6 @@ Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len) sv_usepvn_flags(sv,ptr,len, SV_SMAGIC); } -/* -=for apidoc sv_usepvn - -Tells an SV to use C to find its string value. Implemented by -calling C with C of 0, hence does not handle 'set' -magic. See C>. - -=cut -*/ void Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len) @@ -824,50 +544,6 @@ Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len) sv_usepvn_flags(sv,ptr,len, 0); } -/* -=for apidoc unpack_str - -The engine implementing C Perl function. Note: parameters C, -C and C are not used. This call should not be used, use -C instead. - -=cut */ - -I32 -Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s, - const char *strbeg, const char *strend, char **new_s, I32 ocnt, - U32 flags) -{ - PERL_ARGS_ASSERT_UNPACK_STR; - - PERL_UNUSED_ARG(strbeg); - PERL_UNUSED_ARG(new_s); - PERL_UNUSED_ARG(ocnt); - - return unpackstring(pat, patend, s, strend, flags); -} - -/* -=for apidoc pack_cat - -The engine implementing C Perl function. Note: parameters -C and C are not used. This call should not be used; use -C instead. - -=cut -*/ - -void -Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) -{ - PERL_ARGS_ASSERT_PACK_CAT; - - PERL_UNUSED_ARG(next_in_list); - PERL_UNUSED_ARG(flags); - - packlist(cat, pat, patend, beglist, endlist); -} - HE * Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) { @@ -879,8 +555,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) { PERL_ARGS_ASSERT_HV_EXISTS_ENT; - return hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash) - ? TRUE : FALSE; + return cBOOL(hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)); } HE * @@ -889,7 +564,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash) PERL_ARGS_ASSERT_HV_FETCH_ENT; return (HE *)hv_common(hv, keysv, NULL, 0, 0, - (lval ? HV_FETCH_LVALUE : 0), NULL, hash); + (lval ? HV_FETCH_LVALUE : 0), NULL, hash); } SV * @@ -898,15 +573,15 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) PERL_ARGS_ASSERT_HV_DELETE_ENT; return MUTABLE_SV(hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL, - hash)); + hash)); } SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash, - int flags) + int flags) { return (SV**) hv_common(hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); } SV** @@ -916,14 +591,14 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) int flags; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return (SV **) hv_common(hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); } bool @@ -935,14 +610,13 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32) PERL_ARGS_ASSERT_HV_EXISTS; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } - return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0) - ? TRUE : FALSE; + return cBOOL(hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)); } SV** @@ -954,15 +628,15 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) PERL_ARGS_ASSERT_HV_FETCH; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return (SV **) hv_common(hv, NULL, key, klen, flags, - lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) - : HV_FETCH_JUST_SV, NULL, 0); + lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) + : HV_FETCH_JUST_SV, NULL, 0); } SV * @@ -974,14 +648,14 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags) PERL_ARGS_ASSERT_HV_DELETE; if (klen_i32 < 0) { - klen = -klen_i32; - k_flags = HVhek_UTF8; + klen = -klen_i32; + k_flags = HVhek_UTF8; } else { - klen = klen_i32; - k_flags = 0; + klen = klen_i32; + k_flags = 0; } return MUTABLE_SV(hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE, - NULL, 0)); + NULL, 0)); } AV * @@ -1097,605 +771,166 @@ Perl_sv_eq(pTHX_ SV *sv1, SV *sv2) char * Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp) { + PERL_ARGS_ASSERT_SV_COLLXFRM; return sv_collxfrm_flags(sv, nxp, SV_GMAGIC); } + #endif bool Perl_sv_2bool(pTHX_ SV *const sv) { + PERL_ARGS_ASSERT_SV_2BOOL; return sv_2bool_flags(sv, SV_GMAGIC); } - -/* -=for apidoc custom_op_name -Return the name for a given custom op. This was once used by the C -macro, but is no longer: it has only been kept for compatibility, and -should not be used. - -=for apidoc custom_op_desc -Return the description of a given custom op. This was once used by the -C macro, but is no longer: it has only been kept for -compatibility, and should not be used. - -=cut -*/ - -const char* -Perl_custom_op_name(pTHX_ const OP* o) +CV * +Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) { - PERL_ARGS_ASSERT_CUSTOM_OP_NAME; - return XopENTRYCUSTOM(o, xop_name); + return newATTRSUB(floor, o, proto, NULL, block); } -const char* -Perl_custom_op_desc(pTHX_ const OP* o) +SV * +Perl_sv_mortalcopy(pTHX_ SV *const oldsv) { - PERL_ARGS_ASSERT_CUSTOM_OP_DESC; - return XopENTRYCUSTOM(o, xop_desc); + return Perl_sv_mortalcopy_flags(aTHX_ oldsv, SV_GMAGIC); } -CV * -Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) +void +Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) { - return newATTRSUB(floor, o, proto, NULL, block); + PERL_ARGS_ASSERT_SV_COPYPV; + + sv_copypv_flags(dsv, ssv, SV_GMAGIC); } -UV -Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) -{ - PERL_ARGS_ASSERT_TO_UTF8_FOLD; +/* +=for apidoc_section $unicode +=for apidoc is_utf8_char_buf - return _to_utf8_fold_flags(p, ustrp, lenp, FOLD_FLAGS_FULL); -} +This is identical to the macro L. -UV -Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) +=cut */ + +STRLEN +Perl_is_utf8_char_buf(const U8 *buf, const U8* buf_end) { - PERL_ARGS_ASSERT_TO_UTF8_LOWER; - return _to_utf8_lower_flags(p, ustrp, lenp, FALSE); + PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF; + + return isUTF8_CHAR(buf, buf_end); } +/* +=for apidoc_section $unicode +=for apidoc utf8_to_uvuni + +Returns the Unicode code point of the first character in the string C +which is assumed to be in UTF-8 encoding; C will be set to the +length, in bytes, of that character. + +Some, but not all, UTF-8 malformations are detected, and in fact, some +malformed input could cause reading beyond the end of the input buffer, which +is one reason why this function is deprecated. The other is that only in +extremely limited circumstances should the Unicode versus native code point be +of any interest to you. + +If C points to one of the detected malformations, and UTF8 warnings are +enabled, zero is returned and C<*retlen> is set (if C doesn't point to +NULL) to -1. If those warnings are off, the computed value if well-defined (or +the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen> +is set (if C isn't NULL) so that (S + C<*retlen>>) is the +next possible position in C that could begin a non-malformed character. +See L for details on when the REPLACEMENT CHARACTER is returned. + +=cut +*/ + UV -Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) +Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) { - PERL_ARGS_ASSERT_TO_UTF8_TITLE; + PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_UTF8_TO_UVUNI; - return _to_utf8_title_flags(p, ustrp, lenp, FALSE); + return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen)); } -UV -Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) +/* return ptr to little string in big string, NULL if not found */ +/* The original version of this routine was donated by Corey Satten. */ + +char * +Perl_instr(const char *big, const char *little) { - PERL_ARGS_ASSERT_TO_UTF8_UPPER; + PERL_ARGS_ASSERT_INSTR; - return _to_utf8_upper_flags(p, ustrp, lenp, FALSE); + return instr(big, little); } SV * -Perl_sv_mortalcopy(pTHX_ SV *const oldstr) +Perl_newSVsv(pTHX_ SV *const old) { - return Perl_sv_mortalcopy_flags(aTHX_ oldstr, SV_GMAGIC); + return newSVsv(old); } -void -Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) +bool +Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) { - PERL_ARGS_ASSERT_SV_COPYPV; + PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE; - sv_copypv_flags(dsv, ssv, 0); + return sv_utf8_downgrade(sv, fail_ok); } -UV /* Made into a function, so can be deprecated */ -NATIVE_TO_NEED(const UV enc, const UV ch) +char * +Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp) { - PERL_UNUSED_ARG(enc); - return ch; + PERL_ARGS_ASSERT_SV_2PVUTF8; + + return sv_2pvutf8(sv, lp); } -UV /* Made into a function, so can be deprecated */ -ASCII_TO_NEED(const UV enc, const UV ch) -{ - PERL_UNUSED_ARG(enc); - return ch; -} - -bool /* Made into a function, so can be deprecated */ -Perl_isIDFIRST_lazy(pTHX_ const char* p) -{ - PERL_ARGS_ASSERT_ISIDFIRST_LAZY; - - return isIDFIRST_lazy_if(p,1); -} - -bool /* Made into a function, so can be deprecated */ -Perl_isALNUM_lazy(pTHX_ const char* p) -{ - PERL_ARGS_ASSERT_ISALNUM_LAZY; - - return isALNUM_lazy_if(p,1); -} - -bool -Perl_is_uni_alnum(pTHX_ UV c) -{ - return isWORDCHAR_uni(c); -} - -bool -Perl_is_uni_alnumc(pTHX_ UV c) -{ - return isALNUM_uni(c); -} - -bool -Perl_is_uni_alpha(pTHX_ UV c) -{ - return isALPHA_uni(c); -} - -bool -Perl_is_uni_ascii(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isASCII_uni(c); -} - -bool -Perl_is_uni_blank(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isBLANK_uni(c); -} - -bool -Perl_is_uni_space(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isSPACE_uni(c); -} - -bool -Perl_is_uni_digit(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isDIGIT_uni(c); -} - -bool -Perl_is_uni_upper(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isUPPER_uni(c); -} - -bool -Perl_is_uni_lower(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isLOWER_uni(c); -} - -bool -Perl_is_uni_cntrl(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isCNTRL_L1(c); -} - -bool -Perl_is_uni_graph(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isGRAPH_uni(c); -} - -bool -Perl_is_uni_print(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isPRINT_uni(c); -} - -bool -Perl_is_uni_punct(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isPUNCT_uni(c); -} - -bool -Perl_is_uni_xdigit(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isXDIGIT_uni(c); -} - -bool -Perl_is_uni_alnum_lc(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isWORDCHAR_LC_uvchr(c); -} - -bool -Perl_is_uni_alnumc_lc(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isALPHANUMERIC_LC_uvchr(c); -} - -bool -Perl_is_uni_idfirst_lc(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - /* XXX Should probably be something that resolves to the old IDFIRST, but - * this function is deprecated, so not bothering */ - return isIDFIRST_LC_uvchr(c); -} - -bool -Perl_is_uni_alpha_lc(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isALPHA_LC_uvchr(c); -} - -bool -Perl_is_uni_ascii_lc(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isASCII_LC_uvchr(c); -} - -bool -Perl_is_uni_blank_lc(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isBLANK_LC_uvchr(c); -} - -bool -Perl_is_uni_space_lc(pTHX_ UV c) -{ - PERL_UNUSED_CONTEXT; - return isSPACE_LC_uvchr(c); -} - -bool -Perl_is_uni_digit_lc(pTHX_ UV c) -{ - return isDIGIT_LC_uvchr(c); -} - -bool -Perl_is_uni_idfirst(pTHX_ UV c) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_idstart(tmpbuf); -} - -bool -Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */ -{ - PERL_ARGS_ASSERT_IS_UTF8_IDFIRST; - - return _is_utf8_idstart(p); -} - -bool -Perl_is_utf8_xidfirst(pTHX_ const U8 *p) /* The naming is historical. */ -{ - PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST; - - return _is_utf8_xidstart(p); -} - -bool -Perl_is_utf8_idcont(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_IDCONT; - - return _is_utf8_idcont(p); -} - -bool -Perl_is_utf8_xidcont(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_XIDCONT; - - return _is_utf8_xidcont(p); -} - -bool -Perl_is_uni_upper_lc(pTHX_ UV c) -{ - return isUPPER_LC_uvchr(c); -} - -bool -Perl_is_uni_lower_lc(pTHX_ UV c) -{ - return isLOWER_LC_uvchr(c); -} - -bool -Perl_is_uni_cntrl_lc(pTHX_ UV c) -{ - return isCNTRL_LC_uvchr(c); -} - -bool -Perl_is_uni_graph_lc(pTHX_ UV c) -{ - return isGRAPH_LC_uvchr(c); -} - -bool -Perl_is_uni_print_lc(pTHX_ UV c) -{ - return isPRINT_LC_uvchr(c); -} - -bool -Perl_is_uni_punct_lc(pTHX_ UV c) -{ - return isPUNCT_LC_uvchr(c); -} - -bool -Perl_is_uni_xdigit_lc(pTHX_ UV c) -{ - return isXDIGIT_LC_uvchr(c); -} - -U32 -Perl_to_uni_upper_lc(pTHX_ U32 c) -{ - /* XXX returns only the first character -- do not use XXX */ - /* XXX no locale support yet */ - STRLEN len; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - return (U32)to_uni_upper(c, tmpbuf, &len); -} - -U32 -Perl_to_uni_title_lc(pTHX_ U32 c) -{ - /* XXX returns only the first character XXX -- do not use XXX */ - /* XXX no locale support yet */ - STRLEN len; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - return (U32)to_uni_title(c, tmpbuf, &len); -} - -U32 -Perl_to_uni_lower_lc(pTHX_ U32 c) -{ - /* XXX returns only the first character -- do not use XXX */ - /* XXX no locale support yet */ - STRLEN len; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - return (U32)to_uni_lower(c, tmpbuf, &len); -} - -bool -Perl_is_utf8_alnum(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_ALNUM; - - /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true - * descendant of isalnum(3), in other words, it doesn't - * contain the '_'. --jhi */ - return isWORDCHAR_utf8(p); -} - -bool -Perl_is_utf8_alnumc(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_ALNUMC; - - return isALPHANUMERIC_utf8(p); -} - -bool -Perl_is_utf8_alpha(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_ALPHA; - - return isALPHA_utf8(p); -} - -bool -Perl_is_utf8_ascii(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_ASCII; - PERL_UNUSED_CONTEXT; - - return isASCII_utf8(p); -} - -bool -Perl_is_utf8_blank(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_BLANK; - PERL_UNUSED_CONTEXT; - - return isBLANK_utf8(p); -} - -bool -Perl_is_utf8_space(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_SPACE; - PERL_UNUSED_CONTEXT; - - return isSPACE_utf8(p); -} - -bool -Perl_is_utf8_perl_space(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE; - PERL_UNUSED_CONTEXT; - - /* Only true if is an ASCII space-like character, and ASCII is invariant - * under utf8, so can just use the macro */ - return isSPACE_A(*p); -} - -bool -Perl_is_utf8_perl_word(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD; - PERL_UNUSED_CONTEXT; - - /* Only true if is an ASCII word character, and ASCII is invariant - * under utf8, so can just use the macro */ - return isWORDCHAR_A(*p); -} - -bool -Perl_is_utf8_digit(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_DIGIT; - - return isDIGIT_utf8(p); -} - -bool -Perl_is_utf8_posix_digit(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT; - PERL_UNUSED_CONTEXT; - - /* Only true if is an ASCII digit character, and ASCII is invariant - * under utf8, so can just use the macro */ - return isDIGIT_A(*p); -} - -bool -Perl_is_utf8_upper(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_UPPER; - - return isUPPER_utf8(p); -} - -bool -Perl_is_utf8_lower(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_LOWER; - - return isLOWER_utf8(p); -} - -bool -Perl_is_utf8_cntrl(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_CNTRL; - PERL_UNUSED_CONTEXT; - - return isCNTRL_utf8(p); -} - -bool -Perl_is_utf8_graph(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_GRAPH; - - return isGRAPH_utf8(p); -} - -bool -Perl_is_utf8_print(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_PRINT; - - return isPRINT_utf8(p); -} - -bool -Perl_is_utf8_punct(pTHX_ const U8 *p) -{ - PERL_ARGS_ASSERT_IS_UTF8_PUNCT; - - return isPUNCT_utf8(p); -} - -bool -Perl_is_utf8_xdigit(pTHX_ const U8 *p) +char * +Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp) { - PERL_ARGS_ASSERT_IS_UTF8_XDIGIT; - PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_SV_2PVBYTE; - return isXDIGIT_utf8(p); + return sv_2pvbyte(sv, lp); } -bool -Perl_is_utf8_mark(pTHX_ const U8 *p) +U8 * +Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv) { - PERL_ARGS_ASSERT_IS_UTF8_MARK; + PERL_ARGS_ASSERT_UVUNI_TO_UTF8; - return _is_utf8_mark(p); + return uvoffuni_to_utf8_flags(d, uv, 0); } /* -=for apidoc is_utf8_char +=for apidoc_section $unicode +=for apidoc utf8n_to_uvuni -Tests if some arbitrary number of bytes begins in a valid UTF-8 -character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines) -character is a valid UTF-8 character. The actual number of bytes in the UTF-8 -character will be returned if it is valid, otherwise 0. - -This function is deprecated due to the possibility that malformed input could -cause reading beyond the end of the input buffer. Use L -instead. - -=cut */ - -STRLEN -Perl_is_utf8_char(const U8 *s) -{ - PERL_ARGS_ASSERT_IS_UTF8_CHAR; - - /* Assumes we have enough space, which is why this is deprecated */ - return isUTF8_CHAR(s, s + UTF8SKIP(s)); -} - -/* -=for apidoc is_utf8_char_buf +Instead use L, or rarely, L. -This is identical to the macro L. +This function was useful for code that wanted to handle both EBCDIC and +ASCII platforms with Unicode properties, but starting in Perl v5.20, the +distinctions between the platforms have mostly been made invisible to most +code, so this function is quite unlikely to be what you want. If you do need +this precise functionality, use instead +C> +or C>. -=cut */ - -STRLEN -Perl_is_utf8_char_buf(const U8 *buf, const U8* buf_end) -{ - - PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF; - - return isUTF8_CHAR(buf, buf_end); -} - -/* DEPRECATED! - * Like L(), but should only be called when it is known that - * there are no malformations in the input UTF-8 string C. Surrogates, - * non-character code points, and non-Unicode code points are allowed */ +=cut +*/ UV -Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) +Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) { - PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI; + PERL_ARGS_ASSERT_UTF8N_TO_UVUNI; - return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen)); + return NATIVE_TO_UNI(utf8n_to_uvchr(s, curlen, retlen, flags)); } /* +=for apidoc_section $unicode =for apidoc utf8_to_uvchr Returns the native code point of the first character in the string C @@ -1722,67 +957,20 @@ Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen) { PERL_ARGS_ASSERT_UTF8_TO_UVCHR; - return utf8_to_uvchr_buf(s, s + UTF8_MAXBYTES, retlen); -} - -/* -=for apidoc utf8_to_uvuni + /* This function is unsafe if malformed UTF-8 input is given it, which is + * why the function is deprecated. If the first byte of the input + * indicates that there are more bytes remaining in the sequence that forms + * the character than there are in the input buffer, it can read past the + * end. But we can make it safe if the input string happens to be + * NUL-terminated, as many strings in Perl are, by refusing to read past a + * NUL, which is what UTF8_CHK_SKIP() does. A NUL indicates the start of + * the next character anyway. If the input isn't NUL-terminated, the + * function remains unsafe, as it always has been. */ -Returns the Unicode code point of the first character in the string C -which is assumed to be in UTF-8 encoding; C will be set to the -length, in bytes, of that character. - -Some, but not all, UTF-8 malformations are detected, and in fact, some -malformed input could cause reading beyond the end of the input buffer, which -is one reason why this function is deprecated. The other is that only in -extremely limited circumstances should the Unicode versus native code point be -of any interest to you. See L for alternatives. - -If C points to one of the detected malformations, and UTF8 warnings are -enabled, zero is returned and C<*retlen> is set (if C doesn't point to -NULL) to -1. If those warnings are off, the computed value if well-defined (or -the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen> -is set (if C isn't NULL) so that (S + C<*retlen>>) is the -next possible position in C that could begin a non-malformed character. -See L for details on when the REPLACEMENT CHARACTER is returned. - -=cut -*/ - -UV -Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) -{ - PERL_ARGS_ASSERT_UTF8_TO_UVUNI; - - return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen)); + return utf8_to_uvchr_buf(s, s + UTF8_CHK_SKIP(s), retlen); } -/* -=for apidoc Am|HV *|pad_compname_type|PADOFFSET po - -Looks up the type of the lexical variable at position C in the -currently-compiling pad. If the variable is typed, the stash of the -class to which it is typed is returned. If not, C is returned. - -=cut -*/ - -HV * -Perl_pad_compname_type(pTHX_ const PADOFFSET po) -{ - return PAD_COMPNAME_TYPE(po); -} - -/* return ptr to little string in big string, NULL if not found */ -/* The original version of this routine was donated by Corey Satten. */ - -char * -Perl_instr(const char *big, const char *little) -{ - PERL_ARGS_ASSERT_INSTR; - - return instr((char *) big, (char *) little); -} +GCC_DIAG_RESTORE #endif /* NO_MATHOMS */