This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pos.t: test something I almost broke
[perl5.git] / t / op / pos.t
CommitLineData
02c45c47
GS
1#!./perl
2
ee8ba353
SP
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6 require './test.pl';
7}
8
85375852 9plan tests => 22;
02c45c47
GS
10
11$x='banana';
12$x=~/.a/g;
e58f9f94 13is(pos($x), 2, "matching, pos() leaves off at offset 2");
02c45c47
GS
14
15$x=~/.z/gc;
e58f9f94 16is(pos($x), 2, "not matching, pos() remains at offset 2");
02c45c47
GS
17
18sub f { my $p=$_[0]; return $p }
19
20$x=~/.a/g;
e58f9f94 21is(f(pos($x)), 4, "matching again, pos() next leaves off at offset 4");
02c45c47 22
084916e3
JH
23# Is pos() set inside //g? (bug id 19990615.008)
24$x = "test string?"; $x =~ s/\w/pos($x)/eg;
e58f9f94 25is($x, "0123 5678910?", "pos() set inside //g");
ee8ba353 26
e7cbf6c6 27$x = "123 56"; $x =~ / /g;
e58f9f94 28is(pos($x), 4, "matching, pos() leaves off at offset 4");
e7cbf6c6 29{ local $x }
e58f9f94 30is(pos($x), 4, "value of pos() unaffected by intermediate localization");
0d7caf4c 31
93f09d7b 32# Explicit test that triggers the utf8_mg_len_cache_update() code path in
0d7caf4c
NC
33# Perl_sv_pos_b2u().
34
35$x = "\x{100}BC";
36$x =~ m/.*/g;
e58f9f94 37is(pos $x, 3, "utf8_mg_len_cache_update() test");
0d7caf4c 38
85375852
FC
39is(scalar pos $x, 3, "rvalue pos() utf8 test");
40
0607bed5
EB
41
42my $destroyed;
43{ package Class; DESTROY { ++$destroyed; } }
44
45$destroyed = 0;
46{
47 my $x = '';
48 pos($x) = 0;
49 $x = bless({}, 'Class');
50}
2154eca7 51is($destroyed, 1, 'Timely scalar destruction with lvalue pos');
32a60974
FC
52
53eval 'pos @a = 1';
54like $@, qr/^Can't modify array dereference in match position at /,
55 'pos refuses @arrays';
56eval 'pos %a = 1';
57like $@, qr/^Can't modify hash dereference in match position at /,
58 'pos refuses %hashes';
59eval 'pos *a = 1';
60is eval 'pos *a', 1, 'pos *glob works';
57e30c7a
FC
61
62# Test that UTF8-ness of $1 changing does not confuse pos
63"f" =~ /(f)/; "$1"; # first make sure UTF8-ness is off
64"\x{100}a" =~ /(..)/; # give PL_curpm a UTF8 string; $1 does not know yet
65pos($1) = 2; # set pos; was ignoring UTF8-ness
66"$1"; # turn on UTF8 flag
67is pos($1), 2, 'pos is not confused about changing UTF8-ness';
96c2a8ff
FC
68
69sub {
70 $_[0] = "hello";
71 pos $_[0] = 3;
72 is pos $h{k}, 3, 'defelems can propagate pos assignment';
73 $_[0] =~ /./g;
74 is pos $h{k}, 4, 'defelems can propagate implicit pos (via //g)';
75 $_[0] =~ /oentuhoetn/g;
76 is pos $h{k}, undef, 'failed //g sets pos through defelem';
77 $_[1] = "hello";
78 pos $h{l} = 3;
79 is pos $_[1], 3, 'reading pos through a defelem';
80 pos $h{l} = 4;
81 $_[1] =~ /(.)/g;
82 is "$1", 'o', '//g can read pos through a defelem';
83 $_[2] = "hello";
84 () = $_[2] =~ /l/gc;
85 is pos $h{m}, 4, '//gc in list cx can set pos through a defelem';
86 $_[3] = "hello";
87 $_[3] =~
88 s<e><is pos($h{n}), 1, 's///g setting pos through a defelem'>egg;
89 $h{n} = 'hello';
90 $_[3] =~ /e(?{ is pos $h{n},2, 're-evals set pos through defelems' })/;
91 pos $h{n} = 1;
92 ok $_[3] =~ /\Ge/, '\G works with defelem scalars';
93}->($h{k}, $h{l}, $h{m}, $h{n});