xref: /openbsd/gnu/usr.bin/perl/t/op/lex_assign.t (revision e0680481) 
1#!./perl
2
3# Test that $lexical = <some op> optimises the assignment away correctly
4# and causes no ill side-effects.
5
6BEGIN {
7    chdir 't' if -d 't';
8    require './test.pl';
9    set_up_inc('../lib');
10}
11
12$| = 1;
13umask 0;
14$xref = \ "";
15$runme = $^X;
16@a = (1..5);
17%h = (1..6);
18$aref = \@a;
19$href = \%h;
20open 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';
25pos $posstr = 3;
26$nn = $n = 2;
27sub subb {"in s"}
28
29@INPUT = <DATA>;
30@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT;
31
32sub wrn {"@_"}
33
34# Check correct optimization of ucfirst etc
35my $a = "AB";
36my $b = "\u\L$a";
37is( $b, 'Ab', 'Check correct optimization of ucfirst, etc');
38
39# Check correct destruction of objects:
40my $dc = 0;
41sub A::DESTROY {$dc += 1}
42$a=8;
43my $b;
44{ my $c = 6; $b = bless \$c, "A"}
45
46is($dc, 0, 'No destruction yet');
47
48$b = $a+5;
49
50is($dc, 1, 'object destruction via reassignment to variable');
51
52my $xxx = 'b';
53$xxx = 'c' . ($xxx || 'e');
54is( $xxx, 'cb', 'variables can be read before being overwritten');
55
56# Chains of assignments
57
58my ($l1, $l2, $l3, $l4);
59my $zzzz = 12;
60$zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz;
61
62is($zzz1, 13, 'chain assignment, part1');
63is($zzz2, 13, 'chain assignment, part2');
64is($l1,   13, 'chain assignment, part3');
65is($l2,   13, 'chain assignment, part4');
66is($l3,   13, 'chain assignment, part5');
67is($l4,   13, 'chain assignment, part6');
68
69for (@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);
92EOE
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
140for (@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);
152EOE
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>.
177for 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?
188eval {
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};
199is($@, '', '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# GH #20132 and parts of GH ##20114
231# During development of OP_PADSV_STORE, interactions with OP_PADRANGE
232# caused BBC failures not picked up by any pre-existing core tests.
233# (Problems only arose in list context, the void/scalar tests have been
234# included for completeness.)
235eval {
236    my $x = {}; my $y;
237    keys %{$y = $x};
238    1;
239};
240is($@, '', 'keys %{$y = $x}');
241
242eval {
243    my $x = {}; my $y;
244    my $foo = keys %{$y = $x};
245    1;
246};
247is($@, '', 'my $foo = keys %{$y = $x}');
248
249eval {
250    my $x = {}; my $y;
251    my @foo = keys %{$y = $x};
252    1;
253};
254is($@, '', 'my @foo = keys %{$y = $x}');
255
256fresh_perl_is('my ($x, $y); (($y = $x))', '', {}, '(($y = $x))');
257fresh_perl_is('my ($x, $y); my $z= (($y = $x))', '', {}, 'my $z= (($y = $x))');
258fresh_perl_is('my ($x, $y); my @z= (($y = $x))', '', {}, 'my @z= (($y = $x))');
259
260done_testing();
261
262__END__
263ref $xref			# ref
264ref $cstr			# ref nonref
265`$runme -e "print qq[1\\n]"`				# backtick skip(MSWin32)
266`$undefed`			# backtick undef skip(MSWin32)
267'???'				# glob  (not currently OA_TARGLEX)
268<OP>				# readline
269'faked'				# rcatline
270(@z = (1 .. 3))			# aassign
271(chop (@x=@chopar))		# chop
272chop $chopit			# schop
273(chomp (@x=@chopar))		# chomp
274chomp $chopit			# schomp
275pos $posstr			# pos
276pos $chopit			# pos returns undef
277$nn++==2			# postinc
278$nn++==3			# i_postinc
279$nn--==4			# postdec
280$nn--==3			# i_postdec
281$n ** $n			# pow
282$n * $n				# multiply
283$n * $n				# i_multiply
284$n / $n				# divide
285$n / $n				# i_divide
286$n % $n				# modulo
287$n % $n				# i_modulo
288$n x $n				# repeat
289$n + $n				# add
290$n + $n				# i_add
291$n - $n				# subtract
292$n - $n				# i_subtract
293$n . $n				# concat
294$n . $a=='2fake'		# concat with self
295"3$a"=='3fake'			# concat with self in stringify
296"$n"				# stringify
297$n << $n			# left_shift
298$n >> $n			# right_shift
299$n <=> $n			# ncmp
300$n <=> $n			# i_ncmp
301$n cmp $n			# scmp
302$n & $n				# bit_and
303$n ^ $n				# bit_xor
304$n | $n				# bit_or
305-$n				# negate
306-$n				# i_negate
307-$a=="-fake"			# i_negate with string
308~$n				# complement
309atan2 $n,$n			# atan2
310sin $n				# sin
311cos $n				# cos
312'???'				# rand
313exp $n				# exp
314log $n				# log
315sqrt $n				# sqrt
316int $n				# int
317hex $n				# hex
318oct $n				# oct
319abs $n				# abs
320length $posstr			# length
321substr $posstr, 2, 2		# substr
322vec("abc",2,8)			# vec
323index $posstr, 2		# index
324rindex $posstr, 2		# rindex
325sprintf "%i%i", $n, $n		# sprintf
326ord $n				# ord
327chr $n				# chr
328chr ${\256}			# chr $wide
329crypt $n, $n			# crypt
330ucfirst ($cstr . "a")		# ucfirst padtmp
331ucfirst $cstr			# ucfirst
332lcfirst $cstr			# lcfirst
333uc $cstr			# uc
334lc $cstr			# lc
335quotemeta $cstr			# quotemeta
336@$aref				# rv2av
337@$undefed			# rv2av undef
338(each %h) % 2 == 1		# each
339values %h			# values
340keys %h				# keys
341%$href				# rv2hv
342pack "C2", $n,$n		# pack
343split /a/, "abad"		# split
344join "a"; @a			# join
345push @a,3==6			# push
346unshift @aaa			# unshift
347reverse	@a			# reverse
348reverse	$cstr			# reverse - scal
349grep $_, 1,0,2,0,3		# grepwhile
350map "x$_", 1,0,2,0,3		# mapwhile
351subb()				# entersub
352caller				# caller
353warn "ignore this\n"		# warn
354'faked'				# die
355open BLAH, "<non-existent"	# open
356fileno STDERR			# fileno
357umask 0				# umask
358select STDOUT			# sselect
359select undef,undef,undef,0	# select
360getc OP				# getc
361'???'				# read
362'???'				# sysread
363'???'				# syswrite
364'???'				# send
365'???'				# recv
366'???'				# tell
367'???'				# fcntl
368'???'				# ioctl
369'???'				# flock
370'???'				# accept
371'???'				# shutdown
372'???'				# ftsize
373'???'				# ftmtime
374'???'				# ftatime
375'???'				# ftctime
376chdir 'non-existent'		# chdir
377'???'				# chown
378'???'				# chroot
379unlink 'non-existent'		# unlink
380chmod 'non-existent'		# chmod
381utime 'non-existent'		# utime
382rename 'non-existent', 'non-existent1'	# rename
383link 'non-existent', 'non-existent1' # link
384'???'				# symlink
385readlink 'non-existent', 'non-existent1' # readlink
386'???'				# mkdir
387'???'				# rmdir
388'???'				# telldir
389'???'				# fork
390'???'				# wait
391'???'				# waitpid
392system "$runme -e 0"		# system skip(VMS)
393'???'				# exec
394'???'				# kill
395getppid				# getppid
396getpgrp				# getpgrp
397setpgrp				# setpgrp
398getpriority $$, $$		# getpriority
399'???'				# setpriority
400'???'				# time
401localtime $^T			# localtime
402gmtime $^T			# gmtime
403'???'				# sleep: can randomly fail
404'???'				# alarm
405'???'				# shmget
406'???'				# shmctl
407'???'				# shmread
408'???'				# shmwrite
409'???'				# msgget
410'???'				# msgctl
411'???'				# msgsnd
412'???'				# msgrcv
413'???'				# semget
414'???'				# semctl
415'???'				# semop
416'???'				# getlogin
417'???'				# syscall
418