1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9use strict; 10plan( tests => 111 ); 11 12run_tests() unless caller; 13 14sub run_tests { 15 16my $foo = 'Now is the time for all good men to come to the aid of their country.'; 17 18my $first = substr($foo,0,index($foo,'the')); 19is($first, "Now is "); 20 21my $last = substr($foo,rindex($foo,'the'),100); 22is($last, "their country."); 23 24$last = substr($foo,index($foo,'Now'),2); 25is($last, "No"); 26 27$last = substr($foo,rindex($foo,'Now'),2); 28is($last, "No"); 29 30$last = substr($foo,index($foo,'.'),100); 31is($last, "."); 32 33$last = substr($foo,rindex($foo,'.'),100); 34is($last, "."); 35 36is(index("ababa","a",-1), 0); 37is(index("ababa","a",0), 0); 38is(index("ababa","a",1), 2); 39is(index("ababa","a",2), 2); 40is(index("ababa","a",3), 4); 41is(index("ababa","a",4), 4); 42is(index("ababa","a",5), -1); 43 44is(rindex("ababa","a",-1), -1); 45is(rindex("ababa","a",0), 0); 46is(rindex("ababa","a",1), 0); 47is(rindex("ababa","a",2), 2); 48is(rindex("ababa","a",3), 2); 49is(rindex("ababa","a",4), 4); 50is(rindex("ababa","a",5), 4); 51 52# tests for empty search string 53is(index("abc", "", -1), 0); 54is(index("abc", "", 0), 0); 55is(index("abc", "", 1), 1); 56is(index("abc", "", 2), 2); 57is(index("abc", "", 3), 3); 58is(index("abc", "", 4), 3); 59is(rindex("abc", "", -1), 0); 60is(rindex("abc", "", 0), 0); 61is(rindex("abc", "", 1), 1); 62is(rindex("abc", "", 2), 2); 63is(rindex("abc", "", 3), 3); 64is(rindex("abc", "", 4), 3); 65 66$a = "foo \x{1234}bar"; 67 68is(index($a, "\x{1234}"), 4); 69is(index($a, "bar", ), 5); 70 71is(rindex($a, "\x{1234}"), 4); 72is(rindex($a, "foo", ), 0); 73 74{ 75 my $needle = "\x{1230}\x{1270}"; 76 my @needles = split ( //, $needle ); 77 my $haystack = "\x{1228}\x{1228}\x{1230}\x{1270}"; 78 foreach ( @needles ) { 79 my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ ); 80 my $b = index ( $haystack, $_ ); 81 is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8}); 82 } 83 $needle = "\x{1270}\x{1230}"; # Transpose them. 84 @needles = split ( //, $needle ); 85 foreach ( @needles ) { 86 my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ ); 87 my $b = index ( $haystack, $_ ); 88 is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8}); 89 } 90} 91 92{ 93 my $search; 94 my $text; 95 if (ord('A') == 193) { 96 $search = "foo \x71 bar"; 97 $text = "a\xb1\xb1a $search $search quux"; 98 } else { 99 $search = "foo \xc9 bar"; 100 $text = "a\xa3\xa3a $search $search quux"; 101 } 102 103 my $text_utf8 = $text; 104 utf8::upgrade($text_utf8); 105 my $search_utf8 = $search; 106 utf8::upgrade($search_utf8); 107 108 is (index($text, $search), 5); 109 is (rindex($text, $search), 18); 110 is (index($text, $search_utf8), 5); 111 is (rindex($text, $search_utf8), 18); 112 is (index($text_utf8, $search), 5); 113 is (rindex($text_utf8, $search), 18); 114 is (index($text_utf8, $search_utf8), 5); 115 is (rindex($text_utf8, $search_utf8), 18); 116 117 my $text_octets = $text_utf8; 118 utf8::encode ($text_octets); 119 my $search_octets = $search_utf8; 120 utf8::encode ($search_octets); 121 122 is (index($text_octets, $search_octets), 7, "index octets, octets") 123 or _diag ($text_octets, $search_octets); 124 is (rindex($text_octets, $search_octets), 21, "rindex octets, octets"); 125 is (index($text_octets, $search_utf8), -1); 126 is (rindex($text_octets, $search_utf8), -1); 127 is (index($text_utf8, $search_octets), -1); 128 is (rindex($text_utf8, $search_octets), -1); 129 130 is (index($text_octets, $search), -1); 131 is (rindex($text_octets, $search), -1); 132 is (index($text, $search_octets), -1); 133 is (rindex($text, $search_octets), -1); 134} 135 136foreach my $utf8 ('', ', utf-8') { 137 foreach my $arraybase (0, 1, -1, -2) { 138 my $expect_pos = 2 + $arraybase; 139 140 my $prog = "no warnings 'deprecated';\n"; 141 $prog .= "\$[ = $arraybase; \$big = \"N\\xabN\\xab\"; "; 142 $prog .= '$big .= chr 256; chop $big; ' if $utf8; 143 $prog .= 'print rindex $big, "N", 2 + $['; 144 145 fresh_perl_is($prog, $expect_pos, {}, "\$[ = $arraybase$utf8"); 146 } 147} 148 149SKIP: { 150 skip "UTF-EBCDIC is limited to 0x7fffffff", 3 if ord("A") == 193; 151 152 my $a = "\x{80000000}"; 153 my $s = $a.'defxyz'; 154 is(index($s, 'def'), 1, "0x80000000 is a single character"); 155 156 my $b = "\x{fffffffd}"; 157 my $t = $b.'pqrxyz'; 158 is(index($t, 'pqr'), 1, "0xfffffffd is a single character"); 159 160 local ${^UTF8CACHE} = -1; 161 is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache"); 162} 163 164 165# Tests for NUL characters. 166{ 167 my @tests = ( 168 ["", -1, -1, -1], 169 ["foo", -1, -1, -1], 170 ["\0", 0, -1, -1], 171 ["\0\0", 0, 0, -1], 172 ["\0\0\0", 0, 0, 0], 173 ["foo\0", 3, -1, -1], 174 ["foo\0foo\0\0", 3, 7, -1], 175 ); 176 foreach my $l (1 .. 3) { 177 my $q = "\0" x $l; 178 my $i = 0; 179 foreach my $test (@tests) { 180 $i ++; 181 my $str = $$test [0]; 182 my $res = $$test [$l]; 183 184 { 185 is (index ($str, $q), $res, "Find NUL character(s)"); 186 } 187 188 # 189 # Bug #53746 shows a difference between variables and literals, 190 # so test literals as well. 191 # 192 my $test_str = qq {is (index ("$str", "$q"), $res, } . 193 qq {"Find NUL character(s)")}; 194 $test_str =~ s/\0/\\0/g; 195 196 eval $test_str; 197 die $@ if $@; 198 } 199 } 200} 201 202} 203