t/op/pos.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 plan tests => 12;
  10
  11 $x='banana';
  12 $x=~/.a/g;
  13 is(pos($x), 2);
  14
  15 $x=~/.z/gc;
  16 is(pos($x), 2);
  17
  18 sub f { my $p=$_[0]; return $p }
  19
  20 $x=~/.a/g;
  21 is(f(pos($x)), 4);
  22
  23 # Is pos() set inside //g? (bug id 19990615.008)
  24 $x = "test string?"; $x =~ s/\w/pos($x)/eg;
  25 is($x, "0123 5678910?");
  26
  27 $x = "123 56"; $x =~ / /g;
  28 is(pos($x), 4);
  29 { local $x }
  30 is(pos($x), 4);
  31
  32 # Explicit test that triggers the utf8_mg_len_cache_update() code path in
  33 # Perl_sv_pos_b2u().
  34
  35 $x = "\x{100}BC";
  36 $x =~ m/.*/g;
  37 is(pos $x, 3);
  38
  39
  40 my $destroyed;
  41 { package Class; DESTROY { ++$destroyed; } }
  42
  43 $destroyed = 0;
  44 {
  45     my $x = '';
  46     pos($x) = 0;
  47     $x = bless({}, 'Class');
  48 }
  49 is($destroyed, 1, 'Timely scalar destruction with lvalue pos');
  50
  51 eval 'pos @a = 1';
  52 like $@, qr/^Can't modify array dereference in match position at /,
  53   'pos refuses @arrays';
  54 eval 'pos %a = 1';
  55 like $@, qr/^Can't modify hash dereference in match position at /,
  56   'pos refuses %hashes';
  57 eval 'pos *a = 1';
  58 is eval 'pos *a', 1, 'pos *glob works';
  59
  60 # Test that UTF8-ness of $1 changing does not confuse pos
  61 "f" =~ /(f)/; "$1";     # first make sure UTF8-ness is off
  62 "\x{100}a" =~ /(..)/;   # give PL_curpm a UTF8 string; $1 does not know yet
  63 pos($1) = 2;            # set pos; was ignoring UTF8-ness
  64 "$1";                   # turn on UTF8 flag
  65 is pos($1), 2, 'pos is not confused about changing UTF8-ness';