This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix the I32 bug for index() and rindex()
authorTony Cook <tony@develop-help.com>
Tue, 15 Apr 2014 01:57:57 +0000 (03:57 +0200)
committerTony Cook <tony@develop-help.com>
Wed, 28 May 2014 04:12:16 +0000 (14:12 +1000)
MANIFEST
pp.c
t/bigmem/index.t [new file with mode: 0644]

index dcf792a..ea6937c 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4773,6 +4773,7 @@ t/base/rs.t                       See if record-read works
 t/base/term.t                  See if various terms work
 t/base/while.t                 See if while work
 t/benchmark/rt26188-speed-up-keys-on-empty-hash.t      Benchmark if keys on empty hashes is fast enough
+t/bigmem/index.t               Check that index() handles large offsets
 t/bigmem/pos.t                 Check that pos() handles large offsets
 t/bigmem/read.t                        Check read() handles large offsets
 t/bigmem/regexp.t              Test regular expressions with large strings
diff --git a/pp.c b/pp.c
index 4ec6887..04c1f29 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3197,8 +3197,8 @@ PP(pp_index)
     SV *temp = NULL;
     STRLEN biglen;
     STRLEN llen = 0;
-    I32 offset;
-    I32 retval;
+    SSize_t offset = 0;
+    SSize_t retval;
     const char *big_p;
     const char *little_p;
     bool big_utf8;
@@ -3281,13 +3281,13 @@ PP(pp_index)
        offset = is_index ? 0 : biglen;
     else {
        if (big_utf8 && offset > 0)
-           sv_pos_u2b(big, &offset, 0);
+           offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
        if (!is_index)
            offset += llen;
     }
     if (offset < 0)
        offset = 0;
-    else if (offset > (I32)biglen)
+    else if (offset > (SSize_t)biglen)
        offset = biglen;
     if (!(little_p = is_index
          ? fbm_instr((unsigned char*)big_p + offset,
@@ -3298,7 +3298,7 @@ PP(pp_index)
     else {
        retval = little_p - big_p;
        if (retval > 0 && big_utf8)
-           sv_pos_b2u(big, &retval);
+           retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
     }
     SvREFCNT_dec(temp);
  fail:
diff --git a/t/bigmem/index.t b/t/bigmem/index.t
new file mode 100644 (file)
index 0000000..fdd502c
--- /dev/null
@@ -0,0 +1,37 @@
+#!perl
+BEGIN {
+    chdir 't';
+    unshift @INC, "../lib";
+}
+
+use strict;
+require './test.pl';
+use Config qw(%Config);
+
+# memory usage checked with top
+$ENV{PERL_TEST_MEMORY} >= 2
+    or skip_all("Need ~2GB for this test");
+$Config{ptrsize} >= 8
+    or skip_all("Need 64-bit pointers for this test");
+
+plan(tests => 4);
+
+my $space = " "; # avoid constant folding from doubling memory usage
+# concatenation here increases memory usage significantly
+my $work = $space x 0x80000002;
+substr($work, 0x80000000) = "\n\n";
+
+# this would SEGV
+is(index($work, "\n"), 0x80000000, "test index() over 2G mark");
+
+# this would simply fail
+is(rindex($work, "\n"), 0x80000001, "test rindex() over 2G mark");
+
+utf8::upgrade($work);
+
+# this would SEGV
+is(index($work, "\n"), 0x80000000, "test index() over 2G mark (utf8-ish)");
+
+# this would simply fail
+is(rindex($work, "\n"), 0x80000001, "test rindex() over 2G mark (utf8-ish)");
+