Perl_op_sibling_splice(0 remove dead code
[perl.git] / t / op / lex_assign.t
1 #!./perl
2
3 # Test that $lexical = <some op> optimises the assignment away correctly
4 # and causes no ill side-effects.
5
6 BEGIN {
7     chdir 't' if -d 't';
8     require './test.pl';
9     set_up_inc('../lib');
10 }
11
12 $| = 1;
13 umask 0;
14 $xref = \ "";
15 $runme = $^X;
16 @a = (1..5);
17 %h = (1..6);
18 $aref = \@a;
19 $href = \%h;
20 open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"|};
21 $chopit = 'aaaaaa';
22 @chopar = (113 .. 119);
23 $posstr = '123456';
24 $cstr = 'aBcD.eF';
25 pos $posstr = 3;
26 $nn = $n = 2;
27 sub subb {"in s"}
28
29 @INPUT = <DATA>;
30 @simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT;
31
32 sub wrn {"@_"}
33
34 # Check correct optimization of ucfirst etc
35 my $a = "AB";
36 my $b = "\u\L$a";
37 is( $b, 'Ab', 'Check correct optimization of ucfirst, etc');
38
39 # Check correct destruction of objects:
40 my $dc = 0;
41 sub A::DESTROY {$dc += 1}
42 $a=8;
43 my $b;
44 { my $c = 6; $b = bless \$c, "A"}
45
46 is($dc, 0, 'No destruction yet');
47
48 $b = $a+5;
49
50 is($dc, 1, 'object descruction via reassignment to variable');
51
52 my $xxx = 'b';
53 $xxx = 'c' . ($xxx || 'e');
54 is( $xxx, 'cb', 'variables can be read before being overwritten');
55
56 # Chains of assignments
57
58 my ($l1, $l2, $l3, $l4);
59 my $zzzz = 12;
60 $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz;
61
62 is($zzz1, 13, 'chain assignment, part1');
63 is($zzz2, 13, 'chain assignment, part2');
64 is($l1,   13, 'chain assignment, part3');
65 is($l2,   13, 'chain assignment, part4');
66 is($l3,   13, 'chain assignment, part5');
67 is($l4,   13, 'chain assignment, part6');
68
69 for (@INPUT) {
70   ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
71   $comment = $op unless defined $comment;
72   chomp;
73   $op = "$op==$op" unless $op =~ /==/;
74   ($op, $expectop) = $op =~ /(.*)==(.*)/;
75   
76   $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i);
77   $integer = ($comment =~ /^i_/) ? "use integer" : '' ;
78   if ($skip) {
79     SKIP: {
80         skip $comment, 1;
81     }
82     next;
83   }
84   
85   eval <<EOE;
86   local \$SIG{__WARN__} = \\&wrn;
87   my \$a = 'fake';
88   $integer;
89   \$a = $op;
90   \$b = $expectop;
91   is (\$a, \$b, \$comment);
92 EOE
93   if ($@) {
94     $warning = $@;
95     chomp $warning;
96     if ($@ !~ /(?:is un|not )implemented/) {
97       fail($_ . ' ' . $warning);
98     }
99   }
100 }
101
102 {                               # Check calling STORE
103   note('Tied variables, calling STORE');
104   my $sc = 0;
105   # do not use B:: namespace
106   sub BB::TIESCALAR {bless [11], 'BB'}
107   sub BB::FETCH { -(shift->[0]) }
108   sub BB::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift }
109
110   my $m;
111   tie $m, 'BB';
112   $m = 100;
113
114   is( $sc, 1, 'STORE called when assigning scalar to tied variable' );
115
116   my $t = 11;
117   $m = $t + 89;
118   
119   is( $sc, 2, 'and again' );
120   is( $m,  -117, 'checking the tied variable result' );
121
122   $m += $t;
123
124   is( $sc, 3, 'called on self-increment' );
125   is( $m,  89, 'checking the tied variable result' );
126
127   for (@INPUT) {
128     ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
129     $comment = $op unless defined $comment;
130     next if ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i);
131     $op =~ s/==.*//;
132     
133     $sc = 0;
134     local $SIG{__WARN__} = \&wrn;
135     eval "\$m = $op";
136     is $sc, $@ ? 0 : 1, "STORE count for $comment";
137   }
138 }
139
140 for (@simple_input) {
141   ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
142   $comment = $op unless defined $comment;
143   chomp;
144   ($operator, $variable) = /^\s*(\w+)\s*\$(\w+)/ or warn "misprocessed '$_'\n";
145   eval <<EOE;
146   local \$SIG{__WARN__} = \\&wrn;
147   my \$$variable = "Ac# Ca\\nxxx";
148   \$$variable = $operator \$$variable;
149   \$toself = \$$variable;
150   \$direct = $operator "Ac# Ca\\nxxx";
151   is(\$toself, \$direct);
152 EOE
153   if ($@) {
154     $warning = $@;
155     chomp $warning;
156     if ($@ =~ /(?:is un|not )implemented/) {
157       SKIP: {
158         skip $warning, 1;
159         pass($comment);
160       }
161     } elsif ($@ =~ /Can't (modify|take log of 0)/) {
162       SKIP: {
163         skip $warning . ' ' . $comment . ' syntax not good for selfassign', 1;
164         pass();
165       }
166     } else {
167       ##Something bad happened
168       fail($_ . ' ' . $warning);
169     }
170   }
171 }
172
173 # [perl #123790] Assigning to a typeglob
174 # These used to die or crash.
175 # Once the bug is fixed for all ops, we can combine this with the tests
176 # above that use <DATA>.
177 for my $glob (*__) {
178   $glob = $y x $z;
179   { use integer; $glob = $y <=> $z; }
180   $glob = $y cmp $z;
181   $glob = vec 1, 2, 4;
182   $glob = ~${\""};
183   $glob = split;
184 }
185
186 # XXX This test does not really belong here, as it has nothing to do with
187 #     OPpTARGET_MY optimisation.  But where should it go?
188 eval {
189     sub PVBM () { 'foo' }
190     index 'foo', PVBM;
191     my $x = PVBM;
192
193     my $str = 'foo';
194     my $pvlv = \substr $str, 0, 1;
195     $x = $pvlv;
196
197     1;
198 };
199 is($@, '', 'ex-PVBM assert'.$@);
200
201 # RT perl #127855
202 # Check that stringification and assignment to itself doesn't break
203 # anything. This is unlikely to actually fail the tests; its more something
204 # for valgrind to spot. It will also only fail if SvGROW or its caller
205 # decides to over-allocate (otherwise copying the string will skip the
206 # sv_grow(), as the new size is the same as the current size).
207
208 {
209     my $s;
210     for my $len (1..40) {
211         $s = 'x' x $len;
212         my $t = $s;
213         $t = "$t";
214         ok($s eq $t, "RT 127855: len=$len");
215     }
216 }
217
218 # time() can't be tested using the standard framework since two successive
219 # calls may return differing values.
220
221 {
222     my $a;
223     $a = time;
224     $b = time;
225     my $diff = $b - $a;
226     cmp_ok($diff, '>=', 0,  "time is monotically increasing");
227     cmp_ok($diff, '<',  2,  "time delta is small");
228 }
229
230
231 done_testing();
232
233 __END__
234 ref $xref                       # ref
235 ref $cstr                       # ref nonref
236 `$runme -e "print qq[1\\n]"`                            # backtick skip(MSWin32)
237 `$undefed`                      # backtick undef skip(MSWin32)
238 '???'                           # glob  (not currently OA_TARGLEX)
239 <OP>                            # readline
240 'faked'                         # rcatline
241 (@z = (1 .. 3))                 # aassign
242 (chop (@x=@chopar))             # chop
243 chop $chopit                    # schop
244 (chomp (@x=@chopar))            # chomp
245 chomp $chopit                   # schomp
246 pos $posstr                     # pos
247 pos $chopit                     # pos returns undef
248 $nn++==2                        # postinc
249 $nn++==3                        # i_postinc
250 $nn--==4                        # postdec
251 $nn--==3                        # i_postdec
252 $n ** $n                        # pow
253 $n * $n                         # multiply
254 $n * $n                         # i_multiply
255 $n / $n                         # divide
256 $n / $n                         # i_divide
257 $n % $n                         # modulo
258 $n % $n                         # i_modulo
259 $n x $n                         # repeat
260 $n + $n                         # add
261 $n + $n                         # i_add
262 $n - $n                         # subtract
263 $n - $n                         # i_subtract
264 $n . $n                         # concat
265 $n . $a=='2fake'                # concat with self
266 "3$a"=='3fake'                  # concat with self in stringify
267 "$n"                            # stringify
268 $n << $n                        # left_shift
269 $n >> $n                        # right_shift
270 $n <=> $n                       # ncmp
271 $n <=> $n                       # i_ncmp
272 $n cmp $n                       # scmp
273 $n & $n                         # bit_and
274 $n ^ $n                         # bit_xor
275 $n | $n                         # bit_or
276 -$n                             # negate
277 -$n                             # i_negate
278 -$a=="-fake"                    # i_negate with string
279 ~$n                             # complement
280 atan2 $n,$n                     # atan2
281 sin $n                          # sin
282 cos $n                          # cos
283 '???'                           # rand
284 exp $n                          # exp
285 log $n                          # log
286 sqrt $n                         # sqrt
287 int $n                          # int
288 hex $n                          # hex
289 oct $n                          # oct
290 abs $n                          # abs
291 length $posstr                  # length
292 substr $posstr, 2, 2            # substr
293 vec("abc",2,8)                  # vec
294 index $posstr, 2                # index
295 rindex $posstr, 2               # rindex
296 sprintf "%i%i", $n, $n          # sprintf
297 ord $n                          # ord
298 chr $n                          # chr
299 chr ${\256}                     # chr $wide
300 crypt $n, $n                    # crypt
301 ucfirst ($cstr . "a")           # ucfirst padtmp
302 ucfirst $cstr                   # ucfirst
303 lcfirst $cstr                   # lcfirst
304 uc $cstr                        # uc
305 lc $cstr                        # lc
306 quotemeta $cstr                 # quotemeta
307 @$aref                          # rv2av
308 @$undefed                       # rv2av undef
309 (each %h) % 2 == 1              # each
310 values %h                       # values
311 keys %h                         # keys
312 %$href                          # rv2hv
313 pack "C2", $n,$n                # pack
314 split /a/, "abad"               # split
315 join "a"; @a                    # join
316 push @a,3==6                    # push
317 unshift @aaa                    # unshift
318 reverse @a                      # reverse
319 reverse $cstr                   # reverse - scal
320 grep $_, 1,0,2,0,3              # grepwhile
321 map "x$_", 1,0,2,0,3            # mapwhile
322 subb()                          # entersub
323 caller                          # caller
324 warn "ignore this\n"            # warn
325 'faked'                         # die
326 open BLAH, "<non-existent"      # open
327 fileno STDERR                   # fileno
328 umask 0                         # umask
329 select STDOUT                   # sselect
330 select undef,undef,undef,0      # select
331 getc OP                         # getc
332 '???'                           # read
333 '???'                           # sysread
334 '???'                           # syswrite
335 '???'                           # send
336 '???'                           # recv
337 '???'                           # tell
338 '???'                           # fcntl
339 '???'                           # ioctl
340 '???'                           # flock
341 '???'                           # accept
342 '???'                           # shutdown
343 '???'                           # ftsize
344 '???'                           # ftmtime
345 '???'                           # ftatime
346 '???'                           # ftctime
347 chdir 'non-existent'            # chdir
348 '???'                           # chown
349 '???'                           # chroot
350 unlink 'non-existent'           # unlink
351 chmod 'non-existent'            # chmod
352 utime 'non-existent'            # utime
353 rename 'non-existent', 'non-existent1'  # rename
354 link 'non-existent', 'non-existent1' # link
355 '???'                           # symlink
356 readlink 'non-existent', 'non-existent1' # readlink
357 '???'                           # mkdir
358 '???'                           # rmdir
359 '???'                           # telldir
360 '???'                           # fork
361 '???'                           # wait
362 '???'                           # waitpid
363 system "$runme -e 0"            # system skip(VMS)
364 '???'                           # exec
365 '???'                           # kill
366 getppid                         # getppid
367 getpgrp                         # getpgrp
368 setpgrp                         # setpgrp
369 getpriority $$, $$              # getpriority
370 '???'                           # setpriority
371 '???'                           # time
372 localtime $^T                   # localtime
373 gmtime $^T                      # gmtime
374 '???'                           # sleep: can randomly fail
375 '???'                           # alarm
376 '???'                           # shmget
377 '???'                           # shmctl
378 '???'                           # shmread
379 '???'                           # shmwrite
380 '???'                           # msgget
381 '???'                           # msgctl
382 '???'                           # msgsnd
383 '???'                           # msgrcv
384 '???'                           # semget
385 '???'                           # semctl
386 '???'                           # semop
387 '???'                           # getlogin
388 '???'                           # syscall