diff options
Diffstat (limited to 'gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc')
38 files changed, 4339 insertions, 1301 deletions
diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/01_test b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/01_test new file mode 100644 index 00000000000..bf2885339e6 --- /dev/null +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/01_test @@ -0,0 +1,13 @@ +################################################################################ +## +## Copyright (C) 2019, Pali <pali@cpan.org> +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=tests plan => 1 + +# This test file is used as target dependency for Makefile +ok 1; diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/HvNAME b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/HvNAME index 9fba5029fb4..07c84e9ec93 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/HvNAME +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/HvNAME @@ -31,8 +31,8 @@ HvNAMELEN_get(hv) =tests plan => 4 -ok(Devel::PPPort::HvNAME_get(\%Devel::PPPort::), 'Devel::PPPort'); +is(Devel::PPPort::HvNAME_get(\%Devel::PPPort::), 'Devel::PPPort'); ok(!defined Devel::PPPort::HvNAME_get({})); -ok(Devel::PPPort::HvNAMELEN_get(\%Devel::PPPort::), length('Devel::PPPort')); -ok(Devel::PPPort::HvNAMELEN_get({}), 0); +is(Devel::PPPort::HvNAMELEN_get(\%Devel::PPPort::), length('Devel::PPPort')); +is(Devel::PPPort::HvNAMELEN_get({}), 0); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/SvPV b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/SvPV index 4f0ded321c2..c20cb85876c 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/SvPV +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/SvPV @@ -17,21 +17,8 @@ sv_2pvbyte sv_2pv_flags sv_pvn_force_flags -=dontwarn - -NEED_sv_2pv_flags -NEED_sv_2pv_flags_GLOBAL - =implementation -/* Backwards compatibility stuff... :-( */ -#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) -# define NEED_sv_2pv_flags -#endif -#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) -# define NEED_sv_2pv_flags_GLOBAL -#endif - /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ @@ -47,21 +34,14 @@ __UNDEFINED__ sv_2pv_nolen(sv) SvPV_nolen(sv) #if { VERSION < 5.7.0 } -#if { NEED sv_2pvbyte } - -char * -sv_2pvbyte(pTHX_ SV *sv, STRLEN *lp) -{ - sv_utf8_downgrade(sv,0); - return SvPV(sv,*lp); -} - -#endif +__UNDEFINED__ sv_2pvbyte(sv, lp) (sv_utf8_downgrade((sv), 0), SvPV((sv), *(lp))) /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ +/* Replace sv_2pvbyte with SvPVbyte */ + #undef SvPVbyte #define SvPVbyte(sv, lp) \ @@ -83,46 +63,31 @@ __UNDEFINED__ sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) * Always use the SvPV() macro instead of sv_pvn(). */ +/* Replace sv_pvn with SvPV */ + /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ +/* Replace sv_pvn_force with SvPV_force */ + /* If these are undefined, they're not handled by the core anyway */ __UNDEFINED__ SV_IMMEDIATE_UNREF 0 __UNDEFINED__ SV_GMAGIC 0 __UNDEFINED__ SV_COW_DROP_PV 0 __UNDEFINED__ SV_UTF8_NO_ENCODING 0 -__UNDEFINED__ SV_NOSTEAL 0 __UNDEFINED__ SV_CONST_RETURN 0 __UNDEFINED__ SV_MUTABLE_RETURN 0 __UNDEFINED__ SV_SMAGIC 0 __UNDEFINED__ SV_HAS_TRAILING_NUL 0 __UNDEFINED__ SV_COW_SHARED_HASH_KEYS 0 -#if { VERSION < 5.7.2 } - -#if { NEED sv_2pv_flags } - -char * -sv_2pv_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) -{ - STRLEN n_a = (STRLEN) flags; - return sv_2pv(sv, lp ? lp : &n_a); -} - -#endif - -#if { NEED sv_pvn_force_flags } - -char * -sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) -{ - STRLEN n_a = (STRLEN) flags; - return sv_pvn_force(sv, lp ? lp : &n_a); -} - -#endif - +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) + __UNDEFINED__ sv_2pv_flags(sv, lp, flags) ({ SV *_sv = (sv); const I32 _flags = (flags); STRLEN *_lp = lp; _lp = _lp ? : &PL_na; (!(_flags & SV_GMAGIC) && SvGMAGICAL(_sv)) ? ({ char *_pv; SvGMAGICAL_off(_sv); _pv = sv_2pv(_sv, _lp); SvGMAGICAL_on(_sv); _pv; }) : sv_2pv(_sv, _lp); }) + __UNDEFINED__ sv_pvn_force_flags(sv, lp, flags) ({ SV *_sv = (sv); const I32 _flags = (flags); STRLEN *_lp = lp; _lp = _lp ? : &PL_na; (!(_flags & SV_GMAGIC) && SvGMAGICAL(_sv)) ? ({ char *_pv; SvGMAGICAL_off(_sv); _pv = sv_pvn_force(_sv, _lp); SvGMAGICAL_on(_sv); _pv; }) : sv_pvn_force(_sv, _lp); }) +#else + __UNDEFINED__ sv_2pv_flags(sv, lp, flags) ((PL_Sv = (sv)), (!((flags) & SV_GMAGIC) && SvGMAGICAL(PL_Sv)) ? (SvGMAGICAL_off(PL_Sv), (PL_Xpv = (XPV *)sv_2pv(PL_Sv, (lp) ? (lp) : &PL_na)), SvGMAGICAL_on(PL_Sv), (char *)PL_Xpv) : sv_2pv(PL_Sv, (lp) ? (lp) : &PL_na)) + __UNDEFINED__ sv_pvn_force_flags(sv, lp, flags) ((PL_Sv = (sv)), (!((flags) & SV_GMAGIC) && SvGMAGICAL(PL_Sv)) ? (SvGMAGICAL_off(PL_Sv), (PL_Xpv = (XPV *)sv_pvn_force(PL_Sv, (lp) ? (lp) : &PL_na)), SvGMAGICAL_on(PL_Sv), (char *)PL_Xpv) : sv_pvn_force(PL_Sv, (lp) ? (lp) : &PL_na)) #endif #if { VERSION < 5.8.8 } || ( { VERSION >= 5.9.0 } && { VERSION < 5.9.3 } ) @@ -191,12 +156,6 @@ __UNDEFINED__ SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END -=xsinit - -#define NEED_sv_2pv_flags -#define NEED_sv_pvn_force_flags -#define NEED_sv_2pvbyte - =xsubs IV @@ -465,70 +424,70 @@ SvPV_renew(sv, nlen, insv) my $mhx = "mhx"; -ok(&Devel::PPPort::SvPVbyte($mhx), 3); +is(&Devel::PPPort::SvPVbyte($mhx), 3); my $i = 42; -ok(&Devel::PPPort::SvPV_nolen($mhx), $i++); -ok(&Devel::PPPort::SvPV_const($mhx), $i++); -ok(&Devel::PPPort::SvPV_mutable($mhx), $i++); -ok(&Devel::PPPort::SvPV_flags($mhx), $i++); -ok(&Devel::PPPort::SvPV_flags_const($mhx), $i++); - -ok(&Devel::PPPort::SvPV_flags_const_nolen($mhx), $i++); -ok(&Devel::PPPort::SvPV_flags_mutable($mhx), $i++); -ok(&Devel::PPPort::SvPV_force($mhx), $i++); -ok(&Devel::PPPort::SvPV_force_nolen($mhx), $i++); -ok(&Devel::PPPort::SvPV_force_mutable($mhx), $i++); - -ok(&Devel::PPPort::SvPV_force_nomg($mhx), $i++); -ok(&Devel::PPPort::SvPV_force_nomg_nolen($mhx), $i++); -ok(&Devel::PPPort::SvPV_force_flags($mhx), $i++); -ok(&Devel::PPPort::SvPV_force_flags_nolen($mhx), $i++); -ok(&Devel::PPPort::SvPV_force_flags_mutable($mhx), $i++); - -ok(&Devel::PPPort::SvPV_nolen_const($mhx), $i++); -ok(&Devel::PPPort::SvPV_nomg($mhx), $i++); -ok(&Devel::PPPort::SvPV_nomg_const($mhx), $i++); -ok(&Devel::PPPort::SvPV_nomg_const_nolen($mhx), $i++); -ok(&Devel::PPPort::SvPV_nomg_nolen($mhx), $i++); - -$mhx = 42; ok(&Devel::PPPort::SvPV_nolen($mhx), 0); -$mhx = 42; ok(&Devel::PPPort::SvPV_const($mhx), 2); -$mhx = 42; ok(&Devel::PPPort::SvPV_mutable($mhx), 2); -$mhx = 42; ok(&Devel::PPPort::SvPV_flags($mhx), 2); -$mhx = 42; ok(&Devel::PPPort::SvPV_flags_const($mhx), 2); - -$mhx = 42; ok(&Devel::PPPort::SvPV_flags_const_nolen($mhx), 0); -$mhx = 42; ok(&Devel::PPPort::SvPV_flags_mutable($mhx), 2); -$mhx = 42; ok(&Devel::PPPort::SvPV_force($mhx), 2); -$mhx = 42; ok(&Devel::PPPort::SvPV_force_nolen($mhx), 0); -$mhx = 42; ok(&Devel::PPPort::SvPV_force_mutable($mhx), 2); - -$mhx = 42; ok(&Devel::PPPort::SvPV_force_nomg($mhx), 2); -$mhx = 42; ok(&Devel::PPPort::SvPV_force_nomg_nolen($mhx), 0); -$mhx = 42; ok(&Devel::PPPort::SvPV_force_flags($mhx), 2); -$mhx = 42; ok(&Devel::PPPort::SvPV_force_flags_nolen($mhx), 0); -$mhx = 42; ok(&Devel::PPPort::SvPV_force_flags_mutable($mhx), 2); - -$mhx = 42; ok(&Devel::PPPort::SvPV_nolen_const($mhx), 0); -$mhx = 42; ok(&Devel::PPPort::SvPV_nomg($mhx), 2); -$mhx = 42; ok(&Devel::PPPort::SvPV_nomg_const($mhx), 2); -$mhx = 42; ok(&Devel::PPPort::SvPV_nomg_const_nolen($mhx), 0); -$mhx = 42; ok(&Devel::PPPort::SvPV_nomg_nolen($mhx), 0); +is(&Devel::PPPort::SvPV_nolen($mhx), $i++); +is(&Devel::PPPort::SvPV_const($mhx), $i++); +is(&Devel::PPPort::SvPV_mutable($mhx), $i++); +is(&Devel::PPPort::SvPV_flags($mhx), $i++); +is(&Devel::PPPort::SvPV_flags_const($mhx), $i++); + +is(&Devel::PPPort::SvPV_flags_const_nolen($mhx), $i++); +is(&Devel::PPPort::SvPV_flags_mutable($mhx), $i++); +is(&Devel::PPPort::SvPV_force($mhx), $i++); +is(&Devel::PPPort::SvPV_force_nolen($mhx), $i++); +is(&Devel::PPPort::SvPV_force_mutable($mhx), $i++); + +is(&Devel::PPPort::SvPV_force_nomg($mhx), $i++); +is(&Devel::PPPort::SvPV_force_nomg_nolen($mhx), $i++); +is(&Devel::PPPort::SvPV_force_flags($mhx), $i++); +is(&Devel::PPPort::SvPV_force_flags_nolen($mhx), $i++); +is(&Devel::PPPort::SvPV_force_flags_mutable($mhx), $i++); + +is(&Devel::PPPort::SvPV_nolen_const($mhx), $i++); +is(&Devel::PPPort::SvPV_nomg($mhx), $i++); +is(&Devel::PPPort::SvPV_nomg_const($mhx), $i++); +is(&Devel::PPPort::SvPV_nomg_const_nolen($mhx), $i++); +is(&Devel::PPPort::SvPV_nomg_nolen($mhx), $i++); + +$mhx = 42; is(&Devel::PPPort::SvPV_nolen($mhx), 0); +$mhx = 42; is(&Devel::PPPort::SvPV_const($mhx), 2); +$mhx = 42; is(&Devel::PPPort::SvPV_mutable($mhx), 2); +$mhx = 42; is(&Devel::PPPort::SvPV_flags($mhx), 2); +$mhx = 42; is(&Devel::PPPort::SvPV_flags_const($mhx), 2); + +$mhx = 42; is(&Devel::PPPort::SvPV_flags_const_nolen($mhx), 0); +$mhx = 42; is(&Devel::PPPort::SvPV_flags_mutable($mhx), 2); +$mhx = 42; is(&Devel::PPPort::SvPV_force($mhx), 2); +$mhx = 42; is(&Devel::PPPort::SvPV_force_nolen($mhx), 0); +$mhx = 42; is(&Devel::PPPort::SvPV_force_mutable($mhx), 2); + +$mhx = 42; is(&Devel::PPPort::SvPV_force_nomg($mhx), 2); +$mhx = 42; is(&Devel::PPPort::SvPV_force_nomg_nolen($mhx), 0); +$mhx = 42; is(&Devel::PPPort::SvPV_force_flags($mhx), 2); +$mhx = 42; is(&Devel::PPPort::SvPV_force_flags_nolen($mhx), 0); +$mhx = 42; is(&Devel::PPPort::SvPV_force_flags_mutable($mhx), 2); + +$mhx = 42; is(&Devel::PPPort::SvPV_nolen_const($mhx), 0); +$mhx = 42; is(&Devel::PPPort::SvPV_nomg($mhx), 2); +$mhx = 42; is(&Devel::PPPort::SvPV_nomg_const($mhx), 2); +$mhx = 42; is(&Devel::PPPort::SvPV_nomg_const_nolen($mhx), 0); +$mhx = 42; is(&Devel::PPPort::SvPV_nomg_nolen($mhx), 0); my $str = ""; &Devel::PPPort::SvPV_force($str); my($s2, $before, $after) = &Devel::PPPort::SvPV_renew($str, 81, "x"x80); -ok($str, "x"x80); -ok($s2, "x"x80); +is($str, "x"x80); +is($s2, "x"x80); ok($before < 81); -ok($after, 81); +is($after, 81); $str = "x"x400; &Devel::PPPort::SvPV_force($str); ($s2, $before, $after) = &Devel::PPPort::SvPV_renew($str, 41, "x"x40); -ok($str, "x"x40); -ok($s2, "x"x40); +is($str, "x"x40); +is($s2, "x"x40); ok($before > 41); -ok($after, 41); +is($after, 41); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/Sv_set b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/Sv_set index 30452aee66f..8c3f91b7970 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/Sv_set +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/Sv_set @@ -12,9 +12,109 @@ =provides __UNDEFINED__ +SV_NOSTEAL +sv_setsv_flags +newSVsv_nomg =implementation +__UNDEFINED__ SV_NOSTEAL 16 + +#if ( { VERSION >= 5.7.3 } && { VERSION < 5.8.7 } ) || ( { VERSION >= 5.9.0 } && { VERSION < 5.9.2 } ) +#undef sv_setsv_flags +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +#define sv_setsv_flags(dstr, sstr, flags) \ + STMT_START { \ + if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \ + SvTEMP_off((SV *)(sstr)); \ + Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ + SvTEMP_on((SV *)(sstr)); \ + } else { \ + Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ + } \ + } STMT_END +#else + ( \ + (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \ + SvTEMP_off((SV *)(sstr)), \ + Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \ + SvTEMP_on((SV *)(sstr)), \ + 1 \ + ) : ( \ + Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \ + 1 \ + ) \ + ) +#endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +__UNDEFINED__ sv_setsv_flags(dstr, sstr, flags) \ + STMT_START { \ + if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \ + SvTEMP_off((SV *)(sstr)); \ + if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \ + SvGMAGICAL_off((SV *)(sstr)); \ + sv_setsv((dstr), (sstr)); \ + SvGMAGICAL_on((SV *)(sstr)); \ + } else { \ + sv_setsv((dstr), (sstr)); \ + } \ + SvTEMP_on((SV *)(sstr)); \ + } else { \ + if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \ + SvGMAGICAL_off((SV *)(sstr)); \ + sv_setsv((dstr), (sstr)); \ + SvGMAGICAL_on((SV *)(sstr)); \ + } else { \ + sv_setsv((dstr), (sstr)); \ + } \ + } \ + } STMT_END +#else +__UNDEFINED__ sv_setsv_flags(dstr, sstr, flags) \ + ( \ + (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \ + SvTEMP_off((SV *)(sstr)), \ + (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \ + SvGMAGICAL_off((SV *)(sstr)), \ + sv_setsv((dstr), (sstr)), \ + SvGMAGICAL_on((SV *)(sstr)), \ + 1 \ + ) : ( \ + sv_setsv((dstr), (sstr)), \ + 1 \ + ), \ + SvTEMP_on((SV *)(sstr)), \ + 1 \ + ) : ( \ + (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \ + SvGMAGICAL_off((SV *)(sstr)), \ + sv_setsv((dstr), (sstr)), \ + SvGMAGICAL_on((SV *)(sstr)), \ + 1 \ + ) : ( \ + sv_setsv((dstr), (sstr)), \ + 1 \ + ) \ + ) \ + ) +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +__UNDEFINED__ newSVsv_flags(sv, flags) ({ SV *_sv = newSV(0); sv_setsv_flags(_sv, (sv), (flags)); _sv; }) +#else +__UNDEFINED__ newSVsv_flags(sv, flags) ((PL_Sv = newSV(0)), sv_setsv_flags(PL_Sv, (sv), (flags)), PL_Sv) +#endif + +__UNDEFINED__ newSVsv_nomg(sv) newSVsv_flags((sv), SV_NOSTEAL) + +#if { VERSION >= 5.17.5 } +__UNDEFINED__ sv_mortalcopy_flags(sv, flags) Perl_sv_mortalcopy_flags(aTHX_ (sv), (flags)) +#else +__UNDEFINED__ sv_mortalcopy_flags(sv, flags) sv_2mortal(newSVsv_flags((sv), (flags))) +#endif + __UNDEFINED__ SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END @@ -94,20 +194,90 @@ TestSvSTASH_set(sv, name) SvREFCNT_dec(SvSTASH(sv)); SvSTASH_set(sv, (HV*) SvREFCNT_inc(gv_stashpv(name, 0))); -=tests plan => 5 +IV +Test_sv_setsv_SV_NOSTEAL() + PREINIT: + SV *sv1, *sv2; + CODE: + sv1 = sv_2mortal(newSVpv("test1", 0)); + sv2 = sv_2mortal(newSVpv("test2", 0)); + sv_setsv_flags(sv2, sv1, SV_NOSTEAL); + RETVAL = (strEQ(SvPV_nolen(sv1), "test1") && strEQ(SvPV_nolen(sv2), "test1")); + OUTPUT: + RETVAL + +SV * +newSVsv_nomg(sv) + SV *sv + CODE: + RETVAL = newSVsv_nomg(sv); + OUTPUT: + RETVAL + +void +sv_setsv_compile_test(sv) + SV *sv + CODE: + sv_setsv(sv, NULL); + sv_setsv_flags(sv, NULL, 0); + sv_setsv_flags(sv, NULL, SV_NOSTEAL); + +=tests plan => 15 my $foo = 5; -ok(&Devel::PPPort::TestSvUV_set($foo, 12345), 42); -ok(&Devel::PPPort::TestSvPVX_const("mhx"), 43); -ok(&Devel::PPPort::TestSvPVX_mutable("mhx"), 44); +is(&Devel::PPPort::TestSvUV_set($foo, 12345), 42); +is(&Devel::PPPort::TestSvPVX_const("mhx"), 43); +is(&Devel::PPPort::TestSvPVX_mutable("mhx"), 44); my $bar = []; bless $bar, 'foo'; -ok($bar->x(), 'foobar'); +is($bar->x(), 'foobar'); Devel::PPPort::TestSvSTASH_set($bar, 'bar'); -ok($bar->x(), 'hacker'); +is($bar->x(), 'hacker'); + + if (ivers($]) != ivers(5.7.2)) { + ok(Devel::PPPort::Test_sv_setsv_SV_NOSTEAL()); + } + else { + skip("7.2 broken for NOSTEAL", 1); + } + + tie my $scalar, 'TieScalarCounter', 'string'; + + is tied($scalar)->{fetch}, 0; + is tied($scalar)->{store}, 0; + my $copy = Devel::PPPort::newSVsv_nomg($scalar); + is tied($scalar)->{fetch}, 0; + is tied($scalar)->{store}, 0; + + my $fetch = $scalar; + is tied($scalar)->{fetch}, 1; + is tied($scalar)->{store}, 0; + my $copy2 = Devel::PPPort::newSVsv_nomg($scalar); + is tied($scalar)->{fetch}, 1; + is tied($scalar)->{store}, 0; + is $copy2, 'string'; + +package TieScalarCounter; + +sub TIESCALAR { + my ($class, $value) = @_; + return bless { fetch => 0, store => 0, value => $value }, $class; +} + +sub FETCH { + my ($self) = @_; + $self->{fetch}++; + return $self->{value}; +} + +sub STORE { + my ($self, $value) = @_; + $self->{store}++; + $self->{value} = $value; +} package foo; diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/call b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/call index 7c46cbb450a..35258549f82 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/call +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/call @@ -20,6 +20,7 @@ call_method load_module vload_module G_METHOD +G_RETHROW =implementation @@ -28,14 +29,29 @@ __UNDEFINED__ call_sv perl_call_sv __UNDEFINED__ call_pv perl_call_pv __UNDEFINED__ call_argv perl_call_argv __UNDEFINED__ call_method perl_call_method - __UNDEFINED__ eval_sv perl_eval_sv +#if { VERSION >= 5.3.98 } && { VERSION < 5.6.0 } +__UNDEFINED__ eval_pv perl_eval_pv +#endif /* Replace: 0 */ +#if { VERSION < 5.6.0 } +__UNDEFINED__ Perl_eval_sv perl_eval_sv +#if { VERSION >= 5.3.98 } +__UNDEFINED__ Perl_eval_pv perl_eval_pv +#endif +#endif + __UNDEFINED__ PERL_LOADMOD_DENY 0x1 __UNDEFINED__ PERL_LOADMOD_NOIMPORT 0x2 __UNDEFINED__ PERL_LOADMOD_IMPORT_OPS 0x4 +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define D_PPP_CROAK_IF_ERROR(cond) ({ SV *_errsv; ((cond) && (_errsv = ERRSV) && (SvROK(_errsv) || SvTRUE(_errsv)) && (croak_sv(_errsv), 1)); }) +#else +# define D_PPP_CROAK_IF_ERROR(cond) ((cond) && (SvROK(ERRSV) || SvTRUE(ERRSV)) && (croak_sv(ERRSV), 1)) +#endif + #ifndef G_METHOD # define G_METHOD 64 # ifdef call_sv @@ -50,13 +66,36 @@ __UNDEFINED__ PERL_LOADMOD_IMPORT_OPS 0x4 # endif #endif -/* Replace perl_eval_pv with eval_pv */ +#ifndef G_RETHROW +# define G_RETHROW 8192 +# ifdef eval_sv +# undef eval_sv +# endif +# if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define eval_sv(sv, flags) ({ I32 _flags = (flags); I32 _ret = Perl_eval_sv(aTHX_ sv, (_flags & ~G_RETHROW)); D_PPP_CROAK_IF_ERROR(_flags & G_RETHROW); _ret; }) +# else +# define eval_sv(sv, flags) ((PL_na = Perl_eval_sv(aTHX_ sv, ((flags) & ~G_RETHROW))), D_PPP_CROAK_IF_ERROR((flags) & G_RETHROW), (I32)PL_na) +# endif +#endif +/* Older Perl versions have broken croak_on_error=1 */ +#if { VERSION < 5.31.2 } +# ifdef eval_pv +# undef eval_pv +# if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define eval_pv(p, croak_on_error) ({ SV *_sv = Perl_eval_pv(aTHX_ p, 0); D_PPP_CROAK_IF_ERROR(croak_on_error); _sv; }) +# else +# define eval_pv(p, croak_on_error) ((PL_Sv = Perl_eval_pv(aTHX_ p, 0)), D_PPP_CROAK_IF_ERROR(croak_on_error), PL_Sv) +# endif +# endif +#endif + +/* This is backport for Perl 5.3.97d and older which do not provide perl_eval_pv */ #ifndef eval_pv #if { NEED eval_pv } SV* -eval_pv(char *p, I32 croak_on_error) +eval_pv(const char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); @@ -69,8 +108,7 @@ eval_pv(char *p, I32 croak_on_error) sv = POPs; PUTBACK; - if (croak_on_error && SvTRUEx(ERRSV)) - croak_sv(ERRSV); + D_PPP_CROAK_IF_ERROR(croak_on_error); return sv; } @@ -78,7 +116,7 @@ eval_pv(char *p, I32 croak_on_error) #endif #endif -#ifndef vload_module +#if ! defined(vload_module) && defined(start_subparse) #if { NEED vload_module } void @@ -121,16 +159,11 @@ vload_module(U32 flags, SV *name, SV *ver, va_list *args) COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; -#if { VERSION >= 5.004 } utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), - veop, modname, imop); -#elif { VERSION > 5.003 } - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), - veop, modname, imop); -#else - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), - modname, imop); +#if { VERSION > 5.003 } + veop, #endif + modname, imop); PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; @@ -184,6 +217,13 @@ G_DISCARD() OUTPUT: RETVAL +I32 +G_RETHROW() + CODE: + RETVAL = G_RETHROW; + OUTPUT: + RETVAL + void eval_sv(sv, flags) SV* sv @@ -304,13 +344,7 @@ load_module(flags, name, version, ...) Perl_load_module(aTHX_ flags, SvREFCNT_inc_simple(name), SvREFCNT_inc_simple(version), NULL); -=tests plan => 52 - -sub eq_array -{ - my($a, $b) = @_; - join(':', @$a) eq join(':', @$b); -} +=tests plan => 88 sub f { @@ -356,9 +390,69 @@ for $test ( ok(eq_array( [ &Devel::PPPort::call_sv_G_METHOD('meth', $flags, $obj, @$args) ], $expected)); }; -ok(&Devel::PPPort::eval_pv('f()', 0), 'y'); -ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y'); +is(&Devel::PPPort::eval_pv('f()', 0), 'y'); +is(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y'); -ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet"); +is(!defined $::{'less::'}, 1, "Hadn't loaded less yet"); Devel::PPPort::load_module(0, "less", undef); -ok(defined $::{'less::'}, 1, "Have now loaded less"); +is(defined $::{'less::'}, 1, "Have now loaded less"); + +ok(eval { Devel::PPPort::eval_pv('die', 0); 1 }); +ok(!eval { Devel::PPPort::eval_pv('die', 1); 1 }); +ok($@ =~ /^Died at \(eval [0-9]+\) line 1\.\n$/); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 0); 1 }); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('', 1); 1 }); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 0); 1 }); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"', 1); 1 }); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 0); 1 }); +ok(!eval { $@ = 'string1'; Devel::PPPort::eval_pv('$@ = "string2"; die "string3"', 1); 1 }); +ok($@ =~ /^string3 at \(eval [0-9]+\) line 1\.\n$/); +ok(!eval { Devel::PPPort::eval_pv('die False->new', 1); 1 }, 'check false value is rethrown'); + +if ("$]" >= '5.007003' or ("$]" >= '5.006001' and "$]" < '5.007')) { + my $hashref = { key => 'value' }; + is(eval { Devel::PPPort::eval_pv('die $hashref', 1); 1 }, undef, 'check plain hashref is rethrown'); + is(ref($@), 'HASH', 'check $@ is hashref') and + is($@->{key}, 'value', 'check $@ hashref has correct value'); + + my $false = False->new; + ok(!$false); + is(eval { Devel::PPPort::eval_pv('die $false', 1); 1 }, undef, 'check false objects are rethrown'); + is(ref($@), 'False', 'check that $@ contains False object'); + is("$@", "$false", 'check we got the expected object'); +} else { + skip 'skip: no support for references in $@', 7; +} + +ok(eval { Devel::PPPort::eval_sv('die', 0); 1 }); +ok(!eval { Devel::PPPort::eval_sv('die', &Devel::PPPort::G_RETHROW); 1 }); +ok($@ =~ /^Died at \(eval [0-9]+\) line 1\.\n$/); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('', 0); 1 }); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('', &Devel::PPPort::G_RETHROW); 1 }); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"', 0); 1 }); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"', &Devel::PPPort::G_RETHROW); 1 }); +ok(eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"; die "string3"', 0); 1 }); +ok(!eval { $@ = 'string1'; Devel::PPPort::eval_sv('$@ = "string2"; die "string3"', &Devel::PPPort::G_RETHROW); 1 }); +ok($@ =~ /^string3 at \(eval [0-9]+\) line 1\.\n$/); +ok(!eval { Devel::PPPort::eval_sv('die False->new', &Devel::PPPort::G_RETHROW); 1 }, 'check false value is rethrown'); + +if ("$]" >= '5.007003' or ("$]" >= '5.006001' and "$]" < '5.007')) { + my $hashref = { key => 'value' }; + is(eval { Devel::PPPort::eval_sv('die $hashref', &Devel::PPPort::G_RETHROW); 1 }, undef, 'check plain hashref is rethrown'); + is(ref($@), 'HASH', 'check $@ is hashref') and + is($@->{key}, 'value', 'check $@ hashref has correct value'); + + my $false = False->new; + ok(!$false); + is(eval { Devel::PPPort::eval_sv('die $false', &Devel::PPPort::G_RETHROW); 1 }, undef, 'check false objects are rethrown'); + is(ref($@), 'False', 'check that $@ contains False object'); + is("$@", "$false", 'check we got the expected object'); +} else { + skip 'skip: no support for references in $@', 7; +} + +{ + package False; + use overload bool => sub { 0 }, '""' => sub { 'Foo' }; + sub new { bless {}, shift } +} diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/cop b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/cop index 40d31267c27..c9a92ea3f70 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/cop +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/cop @@ -74,7 +74,7 @@ DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) # if { NEED caller_cx } const PERL_CONTEXT * -caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) +caller_cx(pTHX_ I32 level, const PERL_CONTEXT **dbcxp) { register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); register const PERL_CONTEXT *cx; @@ -93,8 +93,8 @@ caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) /* caller() should not report the automatic calls to &DB::sub */ if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) - count++; - if (!count--) + level++; + if (!level--) break; cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); } @@ -167,7 +167,7 @@ caller_cx(level) #endif /* 5.6.0 */ -=tests plan => 28 +=tests plan => 8 my $package; { @@ -175,7 +175,7 @@ my $package; $package = &Devel::PPPort::CopSTASHPV(); } print "# $package\n"; -ok($package, "MyPackage"); +is($package, "MyPackage"); my $file = &Devel::PPPort::CopFILE(); print "# $file\n"; @@ -183,10 +183,7 @@ ok($file =~ /cop/i); BEGIN { if ("$]" < 5.006000) { - # Skip - for (1..28) { - ok(1, 1); - } + skip("Perl version too early", 8); exit; } } @@ -223,9 +220,6 @@ for ( ) { my ($sub, $arg, @want) = @$_; my @got = $sub->($arg); - ok(@got, @want); - for (0..$#want) { - ok($got[$_], $want[$_]); - } + ok(eq_array(\@got, \@want)); } diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/exception b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/exception index 8dd21cc70fa..e4fa8cec5dd 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/exception +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/exception @@ -55,14 +55,14 @@ my $rv; $Devel::PPPort::exception_caught = undef; $rv = eval { &Devel::PPPort::exception(0) }; -ok($@, ''); +is($@, ''); ok(defined $rv); -ok($rv, 42); -ok($Devel::PPPort::exception_caught, 0); +is($rv, 42); +is($Devel::PPPort::exception_caught, 0); $Devel::PPPort::exception_caught = undef; $rv = eval { &Devel::PPPort::exception(1) }; -ok($@, "boo\n"); +is($@, "boo\n"); ok(not defined $rv); -ok($Devel::PPPort::exception_caught, 1); +is($Devel::PPPort::exception_caught, 1); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/format b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/format index 03c632d3baa..094076febe0 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/format +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/format @@ -55,9 +55,64 @@ croak_NVgf(num) PPCODE: Perl_croak(aTHX_ "%.20" NVgf "\n", num); -=tests plan => 1 +#if { VERSION >= 5.004 } + +SV * +sprintf_iv(iv) + IV iv +CODE: + RETVAL = newSVpvf("XX_%" IVdf "_XX", iv); +OUTPUT: + RETVAL + +SV * +sprintf_uv(uv) + UV uv +CODE: + RETVAL = newSVpvf("XX_%" UVuf "_XX", uv); +OUTPUT: + RETVAL + +SV * +sprintf_ivmax() +CODE: + RETVAL = newSVpvf("%" IVdf, IV_MAX); +OUTPUT: + RETVAL + +SV * +sprintf_uvmax() +CODE: + RETVAL = newSVpvf("%" UVuf, UV_MAX); +OUTPUT: + RETVAL + +#endif + +=tests plan => 5 + +use Config; + +if ("$]" < '5.004') { + skip 'skip: No newSVpvf support', 5; + exit; +} my $num = 1.12345678901234567890; eval { Devel::PPPort::croak_NVgf($num) }; ok($@ =~ /^1.1234567890/); + +is(Devel::PPPort::sprintf_iv(-8), 'XX_-8_XX'); +is(Devel::PPPort::sprintf_uv(15), 'XX_15_XX'); + +my $ivsize = $Config::Config{ivsize}; +if ($ivsize && ($ivsize == 4 || $ivsize == 8)) { + my $ivmax = ($ivsize == 4) ? '2147483647' : '9223372036854775807'; + my $uvmax = ($ivsize == 4) ? '4294967295' : '18446744073709551615'; + is(Devel::PPPort::sprintf_ivmax(), $ivmax); + is(Devel::PPPort::sprintf_uvmax(), $uvmax); +} +else { + skip 'skip: unknown ivsize', 2; +} diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/grok b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/grok index 9ca6627f1af..df73008d0b8 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/grok +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/grok @@ -657,14 +657,14 @@ Perl_grok_oct(string) =tests plan => 10 -ok(&Devel::PPPort::grok_number("42"), 42); +is(&Devel::PPPort::grok_number("42"), 42); ok(!defined(&Devel::PPPort::grok_number("A"))); -ok(&Devel::PPPort::grok_bin("10000001"), 129); -ok(&Devel::PPPort::grok_hex("deadbeef"), 0xdeadbeef); -ok(&Devel::PPPort::grok_oct("377"), 255); +is(&Devel::PPPort::grok_bin("10000001"), 129); +is(&Devel::PPPort::grok_hex("deadbeef"), 0xdeadbeef); +is(&Devel::PPPort::grok_oct("377"), 255); -ok(&Devel::PPPort::Perl_grok_number("42"), 42); +is(&Devel::PPPort::Perl_grok_number("42"), 42); ok(!defined(&Devel::PPPort::Perl_grok_number("A"))); -ok(&Devel::PPPort::Perl_grok_bin("10000001"), 129); -ok(&Devel::PPPort::Perl_grok_hex("deadbeef"), 0xdeadbeef); -ok(&Devel::PPPort::Perl_grok_oct("377"), 255); +is(&Devel::PPPort::Perl_grok_bin("10000001"), 129); +is(&Devel::PPPort::Perl_grok_hex("deadbeef"), 0xdeadbeef); +is(&Devel::PPPort::Perl_grok_oct("377"), 255); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/gv b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/gv index d2f526f416f..6f7119a0924 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/gv +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/gv @@ -11,24 +11,23 @@ =provides +GV_NOADD_MASK gv_fetchpvn_flags +GvSVn +isGV_with_GP +gv_fetchsv +get_cvn_flags +gv_init_pvn =implementation -#ifndef gv_fetchpvn_flags -#if { NEED gv_fetchpvn_flags } - -GV* -gv_fetchpvn_flags(pTHX_ const char* name, STRLEN len, int flags, int types) { - char *namepv = savepvn(name, len); - GV* stash = gv_fetchpv(namepv, TRUE, SVt_PVHV); - Safefree(namepv); - return stash; -} - -#endif +#if { VERSION >= 5.9.2 } && { VERSION <= 5.9.3 } /* 5.9.2 and 5.9.3 ignore the length param */ +#undef gv_fetchpvn_flags #endif +__UNDEFINED__ GV_NOADD_MASK 0xE0 +__UNDEFINED__ gv_fetchpvn_flags(name, len, flags, sv_type) gv_fetchpv(SvPVX(sv_2mortal(newSVpvn((name), (len)))), ((flags) & GV_NOADD_MASK) ? FALSE : TRUE, (I32)(sv_type)) + __UNDEFINED__ GvSVn(gv) GvSV(gv) __UNDEFINED__ isGV_with_GP(gv) isGV(gv) __UNDEFINED__ gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) @@ -36,10 +35,6 @@ __UNDEFINED__ gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), fl __UNDEFINED__ get_cvn_flags(name, namelen, flags) get_cv(name, flags) __UNDEFINED__ gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE) -=xsinit - -#define NEED_gv_fetchpvn_flags - =xsubs int @@ -92,11 +87,7 @@ get_cvn_flags() SV* gv_fetchpvn_flags() CODE: -#if { VERSION < 5.9.2 } || { VERSION > 5.9.3 } /* 5.9.2 and 5.9.3 ignore the length param */ RETVAL = newRV_inc((SV*)gv_fetchpvn_flags("Devel::PPPort::VERSIONFAKE", sizeof("Devel::PPPort::VERSIONFAKE")-5, 0, SVt_PV)); -#else - RETVAL = newRV_inc((SV*)gv_fetchpvn_flags("Devel::PPPort::VERSION", 0, 0, SVt_PV)); -#endif OUTPUT: RETVAL @@ -127,15 +118,15 @@ gv_init_type(namesv, multi, flags) =tests plan => 7 -ok(Devel::PPPort::GvSVn(), 1); +is(Devel::PPPort::GvSVn(), 1); -ok(Devel::PPPort::isGV_with_GP(), 2); +is(Devel::PPPort::isGV_with_GP(), 2); -ok(Devel::PPPort::get_cvn_flags(), 3); +is(Devel::PPPort::get_cvn_flags(), 3); -ok(Devel::PPPort::gv_fetchpvn_flags(), \*Devel::PPPort::VERSION); +is(Devel::PPPort::gv_fetchpvn_flags(), \*Devel::PPPort::VERSION); -ok(Devel::PPPort::gv_fetchsv("Devel::PPPort::VERSION"), \*Devel::PPPort::VERSION); +is(Devel::PPPort::gv_fetchsv("Devel::PPPort::VERSION"), \*Devel::PPPort::VERSION); -ok(Devel::PPPort::gv_init_type("sanity_check", 0, 0), "*main::sanity_check"); +is(Devel::PPPort::gv_init_type("sanity_check", 0, 0), "*main::sanity_check"); ok($::{sanity_check}); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/inctools b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/inctools new file mode 100644 index 00000000000..ba181fa6e7b --- /dev/null +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/inctools @@ -0,0 +1,127 @@ +# These are tools that must be included in ppport.h. It doesn't work if given +# a .pl suffix + +sub format_version +{ + # Given an input version that is acceptable to parse_version(), return a + # string of the standard representation of it. + + my($r,$v,$s) = parse_version(shift); + + if ($r < 5 || ($r == 5 && $v < 6)) { + my $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub parse_version +{ + # Returns a triplet, (5, major, minor) from the input, treated as a string, + # which can be in any of several typical formats. + + my $ver = shift; + $ver = "" unless defined $ver; + + my($r,$v,$s); + + if ( ($r, $v, $s) = $ver =~ /^(5)(\d{3})(\d{3})$/ # 5029010, from the file + # names in our + # parts/base/ and + # parts/todo directories + or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d+)\.(\d+)$/ # 5.25.7 + or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d{3})(\d{3})$/ # 5.025008, from the + # output of $] + or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d{1,3})()$/ # 5.24, 5.004 + or ($r, $v, $s) = $ver =~ /^(\d+)\.(00[1-5])_?(\d{2})$/ # 5.003_07 + ) { + + $s = 0 unless $s; + + die "Only Perl 5 is supported '$ver'\n" if $r != 5; + die "Invalid version number: $ver\n" if $v >= 1000 || $s >= 1000; + return (5, 0 + $v, 0 + $s); + } + + # For some safety, don't assume something is a version number if it has a + # literal dot as one of the three characters. This will have to be fixed + # when we reach 5.46 + if ($ver !~ /\./ && (($r, $v, $s) = $ver =~ /^(.)(.)(.)$/)) # vstring 5.25.7 + { + $r = ord $r; + $v = ord $v; + $s = ord $s; + + die "Only Perl 5 is supported '$ver'\n" if $r != 5; + return (5, $v, $s); + } + + my $mesg = ""; + $mesg = ". (In 5.00x_yz, x must be 1-5.)" if $ver =~ /_/; + die "Invalid version number format: '$ver'$mesg\n"; +} + +sub int_parse_version +{ + # Returns integer 7 digit human-readable version, suitable for use in file + # names in parts/todo parts/base. + + return 0 + join "", map { sprintf("%03d", $_) } parse_version(shift); +} + +sub ivers # Shorter name for int_parse_version +{ + return int_parse_version(shift); +} + +sub format_version_line +{ + # Returns a floating point representation of the input version + + my $version = int_parse_version(shift); + $version =~ s/^5\B/5./; + return $version; +} + +sub dictionary_order($$) # Sort caselessly, ignoring punct +{ + my ($lc_a, $lc_b); + my ($squeezed_a, $squeezed_b); + my ($valid_a, $valid_b); # Meaning valid for all releases + + # On early perls, the implicit pass by reference doesn't work, so we have + # to use the globals to initialize. + if ("$]" < "5.006" ) { + $valid_a = $a; $valid_b = $b; + } + else { + ($valid_a, $valid_b) = @_; + } + + $lc_a = lc $valid_a; + $lc_b = lc $valid_b; + + $squeezed_a = $lc_a; + $squeezed_a =~ s/[\W_]//g; # No punct, including no underscore + $squeezed_b = $lc_b; + $squeezed_b =~ s/[\W_]//g; + + return( $squeezed_a cmp $squeezed_b + or $lc_a cmp $lc_b + or $valid_a cmp $valid_b); +} + +sub sort_api_lines # Sort lines of the form flags|return|name|args... + # by 'name' +{ + $a =~ / ^ [^|]* \| [^|]* \| (\w+) /x; # 3rd field '|' is sep + my $a_name = $1; + $b =~ / ^ [^|]* \| [^|]* \| (\w+) /x; + my $b_name = $1; + return dictionary_order($a_name, $b_name); +} + +1; diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/locale b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/locale new file mode 100644 index 00000000000..699adfdc39c --- /dev/null +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/locale @@ -0,0 +1,58 @@ +=provides + +__UNDEFINED__ + +=implementation + + +/* If this doesn't exist, it's not needed, so noop */ +__UNDEFINED__ switch_to_global_locale() + +/* Originally, this didn't return a value, but in perls like that, the value + * should always be TRUE. Add a return to Perl_sync_locale() when it's + * available. And actually do a sync when its not, if locales are available on + * this system. */ +#ifdef sync_locale +# if { VERSION < 5.27.9 } +# if { VERSION >= 5.21.3 } +# undef sync_locale +# define sync_locale() (Perl_sync_locale(aTHX), 1) +# elif defined(sync_locale) /* These should be the 5.20 maints*/ +# undef sync_locale /* Just copy their defn and return 1 */ +# define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), \ + new_collate(setlocale(LC_COLLATE, NULL)), \ + set_numeric_local(), \ + new_numeric(setlocale(LC_NUMERIC, NULL)), \ + 1) +# elif defined(new_ctype) && defined(LC_CTYPE) +# define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), 1) +# endif +# endif +#endif + +__UNDEFINED__ sync_locale() 1 + +=xsubs + +bool +sync_locale() + CODE: + RETVAL = sync_locale(); + OUTPUT: + RETVAL + + +=tests plan => 1 + +use Config; + + # We don't know for sure that we are in the global locale for testing. But + # if this is unthreaded, it almost certainly is. But Configure can be called + # to force POSIX locales on unthreaded systems. If this becomes a problem + # this check could be beefed up. + if ($Config{usethreads}) { + ok(1); +} +else { + ok(&Devel::PPPort::sync_locale()); +} diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/mPUSH b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/mPUSH index a17972c7082..d1b6d3e6a2a 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/mPUSH +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/mPUSH @@ -118,14 +118,14 @@ mXPUSHu() =tests plan => 10 -ok(join(':', &Devel::PPPort::mPUSHs()), "foo:bar:42"); -ok(join(':', &Devel::PPPort::mPUSHp()), "one:two:three"); -ok(join(':', &Devel::PPPort::mPUSHn()), "0.5:-0.25:0.125"); -ok(join(':', &Devel::PPPort::mPUSHi()), "-1:2:-3"); -ok(join(':', &Devel::PPPort::mPUSHu()), "1:2:3"); - -ok(join(':', &Devel::PPPort::mXPUSHs()), "foo:bar:42"); -ok(join(':', &Devel::PPPort::mXPUSHp()), "one:two:three"); -ok(join(':', &Devel::PPPort::mXPUSHn()), "0.5:-0.25:0.125"); -ok(join(':', &Devel::PPPort::mXPUSHi()), "-1:2:-3"); -ok(join(':', &Devel::PPPort::mXPUSHu()), "1:2:3"); +is(join(':', &Devel::PPPort::mPUSHs()), "foo:bar:42"); +is(join(':', &Devel::PPPort::mPUSHp()), "one:two:three"); +is(join(':', &Devel::PPPort::mPUSHn()), "0.5:-0.25:0.125"); +is(join(':', &Devel::PPPort::mPUSHi()), "-1:2:-3"); +is(join(':', &Devel::PPPort::mPUSHu()), "1:2:3"); + +is(join(':', &Devel::PPPort::mXPUSHs()), "foo:bar:42"); +is(join(':', &Devel::PPPort::mXPUSHp()), "one:two:three"); +is(join(':', &Devel::PPPort::mXPUSHn()), "0.5:-0.25:0.125"); +is(join(':', &Devel::PPPort::mXPUSHi()), "-1:2:-3"); +is(join(':', &Devel::PPPort::mXPUSHu()), "1:2:3"); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/magic b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/magic index cecf3ca63c1..3d3b740fc78 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/magic +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/magic @@ -18,6 +18,11 @@ __UNDEFINED__ /sv_\w+_mg/ sv_magic_portable +SvIV_nomg +SvUV_nomg +SvNV_nomg +SvTRUE_nomg + =implementation __UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END @@ -27,8 +32,22 @@ __UNDEFINED__ sv_catpvn_nomg sv_catpvn __UNDEFINED__ sv_catsv_nomg sv_catsv __UNDEFINED__ sv_setsv_nomg sv_setsv __UNDEFINED__ sv_pvn_nomg sv_pvn -__UNDEFINED__ SvIV_nomg SvIV -__UNDEFINED__ SvUV_nomg SvUV + +#ifdef SVf_IVisUV +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ({ SV *_sviv = sv_mortalcopy_flags((sv), SV_NOSTEAL); IV _iv = SvIV(_sviv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_sviv) & SVf_IVisUV); _iv; })) +__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : ({ SV *_svuv = sv_mortalcopy_flags((sv), SV_NOSTEAL); UV _uv = SvUV(_svuv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_svuv) & SVf_IVisUV); _uv; })) +#else +__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvIVX(PL_Sv) = SvIV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvIVX(PL_Sv))) +__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvUVX(PL_Sv) = SvUV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvUVX(PL_Sv))) +#endif +#else +__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : SvIVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) +__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : SvUVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) +#endif + +__UNDEFINED__ SvNV_nomg(sv) (!SvGMAGICAL((sv)) ? SvNV((sv)) : SvNVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) +__UNDEFINED__ SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ @@ -167,7 +186,7 @@ __UNDEFINED__ SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring #if { NEED mg_findext } MAGIC * -mg_findext(SV * sv, int type, const MGVTBL *vtbl) { +mg_findext(const SV * sv, int type, const MGVTBL *vtbl) { if (sv) { MAGIC *mg; @@ -481,31 +500,110 @@ sv_magic_portable(sv) OUTPUT: RETVAL -=tests plan => 23 +UV +above_IV_MAX() + CODE: + RETVAL = (UV)IV_MAX+100; + OUTPUT: + RETVAL + +#ifdef SVf_IVisUV + +U32 +SVf_IVisUV(sv) + SV *sv + CODE: + RETVAL = (SvFLAGS(sv) & SVf_IVisUV); + OUTPUT: + RETVAL + +#endif + +#ifdef SvIV_nomg + +IV +magic_SvIV_nomg(sv) + SV *sv + CODE: + RETVAL = SvIV_nomg(sv); + OUTPUT: + RETVAL + +#endif + +#ifdef SvUV_nomg + +UV +magic_SvUV_nomg(sv) + SV *sv + CODE: + RETVAL = SvUV_nomg(sv); + OUTPUT: + RETVAL + +#endif + +#ifdef SvNV_nomg + +NV +magic_SvNV_nomg(sv) + SV *sv + CODE: + RETVAL = SvNV_nomg(sv); + OUTPUT: + RETVAL + +#endif + +#ifdef SvTRUE_nomg + +bool +magic_SvTRUE_nomg(sv) + SV *sv + CODE: + RETVAL = SvTRUE_nomg(sv); + OUTPUT: + RETVAL + +#endif + +#ifdef SvPV_nomg_nolen + +char * +magic_SvPV_nomg_nolen(sv) + SV *sv + CODE: + RETVAL = SvPV_nomg_nolen(sv); + OUTPUT: + RETVAL + +#endif + +=tests plan => 63 # Find proper magic ok(my $obj1 = Devel::PPPort->new_with_mg()); -ok(Devel::PPPort::as_string($obj1), 'hello'); +is(Devel::PPPort::as_string($obj1), 'hello'); # Find with no magic my $obj = bless {}, 'Fake::Class'; -ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle."); +is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle."); # Find with other magic (not the magic we are looking for) ok($obj = Devel::PPPort->new_with_other_mg()); -ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle."); +is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle."); # Okay, attempt to remove magic that isn't there Devel::PPPort::remove_other_magic($obj1); -ok(Devel::PPPort::as_string($obj1), 'hello'); +is(Devel::PPPort::as_string($obj1), 'hello'); # Remove magic that IS there Devel::PPPort::remove_null_magic($obj1); -ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle."); +is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle."); # Removing when no magic present Devel::PPPort::remove_null_magic($obj1); -ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle."); +is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle."); use Tie::Hash; my %h; @@ -514,34 +612,34 @@ $h{foo} = 'foo'; $h{bar} = ''; &Devel::PPPort::sv_catpv_mg($h{foo}, 'bar'); -ok($h{foo}, 'foobar'); +is($h{foo}, 'foobar'); &Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz'); -ok($h{bar}, 'baz'); +is($h{bar}, 'baz'); &Devel::PPPort::sv_catsv_mg($h{foo}, '42'); -ok($h{foo}, 'foobar42'); +is($h{foo}, 'foobar42'); &Devel::PPPort::sv_setiv_mg($h{bar}, 42); -ok($h{bar}, 42); +is($h{bar}, 42); &Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159); ok(abs($h{PI} - 3.14159) < 0.01); &Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx'); -ok($h{mhx}, 'mhx'); +is($h{mhx}, 'mhx'); &Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus'); -ok($h{mhx}, 'Marcus'); +is($h{mhx}, 'Marcus'); &Devel::PPPort::sv_setsv_mg($h{sv}, 'SV'); -ok($h{sv}, 'SV'); +is($h{sv}, 'SV'); &Devel::PPPort::sv_setuv_mg($h{sv}, 4711); -ok($h{sv}, 4711); +is($h{sv}, 4711); &Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl'); -ok($h{sv}, 'Perl'); +is($h{sv}, 'Perl'); # v1 is treated as a bareword in older perls... my $ver = do { local $SIG{'__WARN__'} = sub {}; eval qq[v1.2.0] }; @@ -552,3 +650,108 @@ ok(!Devel::PPPort::SvVSTRING_mg(4711)); my $foo = 'bar'; ok(Devel::PPPort::sv_magic_portable($foo)); ok($foo eq 'bar'); + + tie my $scalar, 'TieScalarCounter', 10; + my $fetch = $scalar; + + is tied($scalar)->{fetch}, 1; + is tied($scalar)->{store}, 0; + is Devel::PPPort::magic_SvIV_nomg($scalar), 10; + is tied($scalar)->{fetch}, 1; + is tied($scalar)->{store}, 0; + is Devel::PPPort::magic_SvUV_nomg($scalar), 10; + is tied($scalar)->{fetch}, 1; + is tied($scalar)->{store}, 0; + is Devel::PPPort::magic_SvNV_nomg($scalar), 10; + is tied($scalar)->{fetch}, 1; + is tied($scalar)->{store}, 0; + is Devel::PPPort::magic_SvPV_nomg_nolen($scalar), 10; + is tied($scalar)->{fetch}, 1; + is tied($scalar)->{store}, 0; + ok Devel::PPPort::magic_SvTRUE_nomg($scalar); + is tied($scalar)->{fetch}, 1; + is tied($scalar)->{store}, 0; + + my $object = OverloadedObject->new('string', 5.5, 0); + + is Devel::PPPort::magic_SvIV_nomg($object), 5; + is Devel::PPPort::magic_SvUV_nomg($object), 5; + is Devel::PPPort::magic_SvNV_nomg($object), 5.5; + is Devel::PPPort::magic_SvPV_nomg_nolen($object), 'string'; + ok !Devel::PPPort::magic_SvTRUE_nomg($object); + +tie my $negative, 'TieScalarCounter', -1; +$fetch = $negative; + +is tied($negative)->{fetch}, 1; +is tied($negative)->{store}, 0; +is Devel::PPPort::magic_SvIV_nomg($negative), -1; +if (ivers($]) >= ivers(5.6)) { + ok !Devel::PPPort::SVf_IVisUV($negative); +} else { + skip 'SVf_IVisUV is unsupported', 1; +} +is tied($negative)->{fetch}, 1; +is tied($negative)->{store}, 0; +Devel::PPPort::magic_SvUV_nomg($negative); +if (ivers($]) >= ivers(5.6)) { + ok !Devel::PPPort::SVf_IVisUV($negative); +} else { + skip 'SVf_IVisUV is unsupported', 1; +} +is tied($negative)->{fetch}, 1; +is tied($negative)->{store}, 0; + +tie my $big, 'TieScalarCounter', Devel::PPPort::above_IV_MAX(); +$fetch = $big; + +is tied($big)->{fetch}, 1; +is tied($big)->{store}, 0; +Devel::PPPort::magic_SvIV_nomg($big); +if (ivers($]) >= ivers(5.6)) { + ok Devel::PPPort::SVf_IVisUV($big); +} else { + skip 'SVf_IVisUV is unsupported', 1; +} +is tied($big)->{fetch}, 1; +is tied($big)->{store}, 0; +is Devel::PPPort::magic_SvUV_nomg($big), Devel::PPPort::above_IV_MAX(); +if (ivers($]) >= ivers(5.6)) { + ok Devel::PPPort::SVf_IVisUV($big); +} else { + skip 'SVf_IVisUV is unsupported', 1; +} +is tied($big)->{fetch}, 1; +is tied($big)->{store}, 0; + +package TieScalarCounter; + +sub TIESCALAR { + my ($class, $value) = @_; + return bless { fetch => 0, store => 0, value => $value }, $class; +} + +sub FETCH { + my ($self) = @_; + $self->{fetch}++; + return $self->{value}; +} + +sub STORE { + my ($self, $value) = @_; + $self->{store}++; + $self->{value} = $value; +} + +package OverloadedObject; + +sub new { + my ($class, $str, $num, $bool) = @_; + return bless { str => $str, num => $num, bool => $bool }, $class; +} + +use overload + '""' => sub { $_[0]->{str} }, + '0+' => sub { $_[0]->{num} }, + 'bool' => sub { $_[0]->{bool} }, + ; diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/memory b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/memory index 9a5425e39ed..aa102e22e6d 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/memory +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/memory @@ -27,6 +27,8 @@ __UNDEFINED__ memEQs(s1, l, s2) \ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) __UNDEFINED__ memNEs(s1, l, s2) !memEQs(s1, l, s2) +__UNDEFINED__ memCHRs(s, c) ((const char *) memchr("" s "" , c, sizeof(s)-1)) + __UNDEFINED__ MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) __UNDEFINED__ CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #ifdef HAS_MEMSET @@ -82,4 +84,4 @@ checkmem() =tests plan => 1 -ok(Devel::PPPort::checkmem(), 6); +is(Devel::PPPort::checkmem(), 6); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/mess b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/mess index e9af1740aba..14c7def17a9 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/mess +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/mess @@ -28,8 +28,6 @@ Perl_croak_no_modify croak_memory_wrap croak_xs_usage -PERL_ARGS_ASSERT_CROAK_XS_USAGE - =dontwarn NEED_mess @@ -50,24 +48,25 @@ NEED_vmess #ifndef croak_sv #if { VERSION >= 5.7.3 } || ( { VERSION >= 5.6.1 } && { VERSION < 5.7.0 } ) # if ( { VERSION >= 5.8.0 } && { VERSION < 5.8.9 } ) || ( { VERSION >= 5.9.0 } && { VERSION < 5.10.1 } ) -# define D_PPP_FIX_UTF8_ERRSV(errsv, sv) \ - STMT_START { \ - if (sv != errsv) \ - SvFLAGS(errsv) = (SvFLAGS(errsv) & ~SVf_UTF8) | \ - (SvFLAGS(sv) & SVf_UTF8); \ +# define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) \ + STMT_START { \ + SV *_errsv = ERRSV; \ + SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) | \ + (SvFLAGS(sv) & SVf_UTF8); \ } STMT_END # else -# define D_PPP_FIX_UTF8_ERRSV(errsv, sv) STMT_START {} STMT_END +# define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END # endif -# define croak_sv(sv) \ - STMT_START { \ - if (SvROK(sv)) { \ - sv_setsv(ERRSV, sv); \ - croak(NULL); \ - } else { \ - D_PPP_FIX_UTF8_ERRSV(ERRSV, sv); \ - croak("%" SVf, SVfARG(sv)); \ - } \ +# define croak_sv(sv) \ + STMT_START { \ + SV *_sv = (sv); \ + if (SvROK(_sv)) { \ + sv_setsv(ERRSV, _sv); \ + croak(NULL); \ + } else { \ + D_PPP_FIX_UTF8_ERRSV_FOR_SV(_sv); \ + croak("%" SVf, SVfARG(_sv)); \ + } \ } STMT_END #elif { VERSION >= 5.4.0 } # define croak_sv(sv) croak("%" SVf, SVfARG(sv)) @@ -79,9 +78,9 @@ NEED_vmess #ifndef die_sv #if { NEED die_sv } OP * -die_sv(pTHX_ SV *sv) +die_sv(pTHX_ SV *baseex) { - croak_sv(sv); + croak_sv(baseex); return (OP *)NULL; } #endif @@ -95,22 +94,23 @@ die_sv(pTHX_ SV *sv) #endif #endif -#ifndef vmess -#if { NEED vmess } +#if ! defined vmess && { VERSION >= 5.4.0 } +# if { NEED vmess } + SV* vmess(pTHX_ const char* pat, va_list* args) { mess(pat, args); return PL_mess_sv; } -#endif +# endif #endif -#if { VERSION < 5.6.0 } +#if { VERSION < 5.6.0 } && { VERSION >= 5.4.0 } #undef mess #endif -#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) +#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && { VERSION >= 5.4.0 } #if { NEED mess_nocontext } SV* mess_nocontext(const char* pat, ...) @@ -146,7 +146,7 @@ mess(pTHX_ const char* pat, ...) #endif #endif -#ifndef mess_sv +#if ! defined mess_sv && { VERSION >= 5.4.0 } #if { NEED mess_sv } SV * mess_sv(pTHX_ SV *basemsg, bool consume) @@ -201,9 +201,6 @@ mess_sv(pTHX_ SV *basemsg, bool consume) #ifndef croak_xs_usage #if { NEED croak_xs_usage } -#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE -#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) -#endif void croak_xs_usage(const CV *const cv, const char *const params) @@ -211,7 +208,11 @@ croak_xs_usage(const CV *const cv, const char *const params) dTHX; const GV *const gv = CvGV(cv); +#ifdef PERL_ARGS_ASSERT_CROAK_XS_USAGE PERL_ARGS_ASSERT_CROAK_XS_USAGE; +#else + assert(cv); assert(params); +#endif if (gv) { const char *const gvname = GvNAME(gv); @@ -236,6 +237,12 @@ croak_xs_usage(const CV *const cv, const char *const params) #define NEED_mess_sv #define NEED_croak_xs_usage +=xsmisc + +static IV counter; +static void reset_counter(void) { counter = 0; } +static void inc_counter(void) { counter++; } + =xsubs void @@ -245,6 +252,25 @@ CODE: croak_sv(sv); void +croak_sv_errsv() +CODE: + croak_sv(ERRSV); + +void +croak_sv_with_counter(sv) + SV *sv +CODE: + reset_counter(); + croak_sv((inc_counter(), sv)); + +IV +get_counter() +CODE: + RETVAL = counter; +OUTPUT: + RETVAL + +void die_sv(sv) SV *sv CODE: @@ -256,6 +282,8 @@ warn_sv(sv) CODE: warn_sv(sv); +#if { VERSION >= 5.4.0 } + SV * mess_sv(sv, consume) SV *sv @@ -265,6 +293,8 @@ CODE: OUTPUT: RETVAL +#endif + void croak_no_modify() CODE: @@ -281,9 +311,9 @@ croak_xs_usage(params) CODE: croak_xs_usage(cv, params); -=tests plan => 93 +=tests plan => 102 -BEGIN { if ($] lt '5.006') { $^W = 0; } } +BEGIN { if ("$]" < '5.006') { $^W = 0; } } my $warn; my $die; @@ -297,13 +327,13 @@ my $obj = bless {}, 'Package'; undef $die; ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") }; -ok $@, "\xE1\n"; -ok $die, "\xE1\n"; +is $@, "\xE1\n"; +is $die, "\xE1\n"; undef $die; ok !defined eval { Devel::PPPort::croak_sv(10) }; -ok $@ =~ /^10 at $0 line /; -ok $die =~ /^10 at $0 line /; +ok $@ =~ /^10 at \Q$0\E line /; +ok $die =~ /^10 at \Q$0\E line /; undef $die; $@ = 'should not be visible (1)'; @@ -311,8 +341,8 @@ ok !defined eval { $@ = 'should not be visible (2)'; Devel::PPPort::croak_sv(''); }; -ok $@ =~ /^ at $0 line /; -ok $die =~ /^ at $0 line /; +ok $@ =~ /^ at \Q$0\E line /; +ok $die =~ /^ at \Q$0\E line /; undef $die; $@ = 'should not be visible'; @@ -320,8 +350,8 @@ ok !defined eval { $@ = 'this must be visible'; Devel::PPPort::croak_sv($@) }; -ok $@ =~ /^this must be visible at $0 line /; -ok $die =~ /^this must be visible at $0 line /; +ok $@ =~ /^this must be visible at \Q$0\E line /; +ok $die =~ /^this must be visible at \Q$0\E line /; undef $die; $@ = 'should not be visible'; @@ -329,125 +359,159 @@ ok !defined eval { $@ = "this must be visible\n"; Devel::PPPort::croak_sv($@) }; -ok $@, "this must be visible\n"; -ok $die, "this must be visible\n"; +is $@, "this must be visible\n"; +is $die, "this must be visible\n"; + +undef $die; +$@ = 'should not be visible'; +ok !defined eval { + $@ = 'this must be visible'; + Devel::PPPort::croak_sv_errsv() +}; +ok $@ =~ /^this must be visible at \Q$0\E line /; +ok $die =~ /^this must be visible at \Q$0\E line /; + +undef $die; +$@ = 'should not be visible'; +ok !defined eval { + $@ = "this must be visible\n"; + Devel::PPPort::croak_sv_errsv() +}; +is $@, "this must be visible\n"; +is $die, "this must be visible\n"; + +undef $die; +ok !defined eval { Devel::PPPort::croak_sv_with_counter("message\n") }; +is $@, "message\n"; +is Devel::PPPort::get_counter(), 1; undef $die; ok !defined eval { Devel::PPPort::croak_sv('') }; -ok $@ =~ /^ at $0 line /; -ok $die =~ /^ at $0 line /; +ok $@ =~ /^ at \Q$0\E line /; +ok $die =~ /^ at \Q$0\E line /; undef $die; ok !defined eval { Devel::PPPort::croak_sv("\xE1") }; -ok $@ =~ /^\xE1 at $0 line /; -ok $die =~ /^\xE1 at $0 line /; +ok $@ =~ /^\xE1 at \Q$0\E line /; +ok $die =~ /^\xE1 at \Q$0\E line /; undef $die; ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") }; -ok $@ =~ /^\xC3\xA1 at $0 line /; -ok $die =~ /^\xC3\xA1 at $0 line /; +ok $@ =~ /^\xC3\xA1 at \Q$0\E line /; +ok $die =~ /^\xC3\xA1 at \Q$0\E line /; undef $warn; Devel::PPPort::warn_sv("\xE1\n"); -ok $warn, "\xE1\n"; +is $warn, "\xE1\n"; undef $warn; Devel::PPPort::warn_sv(10); -ok $warn =~ /^10 at $0 line /; +ok $warn =~ /^10 at \Q$0\E line /; undef $warn; Devel::PPPort::warn_sv(''); -ok $warn =~ /^ at $0 line /; +ok $warn =~ /^ at \Q$0\E line /; undef $warn; Devel::PPPort::warn_sv("\xE1"); -ok $warn =~ /^\xE1 at $0 line /; +ok $warn =~ /^\xE1 at \Q$0\E line /; undef $warn; Devel::PPPort::warn_sv("\xC3\xA1"); -ok $warn =~ /^\xC3\xA1 at $0 line /; +ok $warn =~ /^\xC3\xA1 at \Q$0\E line /; -ok Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n"; -ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n"; +is Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n"; +is Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n"; -ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at $0 line /; -ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at $0 line /; +ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at \Q$0\E line /; +ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at \Q$0\E line /; -ok Devel::PPPort::mess_sv('', 0) =~ /^ at $0 line /; -ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at $0 line /; +ok Devel::PPPort::mess_sv('', 0) =~ /^ at \Q$0\E line /; +ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at \Q$0\E line /; -ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at $0 line /; -ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at $0 line /; +ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at \Q$0\E line /; +ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at \Q$0\E line /; -ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at $0 line /; -ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at $0 line /; +ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at \Q$0\E line /; +ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at \Q$0\E line /; -if ($] ge '5.006') { - BEGIN { if ($] ge '5.006' && $] lt '5.008') { require utf8; utf8->import(); } } +if ("$]" >= '5.006') { + BEGIN { if ("$]" >= '5.006' && "$]" < '5.008') { require utf8; utf8->import(); } } undef $die; ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") }; - ok $@, "\x{100}\n"; - if ($] ne '5.008') { - ok $die, "\x{100}\n"; + if ("$]" < '5.007001' || "$]" > '5.007003') { + is $@, "\x{100}\n"; + } else { + skip 'skip: broken utf8 support in die hook', 1; + } + if ("$]" < '5.007001' || "$]" > '5.008') { + is $die, "\x{100}\n"; } else { - skip 'skip: broken utf8 support in die hook', 0; + skip 'skip: broken utf8 support in die hook', 1; } undef $die; ok !defined eval { Devel::PPPort::croak_sv("\x{100}") }; - ok $@ =~ /^\x{100} at $0 line /; - if ($] ne '5.008') { - ok $die =~ /^\x{100} at $0 line /; + if ("$]" < '5.007001' || "$]" > '5.007003') { + ok $@ =~ /^\x{100} at \Q$0\E line /; } else { - skip 'skip: broken utf8 support in die hook', 0; + skip 'skip: broken utf8 support in die hook', 1; + } + if ("$]" < '5.007001' || "$]" > '5.008') { + ok $die =~ /^\x{100} at \Q$0\E line /; + } else { + skip 'skip: broken utf8 support in die hook', 1; } - if ($] ne '5.008') { + if ("$]" < '5.007001' || "$]" > '5.008') { undef $warn; Devel::PPPort::warn_sv("\x{100}\n"); - ok $warn, "\x{100}\n"; + is $warn, "\x{100}\n"; undef $warn; Devel::PPPort::warn_sv("\x{100}"); - ok (my $tmp = $warn) =~ /^\x{100} at $0 line /; + ok (my $tmp = $warn) =~ /^\x{100} at \Q$0\E line /; } else { - skip 'skip: broken utf8 support in warn hook', 0 for 1..2; + skip 'skip: broken utf8 support in warn hook', 2; } - ok Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n"; - ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n"; + is Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n"; + is Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n"; - ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at $0 line /; - ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at $0 line /; + ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at \Q$0\E line /; + ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at \Q$0\E line /; } else { - skip 'skip: no utf8 support', 0 for 1..12; + skip 'skip: no utf8 support', 12; } if (ord('A') != 65) { - skip 'skip: no ASCII support', 0 for 1..24; -} elsif ($] ge '5.008' && $] ne '5.012000') { + skip 'skip: no ASCII support', 24; +} elsif ( "$]" >= '5.008' + && "$]" != '5.013000' # Broken in these ranges + && ! ("$]" >= '5.011005' && "$]" <= '5.012000')) +{ undef $die; ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') }; - ok $@, "\xE1\n"; - ok $die, "\xE1\n"; + is $@, "\xE1\n"; + is $die, "\xE1\n"; undef $die; ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') }; - ok $@ =~ /^\xE1 at $0 line /; - ok $die =~ /^\xE1 at $0 line /; + ok $@ =~ /^\xE1 at \Q$0\E line /; + ok $die =~ /^\xE1 at \Q$0\E line /; { undef $die; my $expect = eval '"\N{U+C3}\N{U+A1}\n"'; ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") }; - ok $@, $expect; - ok $die, $expect; + is $@, $expect; + is $die, $expect; } { undef $die; - my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /'; + my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /'; ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") }; ok $@ =~ $expect; ok $die =~ $expect; @@ -455,36 +519,41 @@ if (ord('A') != 65) { undef $warn; Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"'); - ok $warn, "\xE1\n"; + is $warn, "\xE1\n"; undef $warn; Devel::PPPort::warn_sv(eval '"\N{U+E1}"'); - ok $warn =~ /^\xE1 at $0 line /; + ok $warn =~ /^\xE1 at \Q$0\E line /; undef $warn; Devel::PPPort::warn_sv("\xC3\xA1\n"); - ok $warn, eval '"\N{U+C3}\N{U+A1}\n"'; + is $warn, eval '"\N{U+C3}\N{U+A1}\n"'; undef $warn; Devel::PPPort::warn_sv("\xC3\xA1"); - ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /'; + ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /'; - ok Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"'; - ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"'; + if ("$]" < '5.004') { + skip 'skip: no support for mess_sv', 8; + } + else { + is Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"'; + is Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"'; - ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at $0 line /'; - ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at $0 line /'; + ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at \Q$0\E line /'; + ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at \Q$0\E line /'; - ok Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"'; - ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"'; + is Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"'; + is Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"'; - ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /'; - ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /'; + ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /'; + ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /'; + } } else { - skip 'skip: no support for \N{U+..} syntax', 0 for 1..24; + skip 'skip: no support for \N{U+..} syntax', 24; } -if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) { +if ("$]" >= '5.007003' or ("$]" >= '5.006001' and "$]" < '5.007')) { undef $die; ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) }; ok $@ == $scalar_ref; @@ -505,14 +574,14 @@ if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) { ok $@ == $obj; ok $die == $obj; } else { - skip 'skip: no support for exceptions', 0 for 1..12; + skip 'skip: no support for exceptions', 12; } ok !defined eval { Devel::PPPort::croak_no_modify() }; -ok $@ =~ /^Modification of a read-only value attempted at $0 line /; +ok $@ =~ /^Modification of a read-only value attempted at \Q$0\E line /; ok !defined eval { Devel::PPPort::croak_memory_wrap() }; -ok $@ =~ /^panic: memory wrap at $0 line /; +ok $@ =~ /^panic: memory wrap at \Q$0\E line /; ok !defined eval { Devel::PPPort::croak_xs_usage("params") }; -ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at $0 line /; +ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at \Q$0\E line /; diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/misc b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/misc index 2bd2dcfb028..deb1fb87a63 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/misc +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/misc @@ -17,7 +17,6 @@ EXTERN_C INT2PTR MUTABLE_PTR NVTYPE -PERL_GCC_BRACE_GROUPS_FORBIDDEN PERLIO_FUNCS_CAST PERLIO_FUNCS_DECL PERL_UNUSED_ARG @@ -32,7 +31,6 @@ START_EXTERN_C STMT_END STMT_START SvRX -UTF8_MAXBYTES WIDEST_UTYPE XSRETURN @@ -52,26 +50,83 @@ __UNDEFINED__ __ASSERT_(statement) assert(statement), __UNDEFINED__ __ASSERT_(statement) #endif -#ifndef SvRX -#if { NEED SvRX } - -void * -SvRX(pTHX_ SV *rv) -{ - if (SvROK(rv)) { - SV *sv = SvRV(rv); - if (SvMAGICAL(sv)) { - MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); - if (mg && mg->mg_obj) { - return mg->mg_obj; - } - } - } - return 0; -} -#endif -#endif - +/* These could become provided if/when they become part of the public API */ +__UNDEF_NOT_PROVIDED__ withinCOUNT(c, l, n) \ + (((WIDEST_UTYPE) (((c)) - ((l) | 0))) <= (((WIDEST_UTYPE) ((n) | 0)))) +__UNDEF_NOT_PROVIDED__ inRANGE(c, l, u) \ + ( (sizeof(c) == sizeof(U8)) ? withinCOUNT(((U8) (c)), (l), ((u) - (l))) \ + : (sizeof(c) == sizeof(U16)) ? withinCOUNT(((U16) (c)), (l), ((u) - (l))) \ + : (sizeof(c) == sizeof(U32)) ? withinCOUNT(((U32) (c)), (l), ((u) - (l))) \ + : (withinCOUNT(((WIDEST_UTYPE) (c)), (l), ((u) - (l))))) + +/* The '| 0' part ensures a compiler error if c is not integer (like e.g., a + * pointer) */ +#undef FITS_IN_8_BITS /* handy.h version uses a core-only constant */ +__UNDEF_NOT_PROVIDED__ FITS_IN_8_BITS(c) ( (sizeof(c) == 1) \ + || !(((WIDEST_UTYPE)((c) | 0)) & ~0xFF)) + +/* Create the macro for "is'macro'_utf8_safe(s, e)". For code points below + * 256, it calls the equivalent _L1 macro by converting the UTF-8 to code + * point. That is so that it can automatically get the bug fixes done in this + * file. */ +#define D_PPP_IS_GENERIC_UTF8_SAFE(s, e, macro) \ + (((e) - (s)) <= 0 \ + ? 0 \ + : UTF8_IS_INVARIANT((s)[0]) \ + ? is ## macro ## _L1((s)[0]) \ + : (((e) - (s)) < UTF8SKIP(s)) \ + ? 0 \ + : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ + /* The cast in the line below is only to silence warnings */ \ + ? is ## macro ## _L1((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ + UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ + & UTF_START_MASK(2), \ + (s)[1]))) \ + : is ## macro ## _utf8(s)) + +/* Create the macro for "is'macro'_LC_utf8_safe(s, e)". For code points below + * 256, it calls the equivalent _L1 macro by converting the UTF-8 to code + * point. That is so that it can automatically get the bug fixes done in this + * file. */ +#define D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, macro) \ + (((e) - (s)) <= 0 \ + ? 0 \ + : UTF8_IS_INVARIANT((s)[0]) \ + ? is ## macro ## _LC((s)[0]) \ + : (((e) - (s)) < UTF8SKIP(s)) \ + ? 0 \ + : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ + /* The cast in the line below is only to silence warnings */ \ + ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ + UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ + & UTF_START_MASK(2), \ + (s)[1]))) \ + : is ## macro ## _utf8(s)) + +/* A few of the early functions are broken. For these and the non-LC case, + * machine generated code is substituted. But that code doesn't work for + * locales. This is just like the above macro, but at the end, we call the + * macro we've generated for the above 255 case, which is correct since locale + * isn't involved. This will generate extra code to handle the 0-255 inputs, + * but hopefully it will be optimized out by the C compiler. But just in case + * it isn't, this macro is only used on the few versions that are broken */ + +#define D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, macro) \ + (((e) - (s)) <= 0 \ + ? 0 \ + : UTF8_IS_INVARIANT((s)[0]) \ + ? is ## macro ## _LC((s)[0]) \ + : (((e) - (s)) < UTF8SKIP(s)) \ + ? 0 \ + : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ + /* The cast in the line below is only to silence warnings */ \ + ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ + UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ + & UTF_START_MASK(2), \ + (s)[1]))) \ + : is ## macro ## _utf8_safe(s, e)) + +__UNDEFINED__ SvRX(rv) (SvROK((rv)) ? (SvMAGICAL(SvRV((rv))) ? (mg_find(SvRV((rv)), PERL_MAGIC_qr) ? mg_find(SvRV((rv)), PERL_MAGIC_qr)->mg_obj : NULL) : NULL) : NULL) __UNDEFINED__ SvRXOK(sv) (!!SvRX(sv)) #ifndef PERL_UNUSED_DECL @@ -168,9 +223,9 @@ __UNDEFINED__ PTR2NV(p) NUM2PTR(NV,p) # define EXTERN_C extern #endif -#if defined(PERL_GCC_PEDANTIC) +#if { VERSION < 5.004 } || defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN -# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +__UNDEF_NOT_PROVIDED__ PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif @@ -258,8 +313,6 @@ __UNDEFINED__ dVAR dNOOP __UNDEFINED__ SVf "_" -__UNDEFINED__ UTF8_MAXBYTES UTF8_MAXLEN - __UNDEFINED__ CPERLscope(x) x __UNDEFINED__ PERL_HASH(hash,str,len) \ @@ -307,52 +360,103 @@ typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); # endif #endif +/* On versions without NATIVE_TO_ASCII, only ASCII is supported */ +#if defined(EBCDIC) && defined(NATIVE_TO_ASCI) +__UNDEFINED__ NATIVE_TO_LATIN1(c) NATIVE_TO_ASCII(c) +__UNDEFINED__ LATIN1_TO_NATIVE(c) ASCII_TO_NATIVE(c) +__UNDEFINED__ NATIVE_TO_UNI(c) ((c) > 255 ? (c) : NATIVE_TO_LATIN1(c)) +__UNDEFINED__ UNI_TO_NATIVE(c) ((c) > 255 ? (c) : LATIN1_TO_NATIVE(c)) +#else +__UNDEFINED__ NATIVE_TO_LATIN1(c) (c) +__UNDEFINED__ LATIN1_TO_NATIVE(c) (c) +__UNDEFINED__ NATIVE_TO_UNI(c) (c) +__UNDEFINED__ UNI_TO_NATIVE(c) (c) +#endif + +/* Warning: LATIN1_TO_NATIVE, NATIVE_TO_LATIN1 NATIVE_TO_UNI UNI_TO_NATIVE + EBCDIC is not supported on versions earlier than 5.7.1 + */ + +/* The meaning of this changed; use the modern version */ +#undef isPSXSPC +#undef isPSXSPC_A +#undef isPSXSPC_L1 + +/* Hint: isPSXSPC, isPSXSPC_A, isPSXSPC_L1, isPSXSPC_utf8_safe + This is equivalent to the corresponding isSPACE-type macro. On perls + before 5.18, this matched a vertical tab and SPACE didn't. But the + ppport.h SPACE version does match VT in all perl releases. Since VT's are + extremely rarely found in real-life files, this difference effectively + doesn't matter */ + +/* Hint: isSPACE, isSPACE_A, isSPACE_L1, isSPACE_utf8_safe + Until Perl 5.18, this did not match the vertical tab (VT). The ppport.h + version does match it in all perl releases. Since VT's are extremely rarely + found in real-life files, this difference effectively doesn't matter */ + #ifdef EBCDIC -/* This is the first version where these macros are fully correct. Relying on - * the C library functions, as earlier releases did, causes problems with - * locales */ +/* This is the first version where these macros are fully correct on EBCDIC + * platforms. Relying on * the C library functions, as earlier releases did, + * causes problems with * locales */ # if { VERSION < 5.22.0 } # undef isALNUM # undef isALNUM_A +# undef isALNUM_L1 # undef isALNUMC # undef isALNUMC_A +# undef isALNUMC_L1 # undef isALPHA # undef isALPHA_A +# undef isALPHA_L1 # undef isALPHANUMERIC # undef isALPHANUMERIC_A +# undef isALPHANUMERIC_L1 # undef isASCII # undef isASCII_A +# undef isASCII_L1 # undef isBLANK # undef isBLANK_A +# undef isBLANK_L1 # undef isCNTRL # undef isCNTRL_A +# undef isCNTRL_L1 # undef isDIGIT # undef isDIGIT_A +# undef isDIGIT_L1 # undef isGRAPH # undef isGRAPH_A +# undef isGRAPH_L1 # undef isIDCONT # undef isIDCONT_A +# undef isIDCONT_L1 # undef isIDFIRST # undef isIDFIRST_A +# undef isIDFIRST_L1 # undef isLOWER # undef isLOWER_A +# undef isLOWER_L1 # undef isOCTAL # undef isOCTAL_A +# undef isOCTAL_L1 # undef isPRINT # undef isPRINT_A -# undef isPSXSPC -# undef isPSXSPC_A +# undef isPRINT_L1 # undef isPUNCT # undef isPUNCT_A +# undef isPUNCT_L1 # undef isSPACE # undef isSPACE_A +# undef isSPACE_L1 # undef isUPPER # undef isUPPER_A +# undef isUPPER_L1 # undef isWORDCHAR # undef isWORDCHAR_A +# undef isWORDCHAR_L1 # undef isXDIGIT # undef isXDIGIT_A +# undef isXDIGIT_L1 # endif __UNDEFINED__ isASCII(c) (isCNTRL(c) || isPRINT(c)) @@ -379,6 +483,16 @@ __UNDEFINED__ isCNTRL(c) ( (c) == '\0' || (c) == '\a' || (c) == '\b' || (c) == 0x3D /* U+15 NAK */ \ || (c) == 0x3F /* U+1A SUB */ \ ) + +#if '^' == 106 /* EBCDIC POSIX-BC */ +# define D_PPP_OUTLIER_CONTROL 0x5F +#else /* EBCDIC 1047 037 */ +# define D_PPP_OUTLIER_CONTROL 0xFF +#endif + +/* The controls are everything below blank, plus one outlier */ +__UNDEFINED__ isCNTRL_L1(c) ((WIDEST_UTYPE) (c) < ' ' \ + || (WIDEST_UTYPE) (c) == D_PPP_OUTLIER_CONTROL) /* The ordering of the tests in this and isUPPER are to exclude most characters * early */ __UNDEFINED__ isLOWER(c) ( (c) >= 'a' && (c) <= 'z' \ @@ -409,94 +523,534 @@ __UNDEFINED__ isUPPER(c) ( (c) >= 'A' && (c) <= 'Z' # undef isUPPER_A # endif -# if { VERSION < 5.8.0 } -/* Hint: isCNTRL - * Earlier perls omitted DEL */ +# if { VERSION == 5.7.0 } /* this perl made space GRAPH */ +# undef isGRAPH +# endif + +# if { VERSION < 5.8.0 } /* earlier perls omitted DEL */ # undef isCNTRL # endif # if { VERSION < 5.10.0 } -/* Hint: isPRINT - * The implementation in older perl versions includes all of the - * isSPACE() characters, which is wrong. The version provided by - * Devel::PPPort always overrides a present buggy version. - */ +/* earlier perls included all of the isSPACE() characters, which is wrong. The + * version provided by Devel::PPPort always overrides an existing buggy + * version. */ # undef isPRINT # undef isPRINT_A # endif # if { VERSION < 5.14.0 } -/* Hint: isASCII - * The implementation in older perl versions always returned true if the - * parameter was a signed char - */ +/* earlier perls always returned true if the parameter was a signed char */ # undef isASCII # undef isASCII_A # endif -# if { VERSION < 5.20.0 } -/* Hint: isSPACE - * The implementation in older perl versions didn't include \v */ +# if { VERSION < 5.17.8 } /* earlier perls didn't include PILCROW, SECTION SIGN */ +# undef isPUNCT_L1 +# endif + +# if { VERSION < 5.13.7 } /* khw didn't investigate why this failed */ +# undef isALNUMC_L1 +#endif + +# if { VERSION < 5.20.0 } /* earlier perls didn't include \v */ # undef isSPACE # undef isSPACE_A +# undef isSPACE_L1 + # endif __UNDEFINED__ isASCII(c) ((WIDEST_UTYPE) (c) <= 127) __UNDEFINED__ isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) +__UNDEFINED__ isCNTRL_L1(c) (isCNTRL(c) || ( (WIDEST_UTYPE) (c) <= 0x9F \ + && (WIDEST_UTYPE) (c) >= 0x80)) __UNDEFINED__ isLOWER(c) ((c) >= 'a' && (c) <= 'z') __UNDEFINED__ isUPPER(c) ((c) <= 'Z' && (c) >= 'A') + #endif /* Below are definitions common to EBCDIC and ASCII */ +__UNDEFINED__ isASCII_L1(c) isASCII(c) +__UNDEFINED__ isASCII_LC(c) isASCII(c) __UNDEFINED__ isALNUM(c) isWORDCHAR(c) __UNDEFINED__ isALNUMC(c) isALPHANUMERIC(c) +__UNDEFINED__ isALNUMC_L1(c) isALPHANUMERIC_L1(c) __UNDEFINED__ isALPHA(c) (isUPPER(c) || isLOWER(c)) +__UNDEFINED__ isALPHA_L1(c) (isUPPER_L1(c) || isLOWER_L1(c)) __UNDEFINED__ isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c)) +__UNDEFINED__ isALPHANUMERIC_L1(c) (isALPHA_L1(c) || isDIGIT(c)) +__UNDEFINED__ isALPHANUMERIC_LC(c) (isALPHA_LC(c) || isDIGIT_LC(c)) __UNDEFINED__ isBLANK(c) ((c) == ' ' || (c) == '\t') -__UNDEFINED__ isDIGIT(c) ((c) <= '9' && (c) >= '0') +__UNDEFINED__ isBLANK_L1(c) ( isBLANK(c) \ + || ( FITS_IN_8_BITS(c) \ + && NATIVE_TO_LATIN1((U8) c) == 0xA0)) +__UNDEFINED__ isBLANK_LC(c) isBLANK(c) +__UNDEFINED__ isDIGIT(c) inRANGE(c, '0', '9') +__UNDEFINED__ isDIGIT_L1(c) isDIGIT(c) __UNDEFINED__ isGRAPH(c) (isWORDCHAR(c) || isPUNCT(c)) +__UNDEFINED__ isGRAPH_L1(c) ( isPRINT_L1(c) \ + && (c) != ' ' \ + && NATIVE_TO_LATIN1((U8) c) != 0xA0) __UNDEFINED__ isIDCONT(c) isWORDCHAR(c) +__UNDEFINED__ isIDCONT_L1(c) isWORDCHAR_L1(c) +__UNDEFINED__ isIDCONT_LC(c) isWORDCHAR_LC(c) __UNDEFINED__ isIDFIRST(c) (isALPHA(c) || (c) == '_') +__UNDEFINED__ isIDFIRST_L1(c) (isALPHA_L1(c) || (U8) (c) == '_') +__UNDEFINED__ isIDFIRST_LC(c) (isALPHA_LC(c) || (U8) (c) == '_') +__UNDEFINED__ isLOWER_L1(c) ( isLOWER(c) \ + || ( FITS_IN_8_BITS(c) \ + && ( ( NATIVE_TO_LATIN1((U8) c) >= 0xDF \ + && NATIVE_TO_LATIN1((U8) c) != 0xF7) \ + || NATIVE_TO_LATIN1((U8) c) == 0xAA \ + || NATIVE_TO_LATIN1((U8) c) == 0xBA \ + || NATIVE_TO_LATIN1((U8) c) == 0xB5))) __UNDEFINED__ isOCTAL(c) (((WIDEST_UTYPE)((c)) & ~7) == '0') +__UNDEFINED__ isOCTAL_L1(c) isOCTAL(c) __UNDEFINED__ isPRINT(c) (isGRAPH(c) || (c) == ' ') +__UNDEFINED__ isPRINT_L1(c) (FITS_IN_8_BITS(c) && ! isCNTRL_L1(c)) __UNDEFINED__ isPSXSPC(c) isSPACE(c) -__UNDEFINED__ isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \ - || (c) == '#' || (c) == '$' || (c) == '%' \ - || (c) == '&' || (c) == '\'' || (c) == '(' \ - || (c) == ')' || (c) == '*' || (c) == '+' \ - || (c) == ',' || (c) == '.' || (c) == '/' \ - || (c) == ':' || (c) == ';' || (c) == '<' \ - || (c) == '=' || (c) == '>' || (c) == '?' \ - || (c) == '@' || (c) == '[' || (c) == '\\' \ - || (c) == ']' || (c) == '^' || (c) == '_' \ - || (c) == '`' || (c) == '{' || (c) == '|' \ +__UNDEFINED__ isPSXSPC_L1(c) isSPACE_L1(c) +__UNDEFINED__ isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \ + || (c) == '#' || (c) == '$' || (c) == '%' \ + || (c) == '&' || (c) == '\'' || (c) == '(' \ + || (c) == ')' || (c) == '*' || (c) == '+' \ + || (c) == ',' || (c) == '.' || (c) == '/' \ + || (c) == ':' || (c) == ';' || (c) == '<' \ + || (c) == '=' || (c) == '>' || (c) == '?' \ + || (c) == '@' || (c) == '[' || (c) == '\\' \ + || (c) == ']' || (c) == '^' || (c) == '_' \ + || (c) == '`' || (c) == '{' || (c) == '|' \ || (c) == '}' || (c) == '~') -__UNDEFINED__ isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \ +__UNDEFINED__ isPUNCT_L1(c) ( isPUNCT(c) \ + || ( FITS_IN_8_BITS(c) \ + && ( NATIVE_TO_LATIN1((U8) c) == 0xA1 \ + || NATIVE_TO_LATIN1((U8) c) == 0xA7 \ + || NATIVE_TO_LATIN1((U8) c) == 0xAB \ + || NATIVE_TO_LATIN1((U8) c) == 0xB6 \ + || NATIVE_TO_LATIN1((U8) c) == 0xB7 \ + || NATIVE_TO_LATIN1((U8) c) == 0xBB \ + || NATIVE_TO_LATIN1((U8) c) == 0xBF))) +__UNDEFINED__ isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \ || (c) == '\v' || (c) == '\f') +__UNDEFINED__ isSPACE_L1(c) ( isSPACE(c) \ + || (FITS_IN_8_BITS(c) \ + && ( NATIVE_TO_LATIN1((U8) c) == 0x85 \ + || NATIVE_TO_LATIN1((U8) c) == 0xA0))) +__UNDEFINED__ isUPPER_L1(c) ( isUPPER(c) \ + || (FITS_IN_8_BITS(c) \ + && ( NATIVE_TO_LATIN1((U8) c) >= 0xC0 \ + && NATIVE_TO_LATIN1((U8) c) <= 0xDE \ + && NATIVE_TO_LATIN1((U8) c) != 0xD7))) __UNDEFINED__ isWORDCHAR(c) (isALPHANUMERIC(c) || (c) == '_') -__UNDEFINED__ isXDIGIT(c) ( isDIGIT(c) \ - || ((c) >= 'a' && (c) <= 'f') \ +__UNDEFINED__ isWORDCHAR_L1(c) (isIDFIRST_L1(c) || isDIGIT(c)) +__UNDEFINED__ isWORDCHAR_LC(c) (isIDFIRST_LC(c) || isDIGIT_LC(c)) +__UNDEFINED__ isXDIGIT(c) ( isDIGIT(c) \ + || ((c) >= 'a' && (c) <= 'f') \ || ((c) >= 'A' && (c) <= 'F')) +__UNDEFINED__ isXDIGIT_L1(c) isXDIGIT(c) +__UNDEFINED__ isXDIGIT_LC(c) isxdigit(c) + +__UNDEFINED__ isALNUM_A(c) isALNUM(c) +__UNDEFINED__ isALNUMC_A(c) isALNUMC(c) +__UNDEFINED__ isALPHA_A(c) isALPHA(c) +__UNDEFINED__ isALPHANUMERIC_A(c) isALPHANUMERIC(c) +__UNDEFINED__ isASCII_A(c) isASCII(c) +__UNDEFINED__ isBLANK_A(c) isBLANK(c) +__UNDEFINED__ isCNTRL_A(c) isCNTRL(c) +__UNDEFINED__ isDIGIT_A(c) isDIGIT(c) +__UNDEFINED__ isGRAPH_A(c) isGRAPH(c) +__UNDEFINED__ isIDCONT_A(c) isIDCONT(c) +__UNDEFINED__ isIDFIRST_A(c) isIDFIRST(c) +__UNDEFINED__ isLOWER_A(c) isLOWER(c) +__UNDEFINED__ isOCTAL_A(c) isOCTAL(c) +__UNDEFINED__ isPRINT_A(c) isPRINT(c) +__UNDEFINED__ isPSXSPC_A(c) isPSXSPC(c) +__UNDEFINED__ isPUNCT_A(c) isPUNCT(c) +__UNDEFINED__ isSPACE_A(c) isSPACE(c) +__UNDEFINED__ isUPPER_A(c) isUPPER(c) +__UNDEFINED__ isWORDCHAR_A(c) isWORDCHAR(c) +__UNDEFINED__ isXDIGIT_A(c) isXDIGIT(c) + +__UNDEFINED__ isASCII_utf8_safe(s,e) (((e) - (s)) <= 0 ? 0 : isASCII(*(s))) +__UNDEFINED__ isASCII_uvchr(c) (FITS_IN_8_BITS(c) ? isASCII_L1(c) : 0) + +#if { VERSION >= 5.006 } +# ifdef isALPHA_uni /* If one defined, all are; this is just an exemplar */ +# define D_PPP_is_ctype(upper, lower, c) \ + (FITS_IN_8_BITS(c) \ + ? is ## upper ## _L1(c) \ + : is ## upper ## _uni((UV) (c))) /* _uni is old synonym */ +# else +# define D_PPP_is_ctype(upper, lower, c) \ + (FITS_IN_8_BITS(c) \ + ? is ## upper ## _L1(c) \ + : is_uni_ ## lower((UV) (c))) /* is_uni_ is even older */ +# endif + +__UNDEFINED__ isALPHA_uvchr(c) D_PPP_is_ctype(ALPHA, alpha, c) +__UNDEFINED__ isALPHANUMERIC_uvchr(c) (isALPHA_uvchr(c) || isDIGIT_uvchr(c)) +# ifdef is_uni_blank +__UNDEFINED__ isBLANK_uvchr(c) D_PPP_is_ctype(BLANK, blank, c) +# else +__UNDEFINED__ isBLANK_uvchr(c) (FITS_IN_8_BITS(c) \ + ? isBLANK_L1(c) \ + : ( (UV) (c) == 0x1680 /* Unicode 3.0 */ \ + || inRANGE((UV) (c), 0x2000, 0x200A) \ + || (UV) (c) == 0x202F /* Unicode 3.0 */\ + || (UV) (c) == 0x205F /* Unicode 3.2 */\ + || (UV) (c) == 0x3000)) +# endif +__UNDEFINED__ isCNTRL_uvchr(c) D_PPP_is_ctype(CNTRL, cntrl, c) +__UNDEFINED__ isDIGIT_uvchr(c) D_PPP_is_ctype(DIGIT, digit, c) +__UNDEFINED__ isGRAPH_uvchr(c) D_PPP_is_ctype(GRAPH, graph, c) +__UNDEFINED__ isIDCONT_uvchr(c) isWORDCHAR_uvchr(c) +__UNDEFINED__ isIDFIRST_uvchr(c) D_PPP_is_ctype(IDFIRST, idfirst, c) +__UNDEFINED__ isLOWER_uvchr(c) D_PPP_is_ctype(LOWER, lower, c) +__UNDEFINED__ isPRINT_uvchr(c) D_PPP_is_ctype(PRINT, print, c) +__UNDEFINED__ isPSXSPC_uvchr(c) isSPACE_uvchr(c) +__UNDEFINED__ isPUNCT_uvchr(c) D_PPP_is_ctype(PUNCT, punct, c) +__UNDEFINED__ isSPACE_uvchr(c) D_PPP_is_ctype(SPACE, space, c) +__UNDEFINED__ isUPPER_uvchr(c) D_PPP_is_ctype(UPPER, upper, c) +__UNDEFINED__ isXDIGIT_uvchr(c) D_PPP_is_ctype(XDIGIT, xdigit, c) +__UNDEFINED__ isWORDCHAR_uvchr(c) (FITS_IN_8_BITS(c) \ + ? isWORDCHAR_L1(c) : isALPHANUMERIC_uvchr(c)) + +__UNDEFINED__ isALPHA_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHA) +# ifdef isALPHANUMERIC_utf8 +__UNDEFINED__ isALPHANUMERIC_utf8_safe(s,e) \ + D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHANUMERIC) +# else +__UNDEFINED__ isALPHANUMERIC_utf8_safe(s,e) \ + (isALPHA_utf8_safe(s,e) || isDIGIT_utf8_safe(s,e)) +# endif + +/* This was broken before 5.18, and just use this instead of worrying about + * which releases the official works on */ +# if 'A' == 65 +__UNDEFINED__ isBLANK_utf8_safe(s,e) \ +( ( LIKELY((e) > (s)) ) ? /* Machine generated */ \ + ( ( 0x09 == ((const U8*)s)[0] || 0x20 == ((const U8*)s)[0] ) ? 1 \ + : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ + ( ( 0xC2 == ((const U8*)s)[0] ) ? \ + ( ( 0xA0 == ((const U8*)s)[1] ) ? 2 : 0 ) \ + : ( 0xE1 == ((const U8*)s)[0] ) ? \ + ( ( ( 0x9A == ((const U8*)s)[1] ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ + : ( 0xE2 == ((const U8*)s)[0] ) ? \ + ( ( 0x80 == ((const U8*)s)[1] ) ? \ + ( ( inRANGE(((const U8*)s)[2], 0x80, 0x8A ) || 0xAF == ((const U8*)s)[2] ) ? 3 : 0 )\ + : ( ( 0x81 == ((const U8*)s)[1] ) && ( 0x9F == ((const U8*)s)[2] ) ) ? 3 : 0 )\ + : ( ( ( 0xE3 == ((const U8*)s)[0] ) && ( 0x80 == ((const U8*)s)[1] ) ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ + : 0 ) \ + : 0 ) + +# elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */ + +__UNDEFINED__ isBLANK_utf8_safe(s,e) \ +( ( LIKELY((e) > (s)) ) ? \ + ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \ + : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ + ( ( 0x80 == ((const U8*)s)[0] ) ? \ + ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \ + : ( 0xBC == ((const U8*)s)[0] ) ? \ + ( ( ( 0x63 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ + : ( 0xCA == ((const U8*)s)[0] ) ? \ + ( ( 0x41 == ((const U8*)s)[1] ) ? \ + ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\ + : ( 0x42 == ((const U8*)s)[1] ) ? \ + ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \ + : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x73 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ + : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ + : 0 ) \ +: 0 ) + +# elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */ + +__UNDEFINED__ isBLANK_utf8_safe(s,e) \ +( ( LIKELY((e) > (s)) ) ? \ + ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \ + : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ + ( ( 0x78 == ((const U8*)s)[0] ) ? \ + ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \ + : ( 0xBD == ((const U8*)s)[0] ) ? \ + ( ( ( 0x62 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ + : ( 0xCA == ((const U8*)s)[0] ) ? \ + ( ( 0x41 == ((const U8*)s)[1] ) ? \ + ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\ + : ( 0x42 == ((const U8*)s)[1] ) ? \ + ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \ + : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x72 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ + : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ + : 0 ) \ +: 0 ) + +# else +# error Unknown character set +# endif + +__UNDEFINED__ isCNTRL_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, CNTRL) +__UNDEFINED__ isDIGIT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, DIGIT) +__UNDEFINED__ isGRAPH_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, GRAPH) +# ifdef isIDCONT_utf8 +__UNDEFINED__ isIDCONT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDCONT) +# else +__UNDEFINED__ isIDCONT_utf8_safe(s,e) isWORDCHAR_utf8_safe(s,e) +# endif + +__UNDEFINED__ isIDFIRST_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDFIRST) +__UNDEFINED__ isLOWER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, LOWER) +__UNDEFINED__ isPRINT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PRINT) + +# undef isPSXSPC_utf8_safe /* Use the modern definition */ +__UNDEFINED__ isPSXSPC_utf8_safe(s,e) isSPACE_utf8_safe(s,e) + +__UNDEFINED__ isPUNCT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PUNCT) +__UNDEFINED__ isSPACE_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, SPACE) +__UNDEFINED__ isUPPER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, UPPER) + +# ifdef isWORDCHAR_utf8 +__UNDEFINED__ isWORDCHAR_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, WORDCHAR) +# else +__UNDEFINED__ isWORDCHAR_utf8_safe(s,e) \ + (isALPHANUMERIC_utf8_safe(s,e) || (*(s)) == '_') +# endif + +/* This was broken before 5.12, and just use this instead of worrying about + * which releases the official works on */ +# if 'A' == 65 +__UNDEFINED__ isXDIGIT_utf8_safe(s,e) \ +( ( LIKELY((e) > (s)) ) ? \ + ( ( inRANGE(((const U8*)s)[0], 0x30, 0x39 ) || inRANGE(((const U8*)s)[0], 0x41, 0x46 ) || inRANGE(((const U8*)s)[0], 0x61, 0x66 ) ) ? 1\ + : ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xEF == ((const U8*)s)[0] ) ) ? ( ( 0xBC == ((const U8*)s)[1] ) ?\ + ( ( inRANGE(((const U8*)s)[2], 0x90, 0x99 ) || inRANGE(((const U8*)s)[2], 0xA1, 0xA6 ) ) ? 3 : 0 )\ + : ( ( 0xBD == ((const U8*)s)[1] ) && ( inRANGE(((const U8*)s)[2], 0x81, 0x86 ) ) ) ? 3 : 0 ) : 0 )\ +: 0 ) + +# elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */ + +__UNDEFINED__ isXDIGIT_utf8_safe(s,e) \ +( ( LIKELY((e) > (s)) ) ? \ + ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\ + : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x73 == ((const U8*)s)[1] ) ) ? ( ( 0x67 == ((const U8*)s)[2] ) ?\ + ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || inRANGE(((const U8*)s)[3], 0x62, 0x68 ) ) ? 4 : 0 )\ + : ( ( inRANGE(((const U8*)s)[2], 0x68, 0x69 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\ +: 0 ) + +# elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */ + +__UNDEFINED__ isXDIGIT_utf8_safe(s,e) \ +( ( LIKELY((e) > (s)) ) ? \ + ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\ + : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x72 == ((const U8*)s)[1] ) ) ? ( ( 0x66 == ((const U8*)s)[2] ) ?\ + ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || 0x5F == ((const U8*)s)[3] || inRANGE(((const U8*)s)[3], 0x62, 0x67 ) ) ? 4 : 0 )\ + : ( ( inRANGE(((const U8*)s)[2], 0x67, 0x68 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\ +: 0 ) + +# else +# error Unknown character set +# endif + +__UNDEFINED__ isALPHA_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHA) +# ifdef isALPHANUMERIC_utf8 +__UNDEFINED__ isALPHANUMERIC_LC_utf8_safe(s,e) \ + D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHANUMERIC) +# else +__UNDEFINED__ isALPHANUMERIC_LC_utf8_safe(s,e) \ + (isALPHA_LC_utf8_safe(s,e) || isDIGIT_LC_utf8_safe(s,e)) +# endif + +__UNDEFINED__ isBLANK_LC_utf8_safe(s,e) \ + D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, BLANK) +__UNDEFINED__ isCNTRL_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, CNTRL) +__UNDEFINED__ isDIGIT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, DIGIT) +__UNDEFINED__ isGRAPH_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, GRAPH) +# ifdef isIDCONT_utf8 +__UNDEFINED__ isIDCONT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDCONT) +# else +__UNDEFINED__ isIDCONT_LC_utf8_safe(s,e) isWORDCHAR_LC_utf8_safe(s,e) +# endif + +__UNDEFINED__ isIDFIRST_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDFIRST) +__UNDEFINED__ isLOWER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, LOWER) +__UNDEFINED__ isPRINT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PRINT) + +# undef isPSXSPC_LC_utf8_safe /* Use the modern definition */ +__UNDEFINED__ isPSXSPC_LC_utf8_safe(s,e) isSPACE_LC_utf8_safe(s,e) + +__UNDEFINED__ isPUNCT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PUNCT) +__UNDEFINED__ isSPACE_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, SPACE) +__UNDEFINED__ isUPPER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, UPPER) + +# ifdef isWORDCHAR_utf8 +__UNDEFINED__ isWORDCHAR_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, WORDCHAR) +# else +__UNDEFINED__ isWORDCHAR_LC_utf8_safe(s,e) \ + (isALPHANUMERIC_LC_utf8_safe(s,e) || (*(s)) == '_') +# endif + +__UNDEFINED__ isXDIGIT_LC_utf8_safe(s,e) \ + D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, XDIGIT) + +/* Warning: isALPHANUMERIC_utf8_safe, isALPHA_utf8_safe, isASCII_utf8_safe, + * isBLANK_utf8_safe, isCNTRL_utf8_safe, isDIGIT_utf8_safe, isGRAPH_utf8_safe, + * isIDCONT_utf8_safe, isIDFIRST_utf8_safe, isLOWER_utf8_safe, + * isPRINT_utf8_safe, isPSXSPC_utf8_safe, isPUNCT_utf8_safe, isSPACE_utf8_safe, + * isUPPER_utf8_safe, isWORDCHAR_utf8_safe, isWORDCHAR_utf8_safe, + * isXDIGIT_utf8_safe, + * isALPHANUMERIC_LC_utf8_safe, isALPHA_LC_utf8_safe, isASCII_LC_utf8_safe, + * isBLANK_LC_utf8_safe, isCNTRL_LC_utf8_safe, isDIGIT_LC_utf8_safe, + * isGRAPH_LC_utf8_safe, isIDCONT_LC_utf8_safe, isIDFIRST_LC_utf8_safe, + * isLOWER_LC_utf8_safe, isPRINT_LC_utf8_safe, isPSXSPC_LC_utf8_safe, + * isPUNCT_LC_utf8_safe, isSPACE_LC_utf8_safe, isUPPER_LC_utf8_safe, + * isWORDCHAR_LC_utf8_safe, isWORDCHAR_LC_utf8_safe, isXDIGIT_LC_utf8_safe, + * isALPHANUMERIC_uvchr, isALPHA_uvchr, isASCII_uvchr, isBLANK_uvchr, + * isCNTRL_uvchr, isDIGIT_uvchr, isGRAPH_uvchr, isIDCONT_uvchr, + * isIDFIRST_uvchr, isLOWER_uvchr, isPRINT_uvchr, isPSXSPC_uvchr, + * isPUNCT_uvchr, isSPACE_uvchr, isUPPER_uvchr, isWORDCHAR_uvchr, + * isWORDCHAR_uvchr, isXDIGIT_uvchr + * + * The UTF-8 handling is buggy in early Perls, and this can give inaccurate + * results for code points above 0xFF, until the implementation started + * settling down in 5.12 and 5.14 */ + +#endif + +#define D_PPP_TOO_SHORT_MSG "Malformed UTF-8 character starting with:" \ + " \\x%02x (too short; %d bytes available, need" \ + " %d)\n" +/* Perls starting here had a new API which handled multi-character results */ +#if { VERSION >= 5.7.3 } -__UNDEFINED__ isALNUM_A isALNUM -__UNDEFINED__ isALNUMC_A isALNUMC -__UNDEFINED__ isALPHA_A isALPHA -__UNDEFINED__ isALPHANUMERIC_A isALPHANUMERIC -__UNDEFINED__ isASCII_A isASCII -__UNDEFINED__ isBLANK_A isBLANK -__UNDEFINED__ isCNTRL_A isCNTRL -__UNDEFINED__ isDIGIT_A isDIGIT -__UNDEFINED__ isGRAPH_A isGRAPH -__UNDEFINED__ isIDCONT_A isIDCONT -__UNDEFINED__ isIDFIRST_A isIDFIRST -__UNDEFINED__ isLOWER_A isLOWER -__UNDEFINED__ isOCTAL_A isOCTAL -__UNDEFINED__ isPRINT_A isPRINT -__UNDEFINED__ isPSXSPC_A isPSXSPC -__UNDEFINED__ isPUNCT_A isPUNCT -__UNDEFINED__ isSPACE_A isSPACE -__UNDEFINED__ isUPPER_A isUPPER -__UNDEFINED__ isWORDCHAR_A isWORDCHAR -__UNDEFINED__ isXDIGIT_A isXDIGIT +__UNDEFINED__ toLOWER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_lower(NATIVE_TO_UNI(c), s, l)) +__UNDEFINED__ toUPPER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_upper(NATIVE_TO_UNI(c), s, l)) +__UNDEFINED__ toTITLE_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_title(NATIVE_TO_UNI(c), s, l)) +__UNDEFINED__ toFOLD_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_fold( NATIVE_TO_UNI(c), s, l)) + +# if { VERSION != 5.15.6 } /* Just this version is broken */ + + /* Prefer the macro to the function */ +# if defined toLOWER_utf8 +# define D_PPP_TO_LOWER_CALLEE(s,r,l) toLOWER_utf8(s,r,l) +# else +# define D_PPP_TO_LOWER_CALLEE(s,r,l) to_utf8_lower(s,r,l) +# endif +# if defined toTITLE_utf8 +# define D_PPP_TO_TITLE_CALLEE(s,r,l) toTITLE_utf8(s,r,l) +# else +# define D_PPP_TO_TITLE_CALLEE(s,r,l) to_utf8_title(s,r,l) +# endif +# if defined toUPPER_utf8 +# define D_PPP_TO_UPPER_CALLEE(s,r,l) toUPPER_utf8(s,r,l) +# else +# define D_PPP_TO_UPPER_CALLEE(s,r,l) to_utf8_upper(s,r,l) +# endif +# if defined toFOLD_utf8 +# define D_PPP_TO_FOLD_CALLEE(s,r,l) toFOLD_utf8(s,r,l) +# else +# define D_PPP_TO_FOLD_CALLEE(s,r,l) to_utf8_fold(s,r,l) +# endif +# else /* Below is 5.15.6, which failed to make the macros available +# outside of core, so we have to use the 'Perl_' form. khw +# decided it was easier to just handle this case than have to +# document the exception, and make an exception in the tests below +# */ +# define D_PPP_TO_LOWER_CALLEE(s,r,l) \ + Perl__to_utf8_lower_flags(aTHX_ s, r, l, 0, NULL) +# define D_PPP_TO_TITLE_CALLEE(s,r,l) \ + Perl__to_utf8_title_flags(aTHX_ s, r, l, 0, NULL) +# define D_PPP_TO_UPPER_CALLEE(s,r,l) \ + Perl__to_utf8_upper_flags(aTHX_ s, r, l, 0, NULL) +# define D_PPP_TO_FOLD_CALLEE(s,r,l) \ + Perl__to_utf8_fold_flags(aTHX_ s, r, l, FOLD_FLAGS_FULL, NULL) +# endif + +/* The actual implementation of the backported macros. If too short, croak, + * otherwise call the original that doesn't have an upper limit parameter */ +# define D_PPP_GENERIC_MULTI_ARG_TO(name, s, e,r,l) \ + (((((e) - (s)) <= 0) \ + /* We could just do nothing, but modern perls croak */ \ + ? (croak("Attempting case change on zero length string"), \ + 0) /* So looks like it returns something, and will compile */ \ + : ((e) - (s)) < UTF8SKIP(s)) \ + ? (croak(D_PPP_TOO_SHORT_MSG, \ + s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \ + 0) \ + : D_PPP_TO_ ## name ## _CALLEE(s,r,l)) + +__UNDEFINED__ toUPPER_utf8_safe(s,e,r,l) \ + D_PPP_GENERIC_MULTI_ARG_TO(UPPER,s,e,r,l) +__UNDEFINED__ toLOWER_utf8_safe(s,e,r,l) \ + D_PPP_GENERIC_MULTI_ARG_TO(LOWER,s,e,r,l) +__UNDEFINED__ toTITLE_utf8_safe(s,e,r,l) \ + D_PPP_GENERIC_MULTI_ARG_TO(TITLE,s,e,r,l) +__UNDEFINED__ toFOLD_utf8_safe(s,e,r,l) \ + D_PPP_GENERIC_MULTI_ARG_TO(FOLD,s,e,r,l) + +#elif { VERSION >= 5.006 } + +/* Here we have UTF-8 support, but using the original API where the case + * changing functions merely returned the changed code point; hence they + * couldn't handle multi-character results. */ + +# ifdef uvchr_to_utf8 +# define D_PPP_UV_TO_UTF8 uvchr_to_utf8 +# else +# define D_PPP_UV_TO_UTF8 uv_to_utf8 +# endif + + /* Get the utf8 of the case changed value, and store its length; then have + * to re-calculate the changed case value in order to return it */ +# define D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(name, c, s, l) \ + (*(l) = (D_PPP_UV_TO_UTF8(s, \ + UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) - (s)), \ + UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) + +__UNDEFINED__ toLOWER_uvchr(c, s, l) \ + D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(lower, c, s, l) +__UNDEFINED__ toUPPER_uvchr(c, s, l) \ + D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(upper, c, s, l) +__UNDEFINED__ toTITLE_uvchr(c, s, l) \ + D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(title, c, s, l) +__UNDEFINED__ toFOLD_uvchr(c, s, l) toLOWER_uvchr(c, s, l) + +# define D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(name, s, e, r, l) \ + (((((e) - (s)) <= 0) \ + ? (croak("Attempting case change on zero length string"), \ + 0) /* So looks like it returns something, and will compile */ \ + : ((e) - (s)) < UTF8SKIP(s)) \ + ? (croak(D_PPP_TOO_SHORT_MSG, \ + s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \ + 0) \ + /* Get the changed code point and store its UTF-8 */ \ + : D_PPP_UV_TO_UTF8(r, to_utf8_ ## name(s)), \ + /* Then store its length, and re-get code point for return */ \ + *(l) = UTF8SKIP(r), to_utf8_ ## name(r)) + +/* Warning: toUPPER_utf8_safe, toLOWER_utf8_safe, toTITLE_utf8_safe, + * toUPPER_uvchr, toLOWER_uvchr, toTITLE_uvchr + The UTF-8 case changing operations had bugs before around 5.12 or 5.14; + this backport does not correct them. + + In perls before 7.3, multi-character case changing is not implemented; this + backport uses the simple case changes available in those perls. */ + +__UNDEFINED__ toUPPER_utf8_safe(s,e,r,l) \ + D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(upper, s, e, r, l) +__UNDEFINED__ toLOWER_utf8_safe(s,e,r,l) \ + D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(lower, s, e, r, l) +__UNDEFINED__ toTITLE_utf8_safe(s,e,r,l) \ + D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(title, s, e, r, l) + + /* Warning: toFOLD_utf8_safe, toFOLD_uvchr + The UTF-8 case changing operations had bugs before around 5.12 or 5.14; + this backport does not correct them. + + In perls before 7.3, case folding is not implemented; instead, this + backport substitutes simple (not multi-character, which isn't available) + lowercasing. This gives the correct result in most, but not all, instances + */ + +__UNDEFINED__ toFOLD_utf8_safe(s,e,r,l) toLOWER_utf8_safe(s,e,r,l) + +#endif /* Until we figure out how to support this in older perls... */ #if { VERSION >= 5.8.0 } @@ -513,8 +1067,6 @@ __UNDEFINED__ C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) __UNDEFINED__ LIKELY(x) (x) __UNDEFINED__ UNLIKELY(x) (x) -__UNDEFINED__ UNICODE_REPLACEMENT 0xFFFD - #ifndef MUTABLE_PTR #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) @@ -559,10 +1111,6 @@ XS(XS_Devel__PPPort_dAXMARK) XSRETURN(1); } -=xsinit - -#define NEED_SvRX - =xsboot { @@ -768,7 +1316,7 @@ DEFSV_modify() int ERRSV() CODE: - RETVAL = SvTRUE(ERRSV); + RETVAL = SvTRUEx(ERRSV); OUTPUT: RETVAL @@ -855,325 +1403,1168 @@ check_c_array() mXPUSHi(*(C_ARRAY_END(x)-1)); /* 13 */ bool -test_isBLANK(UV ord) +isBLANK(ord) + UV ord CODE: RETVAL = isBLANK(ord); OUTPUT: RETVAL bool -test_isBLANK_A(UV ord) +isBLANK_A(ord) + UV ord CODE: RETVAL = isBLANK_A(ord); OUTPUT: RETVAL bool -test_isUPPER(UV ord) +isBLANK_L1(ord) + UV ord + CODE: + RETVAL = isBLANK_L1(ord); + OUTPUT: + RETVAL + +bool +isUPPER(ord) + UV ord CODE: RETVAL = isUPPER(ord); OUTPUT: RETVAL bool -test_isUPPER_A(UV ord) +isUPPER_A(ord) + UV ord CODE: RETVAL = isUPPER_A(ord); OUTPUT: RETVAL bool -test_isLOWER(UV ord) +isUPPER_L1(ord) + UV ord + CODE: + RETVAL = isUPPER_L1(ord); + OUTPUT: + RETVAL + +bool +isLOWER(ord) + UV ord CODE: RETVAL = isLOWER(ord); OUTPUT: RETVAL bool -test_isLOWER_A(UV ord) +isLOWER_A(ord) + UV ord CODE: RETVAL = isLOWER_A(ord); OUTPUT: RETVAL bool -test_isALPHA(UV ord) +isLOWER_L1(ord) + UV ord + CODE: + RETVAL = isLOWER_L1(ord); + OUTPUT: + RETVAL + +bool +isALPHA(ord) + UV ord CODE: RETVAL = isALPHA(ord); OUTPUT: RETVAL bool -test_isALPHA_A(UV ord) +isALPHA_A(ord) + UV ord CODE: RETVAL = isALPHA_A(ord); OUTPUT: RETVAL bool -test_isWORDCHAR(UV ord) +isALPHA_L1(ord) + UV ord + CODE: + RETVAL = isALPHA_L1(ord); + OUTPUT: + RETVAL + +bool +isWORDCHAR(ord) + UV ord CODE: RETVAL = isWORDCHAR(ord); OUTPUT: RETVAL bool -test_isWORDCHAR_A(UV ord) +isWORDCHAR_A(ord) + UV ord CODE: RETVAL = isWORDCHAR_A(ord); OUTPUT: RETVAL bool -test_isALPHANUMERIC(UV ord) +isWORDCHAR_L1(ord) + UV ord + CODE: + RETVAL = isWORDCHAR_L1(ord); + OUTPUT: + RETVAL + +bool +isALPHANUMERIC(ord) + UV ord CODE: RETVAL = isALPHANUMERIC(ord); OUTPUT: RETVAL bool -test_isALPHANUMERIC_A(UV ord) +isALPHANUMERIC_A(ord) + UV ord CODE: RETVAL = isALPHANUMERIC_A(ord); OUTPUT: RETVAL bool -test_isALNUM(UV ord) +isALNUM(ord) + UV ord CODE: RETVAL = isALNUM(ord); OUTPUT: RETVAL bool -test_isALNUM_A(UV ord) +isALNUM_A(ord) + UV ord CODE: RETVAL = isALNUM_A(ord); OUTPUT: RETVAL bool -test_isDIGIT(UV ord) +isDIGIT(ord) + UV ord CODE: RETVAL = isDIGIT(ord); OUTPUT: RETVAL bool -test_isDIGIT_A(UV ord) +isDIGIT_A(ord) + UV ord CODE: RETVAL = isDIGIT_A(ord); OUTPUT: RETVAL bool -test_isOCTAL(UV ord) +isOCTAL(ord) + UV ord CODE: RETVAL = isOCTAL(ord); OUTPUT: RETVAL bool -test_isOCTAL_A(UV ord) +isOCTAL_A(ord) + UV ord CODE: RETVAL = isOCTAL_A(ord); OUTPUT: RETVAL bool -test_isIDFIRST(UV ord) +isIDFIRST(ord) + UV ord CODE: RETVAL = isIDFIRST(ord); OUTPUT: RETVAL bool -test_isIDFIRST_A(UV ord) +isIDFIRST_A(ord) + UV ord CODE: RETVAL = isIDFIRST_A(ord); OUTPUT: RETVAL bool -test_isIDCONT(UV ord) +isIDCONT(ord) + UV ord CODE: RETVAL = isIDCONT(ord); OUTPUT: RETVAL bool -test_isIDCONT_A(UV ord) +isIDCONT_A(ord) + UV ord CODE: RETVAL = isIDCONT_A(ord); OUTPUT: RETVAL bool -test_isSPACE(UV ord) +isSPACE(ord) + UV ord CODE: RETVAL = isSPACE(ord); OUTPUT: RETVAL bool -test_isSPACE_A(UV ord) +isSPACE_A(ord) + UV ord CODE: RETVAL = isSPACE_A(ord); OUTPUT: RETVAL bool -test_isASCII(UV ord) +isASCII(ord) + UV ord CODE: RETVAL = isASCII(ord); OUTPUT: RETVAL bool -test_isASCII_A(UV ord) +isASCII_A(ord) + UV ord CODE: RETVAL = isASCII_A(ord); OUTPUT: RETVAL bool -test_isCNTRL(UV ord) +isCNTRL(ord) + UV ord CODE: RETVAL = isCNTRL(ord); OUTPUT: RETVAL bool -test_isCNTRL_A(UV ord) +isCNTRL_A(ord) + UV ord CODE: RETVAL = isCNTRL_A(ord); OUTPUT: RETVAL bool -test_isPRINT(UV ord) +isPRINT(ord) + UV ord CODE: RETVAL = isPRINT(ord); OUTPUT: RETVAL bool -test_isPRINT_A(UV ord) +isPRINT_A(ord) + UV ord CODE: RETVAL = isPRINT_A(ord); OUTPUT: RETVAL bool -test_isGRAPH(UV ord) +isGRAPH(ord) + UV ord CODE: RETVAL = isGRAPH(ord); OUTPUT: RETVAL bool -test_isGRAPH_A(UV ord) +isGRAPH_A(ord) + UV ord CODE: RETVAL = isGRAPH_A(ord); OUTPUT: RETVAL bool -test_isPUNCT(UV ord) +isPUNCT(ord) + UV ord CODE: RETVAL = isPUNCT(ord); OUTPUT: RETVAL bool -test_isPUNCT_A(UV ord) +isPUNCT_A(ord) + UV ord CODE: RETVAL = isPUNCT_A(ord); OUTPUT: RETVAL bool -test_isXDIGIT(UV ord) +isXDIGIT(ord) + UV ord CODE: RETVAL = isXDIGIT(ord); OUTPUT: RETVAL bool -test_isXDIGIT_A(UV ord) +isXDIGIT_A(ord) + UV ord CODE: RETVAL = isXDIGIT_A(ord); OUTPUT: RETVAL bool -test_isPSXSPC(UV ord) +isPSXSPC(ord) + UV ord CODE: RETVAL = isPSXSPC(ord); OUTPUT: RETVAL bool -test_isPSXSPC_A(UV ord) +isPSXSPC_A(ord) + UV ord CODE: RETVAL = isPSXSPC_A(ord); OUTPUT: RETVAL +bool +isALPHANUMERIC_L1(ord) + UV ord + CODE: + RETVAL = isALPHANUMERIC_L1(ord); + OUTPUT: + RETVAL + +bool +isALNUMC_L1(ord) + UV ord + CODE: + RETVAL = isALNUMC_L1(ord); + OUTPUT: + RETVAL + +bool +isDIGIT_L1(ord) + UV ord + CODE: + RETVAL = isDIGIT_L1(ord); + OUTPUT: + RETVAL + +bool +isOCTAL_L1(ord) + UV ord + CODE: + RETVAL = isOCTAL_L1(ord); + OUTPUT: + RETVAL + +bool +isIDFIRST_L1(ord) + UV ord + CODE: + RETVAL = isIDFIRST_L1(ord); + OUTPUT: + RETVAL + +bool +isIDCONT_L1(ord) + UV ord + CODE: + RETVAL = isIDCONT_L1(ord); + OUTPUT: + RETVAL + +bool +isSPACE_L1(ord) + UV ord + CODE: + RETVAL = isSPACE_L1(ord); + OUTPUT: + RETVAL + +bool +isASCII_L1(ord) + UV ord + CODE: + RETVAL = isASCII_L1(ord); + OUTPUT: + RETVAL + +bool +isCNTRL_L1(ord) + UV ord + CODE: + RETVAL = isCNTRL_L1(ord); + OUTPUT: + RETVAL + +bool +isPRINT_L1(ord) + UV ord + CODE: + RETVAL = isPRINT_L1(ord); + OUTPUT: + RETVAL + +bool +isGRAPH_L1(ord) + UV ord + CODE: + RETVAL = isGRAPH_L1(ord); + OUTPUT: + RETVAL + +bool +isPUNCT_L1(ord) + UV ord + CODE: + RETVAL = isPUNCT_L1(ord); + OUTPUT: + RETVAL + +bool +isXDIGIT_L1(ord) + UV ord + CODE: + RETVAL = isXDIGIT_L1(ord); + OUTPUT: + RETVAL + +bool +isPSXSPC_L1(ord) + UV ord + CODE: + RETVAL = isPSXSPC_L1(ord); + OUTPUT: + RETVAL + +bool +isASCII_uvchr(ord) + UV ord + CODE: + RETVAL = isASCII_uvchr(ord); + OUTPUT: + RETVAL + +bool +isASCII_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + PERL_UNUSED_ARG(offset); + RETVAL = isASCII_utf8_safe(s, s + 1 + offset); + OUTPUT: + RETVAL + +#if { VERSION >= 5.006 } + +bool +isBLANK_uvchr(ord) + UV ord + CODE: + RETVAL = isBLANK_uvchr(ord); + OUTPUT: + RETVAL + +bool +isALPHA_uvchr(ord) + UV ord + CODE: + RETVAL = isALPHA_uvchr(ord); + OUTPUT: + RETVAL + +bool +isALPHANUMERIC_uvchr(ord) + UV ord + CODE: + RETVAL = isALPHANUMERIC_uvchr(ord); + OUTPUT: + RETVAL + +bool +isCNTRL_uvchr(ord) + UV ord + CODE: + RETVAL = isCNTRL_uvchr(ord); + OUTPUT: + RETVAL + +bool +isDIGIT_uvchr(ord) + UV ord + CODE: + RETVAL = isDIGIT_uvchr(ord); + OUTPUT: + RETVAL + +bool +isIDFIRST_uvchr(ord) + UV ord + CODE: + RETVAL = isIDFIRST_uvchr(ord); + OUTPUT: + RETVAL + +bool +isIDCONT_uvchr(ord) + UV ord + CODE: + RETVAL = isIDCONT_uvchr(ord); + OUTPUT: + RETVAL + +bool +isGRAPH_uvchr(ord) + UV ord + CODE: + RETVAL = isGRAPH_uvchr(ord); + OUTPUT: + RETVAL + +bool +isLOWER_uvchr(ord) + UV ord + CODE: + RETVAL = isLOWER_uvchr(ord); + OUTPUT: + RETVAL + +bool +isPRINT_uvchr(ord) + UV ord + CODE: + RETVAL = isPRINT_uvchr(ord); + OUTPUT: + RETVAL + +bool +isPSXSPC_uvchr(ord) + UV ord + CODE: + RETVAL = isPSXSPC_uvchr(ord); + OUTPUT: + RETVAL + +bool +isPUNCT_uvchr(ord) + UV ord + CODE: + RETVAL = isPUNCT_uvchr(ord); + OUTPUT: + RETVAL + +bool +isSPACE_uvchr(ord) + UV ord + CODE: + RETVAL = isSPACE_uvchr(ord); + OUTPUT: + RETVAL + +bool +isUPPER_uvchr(ord) + UV ord + CODE: + RETVAL = isUPPER_uvchr(ord); + OUTPUT: + RETVAL + +bool +isWORDCHAR_uvchr(ord) + UV ord + CODE: + RETVAL = isWORDCHAR_uvchr(ord); + OUTPUT: + RETVAL + +bool +isXDIGIT_uvchr(ord) + UV ord + CODE: + RETVAL = isXDIGIT_uvchr(ord); + OUTPUT: + RETVAL + +bool +isALPHA_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isALPHA_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isALPHANUMERIC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isALPHANUMERIC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isBLANK_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isBLANK_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isCNTRL_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isCNTRL_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isDIGIT_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isDIGIT_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isGRAPH_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isGRAPH_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isIDCONT_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isIDCONT_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isIDFIRST_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isIDFIRST_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isLOWER_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isLOWER_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isPRINT_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isPRINT_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isPSXSPC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isPSXSPC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isPUNCT_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isPUNCT_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isSPACE_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isSPACE_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isUPPER_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isUPPER_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isWORDCHAR_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isWORDCHAR_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isXDIGIT_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isXDIGIT_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isALPHA_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isALPHA_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isALPHANUMERIC_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isALPHANUMERIC_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isASCII_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + PERL_UNUSED_ARG(offset); + RETVAL = isASCII_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isBLANK_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isBLANK_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isCNTRL_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isCNTRL_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isDIGIT_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isDIGIT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isGRAPH_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isGRAPH_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isIDCONT_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isIDCONT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isIDFIRST_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isIDFIRST_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isLOWER_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isLOWER_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isPRINT_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isPRINT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isPSXSPC_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isPSXSPC_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isPUNCT_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isPUNCT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isSPACE_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isSPACE_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isUPPER_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isUPPER_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isWORDCHAR_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isWORDCHAR_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +bool +isXDIGIT_LC_utf8_safe(s, offset) + unsigned char * s + int offset + CODE: + RETVAL = isXDIGIT_LC_utf8_safe(s, s + UTF8SKIP(s) + offset); + OUTPUT: + RETVAL + +AV * +toLOWER_utf8_safe(s, offset) + unsigned char * s + int offset + PREINIT: + U8 u[UTF8_MAXBYTES+1]; + Size_t len; + UV ret; + SV* utf8; + AV * av; + CODE: + av = newAV(); + ret = toLOWER_utf8_safe(s, s + UTF8SKIP(s) + offset, u, &len); + av_push(av, newSVuv(ret)); + + utf8 = newSVpvn((char *) u, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +toTITLE_utf8_safe(s, offset) + unsigned char * s + int offset + PREINIT: + U8 u[UTF8_MAXBYTES+1]; + Size_t len; + UV ret; + SV* utf8; + AV * av; + CODE: + av = newAV(); + ret = toTITLE_utf8_safe(s, s + UTF8SKIP(s) + offset, u, &len); + av_push(av, newSVuv(ret)); + + utf8 = newSVpvn((char *) u, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +toUPPER_utf8_safe(s, offset) + unsigned char * s + int offset + PREINIT: + U8 u[UTF8_MAXBYTES+1]; + Size_t len; + UV ret; + SV* utf8; + AV * av; + CODE: + av = newAV(); + ret = toUPPER_utf8_safe(s, s + UTF8SKIP(s) + offset, u, &len); + av_push(av, newSVuv(ret)); + + utf8 = newSVpvn((char *) u, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +toFOLD_utf8_safe(s, offset) + unsigned char * s + int offset + PREINIT: + U8 u[UTF8_MAXBYTES+1]; + Size_t len; + UV ret; + SV* utf8; + AV * av; + CODE: + av = newAV(); + ret = toFOLD_utf8_safe(s, s + UTF8SKIP(s) + offset, u, &len); + av_push(av, newSVuv(ret)); + + utf8 = newSVpvn((char *) u, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +toLOWER_uvchr(c) + UV c + PREINIT: + U8 u[UTF8_MAXBYTES+1]; + Size_t len; + UV ret; + SV* utf8; + AV * av; + CODE: + av = newAV(); + ret = toLOWER_uvchr(c, u, &len); + av_push(av, newSVuv(ret)); + + utf8 = newSVpvn((char *) u, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +toTITLE_uvchr(c) + UV c + PREINIT: + U8 u[UTF8_MAXBYTES+1]; + Size_t len; + UV ret; + SV* utf8; + AV * av; + CODE: + av = newAV(); + ret = toTITLE_uvchr(c, u, &len); + av_push(av, newSVuv(ret)); + + utf8 = newSVpvn((char *) u, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +toUPPER_uvchr(c) + UV c + PREINIT: + U8 u[UTF8_MAXBYTES+1]; + Size_t len; + UV ret; + SV* utf8; + AV * av; + CODE: + av = newAV(); + ret = toUPPER_uvchr(c, u, &len); + av_push(av, newSVuv(ret)); + + utf8 = newSVpvn((char *) u, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +toFOLD_uvchr(c) + UV c + PREINIT: + U8 u[UTF8_MAXBYTES+1]; + Size_t len; + UV ret; + SV* utf8; + AV * av; + CODE: + av = newAV(); + ret = toFOLD_uvchr(c, u, &len); + av_push(av, newSVuv(ret)); + + utf8 = newSVpvn((char *) u, len); + SvUTF8_on(utf8); + av_push(av, utf8); + + av_push(av, newSVuv(len)); + RETVAL = av; + OUTPUT: + RETVAL + +#endif + +UV +LATIN1_TO_NATIVE(cp) + UV cp + CODE: + if (cp > 255) RETVAL= cp; + else RETVAL= LATIN1_TO_NATIVE(cp); + OUTPUT: + RETVAL + +UV +NATIVE_TO_LATIN1(cp) + UV cp + CODE: + RETVAL= NATIVE_TO_LATIN1(cp); + OUTPUT: + RETVAL + STRLEN av_tindex(av) - AV *av + SV *av CODE: - RETVAL = av_tindex(av); + RETVAL = av_tindex((AV*)SvRV(av)); OUTPUT: RETVAL STRLEN av_top_index(av) - AV *av + SV *av CODE: - RETVAL = av_top_index(av); + RETVAL = av_top_index((AV*)SvRV(av)); OUTPUT: RETVAL -=tests plan => 128 +=tests plan => 26826 use vars qw($my_sv @my_av %my_hv); -ok(&Devel::PPPort::boolSV(1)); -ok(!&Devel::PPPort::boolSV(0)); +ok(&Devel::PPPort::boolSV(1), "Verify boolSV(1) is true"); +ok(!&Devel::PPPort::boolSV(0), "Verify boolSV(0) is false"); $_ = "Fred"; -ok(&Devel::PPPort::DEFSV(), "Fred"); -ok(&Devel::PPPort::UNDERBAR(), "Fred"); +is(&Devel::PPPort::DEFSV(), "Fred", '$_ is FRED; Verify DEFSV is FRED'); +is(&Devel::PPPort::UNDERBAR(), "Fred", 'And verify UNDERBAR is FRED'); -if ("$]" >= 5.009002 && "$]" < 5.023 && "$]" < 5.023004) { +if (ivers($]) >= ivers(5.9.2) && ivers($]) < ivers(5.23)) { eval q{ no warnings "deprecated"; - no if $^V > v5.17.9, warnings => "experimental::lexical_topic"; + no if $^V >= v5.17.9, warnings => "experimental::lexical_topic"; my $_ = "Tony"; - ok(&Devel::PPPort::DEFSV(), "Fred"); - ok(&Devel::PPPort::UNDERBAR(), "Tony"); + is(&Devel::PPPort::DEFSV(), "Fred", 'lexical_topic eval: $_ is Tony; Verify DEFSV is Fred'); + is(&Devel::PPPort::UNDERBAR(), "Tony", 'And verify UNDERBAR is Tony'); }; + die __FILE__ . __LINE__ . ": $@" if $@; } else { - ok(1); - ok(1); + skip("perl version outside testing range of lexical_topic", 2); } my @r = &Devel::PPPort::DEFSV_modify(); -ok(@r == 3); -ok($r[0], 'Fred'); -ok($r[1], 'DEFSV'); -ok($r[2], 'Fred'); +ok(@r == 3, "Verify got 3 elements"); +is($r[0], 'Fred'); +is($r[1], 'DEFSV'); +is($r[2], 'Fred'); -ok(&Devel::PPPort::DEFSV(), "Fred"); +is(&Devel::PPPort::DEFSV(), "Fred"); eval { 1 }; -ok(!&Devel::PPPort::ERRSV()); +ok(!&Devel::PPPort::ERRSV(), "Verify ERRSV on true is false"); eval { cannot_call_this_one() }; -ok(&Devel::PPPort::ERRSV()); +ok(&Devel::PPPort::ERRSV(), "Verify ERRSV on false is true"); ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0)); ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0)); @@ -1199,177 +2590,386 @@ ok(&Devel::PPPort::get_cv('my_cv', 0)); ok(!&Devel::PPPort::get_cv('not_my_cv', 0)); ok(&Devel::PPPort::get_cv('not_my_cv', 1)); -ok(Devel::PPPort::dXSTARG(42), 43); -ok(Devel::PPPort::dAXMARK(4711), 4710); +is(Devel::PPPort::dXSTARG(42), 43); +is(Devel::PPPort::dAXMARK(4711), 4710); -ok(Devel::PPPort::prepush(), 42); +is(Devel::PPPort::prepush(), 42); -ok(join(':', Devel::PPPort::xsreturn(0)), 'test1'); -ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2'); +is(join(':', Devel::PPPort::xsreturn(0)), 'test1'); +is(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2'); -ok(Devel::PPPort::PERL_ABS(42), 42); -ok(Devel::PPPort::PERL_ABS(-13), 13); +is(Devel::PPPort::PERL_ABS(42), 42, "Verify PERL_ABS(42) is 42"); +is(Devel::PPPort::PERL_ABS(-13), 13, "Verify PERL_ABS(-13) is 13"); -ok(Devel::PPPort::SVf(42), "$]" >= 5.004 ? '[42]' : '42'); -ok(Devel::PPPort::SVf('abc'), "$]" >= 5.004 ? '[abc]' : 'abc'); +is(Devel::PPPort::SVf(42), ivers($]) >= ivers(5.4) ? '[42]' : '42'); +is(Devel::PPPort::SVf('abc'), ivers($]) >= ivers(5.4) ? '[abc]' : 'abc'); -ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo"); +is(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo"); -ok(&Devel::PPPort::ptrtests(), 63); +is(&Devel::PPPort::ptrtests(), 63); -ok(&Devel::PPPort::OpSIBLING_tests(), 0); +is(&Devel::PPPort::OpSIBLING_tests(), 0); -if ("$]" >= 5.009000) { +if (ivers($]) >= ivers(5.9)) { eval q{ - ok(&Devel::PPPort::check_HeUTF8("hello"), "norm"); - ok(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8"); + is(&Devel::PPPort::check_HeUTF8("hello"), "norm"); + is(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8"); }; } else { - ok(1, 1); - ok(1, 1); + skip("Too early perl version", 2); } @r = &Devel::PPPort::check_c_array(); -ok($r[0], 4); -ok($r[1], "13"); +is($r[0], 4); +is($r[1], "13"); ok(!Devel::PPPort::SvRXOK("")); ok(!Devel::PPPort::SvRXOK(bless [], "Regexp")); -if ("$]" < 5.005) { - skip 'no qr// objects in this perl', 0; - skip 'no qr// objects in this perl', 0; +if (ivers($]) < ivers(5.5)) { + skip 'no qr// objects in this perl', 2; } else { my $qr = eval 'qr/./'; - ok(Devel::PPPort::SvRXOK($qr)); + ok(Devel::PPPort::SvRXOK($qr), "SVRXOK(qr) is true"); ok(Devel::PPPort::SvRXOK(bless $qr, "Surprise")); } -ok( Devel::PPPort::test_isBLANK(ord(" "))); -ok(! Devel::PPPort::test_isBLANK(ord("\n"))); - -ok( Devel::PPPort::test_isBLANK_A(ord("\t"))); -ok(! Devel::PPPort::test_isBLANK_A(ord("\r"))); - -ok( Devel::PPPort::test_isUPPER(ord("A"))); -ok(! Devel::PPPort::test_isUPPER(ord("a"))); - -ok( Devel::PPPort::test_isUPPER_A(ord("Z"))); - -# One of these two is uppercase in EBCDIC; the other in Latin1, but neither are -# ASCII uppercase. -ok(! Devel::PPPort::test_isUPPER_A(ord(0xDC))); -ok(! Devel::PPPort::test_isUPPER_A(ord(0xFC))); - -ok( Devel::PPPort::test_isLOWER(ord("b"))); -ok(! Devel::PPPort::test_isLOWER(ord("B"))); - -ok( Devel::PPPort::test_isLOWER_A(ord("y"))); - -# One of these two is lowercase in EBCDIC; the other in Latin1, but neither are -# ASCII lowercase. -ok(! Devel::PPPort::test_isLOWER_A(ord(0xDC))); -ok(! Devel::PPPort::test_isLOWER_A(ord(0xFC))); - -ok( Devel::PPPort::test_isALPHA(ord("C"))); -ok(! Devel::PPPort::test_isALPHA(ord("1"))); - -ok( Devel::PPPort::test_isALPHA_A(ord("x"))); -ok(! Devel::PPPort::test_isALPHA_A(0xDC)); - -ok( Devel::PPPort::test_isWORDCHAR(ord("_"))); -ok(! Devel::PPPort::test_isWORDCHAR(ord("@"))); - -ok( Devel::PPPort::test_isWORDCHAR_A(ord("2"))); -ok(! Devel::PPPort::test_isWORDCHAR_A(0xFC)); - -ok( Devel::PPPort::test_isALPHANUMERIC(ord("4"))); -ok(! Devel::PPPort::test_isALPHANUMERIC(ord("_"))); - -ok( Devel::PPPort::test_isALPHANUMERIC_A(ord("l"))); -ok(! Devel::PPPort::test_isALPHANUMERIC_A(0xDC)); - -ok( Devel::PPPort::test_isALNUM(ord("c"))); -ok(! Devel::PPPort::test_isALNUM(ord("}"))); - -ok( Devel::PPPort::test_isALNUM_A(ord("5"))); -ok(! Devel::PPPort::test_isALNUM_A(0xFC)); - -ok( Devel::PPPort::test_isDIGIT(ord("6"))); -ok(! Devel::PPPort::test_isDIGIT(ord("_"))); - -ok( Devel::PPPort::test_isDIGIT_A(ord("7"))); -ok(! Devel::PPPort::test_isDIGIT_A(0xDC)); - -ok( Devel::PPPort::test_isOCTAL(ord("7"))); -ok(! Devel::PPPort::test_isOCTAL(ord("8"))); +ok( Devel::PPPort::NATIVE_TO_LATIN1(0xB6) == 0xB6); +ok( Devel::PPPort::NATIVE_TO_LATIN1(0x1) == 0x1); +ok( Devel::PPPort::NATIVE_TO_LATIN1(ord("A")) == 0x41); +ok( Devel::PPPort::NATIVE_TO_LATIN1(ord("0")) == 0x30); -ok( Devel::PPPort::test_isOCTAL_A(ord("0"))); -ok(! Devel::PPPort::test_isOCTAL_A(ord("9"))); - -ok( Devel::PPPort::test_isIDFIRST(ord("D"))); -ok(! Devel::PPPort::test_isIDFIRST(ord("1"))); - -ok( Devel::PPPort::test_isIDFIRST_A(ord("_"))); -ok(! Devel::PPPort::test_isIDFIRST_A(0xFC)); - -ok( Devel::PPPort::test_isIDCONT(ord("e"))); -ok(! Devel::PPPort::test_isIDCONT(ord("@"))); - -ok( Devel::PPPort::test_isIDCONT_A(ord("2"))); -ok(! Devel::PPPort::test_isIDCONT_A(0xDC)); - -ok( Devel::PPPort::test_isSPACE(ord(" "))); -ok(! Devel::PPPort::test_isSPACE(ord("_"))); - -ok( Devel::PPPort::test_isSPACE_A(ord("\cK"))); -ok(! Devel::PPPort::test_isSPACE_A(ord("F"))); - -# This stresses the edge for ASCII machines, but happens to work on EBCDIC as -# well -ok( Devel::PPPort::test_isASCII(0x7F)); -ok(! Devel::PPPort::test_isASCII(0x80)); - -ok( Devel::PPPort::test_isASCII_A(ord("9"))); - -# B6 is the PARAGRAPH SIGN in ASCII and EBCDIC -ok(! Devel::PPPort::test_isASCII_A(0xB6)); - -ok( Devel::PPPort::test_isCNTRL(ord("\e"))); -ok(! Devel::PPPort::test_isCNTRL(ord(" "))); +ok( Devel::PPPort::LATIN1_TO_NATIVE(0xB6) == 0xB6, "Verify LATIN1_TO_NATIVE(0xB6) is 0xB6"); +if (ord("A") == 65) { + ok( Devel::PPPort::LATIN1_TO_NATIVE(0x41) == 0x41); + ok( Devel::PPPort::LATIN1_TO_NATIVE(0x30) == 0x30); +} +else { + ok( Devel::PPPort::LATIN1_TO_NATIVE(0x41) == 0xC1); + ok( Devel::PPPort::LATIN1_TO_NATIVE(0x30) == 0xF0); +} -ok( Devel::PPPort::test_isCNTRL_A(ord("\a"))); -ok(! Devel::PPPort::test_isCNTRL_A(0xB6)); +ok( Devel::PPPort::isALNUMC_L1(ord("5"))); +ok( Devel::PPPort::isALNUMC_L1(0xFC)); +ok(! Devel::PPPort::isALNUMC_L1(0xB6)); -ok( Devel::PPPort::test_isPRINT(ord(" "))); -ok(! Devel::PPPort::test_isPRINT(ord("\n"))); +ok( Devel::PPPort::isOCTAL(ord("7")), "Verify '7' is OCTAL"); +ok(! Devel::PPPort::isOCTAL(ord("8")), "Verify '8' isn't OCTAL"); -ok( Devel::PPPort::test_isPRINT_A(ord("G"))); -ok(! Devel::PPPort::test_isPRINT_A(0xB6)); +ok( Devel::PPPort::isOCTAL_A(ord("0")), "Verify '0' is OCTAL_A"); +ok(! Devel::PPPort::isOCTAL_A(ord("9")), "Verify '9' isn't OCTAL_A"); -ok( Devel::PPPort::test_isGRAPH(ord("h"))); -ok(! Devel::PPPort::test_isGRAPH(ord(" "))); +ok( Devel::PPPort::isOCTAL_L1(ord("2")), "Verify '2' is OCTAL_L1"); +ok(! Devel::PPPort::isOCTAL_L1(ord("8")), "Verify '8' isn't OCTAL_L1"); -ok( Devel::PPPort::test_isGRAPH_A(ord("i"))); -ok(! Devel::PPPort::test_isGRAPH_A(0xB6)); +my $way_too_early_msg = 'UTF-8 not implemented on this perl'; -ok( Devel::PPPort::test_isPUNCT(ord("#"))); -ok(! Devel::PPPort::test_isPUNCT(ord(" "))); +# For the other properties, we test every code point from 0.255, and a +# smattering of higher ones. First populate a hash with keys like '65:ALPHA' +# to indicate that the code point there is alphabetic +my $i; +my %types; +for $i (0x41..0x5A, 0x61..0x7A, 0xAA, 0xB5, 0xBA, 0xC0..0xD6, 0xD8..0xF6, + 0xF8..0x101) +{ + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:ALPHA"} = 1; + $types{"$native:ALPHANUMERIC"} = 1; + $types{"$native:IDFIRST"} = 1; + $types{"$native:IDCONT"} = 1; + $types{"$native:PRINT"} = 1; + $types{"$native:WORDCHAR"} = 1; +} +for $i (0x30..0x39, 0x660, 0xFF19) { + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:ALPHANUMERIC"} = 1; + $types{"$native:DIGIT"} = 1; + $types{"$native:IDCONT"} = 1; + $types{"$native:WORDCHAR"} = 1; + $types{"$native:GRAPH"} = 1; + $types{"$native:PRINT"} = 1; + $types{"$native:XDIGIT"} = 1 if $i < 255 || ($i >= 0xFF10 && $i <= 0xFF19); +} -ok( Devel::PPPort::test_isPUNCT_A(ord("*"))); -ok(! Devel::PPPort::test_isPUNCT_A(0xB6)); +for $i (0..0x7F) { + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:ASCII"} = 1; +} +for $i (0..0x1f, 0x7F..0x9F) { + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:CNTRL"} = 1; +} +for $i (0x21..0x7E, 0xA1..0x101, 0x660) { + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:GRAPH"} = 1; + $types{"$native:PRINT"} = 1; +} +for $i (0x09, 0x20, 0xA0) { + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:BLANK"} = 1; + $types{"$native:SPACE"} = 1; + $types{"$native:PSXSPC"} = 1; + $types{"$native:PRINT"} = 1 if $i > 0x09; +} +for $i (0x09..0x0D, 0x85, 0x2029) { + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:SPACE"} = 1; + $types{"$native:PSXSPC"} = 1; +} +for $i (0x41..0x5A, 0xC0..0xD6, 0xD8..0xDE, 0x100) { + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:UPPER"} = 1; + $types{"$native:XDIGIT"} = 1 if $i < 0x47; +} +for $i (0x61..0x7A, 0xAA, 0xB5, 0xBA, 0xDF..0xF6, 0xF8..0xFF, 0x101) { + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:LOWER"} = 1; + $types{"$native:XDIGIT"} = 1 if $i < 0x67; +} +for $i (0x21..0x2F, 0x3A..0x40, 0x5B..0x60, 0x7B..0x7E, 0xB6, 0xA1, 0xA7, 0xAB, + 0xB7, 0xBB, 0xBF, 0x5BE) +{ + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + $types{"$native:PUNCT"} = 1; + $types{"$native:GRAPH"} = 1; + $types{"$native:PRINT"} = 1; +} -ok( Devel::PPPort::test_isXDIGIT(ord("A"))); -ok(! Devel::PPPort::test_isXDIGIT(ord("_"))); +$i = ord('_'); +$types{"$i:WORDCHAR"} = 1; +$types{"$i:IDFIRST"} = 1; +$types{"$i:IDCONT"} = 1; + +# Now find all the unique code points included above. +my %code_points_to_test; +my $key; +for $key (keys %types) { + $key =~ s/:.*//; + $code_points_to_test{$key} = 1; +} -ok( Devel::PPPort::test_isXDIGIT_A(ord("9"))); -ok(! Devel::PPPort::test_isXDIGIT_A(0xDC)); +# And test each one +for $i (sort { $a <=> $b } keys %code_points_to_test) { + my $native = Devel::PPPort::LATIN1_TO_NATIVE($i); + my $hex = sprintf("0x%02X", $native); + + # And for each code point test each of the classes + my $class; + for $class (qw(ALPHA ALPHANUMERIC ASCII BLANK CNTRL DIGIT GRAPH IDCONT + IDFIRST LOWER PRINT PSXSPC PUNCT SPACE UPPER WORDCHAR + XDIGIT)) + { + if ($i < 256) { # For the ones that can fit in a byte, test each of + # three macros. + my $suffix; + for $suffix ("", "_A", "_L1", "_uvchr") { + my $should_be = ($i > 0x7F && $suffix !~ /_(uvchr|L1)/) + ? 0 # Fail on non-ASCII unless unicode + : ($types{"$native:$class"} || 0); + if (ivers($]) < ivers(5.6) && $suffix eq '_uvchr') { + skip("No UTF-8 on this perl", 1); + next; + } -ok( Devel::PPPort::test_isPSXSPC(ord(" "))); -ok(! Devel::PPPort::test_isPSXSPC(ord("k"))); + my $eval_string = "Devel::PPPort::is${class}$suffix($hex)"; + local $SIG{__WARN__} = sub {}; + my $is = eval $eval_string || 0; + die "eval 'For $i: $eval_string' gave $@" if $@; + is($is, $should_be, "'$eval_string'"); + } + } + + # For all code points, test the '_utf8' macros + my $sub_fcn; + for $sub_fcn ("", "_LC") { + my $skip = ""; + if (ivers($]) < ivers(5.6)) { + $skip = $way_too_early_msg; + } + elsif (ivers($]) < ivers(5.7) && $native > 255) { + $skip = "Perls earlier than 5.7 give wrong answers for above Latin1 code points"; + } + elsif (ivers($]) <= ivers(5.11.3) && $native == 0x2029 && ($class eq 'PRINT' || $class eq 'GRAPH')) { + $skip = "Perls earlier than 5.11.3 considered high space characters as isPRINT and isGRAPH"; + } + elsif ($sub_fcn eq '_LC' && $i < 256) { + $skip = "Testing of code points whose results depend on locale is skipped "; + } + my $fcn = "Devel::PPPort::is${class}${sub_fcn}_utf8_safe"; + my $utf8; + + if ($skip) { + skip $skip, 1; + } + else { + $utf8 = quotemeta Devel::PPPort::uvchr_to_utf8($native); + my $should_be = $types{"$native:$class"} || 0; + my $eval_string = "$fcn(\"$utf8\", 0)"; + local $SIG{__WARN__} = sub {}; + my $is = eval $eval_string || 0; + die "eval 'For $i, $eval_string' gave $@" if $@; + is($is, $should_be, sprintf("For U+%04X '%s'", $native, $eval_string)); + } + + # And for the high code points, test that a too short malformation (the + # -1) causes it to fail + if ($i > 255) { + if ($skip) { + skip $skip, 1; + } + elsif (ivers($]) >= ivers(5.25.9)) { + skip("Prints an annoying error message that khw doesn't know how to easily suppress", 1); + } + else { + my $eval_string = "$fcn(\"$utf8\", -1)"; + local $SIG{__WARN__} = sub {}; + my $is = eval "$eval_string" || 0; + die "eval '$eval_string' gave $@" if $@; + is($is, 0, sprintf("For U+%04X '%s'", $native, $eval_string)); + } + } + } + } +} -ok( Devel::PPPort::test_isPSXSPC_A(ord("\cK"))); -ok(! Devel::PPPort::test_isPSXSPC_A(0xFC)); +my %case_changing = ( 'LOWER' => [ [ ord('A'), ord('a') ], + [ Devel::PPPort::LATIN1_TO_NATIVE(0xC0), + Devel::PPPort::LATIN1_TO_NATIVE(0xE0) ], + [ 0x100, 0x101 ], + ], + 'FOLD' => [ [ ord('C'), ord('c') ], + [ Devel::PPPort::LATIN1_TO_NATIVE(0xC0), + Devel::PPPort::LATIN1_TO_NATIVE(0xE0) ], + [ 0x104, 0x105 ], + [ Devel::PPPort::LATIN1_TO_NATIVE(0xDF), + 'ss' ], + ], + 'UPPER' => [ [ ord('a'), ord('A'), ], + [ Devel::PPPort::LATIN1_TO_NATIVE(0xE0), + Devel::PPPort::LATIN1_TO_NATIVE(0xC0) ], + [ 0x101, 0x100 ], + [ Devel::PPPort::LATIN1_TO_NATIVE(0xDF), + 'SS' ], + ], + 'TITLE' => [ [ ord('c'), ord('C'), ], + [ Devel::PPPort::LATIN1_TO_NATIVE(0xE2), + Devel::PPPort::LATIN1_TO_NATIVE(0xC2) ], + [ 0x103, 0x102 ], + [ Devel::PPPort::LATIN1_TO_NATIVE(0xDF), + 'Ss' ], + ], + ); + +my $name; +for $name (keys %case_changing) { + my @code_points_to_test = @{$case_changing{$name}}; + my $unchanged; + for $unchanged (@code_points_to_test) { + my @pair = @$unchanged; + my $original = $pair[0]; + my $changed = $pair[1]; + my $utf8_changed = $changed; + my $is_cp = $utf8_changed =~ /^\d+$/; + my $should_be_bytes; + if (ivers($]) >= ivers(5.6)) { + if ($is_cp) { + $utf8_changed = Devel::PPPort::uvchr_to_utf8($changed); + $should_be_bytes = Devel::PPPort::UTF8_SAFE_SKIP($utf8_changed, 0); + } + else { + die("Test currently doesn't work for non-ASCII multi-char case changes") if eval '$utf8_changed =~ /[[:^ascii:]]/'; + $should_be_bytes = length $utf8_changed; + } + } + + my $fcn = "to${name}_uvchr"; + my $skip = ""; + + if (ivers($]) < ivers(5.6)) { + $skip = $way_too_early_msg; + } + elsif (! $is_cp) { + $skip = "Can't do uvchr on a multi-char string"; + } + if ($skip) { + skip $skip, 4; + } + else { + if ($is_cp) { + $utf8_changed = Devel::PPPort::uvchr_to_utf8($changed); + $should_be_bytes = Devel::PPPort::UTF8_SAFE_SKIP($utf8_changed, 0); + } + else { + my $non_ascii_re = (ivers($]) >= ivers(5.6)) ? '[[:^ascii:]]' : '[^\x00-\x7F]'; + die("Test currently doesn't work for non-ASCII multi-char case changes") if eval '$utf8_changed =~ /$non_ascii_re/'; + $should_be_bytes = length $utf8_changed; + } + + my $ret = eval "Devel::PPPort::$fcn($original)"; + my $fail = $@; # Have to save $@, as it gets destroyed + is ($fail, "", "$fcn($original) didn't fail"); + my $first = (ivers($]) != ivers(5.6)) + ? substr($utf8_changed, 0, 1) + : $utf8_changed, 0, 1; + is($ret->[0], ord $first, + "ord of $fcn($original) is $changed"); + is($ret->[1], $utf8_changed, + "UTF-8 of of $fcn($original) is correct"); + is($ret->[2], $should_be_bytes, + "Length of $fcn($original) is $should_be_bytes"); + } + + my $truncate; + for $truncate (0..2) { + my $skip; + if (ivers($]) < ivers(5.6)) { + $skip = $way_too_early_msg; + } + elsif (! $is_cp && ivers($]) < ivers(5.7.3)) { + $skip = "Multi-character case change not implemented until 5.7.3"; + } + elsif ($truncate == 2 && ivers($]) > ivers(5.25.8)) { + $skip = "Zero length inputs cause assertion failure; test dies in modern perls"; + } + elsif ($truncate > 0 && length $changed > 1) { + $skip = "Don't test shortened multi-char case changes"; + } + elsif ($truncate > 0 && Devel::PPPort::UVCHR_IS_INVARIANT($original)) { + $skip = "Don't try to test shortened single bytes"; + } + if ($skip) { + skip $skip, 4; + } + else { + my $fcn = "to${name}_utf8_safe"; + my $utf8 = quotemeta Devel::PPPort::uvchr_to_utf8($original); + my $real_truncate = ($truncate < 2) + ? $truncate : $should_be_bytes; + my $eval_string = "Devel::PPPort::$fcn(\"$utf8\", $real_truncate)"; + my $ret = eval "no warnings; $eval_string" || 0; + my $fail = $@; # Have to save $@, as it gets destroyed + if ($truncate == 0) { + is ($fail, "", "Didn't fail on full length input"); + my $first = (ivers($]) != ivers(5.6)) + ? substr($utf8_changed, 0, 1) + : $utf8_changed, 0, 1; + is($ret->[0], ord $first, + "ord of $fcn($original) is $changed"); + is($ret->[1], $utf8_changed, + "UTF-8 of of $fcn($original) is correct"); + is($ret->[2], $should_be_bytes, + "Length of $fcn($original) is $should_be_bytes"); + } + else { + is ($fail, eval 'qr/Malformed UTF-8 character/', + "Gave appropriate error for short char: $original"); + skip("Expected failure means remaining tests for" + . " this aren't relevant", 3); + } + } + } + } +} -ok(&Devel::PPPort::av_top_index([1,2,3]), 2); -ok(&Devel::PPPort::av_tindex([1,2,3,4]), 3); +is(&Devel::PPPort::av_top_index([1,2,3]), 2); +is(&Devel::PPPort::av_tindex([1,2,3,4]), 3); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newCONSTSUB b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newCONSTSUB index 336a8e00b8d..fe0a6ce1717 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newCONSTSUB +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newCONSTSUB @@ -13,6 +13,10 @@ newCONSTSUB +=dontwarn + +NEED_newCONSTSUB /* Because we define this weirdly */ + =implementation /* Hint: newCONSTSUB @@ -22,6 +26,11 @@ newCONSTSUB /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if { VERSION < 5.004_63 } && { VERSION != 5.004_05 } + +/* And before that, we need to make sure this gets compiled for the functions + * that rely on it */ +#define NEED_newCONSTSUB + #if { NEED newCONSTSUB } /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ @@ -43,13 +52,7 @@ newCONSTSUB(HV *stash, const char *name, SV *sv) newSUB( -#if { VERSION < 5.003_22 } - start_subparse(), -#elif { VERSION == 5.003_22 } - start_subparse(0), -#else /* 5.003_23 onwards */ start_subparse(FALSE, 0), -#endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ @@ -95,10 +98,10 @@ call_newCONSTSUB_3() =tests plan => 3 &Devel::PPPort::call_newCONSTSUB_1(); -ok(&Devel::PPPort::test_value_1(), 1); +is(&Devel::PPPort::test_value_1(), 1); &Devel::PPPort::call_newCONSTSUB_2(); -ok(&Devel::PPPort::test_value_2(), 2); +is(&Devel::PPPort::test_value_2(), 2); &Devel::PPPort::call_newCONSTSUB_3(); -ok(&Devel::PPPort::test_value_3(), 3); +is(&Devel::PPPort::test_value_3(), 3); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newRV b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newRV index 6db6dfc54fe..6be9ca55a8a 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newRV +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newRV @@ -19,21 +19,13 @@ newRV_noinc __UNDEFINED__ newRV_inc(sv) newRV(sv) /* Replace */ #ifndef newRV_noinc -#if { NEED newRV_noinc } -SV * -newRV_noinc(SV *sv) -{ - SV *rv = (SV *)newRV(sv); - SvREFCNT_dec(sv); - return rv; -} +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define newRV_noinc(sv) ({ SV *_sv = (SV *)newRV((sv)); SvREFCNT_dec((sv)); _sv; }) +#else +# define newRV_noinc(sv) ((PL_Sv = (SV *)newRV((sv))), SvREFCNT_dec((sv)), PL_Sv) #endif #endif -=xsinit - -#define NEED_newRV_noinc - =xsubs U32 @@ -63,5 +55,5 @@ newRV_noinc_REFCNT() =tests plan => 2 -ok(&Devel::PPPort::newRV_inc_REFCNT, 1); -ok(&Devel::PPPort::newRV_noinc_REFCNT, 1); +is(&Devel::PPPort::newRV_inc_REFCNT, 1); +is(&Devel::PPPort::newRV_noinc_REFCNT, 1); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newSV_type b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newSV_type index 039f8010bb5..4b17419917a 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newSV_type +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newSV_type @@ -16,25 +16,13 @@ newSV_type =implementation #ifndef newSV_type - -#if { NEED newSV_type } - -SV* -newSV_type(pTHX_ svtype const t) -{ - SV* const sv = newSV(0); - sv_upgrade(sv, t); - return sv; -} - +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define newSV_type(t) ({ SV *_sv = newSV(0); sv_upgrade(_sv, (t)); _sv; }) +#else +# define newSV_type(t) ((PL_Sv = newSV(0)), sv_upgrade(PL_Sv, (t)), PL_Sv) #endif - #endif -=xsinit - -#define NEED_newSV_type - =xsubs int @@ -76,4 +64,4 @@ newSV_type() =tests plan => 1 -ok(Devel::PPPort::newSV_type(), 4); +is(Devel::PPPort::newSV_type(), 4); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newSVpv b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newSVpv index 7dbe5d03b4f..22e2fb6daa3 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newSVpv +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newSVpv @@ -31,25 +31,13 @@ __UNDEFINED__ newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UT __UNDEFINED__ SVf_UTF8 0 #ifndef newSVpvn_flags - -#if { NEED newSVpvn_flags } - -SV * -newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags) -{ - SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); - SvFLAGS(sv) |= (flags & SVf_UTF8); - return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; -} - +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define newSVpvn_flags(s, len, flags) ({ SV *_sv = newSVpvn(D_PPP_CONSTPV_ARG((s)), (len)); SvFLAGS(_sv) |= ((flags) & SVf_UTF8); ((flags) & SVs_TEMP) ? sv_2mortal(_sv) : _sv; }) +#else +# define newSVpvn_flags(s, len, flags) ((PL_Sv = newSVpvn(D_PPP_CONSTPV_ARG((s)), (len))), SvFLAGS(PL_Sv) |= ((flags) & SVf_UTF8), (((flags) & SVs_TEMP) ? sv_2mortal(PL_Sv) : PL_Sv)) #endif - #endif -=xsinit - -#define NEED_newSVpvn_flags - =xsubs void @@ -82,28 +70,28 @@ newSVpvn_utf8() my @s = &Devel::PPPort::newSVpvn(); ok(@s == 5); -ok($s[0], "test"); -ok($s[1], "te"); -ok($s[2], ""); +is($s[0], "test"); +is($s[1], "te"); +is($s[2], ""); ok(!defined($s[3])); ok(!defined($s[4])); @s = &Devel::PPPort::newSVpvn_flags(); ok(@s == 5); -ok($s[0], "test"); -ok($s[1], "te"); -ok($s[2], ""); +is($s[0], "test"); +is($s[1], "te"); +is($s[2], ""); ok(!defined($s[3])); ok(!defined($s[4])); @s = &Devel::PPPort::newSVpvn_utf8(); ok(@s == 1); -ok($s[0], "test"); +is($s[0], "test"); if ("$]" >= 5.008001) { require utf8; ok(utf8::is_utf8($s[0])); } else { - skip("skip: no is_utf8()", 0); + skip("skip: no is_utf8()", 1); } diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/podtest b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/podtest index d7255b916f1..df18c3a4a82 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/podtest +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/podtest @@ -22,11 +22,11 @@ else { # Try loading Test::Pod eval q{ use Test::Pod; - $Test::Pod::VERSION >= 0.95 + $Test::Pod::VERSION >= 1.41 or die "Test::Pod version only $Test::Pod::VERSION"; import Test::Pod tests => scalar @pods; }; - $reason = 'Test::Pod >= 0.95 required' if $@; + $reason = 'Test::Pod >= 1.41 required' if $@; } if ($reason) { @@ -37,7 +37,7 @@ if ($reason) { for (@pods) { print "# checking $_\n"; if ($reason) { - skip("skip: $reason", 0); + skip("skip: $reason", 1); } else { pod_file_ok($_); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphbin b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphbin index 9b56eaf5c60..975e3f64bab 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphbin +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphbin @@ -15,6 +15,8 @@ use strict; +BEGIN { require warnings if "$]" > '5.006' } + # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if "$]" >= 5.009004 && "$]" <= 5.009005 } @@ -63,26 +65,31 @@ if ($opt{version}) { usage() if $opt{help}; strip() if $opt{strip}; -if (exists $opt{'compat-version'}) { - my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; - if ($@) { - die "Invalid version number format: '$opt{'compat-version'}'\n"; - } - die "Only Perl 5 is supported\n" if $r != 5; - die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; - $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; -} -else { - $opt{'compat-version'} = 5; -} +$opt{'compat-version'} = __MIN_PERL__ unless exists $opt{'compat-version'}; +$opt{'compat-version'} = int_parse_version($opt{'compat-version'}); + +my $int_min_perl = int_parse_version(__MIN_PERL__); +# Each element of this hash looks something like: +# 'Poison' => { +# 'base' => '5.008000', +# 'provided' => 1, +# 'todo' => '5.003007' +# }, my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), - (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + (index($4, 'n') >= 0 ? ( noTHXarg => 1 ) : ()), + (index($4, 'c') >= 0 ? ( core_only => 1 ) : ()), + (index($4, 'd') >= 0 ? ( deprecated => 1 ) : ()), + (index($4, 'i') >= 0 ? ( inaccessible => 1 ) : ()), + (index($4, 'x') >= 0 ? ( experimental => 1 ) : ()), + (index($4, 'u') >= 0 ? ( undocumented => 1 ) : ()), + (index($4, 'o') >= 0 ? ( ppport_fnc => 1 ) : ()), + (index($4, 'V') >= 0 ? ( unverified => 1 ) : ()), } ) : die "invalid spec: $_" } qw( __PERL_API__ @@ -90,14 +97,19 @@ __PERL_API__ if (exists $opt{'list-unsupported'}) { my $f; - for $f (sort { lc $a cmp lc $b } keys %API) { + for $f (sort dictionary_order keys %API) { + next if $API{$f}{core_only}; + next if $API{$f}{beyond_depr}; + next if $API{$f}{inaccessible}; + next if $API{$f}{experimental}; next unless $API{$f}{todo}; + next if int_parse_version($API{$f}{todo}) <= $int_min_perl; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } -# Scan for possible replacement candidates +# Scan for hints, possible replacement candidates, etc. my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; @@ -105,6 +117,7 @@ my($hint, $define, $function); sub find_api { + BEGIN { 'warnings'->unimport('uninitialized') if "$]" > '5.006' } my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) @@ -115,24 +128,65 @@ sub find_api while (<DATA>) { if ($hint) { + + # Here, we are in the middle of accumulating a hint or warning. + my $end_of_hint = 0; + + # A line containing a comment end marker closes the hint. Remove that + # marker for processing below. + if (s/\s*$rcce(.*?)\s*$//) { + die "Nothing can follow the end of comment in '$_'\n" if length $1 > 0; + $end_of_hint = 1; + } + + # Set $h to the hash of which type. my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; - if (m{^\s*\*\s(.*?)\s*$}) { - for (@{$hint->[1]}) { - $h->{$_} ||= ''; # suppress warning with older perls - $h->{$_} .= "$1\n"; - } + + # Ignore any leading and trailing white space, and an optional star comment + # continuation marker, then place the meat of the line into $1 + m/^\s*(?:\*\s*)?(.*?)\s*$/; + + # Add the meat of this line to the hash value of each API element it + # applies to + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # avoid the warning older perls generate + $h->{$_} .= "$1\n"; } - else { undef $hint } - } - $hint = [$1, [split /,?\s+/, $2]] - if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + # If the line had a comment close, we are through with this hint + undef $hint if $end_of_hint; + + next; + } - if ($define) { + # Set up $hint if this is the beginning of a Hint: or Warning: + # These are from a multi-line C comment in the file, with the first line + # looking like (a space has been inserted because this file can't have C + # comment markers in it): + # / * Warning: PL_expect, PL_copline, PL_rsfp + # + # $hint becomes + # [ + # 'Warning', + # [ + # 'PL_expect', + # 'PL_copline', + # 'PL_rsfp', + # ], + # ] + if (m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}) { + $hint = [$1, [split /,?\s+/, $2]]; + next; + } + + if ($define) { # If in the middle of a definition... + + # append a continuation line ending with backslash. if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } - else { + else { # Otherwise this line ends the definition, make foo depend on bar + # (and what bar depends on) if its not one of ppp's own constructs if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n @@ -141,6 +195,8 @@ while (<DATA>) { } } + # For '#define foo bar' or '#define foo(a,b,c) bar', $define becomes a + # reference to [ foo, bar ] $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { @@ -158,11 +214,29 @@ while (<DATA>) { $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + # Set $replace to the number given for lines that look like + # / * Replace: \d+ * / + # (blanks added to keep real C comments from appearing in this file) + # Thus setting it to 1 starts a region where replacements are automatically + # done, and setting it to 0 ends that region. $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + + # Add bar => foo to %replace for lines like '#define foo bar in a region + # where $replace is non-zero $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + + # Add bar => foo to %replace for lines like '#define foo bar / * Replace * / + # (blanks added to keep real C comments from appearing in this file) $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + + # Add foo => bar to %replace for lines like / * Replace foo with bar * / + # (blanks added to keep real C comments from appearing in this file) $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + # For lines like / * foo, bar depends on baz, bat * / + # create a list of the elements on the rhs, and make that list apply to each + # element in the lhs, which becomes a key in \%depends. + # (blanks added to keep real C comments from appearing in this file) if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { my @deps = map { s/\s+//g; $_ } split /,/, $3; my $d; @@ -175,43 +249,145 @@ while (<DATA>) { } for (values %depends) { - my %s; - $_ = [sort grep !$s{$_}++, @$_]; + my %seen; + $_ = [sort dictionary_order grep !$seen{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; - for $f (sort { lc $a cmp lc $b } keys %API) { + for $f (sort dictionary_order keys %API) { next unless $f =~ /$match/; - print "\n=== $f ===\n\n"; + print "\n=== $f ===\n"; my $info = 0; - if ($API{$f}{base} || $API{$f}{todo}) { - my $base = format_version($API{$f}{base} || $API{$f}{todo}); - print "Supported at least starting from perl-$base.\n"; - $info++; + my $base; + $base = int_parse_version($API{$f}{base}) if $API{$f}{base}; + my $todo; + $todo = int_parse_version($API{$f}{todo}) if $API{$f}{todo}; + + # Output information if it is generally publicly usable + if ($base && ! $API{$f}{inaccessible} && ! $API{$f}{core_only}) { + my $with_or= ""; + if ( $base <= $int_min_perl + || ( (! $API{$f}{provided} && ! $todo) + || ($todo && $todo >= $base))) + { + $with_or= " with or"; + } + print "\nSupported at least since perl-", + format_version($base), ",$with_or without $ppport."; + if ($API{$f}{unverified}) { + print "\nThis information is based on inspection of the source code", + " and has not been\n", + "verified by successful compilation."; + } + print "\n"; + $info++; + } + if ($API{$f}{provided} || $todo) { + print "\nThis is only supported by $ppport, and NOT by perl versions going forward.\n" unless $base; + if ($todo) { + if (! $base || $todo < $base) { + my $additionally = ""; + $additionally .= " additionally" if $base; + print "$ppport$additionally provides support at least back to perl-", + format_version($todo), + ".\n"; + } + } + elsif (! $base || $base > $int_min_perl) { + if (exists $depends{$f}) { + my $max = 0; + for (@{$depends{$f}}) { + $max = int_parse_version($API{$_}{todo}) if $API{$_}{todo} && $API{$_}{todo} > $max; + # XXX What to assume unspecified values are? This effectively makes them MIN_PERL + } + $todo = $max if $max; + } + print "\n$ppport provides support for this, but ironically, does not", + " currently know,\n", + "for this report, the minimum version it supports for this"; + if ($API{$f}{undocumented}) { + print " and many things\n", + "it provides that are implemented as macros and aren't", + " documented. You can\n", + "help by submitting a documentation patch"; + } + print ".\n"; + if ($todo) { + if ($todo <= $int_min_perl) { + print "It may very well be supported all the way back to ", + format_version(__MIN_PERL__), ".\n"; + } + else { + print "But given the things $f depends on, it's a good", + " guess that it isn't\n", + "supported prior to ", format_version($todo), ".\n"; + } + } + } } if ($API{$f}{provided}) { - my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "__MIN_PERL__"; - print "Support by $ppport provided back to perl-$todo.\n"; - print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; - print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "Support needs to be explicitly requested by #define NEED_$f\n", + "(or #define NEED_${f}_GLOBAL).\n" if exists $need{$f}; + $info++; + } + + if ($base || ! $API{$f}{ppport_fnc}) { + my $email = "Send email to perl5-porters\@perl.org if you need to have this functionality.\n"; + if ($API{$f}{inaccessible}) { + print "\nThis is not part of the public API, and may not even be accessible to XS code.\n"; + $info++; + } + elsif ($API{$f}{core_only}) { + print "\nThis is not part of the public API, and should not be used by XS code.\n"; + $info++; + } + elsif ($API{$f}{deprecated}) { + print "\nThis is deprecated and should not be used. Convert existing uses.\n"; + $info++; + } + elsif ($API{$f}{experimental}) { + print "\nThe API for this is unstable and should not be used by XS code.\n", $email; + $info++; + } + elsif ($API{$f}{undocumented}) { + print "\nSince this is undocumented, the API should be considered unstable.\n"; + if ($API{$f}{provided}) { + print "Consider bringing this up on the list: perl5-porters\@perl.org.\n"; + } + else { + print "It may be that this is not intended for XS use, or it may just be\n", + "that no one has gotten around to documenting it.\n", $email; + } + $info++; + } + unless ($info) { + print "No portability information available. Check your spelling; or", + " this could be\na bug in Devel::PPPort. To report an issue:\n", + "https://github.com/Dual-Life/Devel-PPPort/issues/new\n"; + } + } + + print "\nDepends on: ", join(', ', @{$depends{$f}}), ".\n" + if exists $depends{$f}; + if (exists $hints{$f} || exists $warnings{$f}) { print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } - print "No portability information available.\n" unless $info; $count++; } - $count or print "Found no API matching '$opt{'api-info'}'."; + + $count or print "\nFound no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; - for $f (sort { lc $a cmp lc $b } keys %API) { + for $f (sort dictionary_order keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; @@ -317,7 +493,9 @@ for $filename (@files) { $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; - if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + if ( ! exists $API{$func}{base} + || int_parse_version($API{$func}{base}) > $opt{'compat-version'}) + { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { @@ -331,7 +509,9 @@ for $filename (@files) { } } } - if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ( exists $API{$func}{todo} + && int_parse_version($API{$func}{todo}) > $opt{'compat-version'}) + { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } @@ -382,9 +562,9 @@ for $filename (@files) { my $c = $file{code}; my $warnings = 0; - for $func (sort keys %{$file{uses_Perl}}) { + for $func (sort dictionary_order keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { - unless ($API{$func}{nothxarg}) { + unless ($API{$func}{noTHXarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { @@ -400,12 +580,12 @@ for $filename (@files) { } } - for $func (sort keys %{$file{uses_replace}}) { + for $func (sort dictionary_order keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } - for $func (sort keys %{$file{uses_provided}}) { + for $func (sort dictionary_order keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); @@ -418,14 +598,15 @@ for $filename (@files) { } unless ($opt{quiet}) { - for $func (sort keys %{$file{uses_todo}}) { + for $func (sort dictionary_order keys %{$file{uses_todo}}) { + next if int_parse_version($API{$func}{todo}) <= $int_min_perl; print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } - for $func (sort keys %{$file{needed_static}}) { + for $func (sort dictionary_order keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; @@ -439,7 +620,7 @@ for $filename (@files) { } } - for $func (sort keys %{$file{needed_global}}) { + for $func (sort dictionary_order keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; @@ -463,7 +644,7 @@ for $filename (@files) { if ($file{needs_inc_ppport}) { my $pp = ''; - for $func (sort keys %{$file{needs}}) { + for $func (sort dictionary_order keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; @@ -660,59 +841,6 @@ sub rec_depend grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } -sub parse_version -{ - my $ver = shift; - - if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { - return ($1, $2, $3); - } - elsif ($ver !~ /^\d+\.[\d_]+$/) { - die "cannot parse version '$ver'\n"; - } - - $ver =~ s/_//g; - $ver =~ s/$/000000/; - - my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; - - $v = int $v; - $s = int $s; - - if ($r < 5 || ($r == 5 && $v < 6)) { - if ($s % 10) { - die "cannot parse version '$ver'\n"; - } - } - - return ($r, $v, $s); -} - -sub format_version -{ - my $ver = shift; - - $ver =~ s/$/000000/; - my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; - - $v = int $v; - $s = int $s; - - if ($r < 5 || ($r == 5 && $v < 6)) { - if ($s % 10) { - die "invalid version '$ver'\n"; - } - $s /= 10; - - $ver = sprintf "%d.%03d", $r, $v; - $s > 0 and $ver .= sprintf "_%02d", $s; - - return $ver; - } - - return sprintf "%d.%d.%d", $r, $v, $s; -} - sub info { $opt{quiet} and return; diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphdoc b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphdoc index 857f39e3fcb..57aa6ad5941 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphdoc +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphdoc @@ -290,6 +290,10 @@ to display information for all known API elements. =head1 BUGS +Some of the suggested edits and/or generated patches may not compile as-is +without tweaking manually. This is generally due to the need for an extra +parameter to be added to the call to prevent buffer overflow. + If this version of F<ppport.h> is causing failure during the compilation of this module, please check if newer versions of either this module or C<Devel::PPPort> are available on CPAN diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphtest b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphtest index 2be43315633..9b13279f92e 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphtest +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/ppphtest @@ -13,9 +13,7 @@ BEGIN { if ($ENV{'SKIP_SLOW_TESTS'}) { - for (1 .. 238) { - skip("skip: SKIP_SLOW_TESTS", 0); - } + skip("skip: SKIP_SLOW_TESTS", 238); exit 0; } } @@ -59,7 +57,7 @@ END { ok(&Devel::PPPort::WriteFile("ppport.h")); # Check GetFileContents() -ok(-e "ppport.h", 1); +is(-e "ppport.h", 1); my $data; @@ -69,8 +67,8 @@ while(<F>) { } close(F); -ok(Devel::PPPort::GetFileContents("ppport.h"), $data); -ok(Devel::PPPort::GetFileContents(), $data); +is(Devel::PPPort::GetFileContents("ppport.h"), $data); +is(Devel::PPPort::GetFileContents(), $data); sub comment { @@ -168,7 +166,7 @@ for $t (@tests) { $err =~ s/^/# *** /mg; print "# *** ERROR ***\n$err\n"; } - ok($@, ''); + is($@, ''); for (keys %{$t->{files}}) { unlink $_ or die "unlink('$_'): $!\n"; @@ -214,8 +212,8 @@ ok($o =~ /^This is.*ppport.*\d+\.\d+(?:_?\d+)?\.$/); $o = ppport(qw(--nochanges)); ok($o =~ /^Scanning.*test\.xs/mi); ok($o =~ /Analyzing.*test\.xs/mi); -ok(matches($o, '^Scanning', 'm'), 1); -ok(matches($o, 'Analyzing', 'm'), 1); +is(matches($o, '^Scanning', 'm'), 1); +is(matches($o, 'Analyzing', 'm'), 1); ok($o =~ /Uses Perl_newSViv instead of newSViv/); $o = ppport(qw(--quiet --nochanges)); @@ -232,7 +230,7 @@ Perl_newSViv(); my $o = ppport(qw(--copy=a)); ok($o =~ /^Scanning.*MyExt\.xs/mi); ok($o =~ /Analyzing.*MyExt\.xs/mi); -ok(matches($o, '^Scanning', 'm'), 1); +is(matches($o, '^Scanning', 'm'), 1); ok($o =~ /^Needs to include.*ppport\.h/m); ok($o !~ /^Uses grok_bin/m); ok($o !~ /^Uses newSVpv/m); @@ -244,7 +242,7 @@ ok(eq_files('MyExt.xsa', 'MyExt.ra')); $o = ppport(qw(--copy=b --cplusplus)); ok($o =~ /^Scanning.*MyExt\.xs/mi); ok($o =~ /Analyzing.*MyExt\.xs/mi); -ok(matches($o, '^Scanning', 'm'), 1); +is(matches($o, '^Scanning', 'm'), 1); ok($o =~ /^Needs to include.*ppport\.h/m); ok($o !~ /^Uses grok_bin/m); ok($o !~ /^Uses newSVpv/m); @@ -350,7 +348,6 @@ ok($o =~ /^\s*$/); ---------------------------- file1.xs ----------------------------------------- #define NEED_newCONSTSUB -#define NEED_sv_2pv_flags #define NEED_PL_parser #include "ppport.h" @@ -367,7 +364,7 @@ mXPUSHp(foo); my $o = ppport(qw(--nochanges)); ok($o =~ /^Scanning.*FooBar\.xs/mi); ok($o =~ /Analyzing.*FooBar\.xs/mi); -ok(matches($o, '^Scanning', 'm'), 1); +is(matches($o, '^Scanning', 'm'), 1); ok($o !~ /^Looks good/m); ok($o =~ /^Uses grok_bin/m); @@ -387,7 +384,7 @@ ok($o =~ /Analyzing.*second\.h/mi); ok($o =~ /^Scanning.*sub.*third\.c/mi); ok($o =~ /Analyzing.*sub.*third\.c/mi); ok($o !~ /^Scanning.*foobar/mi); -ok(matches($o, '^Scanning', 'm'), 3); +is(matches($o, '^Scanning', 'm'), 3); ---------------------------- First.xs ----------------------------------------- @@ -423,9 +420,9 @@ for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) { ok($o =~ /^Scanning.*\Q$_\E/mi); ok($o =~ /Analyzing.*\Q$_\E/i); } -ok(matches($o, '^Scanning', 'm'), 6); +is(matches($o, '^Scanning', 'm'), 6); -ok(matches($o, '^Writing copy of', 'm'), 5); +is(matches($o, '^Writing copy of', 'm'), 5); ok(!-e "mod5.cf"); for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) { @@ -522,7 +519,6 @@ call_pv(); #define NEED_eval_pv_GLOBAL #define NEED_grok_hex #define NEED_newCONSTSUB_GLOBAL -#define NEED_sv_2pv_flags_GLOBAL #include "ppport.h" newCONSTSUB(); @@ -635,7 +631,7 @@ SvPVutf8_force(); my $o = ppport(qw(--nochanges)); ok($o !~ /potentially required change/); -ok(matches($o, '^Looks good', 'm'), 2); +is(matches($o, '^Looks good', 'm'), 2); ---------------------------- FooBar.xs ---------------------------------------- @@ -658,20 +654,20 @@ call_pv(); my $o = ppport(qw(--api-info=INT2PTR)); my %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg; -ok(scalar keys %found, 1); +is(scalar keys %found, 1, "found 1 key"); ok(exists $found{INT2PTR}); -ok(matches($o, '^Supported at least starting from perl-5\.6\.0\.', 'm'), 1); -ok(matches($o, '^Support by .*ppport.* provided back to perl-5\.003\.', 'm'), 1); +is(matches($o, '^Supported at least since perl-5\.6\.0', 'm'), 1, "INT2PTR supported without ppport.h to 5.6.0"); +is(matches($o, '^ppport.h additionally provides support at least back to perl-5\.003', 'm'), 1, "INT2PTR supported with ppport.h to 5.003"); $o = ppport(qw(--api-info=Zero)); %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg; -ok(scalar keys %found, 1); +is(scalar keys %found, 1, "found 1 key"); ok(exists $found{Zero}); -ok(matches($o, '^No portability information available\.', 'm'), 1); +is(matches($o, '^Supported at least since perl-5.003', 'm'), 1, "Zero supported to 5.003"); $o = ppport(qw(--api-info=/Zero/)); %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg; -ok(scalar keys %found, 2); +is(scalar keys %found, 2, "found 2 keys"); ok(exists $found{Zero}); ok(exists $found{ZeroD}); @@ -688,32 +684,32 @@ for (@o) { $p{$name} = defined $flags ? { map { ($_ => 1) } $flags =~ /(\w+)/g } : ''; } ok(@o > 100); -ok($fail, 0); +is($fail, 0); ok(exists $p{call_pv}); ok(not ref $p{call_pv}); ok(exists $p{grok_bin}); -ok(ref $p{grok_bin}, 'HASH'); -ok(scalar keys %{$p{grok_bin}}, 2); +is(ref $p{grok_bin}, 'HASH'); +is(scalar keys %{$p{grok_bin}}, 2); ok($p{grok_bin}{explicit}); ok($p{grok_bin}{depend}); ok(exists $p{gv_stashpvn}); -ok(ref $p{gv_stashpvn}, 'HASH'); -ok(scalar keys %{$p{gv_stashpvn}}, 2); +is(ref $p{gv_stashpvn}, 'HASH'); +is(scalar keys %{$p{gv_stashpvn}}, 2); ok($p{gv_stashpvn}{depend}); ok($p{gv_stashpvn}{hint}); ok(exists $p{sv_catpvf_mg}); -ok(ref $p{sv_catpvf_mg}, 'HASH'); -ok(scalar keys %{$p{sv_catpvf_mg}}, 2); +is(ref $p{sv_catpvf_mg}, 'HASH'); +is(scalar keys %{$p{sv_catpvf_mg}}, 2); ok($p{sv_catpvf_mg}{explicit}); ok($p{sv_catpvf_mg}{depend}); ok(exists $p{PL_signals}); -ok(ref $p{PL_signals}, 'HASH'); -ok(scalar keys %{$p{PL_signals}}, 1); +is(ref $p{PL_signals}, 'HASH'); +is(scalar keys %{$p{PL_signals}}, 1); ok($p{PL_signals}{explicit}); =============================================================================== @@ -729,13 +725,13 @@ for (@o) { $p{$name} = $ver; } ok(@o > 100); -ok($fail, 0); +is($fail, 0); ok(exists $p{utf8_distance}); -ok($p{utf8_distance}, '5.6.0'); +is($p{utf8_distance}, '5.6.0'); ok(exists $p{save_generic_svref}); -ok($p{save_generic_svref}, '5.005_03'); +is($p{save_generic_svref}, '5.005_03'); =============================================================================== @@ -744,17 +740,17 @@ ok($p{save_generic_svref}, '5.005_03'); my $o = ppport(qw(--nochanges)); ok($o =~ /^Scanning.*foo\.cpp/mi); ok($o =~ /Analyzing.*foo\.cpp/mi); -ok(matches($o, '^Scanning', 'm'), 1); -ok(matches($o, 'Analyzing', 'm'), 1); +is(matches($o, '^Scanning', 'm'), 1); +is(matches($o, 'Analyzing', 'm'), 1); $o = ppport(qw(--nochanges foo.cpp foo.o Makefile.PL)); ok($o =~ /Skipping the following files \(use --nofilter to avoid this\):/m); -ok(matches($o, '^\|\s+foo\.o', 'mi'), 1); -ok(matches($o, '^\|\s+Makefile\.PL', 'mi'), 1); +is(matches($o, '^\|\s+foo\.o', 'mi'), 1); +is(matches($o, '^\|\s+Makefile\.PL', 'mi'), 1); ok($o =~ /^Scanning.*foo\.cpp/mi); ok($o =~ /Analyzing.*foo\.cpp/mi); -ok(matches($o, '^Scanning', 'm'), 1); -ok(matches($o, 'Analyzing', 'm'), 1); +is(matches($o, '^Scanning', 'm'), 1); +is(matches($o, 'Analyzing', 'm'), 1); $o = ppport(qw(--nochanges --nofilter foo.cpp foo.o Makefile.PL)); ok($o =~ /^Scanning.*foo\.cpp/mi); @@ -763,8 +759,8 @@ ok($o =~ /^Scanning.*foo\.o/mi); ok($o =~ /Analyzing.*foo\.o/mi); ok($o =~ /^Scanning.*Makefile/mi); ok($o =~ /Analyzing.*Makefile/mi); -ok(matches($o, '^Scanning', 'm'), 3); -ok(matches($o, 'Analyzing', 'm'), 3); +is(matches($o, '^Scanning', 'm'), 3); +is(matches($o, 'Analyzing', 'm'), 3); ---------------------------- foo.cpp ------------------------------------------ @@ -879,8 +875,6 @@ for (qw(file.xs)) { ---------------------------- file.xs ----------------------------------------- -#define NEED_sv_2pv_flags -#define NEED_vnewSVpvf #define NEED_warner #include "ppport.h" Perl_croak_nocontext("foo"); @@ -894,8 +888,6 @@ warner("foo"); ---------------------------- file.xsr ----------------------------------------- -#define NEED_sv_2pv_flags -#define NEED_vnewSVpvf #define NEED_warner #include "ppport.h" Perl_croak_nocontext("foo"); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/pv_tools b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/pv_tools index c51d91ab22c..c523d1c59aa 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/pv_tools +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/pv_tools @@ -257,20 +257,28 @@ ok($uni ? "$]" >= 5.006 : "$]" < 5.008); my @r; @r = &Devel::PPPort::pv_pretty(); -ok($r[0], $r[1]); -ok($r[0], "foobarbaz"); -ok($r[2], $r[3]); -ok($r[2], '<leftpv_p\retty\nright>'); -ok($r[4], $r[5]); -skip(ord("A") != 65 ? "Skip for non-ASCII platform" : 0, - $r[4], $uni ? 'N\375 Batter\355' : 'N\303\275 Batter\303'); -ok($r[6], $r[7]); -skip(ord("A") != 65 ? "Skip for non-ASCII platform" : 0, - $r[6], $uni ? '\301g\346tis Byrju...' : '\303\201g\303\246t...'); +is($r[0], $r[1]); +is($r[0], "foobarbaz"); +is($r[2], $r[3]); +is($r[2], '<leftpv_p\retty\nright>'); +is($r[4], $r[5]); +if(ord("A") == 65) { + is($r[4], $uni ? 'N\375 Batter\355' : 'N\303\275 Batter\303'); +} +else { + skip("Skip for non-ASCII platform"); +} +is($r[6], $r[7]); +if(ord("A") == 65) { + is($r[6], $uni ? '\301g\346tis Byrju...' : '\303\201g\303\246t...'); +} +else { + skip("Skip for non-ASCII platform"); +} @r = &Devel::PPPort::pv_display(); -ok($r[0], $r[1]); -ok($r[0], '"foob\0rbaz"\0'); -ok($r[2], $r[3]); +is($r[0], $r[1]); +is($r[0], '"foob\0rbaz"\0'); +is($r[2], $r[3]); ok($r[2] eq '"pv_di"...\0' || $r[2] eq '"pv_d"...\0'); # some perl implementations are broken... :( diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/pvs b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/pvs index b1be87b26bf..5720df31eef 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/pvs +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/pvs @@ -132,23 +132,23 @@ OUTPUT: my $x = 'foo'; -ok(Devel::PPPort::newSVpvs(), "newSVpvs"); -ok(Devel::PPPort::newSVpvs_flags(), "newSVpvs_flags"); -ok(Devel::PPPort::newSVpvs_share(), 3); +is(Devel::PPPort::newSVpvs(), "newSVpvs"); +is(Devel::PPPort::newSVpvs_flags(), "newSVpvs_flags"); +is(Devel::PPPort::newSVpvs_share(), 3); Devel::PPPort::sv_catpvs($x); -ok($x, "foosv_catpvs"); +is($x, "foosv_catpvs"); Devel::PPPort::sv_setpvs($x); -ok($x, "sv_setpvs"); +is($x, "sv_setpvs"); my %h = ('hv_fetchs' => 42); Devel::PPPort::hv_stores(\%h, 4711); -ok(scalar keys %h, 2); +is(scalar keys %h, 2); ok(exists $h{'hv_stores'}); -ok($h{'hv_stores'}, 4711); -ok(Devel::PPPort::hv_fetchs(\%h), 42); -ok(Devel::PPPort::gv_fetchpvs(), \*Devel::PPPort::VERSION); -ok(Devel::PPPort::gv_stashpvs(), \%Devel::PPPort::); +is($h{'hv_stores'}, 4711); +is(Devel::PPPort::hv_fetchs(\%h), 42); +is(Devel::PPPort::gv_fetchpvs(), \*Devel::PPPort::VERSION); +is(Devel::PPPort::gv_stashpvs(), \%Devel::PPPort::); -ok(Devel::PPPort::get_cvs(), 3); +is(Devel::PPPort::get_cvs(), 3); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/shared_pv b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/shared_pv index 921076fd320..6f87cf1df9e 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/shared_pv +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/shared_pv @@ -27,14 +27,14 @@ __UNDEFINED__ #if { NEED newSVpvn_share } SV * -newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) +newSVpvn_share(pTHX_ const char *s, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) - PERL_HASH(hash, (char*) src, len); - sv = newSVpvn((char *) src, len); + PERL_HASH(hash, (char*) s, len); + sv = newSVpvn((char *) s, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); @@ -87,4 +87,4 @@ newSVpvn_share() =tests plan => 1 -ok(&Devel::PPPort::newSVpvn_share(), 6); +is(&Devel::PPPort::newSVpvn_share(), 6); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/snprintf b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/snprintf index b700d8b8ef8..f89abac063a 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/snprintf +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/snprintf @@ -59,5 +59,5 @@ my_snprintf() =tests plan => 2 my($l, $s) = Devel::PPPort::my_snprintf(); -ok($l, 8); -ok($s, "foobar42"); +is($l, 8); +is($s, "foobar42"); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/sprintf b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/sprintf index 8d45411b4a9..e6f7390c07a 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/sprintf +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/sprintf @@ -18,6 +18,12 @@ my_sprintf #if !defined(my_sprintf) #if { NEED my_sprintf } +/* Warning: my_sprintf + It's safer to use my_snprintf instead +*/ + +/* Replace my_sprintf with my_snprintf */ + int my_sprintf(char *buffer, const char* pat, ...) { @@ -51,5 +57,5 @@ my_sprintf() =tests plan => 2 my($l, $s) = Devel::PPPort::my_sprintf(); -ok($l, 8); -ok($s, "foobar42"); +is($l, 8); +is($s, "foobar42"); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/strlfuncs b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/strlfuncs index 82b5e435410..b58d5e0103d 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/strlfuncs +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/strlfuncs @@ -103,5 +103,5 @@ my @r = Devel::PPPort::my_strlfunc(); ok(@e == @r); for (0 .. $#e) { - ok($r[$_], $e[$_]); + is($r[$_], $e[$_]); } diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/subparse b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/subparse new file mode 100644 index 00000000000..0729c911e9f --- /dev/null +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/subparse @@ -0,0 +1,29 @@ +################################################################################ +## +## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz. +## Version 2.x, Copyright (C) 2001, Paul Marquess. +## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. +## +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. +## +################################################################################ + +=provides + +__UNDEFINED__ + +=implementation + +#if { VERSION <= 5.003_22 } +# undef start_subparse +# if { VERSION < 5.003_22 } +__UNDEFINED__ start_subparse(a, b) Perl_start_subparse() +# else +__UNDEFINED__ start_subparse(a, b) Perl_start_subparse(b) +# endif + +#if {VERSION < 5.003_07 } +foo +#endif +#endif diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/sv_xpvf b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/sv_xpvf index 89612844b4d..c71e805004d 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/sv_xpvf +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/sv_xpvf @@ -26,16 +26,10 @@ sv_vsetpvf_mg =implementation #if { VERSION >= 5.004 } && !defined(vnewSVpvf) -#if { NEED vnewSVpvf } - -SV * -vnewSVpvf(pTHX_ const char *pat, va_list *args) -{ - register SV *sv = newSV(0); - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); - return sv; -} - +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define vnewSVpvf(pat, args) ({ SV *_sv = newSV(0); sv_vsetpvfn(_sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)); _sv; }) +#else +# define vnewSVpvf(pat, args) ((PL_Sv = newSV(0)), sv_vsetpvfn(PL_Sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)), PL_Sv) #endif #endif @@ -51,7 +45,7 @@ vnewSVpvf(pTHX_ const char *pat, va_list *args) #if { NEED sv_catpvf_mg } void -sv_catpvf_mg(pTHX_ SV *sv, const char *pat, ...) +sv_catpvf_mg(pTHX_ SV * const sv, const char * const pat, ...) { va_list args; va_start(args, pat); @@ -68,7 +62,7 @@ sv_catpvf_mg(pTHX_ SV *sv, const char *pat, ...) #if { NEED sv_catpvf_mg_nocontext } void -sv_catpvf_mg_nocontext(SV *sv, const char *pat, ...) +sv_catpvf_mg_nocontext(SV * const sv, const char * const pat, ...) { dTHX; va_list args; @@ -103,7 +97,7 @@ sv_catpvf_mg_nocontext(SV *sv, const char *pat, ...) #if { NEED sv_setpvf_mg } void -sv_setpvf_mg(pTHX_ SV *sv, const char *pat, ...) +sv_setpvf_mg(pTHX_ SV * const sv, const char * const pat, ...) { va_list args; va_start(args, pat); @@ -120,7 +114,7 @@ sv_setpvf_mg(pTHX_ SV *sv, const char *pat, ...) #if { NEED sv_setpvf_mg_nocontext } void -sv_setpvf_mg_nocontext(SV *sv, const char *pat, ...) +sv_setpvf_mg_nocontext(SV * const sv, const char * const pat, ...) { dTHX; va_list args; @@ -153,7 +147,6 @@ sv_setpvf_mg_nocontext(SV *sv, const char *pat, ...) =xsinit -#define NEED_vnewSVpvf #define NEED_sv_catpvf_mg #define NEED_sv_catpvf_mg_nocontext #define NEED_sv_setpvf_mg @@ -290,24 +283,24 @@ tie %h, 'Tie::StdHash'; $h{foo} = 'foo-'; $h{bar} = ''; -ok(&Devel::PPPort::vnewSVpvf(), "$]" >= 5.004 ? 'Perl-42' : '%s-%d'); -ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), "$]" >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); -ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), "$]" >= 5.004 ? 'Perl-42' : '%s-%d'); +is(&Devel::PPPort::vnewSVpvf(), "$]" >= 5.004 ? 'Perl-42' : '%s-%d'); +is(&Devel::PPPort::sv_vcatpvf('1-2-3-'), "$]" >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d'); +is(&Devel::PPPort::sv_vsetpvf('1-2-3-'), "$]" >= 5.004 ? 'Perl-42' : '%s-%d'); &Devel::PPPort::sv_catpvf_mg($h{foo}); -ok($h{foo}, "$]" >= 5.004 ? 'foo-Perl-42' : 'foo-'); +is($h{foo}, "$]" >= 5.004 ? 'foo-Perl-42' : 'foo-'); &Devel::PPPort::Perl_sv_catpvf_mg($h{foo}); -ok($h{foo}, "$]" >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); +is($h{foo}, "$]" >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-'); &Devel::PPPort::sv_catpvf_mg_nocontext($h{foo}); -ok($h{foo}, "$]" >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); +is($h{foo}, "$]" >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-'); &Devel::PPPort::sv_setpvf_mg($h{bar}); -ok($h{bar}, "$]" >= 5.004 ? 'mhx-42' : ''); +is($h{bar}, "$]" >= 5.004 ? 'mhx-42' : ''); &Devel::PPPort::Perl_sv_setpvf_mg($h{bar}); -ok($h{bar}, "$]" >= 5.004 ? 'foo-43' : ''); +is($h{bar}, "$]" >= 5.004 ? 'foo-43' : ''); &Devel::PPPort::sv_setpvf_mg_nocontext($h{bar}); -ok($h{bar}, "$]" >= 5.004 ? 'bar-44' : ''); +is($h{bar}, "$]" >= 5.004 ? 'bar-44' : ''); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/threads b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/threads index 9a8f6ac4b30..786b72936c5 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/threads +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/threads @@ -21,12 +21,26 @@ dTHXR __UNDEFINED__ dTHR dNOOP __UNDEFINED__ dTHX dNOOP +/* Hint: dTHX + + For pre-5.6.0 thread compatibility, instead use dTHXR, available only through + ppport.h */ + __UNDEFINED__ dTHXa(x) dNOOP __UNDEFINED__ pTHX void __UNDEFINED__ pTHX_ __UNDEFINED__ aTHX +/* Hint: aTHX + + For pre-5.6.0 thread compatibility, instead use aTHXR, available only through + ppport.h */ + __UNDEFINED__ aTHX_ +/* Hint: aTHX_ + + For pre-5.6.0 thread compatibility, instead use aTHXR_, available only + through ppport.h */ #if { VERSION < 5.6.0 } # ifdef USE_THREADS @@ -63,6 +77,6 @@ with_THX_arg(error) =tests plan => 2 -ok(&Devel::PPPort::no_THX_arg("42"), 43); +is(&Devel::PPPort::no_THX_arg("42"), 43); eval { &Devel::PPPort::with_THX_arg("yes\n"); }; ok($@ =~ /^yes/); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/utf8 b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/utf8 new file mode 100644 index 00000000000..28f01c058d3 --- /dev/null +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/utf8 @@ -0,0 +1,926 @@ +=provides + +__UNDEFINED__ +SvUTF8 +UTF8f +UTF8fARG +utf8_to_uvchr_buf +sv_len_utf8 +sv_len_utf8_nomg + +=implementation + +#ifdef SVf_UTF8 +__UNDEFINED__ SvUTF8(sv) (SvFLAGS(sv) & SVf_UTF8) +#endif + +#if { VERSION == 5.19.1 } /* 5.19.1 does not have UTF8fARG, only broken UTF8f */ +#undef UTF8f +#endif + +#ifdef SVf_UTF8 +__UNDEFINED__ UTF8f SVf +__UNDEFINED__ UTF8fARG(u,l,p) newSVpvn_flags((p), (l), ((u) ? SVf_UTF8 : 0) | SVs_TEMP) +#endif + +#define D_PPP_MIN(a,b) (((a) <= (b)) ? (a) : (b)) + +__UNDEFINED__ UNICODE_REPLACEMENT 0xFFFD + +#ifdef UTF8_MAXLEN +__UNDEFINED__ UTF8_MAXBYTES UTF8_MAXLEN +#endif + +__UNDEF_NOT_PROVIDED__ UTF_START_MARK(len) \ + (((len) > 7) ? 0xFF : (0xFF & (0xFE << (7-(len))))) + +#if { VERSION < 5.018 } /* On non-EBCDIC was valid before this, */ + /* but easier to just do one check */ +# undef UTF8_MAXBYTES_CASE +#endif + +#if 'A' == 65 +# define D_PPP_BYTE_INFO_BITS 6 /* 6 bits meaningful in continuation bytes */ +__UNDEFINED__ UTF8_MAXBYTES_CASE 13 +#else +# define D_PPP_BYTE_INFO_BITS 5 /* 5 bits meaningful in continuation bytes */ +__UNDEFINED__ UTF8_MAXBYTES_CASE 15 +#endif + +__UNDEF_NOT_PROVIDED__ UTF_ACCUMULATION_SHIFT D_PPP_BYTE_INFO_BITS + +#ifdef NATIVE_TO_UTF +__UNDEF_NOT_PROVIDED__ NATIVE_UTF8_TO_I8(c) NATIVE_TO_UTF(c) +#else /* System doesn't support EBCDIC */ +__UNDEF_NOT_PROVIDED__ NATIVE_UTF8_TO_I8(c) (c) +#endif + +#ifdef UTF_TO_NATIVE +__UNDEF_NOT_PROVIDED__ I8_TO_NATIVE_UTF8(c) UTF_TO_NATIVE(c) +#else /* System doesn't support EBCDIC */ +__UNDEF_NOT_PROVIDED__ I8_TO_NATIVE_UTF8(c) (c) +#endif + +__UNDEF_NOT_PROVIDED__ UTF_START_MASK(len) \ + (((len) >= 7) ? 0x00 : (0x1F >> ((len)-2))) +__UNDEF_NOT_PROVIDED__ UTF_IS_CONTINUATION_MASK \ + ((U8) (0xFF << UTF_ACCUMULATION_SHIFT)) +__UNDEF_NOT_PROVIDED__ UTF_CONTINUATION_MARK \ + (UTF_IS_CONTINUATION_MASK & 0xB0) +__UNDEF_NOT_PROVIDED__ UTF_MIN_START_BYTE \ + ((UTF_CONTINUATION_MARK >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2)) + +__UNDEF_NOT_PROVIDED__ UTF_MIN_ABOVE_LATIN1_BYTE \ + ((0x100 >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2)) + +#if { VERSION < 5.007 } /* Was the complement of what should have been */ +# undef UTF8_IS_DOWNGRADEABLE_START +#endif +__UNDEF_NOT_PROVIDED__ UTF8_IS_DOWNGRADEABLE_START(c) \ + inRANGE(NATIVE_UTF8_TO_I8(c), \ + UTF_MIN_START_BYTE, UTF_MIN_ABOVE_LATIN1_BYTE - 1) +__UNDEF_NOT_PROVIDED__ UTF_CONTINUATION_MASK \ + ((U8) ((1U << UTF_ACCUMULATION_SHIFT) - 1)) + +__UNDEF_NOT_PROVIDED__ UTF8_ACCUMULATE(base, added) \ + (((base) << UTF_ACCUMULATION_SHIFT) \ + | ((NATIVE_UTF8_TO_I8(added)) \ + & UTF_CONTINUATION_MASK)) + +__UNDEF_NOT_PROVIDED__ UTF8_ALLOW_ANYUV 0 +__UNDEF_NOT_PROVIDED__ UTF8_ALLOW_EMPTY 0x0001 +__UNDEF_NOT_PROVIDED__ UTF8_ALLOW_CONTINUATION 0x0002 +__UNDEF_NOT_PROVIDED__ UTF8_ALLOW_NON_CONTINUATION 0x0004 +__UNDEF_NOT_PROVIDED__ UTF8_ALLOW_SHORT 0x0008 +__UNDEF_NOT_PROVIDED__ UTF8_ALLOW_LONG 0x0010 +__UNDEF_NOT_PROVIDED__ UTF8_ALLOW_OVERFLOW 0x0080 +__UNDEF_NOT_PROVIDED__ UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION \ + |UTF8_ALLOW_NON_CONTINUATION \ + |UTF8_ALLOW_SHORT \ + |UTF8_ALLOW_LONG \ + |UTF8_ALLOW_OVERFLOW) + +#if defined UTF8SKIP + +/* Don't use official versions because they use MIN, which may not be available */ +#undef UTF8_SAFE_SKIP +#undef UTF8_CHK_SKIP + +__UNDEFINED__ UTF8_SAFE_SKIP(s, e) ( \ + ((((e) - (s)) <= 0) \ + ? 0 \ + : D_PPP_MIN(((e) - (s)), UTF8SKIP(s)))) + +__UNDEFINED__ UTF8_CHK_SKIP(s) \ + (s[0] == '\0' ? 1 : ((U8) D_PPP_MIN(my_strnlen((char *) (s), UTF8SKIP(s)), \ + UTF8SKIP(s)))) +/* UTF8_CHK_SKIP depends on my_strnlen */ +__UNDEFINED__ UTF8_SKIP(s) UTF8SKIP(s) +#endif + +#if 'A' == 65 +__UNDEFINED__ UTF8_IS_INVARIANT(c) isASCII(c) +#else +__UNDEFINED__ UTF8_IS_INVARIANT(c) (isASCII(c) || isCNTRL_L1(c)) +#endif + +__UNDEFINED__ UVCHR_IS_INVARIANT(c) UTF8_IS_INVARIANT(c) + +#ifdef UVCHR_IS_INVARIANT +# if 'A' == 65 +# ifdef QUADKIND +# define D_PPP_UVCHR_SKIP_UPPER(c) \ + (WIDEST_UTYPE) (c) < \ + (((WIDEST_UTYPE) 1) << (6 * D_PPP_BYTE_INFO_BITS)) ? 7 : 13 +# else +# define D_PPP_UVCHR_SKIP_UPPER(c) 7 /* 32 bit platform */ +# endif +# else + /* In the releases this is backported to, UTF-EBCDIC had a max of 2**31-1 */ +# define D_PPP_UVCHR_SKIP_UPPER(c) 7 +# endif + +__UNDEFINED__ UVCHR_SKIP(c) \ + UVCHR_IS_INVARIANT(c) ? 1 : \ + (WIDEST_UTYPE) (c) < (32 * (1U << ( D_PPP_BYTE_INFO_BITS))) ? 2 : \ + (WIDEST_UTYPE) (c) < (16 * (1U << (2 * D_PPP_BYTE_INFO_BITS))) ? 3 : \ + (WIDEST_UTYPE) (c) < ( 8 * (1U << (3 * D_PPP_BYTE_INFO_BITS))) ? 4 : \ + (WIDEST_UTYPE) (c) < ( 4 * (1U << (4 * D_PPP_BYTE_INFO_BITS))) ? 5 : \ + (WIDEST_UTYPE) (c) < ( 2 * (1U << (5 * D_PPP_BYTE_INFO_BITS))) ? 6 : \ + D_PPP_UVCHR_SKIP_UPPER(c) +#endif + +#ifdef is_ascii_string +__UNDEFINED__ is_invariant_string(s,l) is_ascii_string(s,l) +__UNDEFINED__ is_utf8_invariant_string(s,l) is_ascii_string(s,l) + +/* Hint: is_ascii_string, is_invariant_string + is_utf8_invariant_string() does the same thing and is preferred because its + name is more accurate as to what it does */ +#endif + +#ifdef ibcmp_utf8 +__UNDEFINED__ foldEQ_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2) \ + cBOOL(! ibcmp_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2)) +#endif + +#if defined(is_utf8_string) && defined(UTF8SKIP) +__UNDEFINED__ isUTF8_CHAR(s, e) ( \ + (e) <= (s) || ! is_utf8_string(s, UTF8_SAFE_SKIP(s, e)) \ + ? 0 \ + : UTF8SKIP(s)) +#endif + +#if 'A' == 65 +__UNDEFINED__ BOM_UTF8 "\xEF\xBB\xBF" +__UNDEFINED__ REPLACEMENT_CHARACTER_UTF8 "\xEF\xBF\xBD" +#elif '^' == 95 +__UNDEFINED__ BOM_UTF8 "\xDD\x73\x66\x73" +__UNDEFINED__ REPLACEMENT_CHARACTER_UTF8 "\xDD\x73\x73\x71" +#elif '^' == 176 +__UNDEFINED__ BOM_UTF8 "\xDD\x72\x65\x72" +__UNDEFINED__ REPLACEMENT_CHARACTER_UTF8 "\xDD\x72\x72\x70" +#else +# error Unknown character set +#endif + +#if { VERSION < 5.31.4 } + /* Versions prior to this accepted things that are now considered + * malformations, and didn't return -1 on error with warnings enabled + * */ +# undef utf8_to_uvchr_buf +#endif + +/* This implementation brings modern, generally more restricted standards to + * utf8_to_uvchr_buf. Some of these are security related, and clearly must + * be done. But its arguable that the others need not, and hence should not. + * The reason they're here is that a module that intends to play with the + * latest perls should be able to work the same in all releases. An example is + * that perl no longer accepts any UV for a code point, but limits them to + * IV_MAX or below. This is for future internal use of the larger code points. + * If it turns out that some of these changes are breaking code that isn't + * intended to work with modern perls, the tighter restrictions could be + * relaxed. khw thinks this is unlikely, but has been wrong in the past. */ + +/* 5.6.0 is the first release with UTF-8, and we don't implement this function + * there due to its likely lack of still being in use, and the underlying + * implementation is very different from later ones, without the later + * safeguards, so would require extra work to deal with */ +#if { VERSION >= 5.6.1 } && ! defined(utf8_to_uvchr_buf) + /* Choose which underlying implementation to use. At least one must be + * present or the perl is too early to handle this function */ +# if defined(utf8n_to_uvchr) || defined(utf8_to_uvchr) || defined(utf8_to_uv) +# if defined(utf8n_to_uvchr) /* This is the preferred implementation */ +# define D_PPP_utf8_to_uvchr_buf_callee utf8n_to_uvchr +# elif /* Must be at least 5.6.1 from #if above; \ + If have both regular and _simple, regular has all args */ \ + defined(utf8_to_uv) && defined(utf8_to_uv_simple) +# define D_PPP_utf8_to_uvchr_buf_callee utf8_to_uv +# elif defined(utf8_to_uvchr) /* The below won't work well on error input */ +# define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \ + utf8_to_uvchr((U8 *)(s), (retlen)) +# else +# define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \ + utf8_to_uv((U8 *)(s), (retlen)) +# endif +# endif + +# if { NEED utf8_to_uvchr_buf } + +UV +utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) +{ + UV ret; + STRLEN curlen; + bool overflows = 0; + const U8 *cur_s = s; + const bool do_warnings = ckWARN_d(WARN_UTF8); +# if { VERSION < 5.26.0 } && ! defined(EBCDIC) + STRLEN overflow_length = 0; +# endif + + if (send > s) { + curlen = send - s; + } + else { + assert(0); /* Modern perls die under this circumstance */ + curlen = 0; + if (! do_warnings) { /* Handle empty here if no warnings needed */ + if (retlen) *retlen = 0; + return UNICODE_REPLACEMENT; + } + } + +# if { VERSION < 5.26.0 } && ! defined(EBCDIC) + + /* Perl did not properly detect overflow for much of its history on + * non-EBCDIC platforms, often returning an overlong value which may or may + * not have been tolerated in the call. Also, earlier versions, when they + * did detect overflow, may have disallowed it completely. Modern ones can + * replace it with the REPLACEMENT CHARACTER, depending on calling + * parameters. Therefore detect it ourselves in releases it was + * problematic in. */ + + if (curlen > 0 && UNLIKELY(*s >= 0xFE)) { + + /* First, on a 32-bit machine the first byte being at least \xFE + * automatically is overflow, as it indicates something requiring more + * than 31 bits */ + if (sizeof(ret) < 8) { + overflows = 1; + overflow_length = (*s == 0xFE) ? 7 : 13; + } + else { + const U8 highest[] = /* 2*63-1 */ + "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"; + const U8 *cur_h = highest; + + for (cur_s = s; cur_s < send; cur_s++, cur_h++) { + if (UNLIKELY(*cur_s == *cur_h)) { + continue; + } + + /* If this byte is larger than the corresponding highest UTF-8 + * byte, the sequence overflows; otherwise the byte is less + * than (as we handled the equality case above), and so the + * sequence doesn't overflow */ + overflows = *cur_s > *cur_h; + break; + + } + + /* Here, either we set the bool and broke out of the loop, or got + * to the end and all bytes are the same which indicates it doesn't + * overflow. If it did overflow, it would be this number of bytes + * */ + overflow_length = 13; + } + } + + if (UNLIKELY(overflows)) { + ret = 0; + + if (! do_warnings && retlen) { + *retlen = overflow_length; + } + } + else + +# endif /* < 5.26 */ + + /* Here, we are either in a release that properly detects overflow, or + * we have checked for overflow and the next statement is executing as + * part of the above conditional where we know we don't have overflow. + * + * The modern versions allow anything that evaluates to a legal UV, but + * not overlongs nor an empty input */ + ret = D_PPP_utf8_to_uvchr_buf_callee( + (U8 *) /* Early perls: no const */ + s, curlen, retlen, (UTF8_ALLOW_ANYUV + & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY))); + +# if { VERSION >= 5.26.0 } && { VERSION < 5.28.0 } + + /* But actually, more modern versions restrict the UV to being no more than + * what an IV can hold, so it could still have gotten it wrong about + * overflowing. */ + if (UNLIKELY(ret > IV_MAX)) { + overflows = 1; + } + +# endif + + if (UNLIKELY(overflows)) { + if (! do_warnings) { + if (retlen) { + *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s)); + *retlen = D_PPP_MIN(*retlen, curlen); + } + return UNICODE_REPLACEMENT; + } + else { + + /* We use the error message in use from 5.8-5.26 */ + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "Malformed UTF-8 character (overflow at 0x%" UVxf + ", byte 0x%02x, after start byte 0x%02x)", + ret, *cur_s, *s); + if (retlen) { + *retlen = (STRLEN) -1; + } + return 0; + } + } + + /* Here, did not overflow, but if it failed for some other reason, and + * warnings are off, to emulate the behavior of the real utf8_to_uvchr(), + * try again, allowing anything. (Note a return of 0 is ok if the input + * was '\0') */ + if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) { + + /* If curlen is 0, we already handled the case where warnings are + * disabled, so this 'if' will be true, and so later on, we know that + * 's' is dereferencible */ + if (do_warnings) { + *retlen = (STRLEN) -1; + } + else { + ret = D_PPP_utf8_to_uvchr_buf_callee( + (U8 *) /* Early perls: no const */ + s, curlen, retlen, UTF8_ALLOW_ANY); + /* Override with the REPLACEMENT character, as that is what the + * modern version of this function returns */ + ret = UNICODE_REPLACEMENT; + +# if { VERSION < 5.16.0 } + + /* Versions earlier than this don't necessarily return the proper + * length. It should not extend past the end of string, nor past + * what the first byte indicates the length is, nor past the + * continuation characters */ + if (retlen && (IV) *retlen >= 0) { + unsigned int i = 1; + + *retlen = D_PPP_MIN(*retlen, curlen); + *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s)); + do { +# ifdef UTF8_IS_CONTINUATION + if (! UTF8_IS_CONTINUATION(s[i])) +# else /* Versions without the above don't support EBCDIC anyway */ + if (s[i] < 0x80 || s[i] > 0xBF) +# endif + { + *retlen = i; + break; + } + } while (++i < *retlen); + } + +# endif + + } + } + + return ret; +} + +# endif +#endif + +#if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf) +#undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses + to read past a NUL, making it much less likely to read + off the end of the buffer. 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. */ + +__UNDEFINED__ utf8_to_uvchr(s, lp) \ + ((*(s) == '\0') \ + ? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */ \ + : utf8_to_uvchr_buf(s, (s) + UTF8_CHK_SKIP(s), (lp))) + +#endif + +/* Hint: utf8_to_uvchr + Use utf8_to_uvchr_buf() instead. But ONLY if you KNOW the upper bound + of the input string (not resorting to using UTF8SKIP, etc., to infer it). + The backported utf8_to_uvchr() will do a better job to prevent most cases + of trying to read beyond the end of the buffer */ + +/* Replace utf8_to_uvchr with utf8_to_uvchr_buf */ + +#ifdef sv_len_utf8 + /* Older Perl versions have broken sv_len_utf8() when passed sv does not have SVf_UTF8 flag set */ + /* Also note that SvGETMAGIC() may change presence of SVf_UTF8 flag */ +# if { VERSION < 5.17.5 } +# undef sv_len_utf8 +# if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define sv_len_utf8_nomg(sv) ({ SV *_sv2 = (sv); (SvUTF8(_sv2) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(_sv2) ? _sv2 : sv_mortalcopy_flags(_sv2, SV_NOSTEAL))) : ({ STRLEN _len; SvPV_nomg(_sv2, _len); _len; })); }) +# define sv_len_utf8(sv) ({ SV *_sv1 = (sv); SvGETMAGIC(_sv1); sv_len_utf8_nomg(_sv1); }) +# else +# define sv_len_utf8_nomg(sv) (PL_Sv = (sv), (SvUTF8(PL_Sv) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL))) : (SvPV_nomg(PL_Sv, PL_na), PL_na))) +# define sv_len_utf8(sv) (PL_Sv = (sv), SvGETMAGIC(PL_Sv), sv_len_utf8_nomg(PL_Sv)) +# endif +# endif +# if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) + __UNDEFINED__ sv_len_utf8_nomg(sv) ({ SV *_sv = (sv); sv_len_utf8(!SvGMAGICAL(_sv) ? _sv : sv_mortalcopy_flags(_sv, SV_NOSTEAL)); }) +# else + __UNDEFINED__ sv_len_utf8_nomg(sv) ((PL_Sv = (sv)), sv_len_utf8(!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL))) +# endif +#endif + +=xsinit + +#define NEED_utf8_to_uvchr_buf + +=xsubs + +#if defined(UTF8f) && defined(newSVpvf) + +void +UTF8f(x) + SV *x + PREINIT: + U32 u; + STRLEN len; + char *ptr; + INIT: + ptr = SvPV(x, len); + u = SvUTF8(x); + PPCODE: + x = sv_2mortal(newSVpvf("[%" UTF8f "]", UTF8fARG(u, len, ptr))); + XPUSHs(x); + XSRETURN(1); + +#endif + +#if { VERSION >= 5.006 } /* This is just a helper fcn, not publicized */ \ + /* as being available and params not what the */ \ + /* API function has; works on EBCDIC too */ + +SV * +uvchr_to_utf8(native) + + UV native + PREINIT: + int len; + U8 string[UTF8_MAXBYTES+1]; + int i; + UV uni; + + CODE: + len = UVCHR_SKIP(native); + + for (i = 0; i < len; i++) { + string[i] = '\0'; + } + + if (len <= 1) { + string[0] = native; + } + else { + i = len; + uni = NATIVE_TO_UNI(native); + while (i-- > 1) { + string[i] = I8_TO_NATIVE_UTF8((uni & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK); + uni >>= UTF_ACCUMULATION_SHIFT; + } + string[0] = I8_TO_NATIVE_UTF8((uni & UTF_START_MASK(len)) | UTF_START_MARK(len)); + } + + RETVAL = newSVpvn((char *) string, len); + SvUTF8_on(RETVAL); + OUTPUT: + RETVAL + +#endif +#if defined(UTF8_SAFE_SKIP) && defined(UTF8SKIP) + +STRLEN +UTF8_SAFE_SKIP(s, adjustment) + char * s + int adjustment + PREINIT: + const char *const_s; + CODE: + const_s = s; + /* Instead of passing in an 'e' ptr, use the real end, adjusted */ + RETVAL = UTF8_SAFE_SKIP(const_s, s + UTF8SKIP(s) + adjustment); + OUTPUT: + RETVAL + +#endif + +#ifdef isUTF8_CHAR + +STRLEN +isUTF8_CHAR(s, adjustment) + unsigned char * s + int adjustment + PREINIT: + const unsigned char *const_s; + const unsigned char *const_e; + CODE: + const_s = s; + /* Instead of passing in an 'e' ptr, use the real end, adjusted */ + const_e = const_s + UTF8SKIP(const_s) + adjustment; + RETVAL = isUTF8_CHAR(const_s, const_e); + OUTPUT: + RETVAL + +#endif + + +#ifdef foldEQ_utf8 + +STRLEN +foldEQ_utf8(s1, l1, u1, s2, l2, u2) + char *s1 + UV l1 + bool u1 + char *s2 + UV l2 + bool u2 + PREINIT: + const char *const_s1; + const char *const_s2; + CODE: + const_s1 = s1; + const_s2 = s2; + RETVAL = foldEQ_utf8(const_s1, NULL, l1, u1, const_s2, NULL, l2, u2); + OUTPUT: + RETVAL + +#endif + +#ifdef utf8_to_uvchr_buf + +AV * +utf8_to_uvchr_buf(s, adjustment) + unsigned char *s + int adjustment + PREINIT: + AV *av; + STRLEN len; + const unsigned char *const_s; + CODE: + av = newAV(); + const_s = s; + av_push(av, newSVuv(utf8_to_uvchr_buf(const_s, + s + UTF8SKIP(s) + adjustment, + &len))); + if (len == (STRLEN) -1) { + av_push(av, newSViv(-1)); + } + else { + av_push(av, newSVuv(len)); + } + RETVAL = av; + OUTPUT: + RETVAL + +#endif + +#ifdef utf8_to_uvchr + +AV * +utf8_to_uvchr(s) + unsigned char *s + PREINIT: + AV *av; + STRLEN len; + const unsigned char *const_s; + CODE: + av = newAV(); + const_s = s; + av_push(av, newSVuv(utf8_to_uvchr(const_s, &len))); + if (len == (STRLEN) -1) { + av_push(av, newSViv(-1)); + } + else { + av_push(av, newSVuv(len)); + } + RETVAL = av; + OUTPUT: + RETVAL + +#endif + +#ifdef sv_len_utf8 + +STRLEN +sv_len_utf8(sv) + SV *sv + CODE: + RETVAL = sv_len_utf8(sv); + OUTPUT: + RETVAL + +#endif + +#ifdef sv_len_utf8_nomg + +STRLEN +sv_len_utf8_nomg(sv) + SV *sv + CODE: + RETVAL = sv_len_utf8_nomg(sv); + OUTPUT: + RETVAL + +#endif + +#ifdef UVCHR_IS_INVARIANT + +bool +UVCHR_IS_INVARIANT(c) + unsigned c + PREINIT: + CODE: + RETVAL = UVCHR_IS_INVARIANT(c); + OUTPUT: + RETVAL + +#endif + +#ifdef UVCHR_SKIP + +STRLEN +UVCHR_SKIP(c) + UV c + PREINIT: + CODE: + RETVAL = UVCHR_SKIP(c); + OUTPUT: + RETVAL + +#endif + +=tests plan => 98 + +BEGIN { + # skip tests on 5.6.0 and earlier, plus 5.7.0 + if (ivers($]) <= ivers(5.6) || ivers($]) == ivers(5.7) ) { + skip 'skip: broken utf8 support', 98; + exit; + } + require warnings; +} + +is(Devel::PPPort::UTF8f(42), '[42]'); +is(Devel::PPPort::UTF8f('abc'), '[abc]'); +is(Devel::PPPort::UTF8f("\x{263a}"), "[\x{263a}]"); + +my $str = "\x{A8}"; +if (ivers($]) >= ivers(5.8)) { eval q{utf8::upgrade($str)} } +is(Devel::PPPort::UTF8f($str), "[\x{A8}]"); +if (ivers($]) >= ivers(5.8)) { eval q{utf8::downgrade($str)} } +is(Devel::PPPort::UTF8f($str), "[\x{A8}]"); + +is(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1); +is(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0); + +is(&Devel::PPPort::isUTF8_CHAR("A", -1), 0); +is(&Devel::PPPort::isUTF8_CHAR("A", 0), 1); +is(&Devel::PPPort::isUTF8_CHAR("\x{100}", -1), 0); +is(&Devel::PPPort::isUTF8_CHAR("\x{100}", 0), 2); + +is(&Devel::PPPort::UVCHR_IS_INVARIANT(ord("A")), 1); +ok(! &Devel::PPPort::UVCHR_IS_INVARIANT(0xb6)); +ok(! &Devel::PPPort::UVCHR_IS_INVARIANT(0x100)); + +is(&Devel::PPPort::UVCHR_SKIP(ord("A")), 1); +is(&Devel::PPPort::UVCHR_SKIP(0xb6), 2, "This is a test"); +is(&Devel::PPPort::UVCHR_SKIP(0x3FF), 2); +is(&Devel::PPPort::UVCHR_SKIP(0x3FFF), 3); +is(&Devel::PPPort::UVCHR_SKIP(0x3FFFF), 4); +is(&Devel::PPPort::UVCHR_SKIP(0x3FFFFF), 5); +is(&Devel::PPPort::UVCHR_SKIP(0x3FFFFFF), ord("A") == 65 ? 5 : 6); +is(&Devel::PPPort::UVCHR_SKIP(0x4000000), ord("A") == 65 ? 6 : 7); +if (ord("A") != 65) { + skip("Test not valid on EBCDIC", 1) +} +else { + is(&Devel::PPPort::UVCHR_SKIP(0xFFFFFFFF), 7); +} + +if (ivers($]) < ivers(5.8)) { + skip("Perl version too early", 3); +} +else { + is(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{101}", 3, 1), 1); + is(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{102}", 3, 1), 0); + is(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "b\x{101}", 3, 1), 0); +} + +my $ret = &Devel::PPPort::utf8_to_uvchr("A"); +is($ret->[0], ord("A")); +is($ret->[1], 1); + +$ret = &Devel::PPPort::utf8_to_uvchr("\0"); +is($ret->[0], 0); +is($ret->[1], 1); + +$ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0); +is($ret->[0], ord("A")); +is($ret->[1], 1); + +$ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0); +is($ret->[0], 0); +is($ret->[1], 1); + +my @buf_tests = ( + { + input => "A", + adjustment => -1, + warning => eval "qr/empty/", + no_warnings_returned_length => 0, + }, + { + input => "\xc4\xc5", + adjustment => 0, + warning => eval "qr/non-continuation/", + no_warnings_returned_length => 1, + }, + { + input => "\xc4\x80", + adjustment => -1, + warning => eval "qr/short|1 byte, need 2/", + no_warnings_returned_length => 1, + }, + { + input => "\xc0\x81", + adjustment => 0, + warning => eval "qr/overlong|2 bytes, need 1/", + no_warnings_returned_length => 2, + }, + { + input => "\xe0\x80\x81", + adjustment => 0, + warning => eval "qr/overlong|3 bytes, need 1/", + no_warnings_returned_length => 3, + }, + { + input => "\xf0\x80\x80\x81", + adjustment => 0, + warning => eval "qr/overlong|4 bytes, need 1/", + no_warnings_returned_length => 4, + }, + { # Old algorithm failed to detect this + input => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf", + adjustment => 0, + warning => eval "qr/overflow/", + no_warnings_returned_length => 13, + }, +); + +if (ord("A") != 65) { # tests not valid for EBCDIC + skip("Perl version too early", 2 + 4 + (scalar @buf_tests * 5)); +} +else { + $ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0); + is($ret->[0], 0x100); + is($ret->[1], 2); + + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, @_; }; + + { + use warnings 'utf8'; + $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80"); + is($ret->[0], 0); + is($ret->[1], -1); + + no warnings 'utf8'; + $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80"); + is($ret->[0], 0xFFFD); + is($ret->[1], 1); + } + + + # An empty input is an assertion failure on debugging builds. It is + # deliberately the first test. + require Config; import Config; + use vars '%Config'; + + # VMS doesn't put DEBUGGING in ccflags, and Windows doesn't have + # $Config{config_args}. When 5.14 or later can be assumed, use + # Config::non_bincompat_options(), but for now we're stuck with this. + if ( $Config{ccflags} =~ /-DDEBUGGING/ + || $^O eq 'VMS' && $Config{config_args} =~ /\bDDEBUGGING\b/) + { + shift @buf_tests; + skip("Test not valid on DEBUGGING builds", 5); + } + + my $test; + for $test (@buf_tests) { + my $input = $test->{'input'}; + my $adjustment = $test->{'adjustment'}; + my $display = 'utf8_to_uvchr_buf("'; + my $i; + for ($i = 0; $i < length($input) + $adjustment; $i++) { + $display .= sprintf "\\x%02x", ord substr($input, $i, 1); + } + + $display .= '")'; + my $warning = $test->{'warning'}; + + undef @warnings; + use warnings 'utf8'; + $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment); + is($ret->[0], 0, "returned value $display; warnings enabled"); + is($ret->[1], -1, "returned length $display; warnings enabled"); + my $all_warnings = join "; ", @warnings; + my $contains = grep { $_ =~ $warning } $all_warnings; + is($contains, 1, $display + . "; Got: '$all_warnings', which should contain '$warning'"); + + undef @warnings; + no warnings 'utf8'; + $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment); + is($ret->[0], 0xFFFD, "returned value $display; warnings disabled"); + is($ret->[1], $test->{'no_warnings_returned_length'}, + "returned length $display; warnings disabled"); + } +} + +if (ivers($]) ge ivers(5.008)) { + BEGIN { if (ivers($]) ge ivers(5.008)) { require utf8; "utf8"->import() } } + + is(Devel::PPPort::sv_len_utf8("aščť"), 4); + is(Devel::PPPort::sv_len_utf8_nomg("aščť"), 4); + + my $str = "áíé"; + utf8::downgrade($str); + is(Devel::PPPort::sv_len_utf8($str), 3); + utf8::downgrade($str); + is(Devel::PPPort::sv_len_utf8_nomg($str), 3); + utf8::upgrade($str); + is(Devel::PPPort::sv_len_utf8($str), 3); + utf8::upgrade($str); + is(Devel::PPPort::sv_len_utf8_nomg($str), 3); + + tie my $scalar, 'TieScalarCounter', "é"; + + is(tied($scalar)->{fetch}, 0); + is(tied($scalar)->{store}, 0); + is(Devel::PPPort::sv_len_utf8($scalar), 2); + is(tied($scalar)->{fetch}, 1); + is(tied($scalar)->{store}, 0); + is(Devel::PPPort::sv_len_utf8($scalar), 3); + is(tied($scalar)->{fetch}, 2); + is(tied($scalar)->{store}, 0); + is(Devel::PPPort::sv_len_utf8($scalar), 4); + is(tied($scalar)->{fetch}, 3); + is(tied($scalar)->{store}, 0); + is(Devel::PPPort::sv_len_utf8_nomg($scalar), 4); + is(tied($scalar)->{fetch}, 3); + is(tied($scalar)->{store}, 0); + is(Devel::PPPort::sv_len_utf8_nomg($scalar), 4); + is(tied($scalar)->{fetch}, 3); + is(tied($scalar)->{store}, 0); +} else { + skip 'skip: no utf8::downgrade/utf8::upgrade support', 23; +} + +package TieScalarCounter; + +sub TIESCALAR { + my ($class, $value) = @_; + return bless { fetch => 0, store => 0, value => $value }, $class; +} + +sub FETCH { + BEGIN { if (main::ivers($]) ge main::ivers(5.008)) { require utf8; "utf8"->import() } } + my ($self) = @_; + $self->{fetch}++; + return $self->{value} .= "é"; +} + +sub STORE { + my ($self, $value) = @_; + $self->{store}++; + $self->{value} = $value; +} diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/uv b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/uv index bb5f19eaaad..96145e6833e 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/uv +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/uv @@ -14,17 +14,9 @@ __UNDEFINED__ my_strnlen SvUOK -utf8_to_uvchr_buf - -=dontwarn - -_ppport_utf8_to_uvchr_buf_callee -_ppport_MIN =implementation -#define _ppport_MIN(a,b) (((a) <= (b)) ? (a) : (b)) - __UNDEFINED__ sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ @@ -36,15 +28,26 @@ __UNDEFINED__ sv_setuv(sv, uv) \ __UNDEFINED__ newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +__UNDEFINED__ sv_2uv(sv) ({ SV *_sv = (sv); (UV) (SvNOK(_sv) ? SvNV(_sv) : sv_2nv(_sv)); }) +#else __UNDEFINED__ sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + __UNDEFINED__ SvUVX(sv) ((UV)SvIVX(sv)) __UNDEFINED__ SvUVXx(sv) SvUVX(sv) __UNDEFINED__ SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +__UNDEFINED__ SvUVx(sv) ({ SV *_sv = (sv)); SvUV(_sv); }) +#else __UNDEFINED__ SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ +/* Replace sv_uv with SvUVx */ __UNDEFINED__ sv_uv(sv) SvUVx(sv) #if !defined(SvUOK) && defined(SvIOK_UV) @@ -57,21 +60,10 @@ __UNDEFINED__ XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_E __UNDEFINED__ PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END __UNDEFINED__ XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END -#if defined UTF8SKIP - -/* Don't use official version because it uses MIN, which may not be available */ -#undef UTF8_SAFE_SKIP - -__UNDEFINED__ UTF8_SAFE_SKIP(s, e) ( \ - ((((e) - (s)) <= 0) \ - ? 0 \ - : _ppport_MIN(((e) - (s)), UTF8SKIP(s)))) -#endif - #if !defined(my_strnlen) #if { NEED my_strnlen } -STRLEN +Size_t my_strnlen(const char *str, Size_t maxlen) { const char *p = str; @@ -85,212 +77,9 @@ my_strnlen(const char *str, Size_t maxlen) #endif #endif -#if { VERSION < 5.31.2 } - /* Versions prior to this accepted things that are now considered - * malformations, and didn't return -1 on error with warnings enabled - * */ -# undef utf8_to_uvchr_buf -#endif - -/* This implementation brings modern, generally more restricted standards to - * utf8_to_uvchr_buf. Some of these are security related, and clearly must - * be done. But its arguable that the others need not, and hence should not. - * The reason they're here is that a module that intends to play with the - * latest perls shoud be able to work the same in all releases. An example is - * that perl no longer accepts any UV for a code point, but limits them to - * IV_MAX or below. This is for future internal use of the larger code points. - * If it turns out that some of these changes are breaking code that isn't - * intended to work with modern perls, the tighter restrictions could be - * relaxed. khw thinks this is unlikely, but has been wrong in the past. */ - -#ifndef utf8_to_uvchr_buf - /* Choose which underlying implementation to use. At least one must be - * present or the perl is too early to handle this function */ -# if defined(utf8n_to_uvchr) || defined(utf8_to_uv) -# if defined(utf8n_to_uvchr) /* This is the preferred implementation */ -# define _ppport_utf8_to_uvchr_buf_callee utf8n_to_uvchr -# else -# define _ppport_utf8_to_uvchr_buf_callee utf8_to_uv -# endif - -# endif - -#ifdef _ppport_utf8_to_uvchr_buf_callee -# if { NEED utf8_to_uvchr_buf } - -UV -utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) -{ - UV ret; - STRLEN curlen; - bool overflows = 0; - const U8 *cur_s = s; - const bool do_warnings = ckWARN_d(WARN_UTF8); - - if (send > s) { - curlen = send - s; - } - else { - assert(0); /* Modern perls die under this circumstance */ - curlen = 0; - if (! do_warnings) { /* Handle empty here if no warnings needed */ - if (retlen) *retlen = 0; - return UNICODE_REPLACEMENT; - } - } - - /* The modern version allows anything that evaluates to a legal UV, but not - * overlongs nor an empty input */ - ret = _ppport_utf8_to_uvchr_buf_callee( - s, curlen, retlen, (UTF8_ALLOW_ANYUV - & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY))); - - /* But actually, modern versions restrict the UV to being no more than what - * an IV can hold */ - if (ret > PERL_INT_MAX) { - overflows = 1; - } - -# if { VERSION < 5.26.0 } -# ifndef EBCDIC - - /* There are bugs in versions earlier than this on non-EBCDIC platforms - * in which it did not detect all instances of overflow, which could be - * a security hole. Also, earlier versions did not allow the overflow - * malformation under any circumstances, and modern ones do. So we - * need to check here. */ - - else if (curlen > 0 && *s >= 0xFE) { - - /* If the main routine detected overflow, great; it returned 0. But if the - * input's first byte indicates it could overflow, we need to verify. - * First, on a 32-bit machine the first byte being at least \xFE - * automatically is overflow */ - if (sizeof(ret) < 8) { - overflows = 1; - } - else { - const U8 highest[] = /* 2*63-1 */ - "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"; - const U8 *cur_h = highest; - - for (cur_s = s; cur_s < send; cur_s++, cur_h++) { - if (UNLIKELY(*cur_s == *cur_h)) { - continue; - } - - /* If this byte is larger than the corresponding highest UTF-8 - * byte, the sequence overflows; otherwise the byte is less than - * (as we handled the equality case above), and so the sequence - * doesn't overflow */ - overflows = *cur_s > *cur_h; - break; - - } - - /* Here, either we set the bool and broke out of the loop, or got - * to the end and all bytes are the same which indicates it doesn't - * overflow. */ - } - } - -# endif -# endif /* < 5.26 */ - - if (UNLIKELY(overflows)) { - if (! do_warnings) { - if (retlen) { - *retlen = _ppport_MIN(*retlen, UTF8SKIP(s)); - *retlen = _ppport_MIN(*retlen, curlen); - } - return UNICODE_REPLACEMENT; - } - else { - - /* On versions that correctly detect overflow, but forbid it - * always, 0 will be returned, but also a warning will have been - * raised. Don't repeat it */ - if (ret != 0) { - /* We use the error message in use from 5.8-5.14 */ - Perl_warner(aTHX_ packWARN(WARN_UTF8), - "Malformed UTF-8 character (overflow at 0x%" UVxf - ", byte 0x%02x, after start byte 0x%02x)", - ret, *cur_s, *s); - } - if (retlen) { - *retlen = (STRLEN) -1; - } - return 0; - } - } - - /* If failed and warnings are off, to emulate the behavior of the real - * utf8_to_uvchr(), try again, allowing anything. (Note a return of 0 is - * ok if the input was '\0') */ - if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) { - - /* If curlen is 0, we already handled the case where warnings are - * disabled, so this 'if' will be true, and we won't look at the - * contents of 's' */ - if (do_warnings) { - *retlen = (STRLEN) -1; - } - else { - ret = _ppport_utf8_to_uvchr_buf_callee( - s, curlen, retlen, UTF8_ALLOW_ANY); - /* Override with the REPLACEMENT character, as that is what the - * modern version of this function returns */ - ret = UNICODE_REPLACEMENT; - -# if { VERSION < 5.16.0 } - - /* Versions earlier than this don't necessarily return the proper - * length. It should not extend past the end of string, nor past - * what the first byte indicates the length is, nor past the - * continuation characters */ - if (retlen && *retlen >= 0) { - *retlen = _ppport_MIN(*retlen, curlen); - *retlen = _ppport_MIN(*retlen, UTF8SKIP(s)); - unsigned int i = 1; - do { - if (s[i] < 0x80 || s[i] > 0xBF) { - *retlen = i; - break; - } - } while (++i < *retlen); - } - -# endif - - } - } - - return ret; -} - -# endif -#endif -#endif - -#if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf) -#undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses - to read past a NUL, making it much less likely to read - off the end of the buffer. 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. */ - -__UNDEFINED__ utf8_to_uvchr(s, lp) \ - ((*(s) == '\0') \ - ? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */ \ - : utf8_to_uvchr_buf(s, (s) + my_strnlen((char *) (s), UTF8SKIP(s)), (lp))) - -#endif - =xsinit #define NEED_my_strnlen -#define NEED_utf8_to_uvchr_buf =xsubs @@ -353,16 +142,6 @@ XPUSHu() XSRETURN(1); STRLEN -UTF8_SAFE_SKIP(s, adjustment) - unsigned char * s - int adjustment - CODE: - /* Instead of passing in an 'e' ptr, use the real end, adjusted */ - RETVAL = UTF8_SAFE_SKIP(s, s + UTF8SKIP(s) + adjustment); - OUTPUT: - RETVAL - -STRLEN my_strnlen(s, max) char * s STRLEN max @@ -371,169 +150,18 @@ my_strnlen(s, max) OUTPUT: RETVAL -AV * -utf8_to_uvchr_buf(s, adjustment) - unsigned char *s - int adjustment - PREINIT: - AV *av; - STRLEN len; - CODE: - av = newAV(); - av_push(av, newSVuv(utf8_to_uvchr_buf(s, - s + UTF8SKIP(s) + adjustment, - &len))); - if (len == (STRLEN) -1) { - av_push(av, newSViv(-1)); - } - else { - av_push(av, newSVuv(len)); - } - RETVAL = av; - OUTPUT: - RETVAL - -AV * -utf8_to_uvchr(s) - unsigned char *s - PREINIT: - AV *av; - STRLEN len; - CODE: - av = newAV(); - av_push(av, newSVuv(utf8_to_uvchr(s, &len))); - if (len == (STRLEN) -1) { - av_push(av, newSViv(-1)); - } - else { - av_push(av, newSVuv(len)); - } - RETVAL = av; - OUTPUT: - RETVAL - -=tests plan => 52 - -ok(&Devel::PPPort::sv_setuv(42), 42); -ok(&Devel::PPPort::newSVuv(123), 123); -ok(&Devel::PPPort::sv_2uv("4711"), 4711); -ok(&Devel::PPPort::sv_2uv("1735928559"), 1735928559); -ok(&Devel::PPPort::SvUVx("1735928559"), 1735928559); -ok(&Devel::PPPort::SvUVx(1735928559), 1735928559); -ok(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef); -ok(&Devel::PPPort::XSRETURN_UV(), 42); -ok(&Devel::PPPort::PUSHu(), 42); -ok(&Devel::PPPort::XPUSHu(), 43); -ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1); -ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0); -ok(&Devel::PPPort::my_strnlen("abc\0def", 7), 3); - -my $ret = &Devel::PPPort::utf8_to_uvchr("A"); -ok($ret->[0], ord("A")); -ok($ret->[1], 1); - -$ret = &Devel::PPPort::utf8_to_uvchr("\0"); -ok($ret->[0], 0); -ok($ret->[1], 1); - -$ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0); -ok($ret->[0], ord("A")); -ok($ret->[1], 1); - -$ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0); -ok($ret->[0], 0); -ok($ret->[1], 1); - -if (ord("A") != 65) { # tests not valid for EBCDIC - ok(1, 1) for 1 .. (2 + 4 + (5 * 5)); -} -else { - $ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0); - ok($ret->[0], 0x100); - ok($ret->[1], 2); - - my @warnings; - local $SIG{__WARN__} = sub { push @warnings, @_; }; - - { - use warnings 'utf8'; - $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80"); - ok($ret->[0], 0); - ok($ret->[1], -1); - - no warnings; - $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80"); - ok($ret->[0], 0xFFFD); - ok($ret->[1], 1); - } - - my @buf_tests = ( - { - input => "A", - adjustment => -1, - warning => qr/empty/, - no_warnings_returned_length => 0, - }, - { - input => "\xc4\xc5", - adjustment => 0, - warning => qr/non-continuation/, - no_warnings_returned_length => 1, - }, - { - input => "\xc4\x80", - adjustment => -1, - warning => qr/short|1 byte, need 2/, - no_warnings_returned_length => 1, - }, - { - input => "\xc0\x81", - adjustment => 0, - warning => qr/overlong|2 bytes, need 1/, - no_warnings_returned_length => 2, - }, - { # Old algorithm supposedly failed to detect this - input => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf", - adjustment => 0, - warning => qr/overflow/, - no_warnings_returned_length => 13, - }, - ); - - # An empty input is an assertion failure on debugging builds. It is - # deliberately the first test. - require Config; import Config; - use vars '%Config'; - if ($Config{ccflags} =~ /-DDEBUGGING/) { - shift @buf_tests; - ok(1, 1) for 1..5; - } - - for my $test (@buf_tests) { - my $input = $test->{'input'}; - my $adjustment = $test->{'adjustment'}; - my $display = 'utf8_to_uvchr_buf("'; - for (my $i = 0; $i < length($input) + $adjustment; $i++) { - $display .= sprintf "\\x%02x", ord substr($input, $i, 1); - } - - $display .= '")'; - my $warning = $test->{'warning'}; - - undef @warnings; - use warnings 'utf8'; - $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment); - ok($ret->[0], 0, "returned value $display; warnings enabled"); - ok($ret->[1], -1, "returned length $display; warnings enabled"); - my $all_warnings = join "; ", @warnings; - my $contains = grep { $_ =~ $warning } $all_warnings; - ok($contains, 1, $display . "; '$all_warnings' contains '$warning'"); - - undef @warnings; - no warnings 'utf8'; - $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment); - ok($ret->[0], 0xFFFD, "returned value $display; warnings disabled"); - ok($ret->[1], $test->{'no_warnings_returned_length'}, - "returned length $display; warnings disabled"); - } -} +=tests plan => 11 + +BEGIN { require warnings if "$]" > '5.006' } + +is(&Devel::PPPort::sv_setuv(42), 42); +is(&Devel::PPPort::newSVuv(123), 123); +is(&Devel::PPPort::sv_2uv("4711"), 4711); +is(&Devel::PPPort::sv_2uv("1735928559"), 1735928559); +is(&Devel::PPPort::SvUVx("1735928559"), 1735928559); +is(&Devel::PPPort::SvUVx(1735928559), 1735928559); +is(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef); +is(&Devel::PPPort::XSRETURN_UV(), 42); +is(&Devel::PPPort::PUSHu(), 42); +is(&Devel::PPPort::XPUSHu(), 43); +is(&Devel::PPPort::my_strnlen("abc\0def", 7), 3); diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/variables b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/variables index 83dd5e83081..cc984c852b1 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/variables +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/variables @@ -18,6 +18,7 @@ PL_DBsingle PL_DBsub PL_DBtrace PL_Sv +PL_Xpv PL_bufend PL_bufptr PL_compiling @@ -58,6 +59,7 @@ PL_tainted PL_tainting PL_tokenbuf PL_signals +PL_mess_sv PERL_SIGNALS_UNSAFE_FLAG =implementation @@ -97,6 +99,7 @@ __NEED_VAR__ U32 PL_signals = D_PPP_PERL_SIGNALS_INIT; # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv +# define PL_Xpv Xpv # define PL_bufend bufend # define PL_bufptr bufptr # define PL_compiling compiling @@ -134,13 +137,14 @@ __NEED_VAR__ U32 PL_signals = D_PPP_PERL_SIGNALS_INIT; # define PL_tainted tainted # define PL_tainting tainting # define PL_tokenbuf tokenbuf +# define PL_mess_sv mess_sv /* Replace: 0 */ #endif /* Warning: PL_parser * For perl versions earlier than 5.9.5, this is an always * non-NULL dummy. Also, it cannot be dereferenced. Don't - * use it if you can avoid is and unless you absolutely know + * use it if you can avoid it, and unless you absolutely know * what you're doing. * If you always check that PL_parser is non-NULL, you can * define DPPP_PL_parser_NO_DUMMY to avoid the creation of @@ -438,13 +442,13 @@ ok(Devel::PPPort::compare_PL_signals()); ok(!defined(&Devel::PPPort::PL_sv_undef())); ok(&Devel::PPPort::PL_sv_yes()); ok(!&Devel::PPPort::PL_sv_no()); -ok(&Devel::PPPort::PL_na("abcd"), 4); -ok(&Devel::PPPort::PL_Sv(), "mhx"); +is(&Devel::PPPort::PL_na("abcd"), 4); +is(&Devel::PPPort::PL_Sv(), "mhx"); ok(defined &Devel::PPPort::PL_tokenbuf()); ok("$]" >= 5.009005 || &Devel::PPPort::PL_parser()); ok(&Devel::PPPort::PL_hexdigit() =~ /^[0-9a-zA-Z]+$/); ok(defined &Devel::PPPort::PL_hints()); -ok(&Devel::PPPort::PL_ppaddr("mhx"), "MHX"); +is(&Devel::PPPort::PL_ppaddr("mhx"), "MHX"); for (&Devel::PPPort::other_variables()) { ok($_ != 0); @@ -470,7 +474,7 @@ for (&Devel::PPPort::other_variables()) { else { ok(@w == 0); } - ok($fail, 0); + is($fail, 0); } ok(&Devel::PPPort::no_dummy_parser_vars(1) >= ("$]" < 5.009005 ? 1 : 0)); @@ -478,7 +482,7 @@ ok(&Devel::PPPort::no_dummy_parser_vars(1) >= ("$]" < 5.009005 ? 1 : 0)); eval { &Devel::PPPort::no_dummy_parser_vars(0) }; if ("$]" < 5.009005) { - ok($@, ''); + is($@, ''); } else { if ($@) { diff --git a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/warn b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/warn index b4a5695f8ff..32c772ea2ad 100644 --- a/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/warn +++ b/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/warn @@ -159,7 +159,7 @@ ok("$]" >= 5.004 ? $warning =~ /^Perl_warner_nocontext bar:42/ : $warning eq '') $warning = ''; Devel::PPPort::ckWARN(); -ok($warning, ''); +is($warning, ''); $^W = 1; |