In perl.git, the branch smoke-me/arc/unicode-range-operator has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/d6c970c7e66d6f55dba7f13549143a2f4ba641c7?hp=e4e5e9bc2a06b222cb3293449c2816d7b9be2a0c> discards e4e5e9bc2a06b222cb3293449c2816d7b9be2a0c (commit) - Log ----------------------------------------------------------------- commit d6c970c7e66d6f55dba7f13549143a2f4ba641c7 Author: Aaron Crane <[email protected]> Date: Sun Nov 20 14:18:22 2016 +0000 Fix the Unicode Bug in the range operator ----------------------------------------------------------------------- Summary of changes: Configure | 34 +++++++++++++++++++-- Makefile.SH | 76 +++++++++++++++++++++++++++++++++++++++++----- Porting/Glossary | 5 +++ dist/Data-Dumper/Dumper.pm | 6 ++-- dist/Data-Dumper/Dumper.xs | 2 ++ dist/Data-Dumper/t/bugs.t | 13 +++++++- embed.fnc | 4 +-- ext/XS-APItest/Makefile.PL | 3 +- ext/XS-APItest/t/handy.t | 8 ++--- hints/freebsd.sh | 8 +++++ lib/perl5db.pl | 19 +++++++----- pod/perldelta.pod | 32 ++++++++++++++++++- pod/perlop.pod | 6 ++++ pp_hot.c | 2 +- proto.h | 4 +-- regcomp.c | 15 ++------- sv.c | 4 +-- sv.h | 3 ++ t/op/method.t | 9 +++++- t/re/pat.t | 10 +++++- toke.c | 9 ++++-- utf8.c | 2 +- 22 files changed, 219 insertions(+), 55 deletions(-) diff --git a/Configure b/Configure index 845fc43d76..9d91a81c4f 100755 --- a/Configure +++ b/Configure @@ -949,6 +949,7 @@ lddlflags='' usedl='' doublesize='' dtraceobject='' +dtracexnolibs='' ebcdic='' fflushNULL='' fflushall='' @@ -20966,12 +20967,38 @@ randseedtype=U32 : object file that uses at least one of the probes defined in the .d file case "$usedtrace" in $define) + case "$dtracexnolibs" in + $define|true|[yY]*) + dtracexnolibs=$define + $dtrace -h -xnolibs -s ../perldtrace.d -o perldtrace.h + ;; + ' '|'') + if $dtrace -h -xnolibs -s ../perldtrace.d -o perldtrace.h 2>&1 ; then + dtracexnolibs=$define + echo "Your dtrace accepts -xnolibs" + elif $dtrace -h -s ../perldtrace.d -o perldtrace.h 2>&1 ; then + dtracexnolibs=$undef + echo "Your dtrace doesn't accept -xnolibs" + else + echo "Your dtrace doesn't work at all, try building without dtrace support" >&4 + exit 1 + fi + ;; + *) + dtracexnolibs=$undef + $dtrace -h -s ../perldtrace.d -o perldtrace.h + ;; + esac + case $dtracexnolibs in + $define) xnolibs=-xnolibs ;; + *) xnolibs= ;; + esac + case "$dtraceobject" in $define|true|[yY]*) dtraceobject=$define ;; ' '|'') - $dtrace -h -s ../perldtrace.d -o perldtrace.h $cat >try.c <<EOM #include "perldtrace.h" int main(void) { @@ -20981,14 +21008,14 @@ int main(void) { EOM dtraceobject=$undef if $cc -c -o try.o $optimize $ccflags try.c \ - && $dtrace -G -s ../perldtrace.d try.o >/dev/null 2>&1; then + && $dtrace -G $xnolibs -s ../perldtrace.d try.o >/dev/null 2>&1; then dtraceobject=$define echo "Your dtrace builds an object file" fi - $rm -f try.c try.o perldtrace.o ;; *) dtraceobject=$undef ;; esac + $rm -f try.c try.o perldtrace.o perldtrace.h esac : Determine if this is an EBCDIC system @@ -24954,6 +24981,7 @@ drand01='$drand01' drand48_r_proto='$drand48_r_proto' dtrace='$dtrace' dtraceobject='$dtraceobject' +dtracexnolibs='$dtracexnolibs' dynamic_ext='$dynamic_ext' eagain='$eagain' ebcdic='$ebcdic' diff --git a/Makefile.SH b/Makefile.SH index 6c5ec87c61..1b81e20adc 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -390,8 +390,13 @@ VG_TEST ?= ./perl -e 1 2>/dev/null ;; esac +case "$dtracexnolibs" in +define) xnolibs=-xnolibs ;; +*) xnolibs= ;; +esac + $spitshell >>$Makefile <<!GROK!THIS! -DTRACE = $dtrace +DTRACE = $dtrace $xnolibs DTRACE_H = $dtrace_h DTRACE_PERLLIB_O = $dtrace_perllib_o # "dtrace -G" output for perllib_objs @@ -518,10 +523,52 @@ main_only_objs = op$(OBJ_EXT) perl$(OBJ_EXT) miniperl_objs_nodt = $(mini_only_objs) $(common_objs) miniperlmain$(OBJ_EXT) perllib_objs_nodt = $(main_only_objs) $(common_objs) +!NO!SUBS! + +# dtrace with -G modifies the source object files, which can cause +# dependency issues, and can cause the dtrace -G to fail on FreeBSD +# so separate the objects generated by $(CC) from those used to link +# the executable when dtrace -G is involved. +# +# $(FOO:op%os=np%ns) isn't generally portable but is portable to +# the makes on darwin, Solaris, FreeBSD and Linux, which is where we +# use dtrace + +case "$usedtrace:$dtraceobject" in +define:define) + $spitshell >>$Makefile <<'!NO!SUBS!' + +miniperl_dtrace_objs = $(miniperl_objs_nodt:%=mpdtrace/%) +perllib_dtrace_objs = $(perllib_objs_nodt:%=libpdtrace/%) +perlmain_dtrace_objs = maindtrace/perlmain$(OBJ_EXT) + +miniperl_objs = $(miniperl_dtrace_objs) $(DTRACE_MINI_O) +perllib_objs = $(perllib_dtrace_objs) $(DTRACE_PERLLIB_O) +perlmain_objs = $(perlmain_dtrace_objs) $(DTRACE_MAIN_O) + +miniperl_dep = $(DTRACE_MINI_O) +perllib_dep = $(DTRACE_PERLLIB_O) +perlmain_dep = $(DTRACE_MAIN_O) + +!NO!SUBS! + ;; +*) + $spitshell >>$Makefile <<'!NO!SUBS!' + miniperl_objs = $(miniperl_objs_nodt) $(DTRACE_MINI_O) perllib_objs = $(perllib_objs_nodt) $(DTRACE_PERLLIB_O) perlmain_objs = perlmain$(OBJ_EXT) $(DTRACE_MAIN_O) +miniperl_dep = $(miniperl_objs) +perllib_dep = $(perllib_objs) +perlmain_dep = $(perlmain_objs) + +!NO!SUBS! + ;; +esac + +$spitshell >>$Makefile <<'!NO!SUBS!' + perltoc_pod_prereqs = extra.pods pod/perl5259delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod generated_pods = pod/perltoc.pod $(perltoc_pod_prereqs) generated_headers = uudmap.h bitcount.h mg_data.h @@ -834,19 +881,32 @@ mydtrace.h: $(DTRACE_H) define) $spitshell >>$Makefile <<'!NO!SUBS!' $(DTRACE_MINI_O): perldtrace.d $(miniperl_objs_nodt) - $(DTRACE) -G -s perldtrace.d -o $(DTRACE_MINI_O) $(miniperl_objs_nodt) + -rm -rf mpdtrace + mkdir mpdtrace + cp $(miniperl_objs_nodt) mpdtrace/ + $(DTRACE) -G -s perldtrace.d -o $(DTRACE_MINI_O) $(miniperl_dtrace_objs) $(DTRACE_PERLLIB_O): perldtrace.d $(perllib_objs_nodt) - $(DTRACE) -G -s perldtrace.d -o $(DTRACE_PERLLIB_O) $(perllib_objs_nodt) + -rm -rf libpdtrace + mkdir libpdtrace + cp $(perllib_objs_nodt) libpdtrace/ + $(DTRACE) -G -s perldtrace.d -o $(DTRACE_PERLLIB_O) $(perllib_dtrace_objs) $(DTRACE_MAIN_O): perldtrace.d perlmain$(OBJ_EXT) - $(DTRACE) -G -s perldtrace.d -o $(DTRACE_MAIN_O) perlmain$(OBJ_EXT) + -rm -rf maindtrace + mkdir maindtrace + cp perlmain$(OBJ_EXT) maindtrace/ + $(DTRACE) -G -s perldtrace.d -o $(DTRACE_MAIN_O) $(perlmain_dtrace_objs) || \ + ( $(ECHO) "No probes in perlmain$(OBJ_EXT), generating a dummy $(DTRACE_MAIN_O)" && \ + $(ECHO) >dtrace_main.c && \ + `$(CCCMD)` $(PLDLFLAGS) dtrace_main.c && \ + rm -f dtrace_main.c ) !NO!SUBS! ;; esac $spitshell >>$Makefile <<'!NO!SUBS!' -$(LIBPERL): $& $(perllib_objs) $(DYNALOADER) $(LIBPERLEXPORT) +$(LIBPERL): $& $(perllib_dep) $(DYNALOADER) $(LIBPERLEXPORT) !NO!SUBS! case "$useshrplib" in true) @@ -947,7 +1007,7 @@ lib/buildcustomize.pl: $& $(miniperl_objs) write_buildcustomize.pl *) if test "X$hostperl" != X; then $spitshell >>$Makefile <<!GROK!THIS! -lib/buildcustomize.pl: \$& \$(miniperl_objs) write_buildcustomize.pl +lib/buildcustomize.pl: \$& \$(miniperl_dep) write_buildcustomize.pl -@rm -f miniperl.xok -@rm \$(MINIPERL_EXE) \$(LNS) \$(HOST_PERL) \$(MINIPERL_EXE) @@ -956,7 +1016,7 @@ lib/buildcustomize.pl: \$& \$(miniperl_objs) write_buildcustomize.pl !GROK!THIS! else $spitshell >>$Makefile <<'!NO!SUBS!' -lib/buildcustomize.pl: $& $(miniperl_objs) write_buildcustomize.pl +lib/buildcustomize.pl: $& $(miniperl_dep) write_buildcustomize.pl -@rm -f miniperl.xok $(CC) $(CLDFLAGS) -o $(MINIPERL_EXE) \ $(miniperl_objs) $(libs) @@ -969,7 +1029,7 @@ lib/buildcustomize.pl: $& $(miniperl_objs) write_buildcustomize.pl $spitshell >>$Makefile <<'!NO!SUBS!' -$(PERL_EXE): $& $(perlmain_objs) $(LIBPERL) $(static_ext) ext.libs $(PERLEXPORT) write_buildcustomize.pl +$(PERL_EXE): $& $(perlmain_dep) $(LIBPERL) $(static_ext) ext.libs $(PERLEXPORT) write_buildcustomize.pl -@rm -f miniperl.xok !NO!SUBS! diff --git a/Porting/Glossary b/Porting/Glossary index 1d2a6ea988..a94eaabe8a 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -3031,6 +3031,11 @@ dtrace (usedtrace.U): dtraceobject (dtraceobject.U): Whether we need to build an object file with the dtrace tool. +dtracexnolibs (dtraceobject.U): + Whether dtrace accepts -xnolibs. If available we call dtrace -h + and dtrace -G with -xnolibs to allow dtrace to run in a jail on + FreeBSD. + dynamic_ext (Extensions.U): This variable holds a list of XS extension files we want to link dynamically into the package. It is used by Makefile. diff --git a/dist/Data-Dumper/Dumper.pm b/dist/Data-Dumper/Dumper.pm index 78efd44cae..00f6326ee1 100644 --- a/dist/Data-Dumper/Dumper.pm +++ b/dist/Data-Dumper/Dumper.pm @@ -10,7 +10,7 @@ package Data::Dumper; BEGIN { - $VERSION = '2.166'; # Don't forget to set version and release + $VERSION = '2.167'; # Don't forget to set version and release } # date in POD below! #$| = 1; @@ -1459,13 +1459,13 @@ be to use the C<Sortkeys> filter of Data::Dumper. Gurusamy Sarathy [email protected] -Copyright (c) 1996-2016 Gurusamy Sarathy. All rights reserved. +Copyright (c) 1996-2017 Gurusamy Sarathy. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 VERSION -Version 2.166 (November 14 2016) +Version 2.167 (January 4 2017) =head1 SEE ALSO diff --git a/dist/Data-Dumper/Dumper.xs b/dist/Data-Dumper/Dumper.xs index d288bbd8d5..0e7142e222 100644 --- a/dist/Data-Dumper/Dumper.xs +++ b/dist/Data-Dumper/Dumper.xs @@ -548,6 +548,8 @@ deparsed_output(pTHX_ SV *val) FREETMPS; + PUTBACK; + return text; } diff --git a/dist/Data-Dumper/t/bugs.t b/dist/Data-Dumper/t/bugs.t index 0a1ee8f7d1..5db82dad32 100644 --- a/dist/Data-Dumper/t/bugs.t +++ b/dist/Data-Dumper/t/bugs.t @@ -12,7 +12,7 @@ BEGIN { } use strict; -use Test::More tests => 23; +use Test::More tests => 24; use Data::Dumper; { @@ -168,4 +168,15 @@ SKIP: { } } +# RT#130487 - stack management bug in XS deparse +SKIP: { + skip "No XS available", 1 if !defined &Data::Dumper::Dumpxs; + sub rt130487_args { 0 + @_ } + my $code = sub {}; + local $Data::Dumper::Useperl = 0; + local $Data::Dumper::Deparse = 1; + my $got = rt130487_args( Dumper($code) ); + is($got, 1, "stack management in XS deparse works, rt 130487"); +} + # EOF diff --git a/embed.fnc b/embed.fnc index 66cbee8b6c..656afe569f 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1817,7 +1817,7 @@ Ap |UV |utf8n_to_uvuni|NN const U8 *s|STRLEN curlen|NULLOK STRLEN *retlen|U32 fl Adm |U8* |uvchr_to_utf8 |NN U8 *d|UV uv Ap |U8* |uvuni_to_utf8 |NN U8 *d|UV uv Adm |U8* |uvchr_to_utf8_flags |NN U8 *d|UV uv|UV flags -Apd |U8* |uvoffuni_to_utf8_flags |NN U8 *d|UV uv|UV flags +Apd |U8* |uvoffuni_to_utf8_flags |NN U8 *d|UV uv|const UV flags Ap |U8* |uvuni_to_utf8_flags |NN U8 *d|UV uv|UV flags Apd |char* |pv_uni_display |NN SV *dsv|NN const U8 *spv|STRLEN len|STRLEN pvlim|UV flags ApdR |char* |sv_uni_display |NN SV *dsv|NN SV *ssv|STRLEN pvlim|UV flags @@ -2640,7 +2640,7 @@ s |char* |force_word |NN char *start|int token|int check_keyword \ |int allow_pack s |SV* |tokeq |NN SV *sv sR |char* |scan_const |NN char *start -iR |SV* |get_and_check_backslash_N_name|NN const char* s \ +sR |SV* |get_and_check_backslash_N_name|NN const char* s \ |NN const char* const e sR |char* |scan_formline |NN char *s sR |char* |scan_heredoc |NN char *s diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL index d46fa64dcf..24078a6f8c 100644 --- a/ext/XS-APItest/Makefile.PL +++ b/ext/XS-APItest/Makefile.PL @@ -59,7 +59,8 @@ sub MY::postamble DTRACE_D = ../../perldtrace.d dtrace\$(OBJ_EXT): \$(DTRACE_D) core\$(OBJ_EXT) - $Config{dtrace} -G -s \$(DTRACE_D) -o dtrace\$(OBJ_EXT) core\$(OBJ_EXT) + $Config{dtrace} -G -s \$(DTRACE_D) -o dtrace\$(OBJ_EXT) core\$(OBJ_EXT) || \\ + ( \$(ECHO) >dtrace.c && \$(CCCMD) \$(CCCDLFLAGS) dtrace.c && rm -f dtrace.c ) POSTAMBLE return $post; diff --git a/ext/XS-APItest/t/handy.t b/ext/XS-APItest/t/handy.t index 597ac745fb..8d63e360c6 100644 --- a/ext/XS-APItest/t/handy.t +++ b/ext/XS-APItest/t/handy.t @@ -75,8 +75,7 @@ sub get_display_locale_or_skip($$) { # # The display name is the empty string if not using locale. Functions # with _LC in their name are skipped unless in locale, and functions - # without _LC are executed only outside locale. However, if no locales at - # all are on the system, the _LC functions are executed outside locale. + # without _LC are executed only outside locale. my ($locale, $suffix) = @_; @@ -85,10 +84,9 @@ sub get_display_locale_or_skip($$) { # Here the input is defined, either a locale name or "". If the test is # for not using locales, we want to do the test for non-LC functions, - # and skip it for LC ones (except if there are no locales on the system, - # we do it for LC ones as if they weren't LC). + # and skip it for LC ones. if ($locale eq "") { - return ("", 0) if $suffix !~ /LC/ || ! defined $base_locale; + return ("", 0) if $suffix !~ /LC/; return; } diff --git a/hints/freebsd.sh b/hints/freebsd.sh index 135129f66f..06b0bfd7d2 100644 --- a/hints/freebsd.sh +++ b/hints/freebsd.sh @@ -105,6 +105,14 @@ case "$osvers" in ;; esac +case "$osvers" in +10.*) + # dtrace on 10.x needs libelf symbols, but we don't know if the + # user is going to request usedtrace and there's no .cbu for usedtrace + libswanted="$libswanted elf" + ;; +esac + # Dynamic Loading flags have not changed much, so they are separated # out here to avoid duplicating them everywhere. case "$osvers" in diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 4668a1fc05..265b4441f3 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -1533,14 +1533,6 @@ We then determine what the console should be on various systems: undef $console; } -=item * Unix - use F</dev/tty>. - -=cut - - elsif ( -e "/dev/tty" ) { - $console = "/dev/tty"; - } - =item * Windows or MSDOS - use C<con>. =cut @@ -1565,6 +1557,17 @@ We then determine what the console should be on various systems: $console = 'sys$command'; } +# Keep this penultimate, on the grounds that it satisfies a wide variety of +# Unix-like systems that would otherwise need to be identified individually. + +=item * Unix - use F</dev/tty>. + +=cut + + elsif ( -e "/dev/tty" ) { + $console = "/dev/tty"; + } + # Keep this last. else { diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 2eafd2c2d5..168e961ece 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -336,7 +336,37 @@ L</Platform Support> section, instead. =item * -XXX +The C<dtrace> build process has further changes: + +=over + +=item * + +If the C<-xnolibs> is available, use that so a F<dtrace> perl can be +built within a FreeBSD jail. + +=item * + +On systems that build a dtrace object file (FreeBSD, Solaris and +SystemTap's dtrace emulation), copy the input objects to a separate +directory and process them there, and use those objects in the link, +since C<dtrace -G> also modifies these objects. + +=item * + +Add libelf to the build on FreeBSD 10.x, since dtrace adds references +to libelf symbols. + +=item * + +Generate a dummy dtrace_main.o if C<dtrace -G> fails to build it. A +default build on Solaris generates probes from the unused inline +functions, while they don't on FreeBSD, which causes C<dtrace -G> to +fail. + +=back + +[perl #130108] =back diff --git a/pod/perlop.pod b/pod/perlop.pod index 2640b5173d..82dca55d52 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -1074,6 +1074,12 @@ If the final value specified is not in the sequence that the magical increment would produce, the sequence goes until the next value would be longer than the final value specified. +As of Perl 5.26, the list-context range operator on strings works as expected +in the scope of L<< S<C<"use feature 'unicode_strings">>|feature/The +'unicode_strings' feature >>. In previous versions, and outside the scope of +that feature, it exhibits L<perlunicode/The "Unicode Bug">: its behavior +depends on the internal encoding of the range endpoint. + If the initial value specified isn't part of a magical increment sequence (that is, a non-empty string matching C</^[a-zA-Z]*[0-9]*\z/>), only the initial value will be returned. So the following will only diff --git a/pp_hot.c b/pp_hot.c index 7f11942de5..ec3afe4dd9 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -4467,7 +4467,7 @@ S_opmethod_stash(pTHX_ SV* meth) && SvOBJECT(ob)))) { Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference", - SVfARG((SvPVX(meth) == PL_isa_DOES) + SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES) ? newSVpvs_flags("DOES", SVs_TEMP) : meth)); } diff --git a/proto.h b/proto.h index cc9a5840f5..2fd8a51580 100644 --- a/proto.h +++ b/proto.h @@ -3574,7 +3574,7 @@ PERL_CALLCONV void Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* idop assert(idop) /* PERL_CALLCONV U8* uvchr_to_utf8(pTHX_ U8 *d, UV uv); */ /* PERL_CALLCONV U8* uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags); */ -PERL_CALLCONV U8* Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags); +PERL_CALLCONV U8* Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, const UV flags); #define PERL_ARGS_ASSERT_UVOFFUNI_TO_UTF8_FLAGS \ assert(d) PERL_CALLCONV U8* Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv); @@ -5506,7 +5506,7 @@ STATIC char* S_force_version(pTHX_ char *s, int guessing); STATIC char* S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack); #define PERL_ARGS_ASSERT_FORCE_WORD \ assert(start) -PERL_STATIC_INLINE SV* S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) +STATIC SV* S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) __attribute__warn_unused_result__; #define PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME \ assert(s); assert(e) diff --git a/regcomp.c b/regcomp.c index 953a94d45f..7b312952de 100644 --- a/regcomp.c +++ b/regcomp.c @@ -10101,20 +10101,9 @@ Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b) } } - /* Make sure that the lengths are the same, as well as the final element - * before looping through the remainder. (Thus we test the length, final, - * and first elements right off the bat) */ - if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) { - retval = FALSE; - } - else for (i = 0; i < len_a - 1; i++) { - if (array_a[i] != array_b[i]) { - retval = FALSE; - break; - } - } + return len_a == len_b + && memEQ(array_a, array_b, len_a * sizeof(array_a[0])); - return retval; } #endif diff --git a/sv.c b/sv.c index 83d82fc721..42e34410ed 100644 --- a/sv.c +++ b/sv.c @@ -2915,8 +2915,8 @@ S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) { return 0; } assert((s == buffer + 3) || (s == buffer + 4)); - *s++ = 0; - return s - buffer - 1; /* -1: excluding the zero byte */ + *s = 0; + return s - buffer; } /* diff --git a/sv.h b/sv.h index e311ff2c02..6227d46a0a 100644 --- a/sv.h +++ b/sv.h @@ -2013,6 +2013,9 @@ Returns a pointer to the character buffer. SV must be of type >= C<SVt_PV>. One alternative is to call C<sv_grow> if you are not sure of the type of SV. +You might mistakenly think that C<len> is the number of bytes to add to the +existing size, but instead it is the total size C<sv> should be. + =for apidoc Am|char *|SvPVCLEAR|SV* sv Ensures that sv is a SVt_PV and that its SvCUR is 0, and that it is properly null terminated. Equivalent to sv_setpvs(""), but more efficient. diff --git a/t/op/method.t b/t/op/method.t index 8795734ae4..ef181c4ce0 100644 --- a/t/op/method.t +++ b/t/op/method.t @@ -13,7 +13,7 @@ BEGIN { use strict; no warnings 'once'; -plan(tests => 150); +plan(tests => 151); @A::ISA = 'B'; @B::ISA = 'C'; @@ -704,6 +704,13 @@ SKIP: { "check unknown import() methods don't corrupt the stack"); } +# RT#130496: assertion failure when looking for a method of undefined name +# on an unblessed reference +fresh_perl_is('eval { {}->$x }; print $@;', + "Can't call method \"\" on unblessed reference at - line 1.", + {}, + "no crash with undef method name on unblessed ref"); + __END__ #FF9900 #F78C08 diff --git a/t/re/pat.t b/t/re/pat.t index b8d7680082..a72989f77b 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -23,7 +23,7 @@ BEGIN { skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader; skip_all_without_unicode_tables(); -plan tests => 827; # Update this when adding/deleting tests. +plan tests => 828; # Update this when adding/deleting tests. run_tests() unless caller; @@ -1860,6 +1860,14 @@ EOF_CODE like($got[5],qr/Error: Infinite recursion via empty pattern/, "empty pattern in regex codeblock: produced the right exception message" ); } + { + # [perl #130495] /x comment skipping stopped a byte short, leading + # to assertion failure or 'malformed utf-8 character" warning + fresh_perl_is( + "use utf8; m{a#\x{124}}x", '', {}, + '[perl #130495] utf-8 character at end of /x comment should not misparse', + ); + } } # End of sub run_tests 1; diff --git a/toke.c b/toke.c index c5971c76ef..e6dad0a21e 100644 --- a/toke.c +++ b/toke.c @@ -2543,7 +2543,7 @@ S_sublex_done(pTHX) } } -PERL_STATIC_INLINE SV* +STATIC SV* S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) { /* <s> points to first character of interior of \N{}, <e> to one beyond the @@ -3257,7 +3257,7 @@ S_scan_const(pTHX_ char *start) && !in_charclass && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) { - while (s+1 < send && *s != '\n') + while (s < send && *s != '\n') *d++ = *s++; } @@ -3298,6 +3298,11 @@ S_scan_const(pTHX_ char *start) /* End of else if chain - OP_TRANS rejoin rest */ + if (UNLIKELY(s >= send)) { + assert(s == send); + break; + } + /* backslashes */ if (*s == '\\' && s+1 < send) { char* e; /* Can be used for ending '}', etc. */ diff --git a/utf8.c b/utf8.c index fd965f8638..ed5b027afe 100644 --- a/utf8.c +++ b/utf8.c @@ -146,7 +146,7 @@ For details, see the description for L</uvchr_to_utf8_flags>. #define MASK UTF_CONTINUATION_MASK U8 * -Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) +Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, const UV flags) { PERL_ARGS_ASSERT_UVOFFUNI_TO_UTF8_FLAGS; -- Perl5 Master Repository
