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