t/op/index.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     @INC = () unless is_miniperl();
   7     unshift @INC, '../lib';
   8     require './charset_tools.pl';
   9 }
  10
  11 use strict;
  12 plan( tests => 121 );
  13
  14 run_tests() unless caller;
  15
  16 sub run_tests {
  17
  18 my $foo = 'Now is the time for all good men to come to the aid of their country.';
  19
  20 my $first = substr($foo,0,index($foo,'the'));
  21 is($first, "Now is ");
  22
  23 my $last = substr($foo,rindex($foo,'the'),100);
  24 is($last, "their country.");
  25
  26 $last = substr($foo,index($foo,'Now'),2);
  27 is($last, "No");
  28
  29 $last = substr($foo,rindex($foo,'Now'),2);
  30 is($last, "No");
  31
  32 $last = substr($foo,index($foo,'.'),100);
  33 is($last, ".");
  34
  35 $last = substr($foo,rindex($foo,'.'),100);
  36 is($last, ".");
  37
  38 is(index("ababa","a",-1), 0);
  39 is(index("ababa","a",0), 0);
  40 is(index("ababa","a",1), 2);
  41 is(index("ababa","a",2), 2);
  42 is(index("ababa","a",3), 4);
  43 is(index("ababa","a",4), 4);
  44 is(index("ababa","a",5), -1);
  45
  46 is(rindex("ababa","a",-1), -1);
  47 is(rindex("ababa","a",0), 0);
  48 is(rindex("ababa","a",1), 0);
  49 is(rindex("ababa","a",2), 2);
  50 is(rindex("ababa","a",3), 2);
  51 is(rindex("ababa","a",4), 4);
  52 is(rindex("ababa","a",5), 4);
  53
  54 # tests for empty search string
  55 is(index("abc", "", -1), 0);
  56 is(index("abc", "", 0), 0);
  57 is(index("abc", "", 1), 1);
  58 is(index("abc", "", 2), 2);
  59 is(index("abc", "", 3), 3);
  60 is(index("abc", "", 4), 3);
  61 is(rindex("abc", "", -1), 0);
  62 is(rindex("abc", "", 0), 0);
  63 is(rindex("abc", "", 1), 1);
  64 is(rindex("abc", "", 2), 2);
  65 is(rindex("abc", "", 3), 3);
  66 is(rindex("abc", "", 4), 3);
  67
  68 $a = "foo \x{1234}bar";
  69
  70 is(index($a, "\x{1234}"), 4);
  71 is(index($a, "bar",    ), 5);
  72
  73 is(rindex($a, "\x{1234}"), 4);
  74 is(rindex($a, "foo",    ), 0);
  75
  76 {
  77     my $needle = "\x{1230}\x{1270}";
  78     my @needles = split ( //, $needle );
  79     my $haystack = "\x{1228}\x{1228}\x{1230}\x{1270}";
  80     foreach ( @needles ) {
  81         my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ );
  82         my $b = index ( $haystack, $_ );
  83         is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8});
  84     }
  85     $needle = "\x{1270}\x{1230}"; # Transpose them.
  86     @needles = split ( //, $needle );
  87     foreach ( @needles ) {
  88         my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ );
  89         my $b = index ( $haystack, $_ );
  90         is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8});
  91     }
  92 }
  93
  94 {
  95     my $search;
  96     my $text;
  97     $search = latin1_to_native("foo \xc9 bar");
  98     $text = latin1_to_native("a\xa3\xa3a $search    $search quux");
  99
 100     my $text_utf8 = $text;
 101     utf8::upgrade($text_utf8);
 102     my $search_utf8 = $search;
 103     utf8::upgrade($search_utf8);
 104
 105     is (index($text, $search), 5);
 106     is (rindex($text, $search), 18);
 107     is (index($text, $search_utf8), 5);
 108     is (rindex($text, $search_utf8), 18);
 109     is (index($text_utf8, $search), 5);
 110     is (rindex($text_utf8, $search), 18);
 111     is (index($text_utf8, $search_utf8), 5);
 112     is (rindex($text_utf8, $search_utf8), 18);
 113
 114     my $text_octets = $text_utf8;
 115     utf8::encode ($text_octets);
 116     my $search_octets = $search_utf8;
 117     utf8::encode ($search_octets);
 118
 119     is (index($text_octets, $search_octets), 7, "index octets, octets")
 120         or _diag ($text_octets, $search_octets);
 121     is (rindex($text_octets, $search_octets), 21, "rindex octets, octets");
 122     is (index($text_octets, $search_utf8), -1);
 123     is (rindex($text_octets, $search_utf8), -1);
 124     is (index($text_utf8, $search_octets), -1);
 125     is (rindex($text_utf8, $search_octets), -1);
 126
 127     is (index($text_octets, $search), -1);
 128     is (rindex($text_octets, $search), -1);
 129     is (index($text, $search_octets), -1);
 130     is (rindex($text, $search_octets), -1);
 131 }
 132
 133 SKIP: {
 134     skip "UTF-EBCDIC is limited to 0x7fffffff", 3 if ord("A") == 193;
 135
 136     my $a = "\x{80000000}";
 137     my $s = $a.'defxyz';
 138     is(index($s, 'def'), 1, "0x80000000 is a single character");
 139
 140     my $b = "\x{fffffffd}";
 141     my $t = $b.'pqrxyz';
 142     is(index($t, 'pqr'), 1, "0xfffffffd is a single character");
 143
 144     local ${^UTF8CACHE} = -1;
 145     is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache");
 146 }
 147
 148
 149 # Tests for NUL characters.
 150 {
 151     my @tests = (
 152         ["",            -1, -1, -1],
 153         ["foo",         -1, -1, -1],
 154         ["\0",           0, -1, -1],
 155         ["\0\0",         0,  0, -1],
 156         ["\0\0\0",       0,  0,  0],
 157         ["foo\0",        3, -1, -1],
 158         ["foo\0foo\0\0", 3,  7, -1],
 159     );
 160     foreach my $l (1 .. 3) {
 161         my $q = "\0" x $l;
 162         my $i = 0;
 163         foreach my $test (@tests) {
 164             $i ++;
 165             my $str = $$test [0];
 166             my $res = $$test [$l];
 167
 168             {
 169                 is (index ($str, $q), $res, "Find NUL character(s)");
 170             }
 171
 172             #
 173             # Bug #53746 shows a difference between variables and literals,
 174             # so test literals as well.
 175             #
 176             my $test_str = qq {is (index ("$str", "$q"), $res, } .
 177                            qq {"Find NUL character(s)")};
 178                $test_str =~ s/\0/\\0/g;
 179
 180             eval $test_str;
 181             die $@ if $@;
 182         }
 183     }
 184 }
 185
 186 {
 187     # RT#75898
 188     is(eval { utf8::upgrade($_ = " "); index $_, " ", 72 }, -1,
 189        'UTF-8 cache handles offset beyond the end of the string');
 190     $_ = "\x{100}BC";
 191     is(index($_, "C", 4), -1,
 192        'UTF-8 cache handles offset beyond the end of the string');
 193 }
 194
 195 # RT #89218
 196 use constant {PVBM => 'galumphing', PVBM2 => 'bang'};
 197
 198 sub index_it {
 199     is(index('galumphing', PVBM), 0,
 200        "index isn't confused by format compilation");
 201 }
 202
 203 index_it();
 204 is($^A, '', '$^A is empty');
 205 formline PVBM;
 206 is($^A, 'galumphing', "formline isn't confused by index compilation");
 207 index_it();
 208
 209 $^A = '';
 210 # must not do index here before formline.
 211 is($^A, '', '$^A is empty');
 212 formline PVBM2;
 213 is($^A, 'bang', "formline isn't confused by index compilation");
 214 is(index('bang', PVBM2), 0, "index isn't confused by format compilation");
 215
 216 {
 217     use constant perl => "rules";
 218     is(index("perl rules", perl), 5, 'first index of a constant works');
 219     is(index("rules 1 & 2", perl), 0, 'second index of the same constant works');
 220 }
 221
 222 # PVBM compilation should not flatten ref constants
 223 use constant riffraff => \our $referent;
 224 index "foo", riffraff;
 225 is ref riffraff, 'SCALAR', 'index does not flatten ref constants';
 226
 227 package o { use overload '""' => sub { "foo" } }
 228 bless \our $referent, o::;
 229 is index("foo", riffraff), 0,
 230     'index respects changes in ref stringification';
 231
 232 use constant quire => ${qr/(?{})/}; # A REGEXP, not a reference to one
 233 index "foo", quire;
 234 eval ' "" =~ quire ';
 235 is $@, "", 'regexp constants containing code blocks are not flattened';
 236
 237 use constant bang => $! = 8;
 238 index "foo", bang;
 239 cmp_ok bang, '==', 8, 'dualvar constants are not flattened';
 240
 241 use constant u => undef;
 242 {
 243     my $w;
 244     local $SIG{__WARN__} = sub { $w .= shift };
 245     eval '
 246         use warnings;
 247         sub { () = index "foo", u; }
 248     ';
 249     is $w, undef, 'no warnings from compiling index($foo, undef_constant)';
 250 }
 251 is u, undef, 'undef constant is still undef';
 252
 253 is index('the main road', __PACKAGE__), 4,
 254     '[perl #119169] __PACKAGE__ as 2nd argument';
 255
 256 } # end of sub run_tests