From 515204bfa002e61c4cdf7ed85a1b7cf8a1a36469 Mon Sep 17 00:00:00 2001 From: Stuart Henderson Date: Mon, 25 Mar 2013 20:44:47 +0000 Subject: merge/resolve conflicts/add files --- gnu/usr.bin/perl/Makefile.bsd-wrapper | 2 +- gnu/usr.bin/perl/config.over | 2 +- gnu/usr.bin/perl/pod/perldelta.pod | 133 ++++++ gnu/usr.bin/perl/t/op/substr.t | 819 ++++++++++++++++++++++++++++++++++ gnu/usr.bin/perl/t/op/substr_thr.t | 3 + gnu/usr.bin/perl/uconfig64.sh | 2 +- 6 files changed, 958 insertions(+), 3 deletions(-) create mode 100644 gnu/usr.bin/perl/pod/perldelta.pod create mode 100644 gnu/usr.bin/perl/t/op/substr.t create mode 100755 gnu/usr.bin/perl/t/op/substr_thr.t diff --git a/gnu/usr.bin/perl/Makefile.bsd-wrapper b/gnu/usr.bin/perl/Makefile.bsd-wrapper index ef1d4e48414..b911b2798dd 100644 --- a/gnu/usr.bin/perl/Makefile.bsd-wrapper +++ b/gnu/usr.bin/perl/Makefile.bsd-wrapper @@ -1,4 +1,4 @@ -# $OpenBSD: Makefile.bsd-wrapper,v 1.88 2013/03/25 20:40:43 sthen Exp $ +# $OpenBSD: Makefile.bsd-wrapper,v 1.89 2013/03/25 20:44:46 sthen Exp $ # # Build wrapper for Perl 5.16.2 # diff --git a/gnu/usr.bin/perl/config.over b/gnu/usr.bin/perl/config.over index abaeae8dffe..7d50b1ae31c 100644 --- a/gnu/usr.bin/perl/config.over +++ b/gnu/usr.bin/perl/config.over @@ -1,7 +1,7 @@ # # Override default paths when building in the OpenBSD src tree # -# $OpenBSD: config.over,v 1.15 2013/03/25 20:40:43 sthen Exp $ +# $OpenBSD: config.over,v 1.16 2013/03/25 20:44:46 sthen Exp $ # # We use a different architecture name than the default diff --git a/gnu/usr.bin/perl/pod/perldelta.pod b/gnu/usr.bin/perl/pod/perldelta.pod new file mode 100644 index 00000000000..2f75b747251 --- /dev/null +++ b/gnu/usr.bin/perl/pod/perldelta.pod @@ -0,0 +1,133 @@ +=encoding utf8 + +=head1 NAME + +perldelta - what is new for perl v5.16.3 + +=head1 DESCRIPTION + +This document describes differences between the 5.16.2 release and +the 5.16.3 release. + +If you are upgrading from an earlier release such as 5.16.1, first read +L, which describes differences between 5.16.1 and +5.16.2. + +=head1 Core Enhancements + +No changes since 5.16.0. + +=head1 Security + +This release contains one major and a number of minor security fixes. +These latter are included mainly to allow the test suite to pass cleanly +with the clang compiler's address sanitizer facility. + +=head2 CVE-2013-1667: memory exhaustion with arbitrary hash keys + +With a carefully crafted set of hash keys (for example arguments on a +URL), it is possible to cause a hash to consume a large amount of memory +and CPU, and thus possibly to achieve a Denial-of-Service. + +This problem has been fixed. + +=head2 wrap-around with IO on long strings + +Reading or writing strings greater than 2**31 bytes in size could segfault +due to integer wraparound. + +This problem has been fixed. + +=head2 memory leak in Encode + +The UTF-8 encoding implementation in Encode.xs had a memory leak which has been +fixed. + +=head1 Incompatible Changes + +There are no changes intentionally incompatible with 5.16.0. If any +exist, they are bugs and reports are welcome. + +=head1 Deprecations + +There have been no deprecations since 5.16.0. + +=head1 Modules and Pragmata + +=head2 Updated Modules and Pragmata + +=over 4 + +=item * + +L has been upgraded from version 2.44 to version 2.44_01. + +=item * + +L has been upgraded from version 2.76 to version 2.76_02. + +=item * + +L has been upgraded from version 0.38 to version 0.39. + +=back + +=head1 Known Problems + +None. + +=head1 Acknowledgements + +Perl 5.16.3 represents approximately 4 months of development since Perl 5.16.2 +and contains approximately 870 lines of changes across 39 files from 7 authors. + +Perl continues to flourish into its third decade thanks to a vibrant community +of users and developers. The following people are known to have contributed the +improvements that became Perl 5.16.3: + +Andy Dougherty, Chris 'BinGOs' Williams, Dave Rolsky, David Mitchell, Michael +Schroeder, Ricardo Signes, Yves Orton. + +The list above is almost certainly incomplete as it is automatically generated +from version control history. In particular, it does not include the names of +the (very much appreciated) contributors who reported issues to the Perl bug +tracker. + +For a more complete list of all of Perl's historical contributors, please see +the F file in the Perl source distribution. + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the articles +recently posted to the comp.lang.perl.misc newsgroup and the perl +bug database at http://rt.perl.org/perlbug/ . There may also be +information at http://www.perl.org/ , the Perl Home Page. + +If you believe you have an unreported bug, please run the L +program included with your release. Be sure to trim your bug down +to a tiny but sufficient test case. Your bug report, along with the +output of C, will be sent off to perlbug@perl.org to be +analysed by the Perl porting team. + +If the bug you are reporting has security implications, which make it +inappropriate to send to a publicly archived mailing list, then please +send it to perl5-security-report@perl.org. This points to a closed +subscription unarchived mailing list, which includes all the core +committers, who will be able to help assess the impact of issues, figure +out a resolution, and help co-ordinate the release of patches to +mitigate or fix the problem across all platforms on which Perl is +supported. Please only use this address for security issues in the Perl +core, not for modules independently distributed on CPAN. + +=head1 SEE ALSO + +The F file for an explanation of how to view exhaustive details +on what changed. + +The F file for how to build Perl. + +The F file for general stuff. + +The F and F files for copyright information. + +=cut diff --git a/gnu/usr.bin/perl/t/op/substr.t b/gnu/usr.bin/perl/t/op/substr.t new file mode 100644 index 00000000000..fa8f67f9450 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/substr.t @@ -0,0 +1,819 @@ +#!./perl + +#P = start of string Q = start of substr R = end of substr S = end of string + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} +use warnings ; + +$a = 'abcdefxyz'; +$SIG{__WARN__} = sub { + if ($_[0] =~ /^substr outside of string/) { + $w++; + } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) { + $w += 2; + } elsif ($_[0] =~ /^Use of uninitialized value/) { + $w += 3; + } else { + warn $_[0]; + } +}; + +BEGIN { require './test.pl'; } + +plan(381); + +run_tests() unless caller; + +my $krunch = "a"; + +sub run_tests { + +$FATAL_MSG = qr/^substr outside of string/; + +is(substr($a,0,3), 'abc'); # P=Q R S +is(substr($a,3,3), 'def'); # P Q R S +is(substr($a,6,999), 'xyz'); # P Q S R +$b = substr($a,999,999) ; # warn # P R Q S +is ($w--, 1); +eval{substr($a,999,999) = "" ; };# P R Q S +like ($@, $FATAL_MSG); +is(substr($a,0,-6), 'abc'); # P=Q R S +is(substr($a,-3,1), 'x'); # P Q R S +sub{$b = shift}->(substr($a,999,999)); +is ($w--, 1, 'boundless lvalue substr only warns on fetch'); + +substr($a,3,3) = 'XYZ'; +is($a, 'abcXYZxyz' ); +substr($a,0,2) = ''; +is($a, 'cXYZxyz' ); +substr($a,0,0) = 'ab'; +is($a, 'abcXYZxyz' ); +substr($a,0,0) = '12345678'; +is($a, '12345678abcXYZxyz' ); +substr($a,-3,3) = 'def'; +is($a, '12345678abcXYZdef'); +substr($a,-3,3) = '<'; +is($a, '12345678abcXYZ<' ); +substr($a,-1,1) = '12345678'; +is($a, '12345678abcXYZ12345678' ); + +$a = 'abcdefxyz'; + +is(substr($a,6), 'xyz' ); # P Q R=S +is(substr($a,-3), 'xyz' ); # P Q R=S +$b = substr($a,999,999) ; # warning # P R=S Q +is($w--, 1); +eval{substr($a,999,999) = "" ; } ; # P R=S Q +like($@, $FATAL_MSG); +is(substr($a,0), 'abcdefxyz'); # P=Q R=S +is(substr($a,9), ''); # P Q=R=S +is(substr($a,-11), 'abcdefxyz'); # Q P R=S +is(substr($a,-9), 'abcdefxyz'); # P=Q R=S + +$a = '54321'; + +$b = substr($a,-7, 1) ; # warn # Q R P S +is($w--, 1); +eval{substr($a,-7, 1) = "" ; }; # Q R P S +like($@, $FATAL_MSG); +$b = substr($a,-7,-6) ; # warn # Q R P S +is($w--, 1); +eval{substr($a,-7,-6) = "" ; }; # Q R P S +like($@, $FATAL_MSG); +is(substr($a,-5,-7), ''); # R P=Q S +is(substr($a, 2,-7), ''); # R P Q S +is(substr($a,-3,-7), ''); # R P Q S +is(substr($a, 2,-5), ''); # P=R Q S +is(substr($a,-3,-5), ''); # P=R Q S +is(substr($a, 2,-4), ''); # P R Q S +is(substr($a,-3,-4), ''); # P R Q S +is(substr($a, 5,-6), ''); # R P Q=S +is(substr($a, 5,-5), ''); # P=R Q S +is(substr($a, 5,-3), ''); # P R Q=S +$b = substr($a, 7,-7) ; # warn # R P S Q +is($w--, 1); +eval{substr($a, 7,-7) = "" ; }; # R P S Q +like($@, $FATAL_MSG); +$b = substr($a, 7,-5) ; # warn # P=R S Q +is($w--, 1); +eval{substr($a, 7,-5) = "" ; }; # P=R S Q +like($@, $FATAL_MSG); +$b = substr($a, 7,-3) ; # warn # P Q S Q +is($w--, 1); +eval{substr($a, 7,-3) = "" ; }; # P Q S Q +like($@, $FATAL_MSG); +$b = substr($a, 7, 0) ; # warn # P S Q=R +is($w--, 1); +eval{substr($a, 7, 0) = "" ; }; # P S Q=R +like($@, $FATAL_MSG); + +is(substr($a,-7,2), ''); # Q P=R S +is(substr($a,-7,4), '54'); # Q P R S +is(substr($a,-7,7), '54321');# Q P R=S +is(substr($a,-7,9), '54321');# Q P S R +is(substr($a,-5,0), ''); # P=Q=R S +is(substr($a,-5,3), '543');# P=Q R S +is(substr($a,-5,5), '54321');# P=Q R=S +is(substr($a,-5,7), '54321');# P=Q S R +is(substr($a,-3,0), ''); # P Q=R S +is(substr($a,-3,3), '321');# P Q R=S +is(substr($a,-2,3), '21'); # P Q S R +is(substr($a,0,-5), ''); # P=Q=R S +is(substr($a,2,-3), ''); # P Q=R S +is(substr($a,0,0), ''); # P=Q=R S +is(substr($a,0,5), '54321');# P=Q R=S +is(substr($a,0,7), '54321');# P=Q S R +is(substr($a,2,0), ''); # P Q=R S +is(substr($a,2,3), '321'); # P Q R=S +is(substr($a,5,0), ''); # P Q=R=S +is(substr($a,5,2), ''); # P Q=S R +is(substr($a,-7,-5), ''); # Q P=R S +is(substr($a,-7,-2), '543');# Q P R S +is(substr($a,-5,-5), ''); # P=Q=R S +is(substr($a,-5,-2), '543');# P=Q R S +is(substr($a,-3,-3), ''); # P Q=R S +is(substr($a,-3,-1), '32');# P Q R S + +$a = ''; + +is(substr($a,-2,2), ''); # Q P=R=S +is(substr($a,0,0), ''); # P=Q=R=S +is(substr($a,0,1), ''); # P=Q=S R +is(substr($a,-2,3), ''); # Q P=S R +is(substr($a,-2), ''); # Q P=R=S +is(substr($a,0), ''); # P=Q=R=S + + +is(substr($a,0,-1), ''); # R P=Q=S +$b = substr($a,-2, 0) ; # warn # Q=R P=S +is($w--, 1); +eval{substr($a,-2, 0) = "" ; }; # Q=R P=S +like($@, $FATAL_MSG); + +$b = substr($a,-2, 1) ; # warn # Q R P=S +is($w--, 1); +eval{substr($a,-2, 1) = "" ; }; # Q R P=S +like($@, $FATAL_MSG); + +$b = substr($a,-2,-1) ; # warn # Q R P=S +is($w--, 1); +eval{substr($a,-2,-1) = "" ; }; # Q R P=S +like($@, $FATAL_MSG); + +$b = substr($a,-2,-2) ; # warn # Q=R P=S +is($w--, 1); +eval{substr($a,-2,-2) = "" ; }; # Q=R P=S +like($@, $FATAL_MSG); + +$b = substr($a, 1,-2) ; # warn # R P=S Q +is($w--, 1); +eval{substr($a, 1,-2) = "" ; }; # R P=S Q +like($@, $FATAL_MSG); + +$b = substr($a, 1, 1) ; # warn # P=S Q R +is($w--, 1); +eval{substr($a, 1, 1) = "" ; }; # P=S Q R +like($@, $FATAL_MSG); + +$b = substr($a, 1, 0) ;# warn # P=S Q=R +is($w--, 1); +eval{substr($a, 1, 0) = "" ; }; # P=S Q=R +like($@, $FATAL_MSG); + +$b = substr($a,1) ; # warning # P=R=S Q +is($w--, 1); +eval{substr($a,1) = "" ; }; # P=R=S Q +like($@, $FATAL_MSG); + +$b = substr($a,-7,-6) ; # warn # Q R P S +is($w--, 1); +eval{substr($a,-7,-6) = "" ; }; # Q R P S +like($@, $FATAL_MSG); + +my $a = 'zxcvbnm'; +substr($a,2,0) = ''; +is($a, 'zxcvbnm'); +substr($a,7,0) = ''; +is($a, 'zxcvbnm'); +substr($a,5,0) = ''; +is($a, 'zxcvbnm'); +substr($a,0,2) = 'pq'; +is($a, 'pqcvbnm'); +substr($a,2,0) = 'r'; +is($a, 'pqrcvbnm'); +substr($a,8,0) = 'asd'; +is($a, 'pqrcvbnmasd'); +substr($a,0,2) = 'iop'; +is($a, 'ioprcvbnmasd'); +substr($a,0,5) = 'fgh'; +is($a, 'fghvbnmasd'); +substr($a,3,5) = 'jkl'; +is($a, 'fghjklsd'); +substr($a,3,2) = '1234'; +is($a, 'fgh1234lsd'); + + +# with lexicals (and in re-entered scopes) +for (0,1) { + my $txt; + unless ($_) { + $txt = "Foo"; + substr($txt, -1) = "X"; + is($txt, "FoX"); + } + else { + substr($txt, 0, 1) = "X"; + is($txt, "X"); + } +} + +$w = 0 ; +# coercion of references +{ + my $s = []; + substr($s, 0, 1) = 'Foo'; + is (substr($s,0,7), "FooRRAY"); + is ($w,2); + $w = 0; +} + +# check no spurious warnings +is($w, 0); + +# check new 4 arg replacement syntax +$a = "abcxyz"; +$w = 0; +is(substr($a, 0, 3, ""), "abc"); +is($a, "xyz"); +is(substr($a, 0, 0, "abc"), ""); +is($a, "abcxyz"); +is(substr($a, 3, -1, ""), "xy"); +is($a, "abcz"); + +is(substr($a, 3, undef, "xy"), ""); +is($a, "abcxyz"); +is($w, 3); + +$w = 0; + +is(substr($a, 3, 9999999, ""), "xyz"); +is($a, "abc"); +eval{substr($a, -99, 0, "") }; +like($@, $FATAL_MSG); +eval{substr($a, 99, 3, "") }; +like($@, $FATAL_MSG); + +substr($a, 0, length($a), "foo"); +is ($a, "foo"); +is ($w, 0); + +# using 4 arg substr as lvalue is a compile time error +eval 'substr($a,0,0,"") = "abc"'; +like ($@, qr/Can't modify substr/); +is ($a, "foo"); + +$a = "abcdefgh"; +is(sub { shift }->(substr($a, 0, 4, "xxxx")), 'abcd'); +is($a, 'xxxxefgh'); + +{ + my $y = 10; + $y = "2" . $y; + is ($y, 210); +} + +# utf8 sanity +{ + my $x = substr("a\x{263a}b",0); + is(length($x), 3); + $x = substr($x,1,1); + is($x, "\x{263a}"); + $x = $x x 2; + is(length($x), 2); + substr($x,0,1) = "abcd"; + is($x, "abcd\x{263a}"); + is(length($x), 5); + $x = reverse $x; + is(length($x), 5); + is($x, "\x{263a}dcba"); + + my $z = 10; + $z = "21\x{263a}" . $z; + is(length($z), 5); + is($z, "21\x{263a}10"); +} + +# replacement should work on magical values +require Tie::Scalar; +my %data; +tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical +$data{a} = "firstlast"; +is(substr($data{'a'}, 0, 5, ""), "first"); +is($data{'a'}, "last"); + +# more utf8 + +# The following two originally from Ignasi Roca. + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} +is(length($x), 3); +is($x, "\x{100}\xF2\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{F3}"); + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} +is(length($x), 4); +is($x, "\x{100}\x{FF}\xF2\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{F2}"); +is(substr($x, 3, 1), "\x{F3}"); + +# more utf8 lval exercise + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 2) = "\x{100}\xFF"; +is(length($x), 3); +is($x, "\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{F3}"); + +$x = "\xF1\xF2\xF3"; +substr($x, 1, 1) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\xF1\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{F1}"); +is(substr($x, 1, 1), "\x{100}"); +is(substr($x, 2, 1), "\x{FF}"); +is(substr($x, 3, 1), "\x{F3}"); + +$x = "\xF1\xF2\xF3"; +substr($x, 2, 1) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\xF1\xF2\x{100}\xFF"); +is(substr($x, 0, 1), "\x{F1}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{100}"); +is(substr($x, 3, 1), "\x{FF}"); + +$x = "\xF1\xF2\xF3"; +substr($x, 3, 1) = "\x{100}\xFF"; +is(length($x), 5); +is($x, "\xF1\xF2\xF3\x{100}\xFF"); +is(substr($x, 0, 1), "\x{F1}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{F3}"); +is(substr($x, 3, 1), "\x{100}"); +is(substr($x, 4, 1), "\x{FF}"); + +$x = "\xF1\xF2\xF3"; +substr($x, -1, 1) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\xF1\xF2\x{100}\xFF"); +is(substr($x, 0, 1), "\x{F1}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{100}"); +is(substr($x, 3, 1), "\x{FF}"); + +$x = "\xF1\xF2\xF3"; +substr($x, -1, 0) = "\x{100}\xFF"; +is(length($x), 5); +is($x, "\xF1\xF2\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{F1}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{100}"); +is(substr($x, 3, 1), "\x{FF}"); +is(substr($x, 4, 1), "\x{F3}"); + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -1) = "\x{100}\xFF"; +is(length($x), 3); +is($x, "\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{F3}"); + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -2) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\x{100}\xFF\xF2\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{F2}"); +is(substr($x, 3, 1), "\x{F3}"); + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -3) = "\x{100}\xFF"; +is(length($x), 5); +is($x, "\x{100}\xFF\xF1\xF2\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{F1}"); +is(substr($x, 3, 1), "\x{F2}"); +is(substr($x, 4, 1), "\x{F3}"); + +$x = "\xF1\xF2\xF3"; +substr($x, 1, -1) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\xF1\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{F1}"); +is(substr($x, 1, 1), "\x{100}"); +is(substr($x, 2, 1), "\x{FF}"); +is(substr($x, 3, 1), "\x{F3}"); + +$x = "\xF1\xF2\xF3"; +substr($x, -1, -1) = "\x{100}\xFF"; +is(length($x), 5); +is($x, "\xF1\xF2\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{F1}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{100}"); +is(substr($x, 3, 1), "\x{FF}"); +is(substr($x, 4, 1), "\x{F3}"); + +# And tests for already-UTF8 one + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 1) = "\x{100}"; +is(length($x), 3); +is($x, "\x{100}\xF2\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{F3}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 1) = "\x{100}\x{FF}"; +is(length($x), 4); +is($x, "\x{100}\x{FF}\xF2\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{F2}"); +is(substr($x, 3, 1), "\x{F3}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 2) = "\x{100}\xFF"; +is(length($x), 3); +is($x, "\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{F3}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 1, 1) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\x{101}\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{101}"); +is(substr($x, 1, 1), "\x{100}"); +is(substr($x, 2, 1), "\x{FF}"); +is(substr($x, 3, 1), "\x{F3}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 2, 1) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\x{101}\xF2\x{100}\xFF"); +is(substr($x, 0, 1), "\x{101}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{100}"); +is(substr($x, 3, 1), "\x{FF}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 3, 1) = "\x{100}\xFF"; +is(length($x), 5); +is($x, "\x{101}\x{F2}\x{F3}\x{100}\xFF"); +is(substr($x, 0, 1), "\x{101}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{F3}"); +is(substr($x, 3, 1), "\x{100}"); +is(substr($x, 4, 1), "\x{FF}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, 1) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\x{101}\xF2\x{100}\xFF"); +is(substr($x, 0, 1), "\x{101}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{100}"); +is(substr($x, 3, 1), "\x{FF}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, 0) = "\x{100}\xFF"; +is(length($x), 5); +is($x, "\x{101}\xF2\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{101}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{100}"); +is(substr($x, 3, 1), "\x{FF}"); +is(substr($x, 4, 1), "\x{F3}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -1) = "\x{100}\xFF"; +is(length($x), 3); +is($x, "\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{F3}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -2) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\x{100}\xFF\xF2\xF3"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{F2}"); +is(substr($x, 3, 1), "\x{F3}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -3) = "\x{100}\xFF"; +is(length($x), 5); +is($x, "\x{100}\xFF\x{101}\x{F2}\x{F3}"); +is(substr($x, 0, 1), "\x{100}"); +is(substr($x, 1, 1), "\x{FF}"); +is(substr($x, 2, 1), "\x{101}"); +is(substr($x, 3, 1), "\x{F2}"); +is(substr($x, 4, 1), "\x{F3}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 1, -1) = "\x{100}\xFF"; +is(length($x), 4); +is($x, "\x{101}\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{101}"); +is(substr($x, 1, 1), "\x{100}"); +is(substr($x, 2, 1), "\x{FF}"); +is(substr($x, 3, 1), "\x{F3}"); + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, -1) = "\x{100}\xFF"; +is(length($x), 5); +is($x, "\x{101}\xF2\x{100}\xFF\xF3"); +is(substr($x, 0, 1), "\x{101}"); +is(substr($x, 1, 1), "\x{F2}"); +is(substr($x, 2, 1), "\x{100}"); +is(substr($x, 3, 1), "\x{FF}"); +is(substr($x, 4, 1), "\x{F3}"); + +substr($x = "ab", 0, 0, "\x{100}\x{200}"); +is($x, "\x{100}\x{200}ab"); + +substr($x = "\x{100}\x{200}", 0, 0, "ab"); +is($x, "ab\x{100}\x{200}"); + +substr($x = "ab", 1, 0, "\x{100}\x{200}"); +is($x, "a\x{100}\x{200}b"); + +substr($x = "\x{100}\x{200}", 1, 0, "ab"); +is($x, "\x{100}ab\x{200}"); + +substr($x = "ab", 2, 0, "\x{100}\x{200}"); +is($x, "ab\x{100}\x{200}"); + +substr($x = "\x{100}\x{200}", 2, 0, "ab"); +is($x, "\x{100}\x{200}ab"); + +substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); +is($x, "\x{100}\x{200}\xFFb"); + +substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); +is($x, "\xFFb\x{100}\x{200}"); + +substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); +is($x, "\xFF\x{100}\x{200}b"); + +substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); +is($x, "\x{100}\xFFb\x{200}"); + +substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); +is($x, "\xFFb\x{100}\x{200}"); + +substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); +is($x, "\x{100}\x{200}\xFFb"); + +# [perl #20933] +{ + my $s = "ab"; + my @r; + $r[$_] = \ substr $s, $_, 1 for (0, 1); + is(join("", map { $$_ } @r), "ab"); +} + +# [perl #23207] +{ + sub ss { + substr($_[0],0,1) ^= substr($_[0],1,1) ^= + substr($_[0],0,1) ^= substr($_[0],1,1); + } + my $x = my $y = 'AB'; ss $x; ss $y; + is($x, $y); +} + +# [perl #24605] +{ + my $x = "0123456789\x{500}"; + my $y = substr $x, 4; + is(substr($x, 7, 1), "7"); +} + +# multiple assignments to lvalue [perl #24346] +{ + my $x = "abcdef"; + for (substr($x,1,3)) { + is($_, 'bcd'); + $_ = 'XX'; + is($_, 'XX'); + is($x, 'aXXef'); + $_ = "\xFF"; + is($_, "\xFF"); + is($x, "a\xFFef"); + $_ = "\xF1\xF2\xF3\xF4\xF5\xF6"; + is($_, "\xF1\xF2\xF3\xF4\xF5\xF6"); + is($x, "a\xF1\xF2\xF3\xF4\xF5\xF6ef"); + $_ = 'YYYY'; + is($_, 'YYYY'); + is($x, 'aYYYYef'); + } + $x = "abcdef"; + for (substr($x,1)) { + is($_, 'bcdef'); + $_ = 'XX'; + is($_, 'XX'); + is($x, 'aXX'); + $x .= "frompswiggle"; + is $_, "XXfrompswiggle"; + } + $x = "abcdef"; + for (substr($x,1,-1)) { + is($_, 'bcde'); + $_ = 'XX'; + is($_, 'XX'); + is($x, 'aXXf'); + $x .= "frompswiggle"; + is $_, "XXffrompswiggl"; + } + $x = "abcdef"; + for (substr($x,-5,3)) { + is($_, 'bcd'); + $_ = 'XX'; # now $_ is substr($x, -4, 2) + is($_, 'XX'); + is($x, 'aXXef'); + $x .= "frompswiggle"; + is $_, "gg"; + } + $x = "abcdef"; + for (substr($x,-5)) { + is($_, 'bcdef'); + $_ = 'XX'; # now substr($x, -2) + is($_, 'XX'); + is($x, 'aXX'); + $x .= "frompswiggle"; + is $_, "le"; + } + $x = "abcdef"; + for (substr($x,-5,-1)) { + is($_, 'bcde'); + $_ = 'XX'; # now substr($x, -3, -1) + is($_, 'XX'); + is($x, 'aXXf'); + $x .= "frompswiggle"; + is $_, "gl"; + } +} + +# [perl #24200] string corruption with lvalue sub + +{ + sub bar: lvalue { substr $krunch, 0 } + bar = "XXX"; + is(bar, 'XXX'); + $krunch = '123456789'; + is(bar, '123456789'); +} + +# [perl #29149] +{ + my $text = "0123456789\xED "; + utf8::upgrade($text); + my $pos = 5; + pos($text) = $pos; + my $a = substr($text, $pos, $pos); + is(substr($text,$pos,1), $pos); + +} + +# [perl #23765] +{ + my $a = pack("C", 0xbf); + substr($a, -1) &= chr(0xfeff); + is($a, "\xbf"); +} + +# [perl #34976] incorrect caching of utf8 substr length +{ + my $a = "abcd\x{100}"; + is(substr($a,1,2), 'bc'); + is(substr($a,1,1), 'b'); +} + +# [perl #62646] offsets exceeding 32 bits on 64-bit system +SKIP: { + skip("32-bit system", 24) unless ~0 > 0xffffffff; + my $a = "abc"; + my $s; + my $r; + + utf8::downgrade($a); + for (1..2) { + $w = 0; + $r = substr($a, 0xffffffff, 1); + is($r, undef); + is($w, 1); + + $w = 0; + $r = substr($a, 0xffffffff+1, 1); + is($r, undef); + is($w, 1); + + $w = 0; + ok( !eval { $r = substr($s=$a, 0xffffffff, 1, "_"); 1 } ); + is($r, undef); + is($s, $a); + is($w, 0); + + $w = 0; + ok( !eval { $r = substr($s=$a, 0xffffffff+1, 1, "_"); 1 } ); + is($r, undef); + is($s, $a); + is($w, 0); + + utf8::upgrade($a); + } +} + +# [perl #77692] UTF8 cache not being reset when TARG is reused +ok eval { + local ${^UTF8CACHE} = -1; + for my $i (0..1) + { + my $dummy = length(substr("\x{100}",0,$i)); + } + 1 +}, 'UTF8 cache is reset when TARG is reused [perl #77692]'; + +{ + use utf8; + use open qw( :utf8 :std ); + no warnings 'once'; + + my $t = ""; + substr $t, 0, 0, *ワルド; + is($t, "*main::ワルド", "substr works on UTF-8 globs"); + + $t = "The World!"; + substr $t, 0, 9, *ザ::ワルド; + is($t, "*ザ::ワルド!", "substr works on a UTF-8 glob + stash"); +} + +{ + my $x = *foo; + my $y = \substr *foo, 0, 0; + is ref \$x, 'GLOB', '\substr does not coerce its glob arg just yet'; + $x = \"foo"; + $y = \substr *foo, 0, 0; + is ref \$x, 'REF', '\substr does not coerce its ref arg just yet'; +} + +} # sub run_tests - put tests above this line that can run in threads + + +my $destroyed; +{ package Class; DESTROY { ++$destroyed; } } + +$destroyed = 0; +{ + my $x = ''; + substr($x,0,1) = ""; + $x = bless({}, 'Class'); +} +is($destroyed, 1, 'Timely scalar destruction with lvalue substr'); + +{ + my $result_3363; + sub a_3363 { + my ($word, $replace) = @_; + my $ref = \substr($word, 0, 1); + $$ref = $replace; + if ($replace eq "b") { + $result_3363 = $word; + } else { + a_3363($word, "b"); + } + } + a_3363($_, "v") for "test"; + + is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]"); +} diff --git a/gnu/usr.bin/perl/t/op/substr_thr.t b/gnu/usr.bin/perl/t/op/substr_thr.t new file mode 100755 index 00000000000..9ce1d3ada40 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/substr_thr.t @@ -0,0 +1,3 @@ +#!./perl +chdir 't' if -d 't'; +require './thread_it.pl'; diff --git a/gnu/usr.bin/perl/uconfig64.sh b/gnu/usr.bin/perl/uconfig64.sh index 80e6f7fc9a6..f57c97913e3 100644 --- a/gnu/usr.bin/perl/uconfig64.sh +++ b/gnu/usr.bin/perl/uconfig64.sh @@ -425,7 +425,7 @@ d_strftime='undef' d_strlcat='undef' d_strlcpy='undef' d_strtod='undef' -d_strtol='undef' +d_strtol='define' d_strtold='undef' d_strtoll='undef' d_strtoq='undef' -- cgit v1.2.3