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 destruction 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 # 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.)
 235 eval {
 236     my $x = {}; my $y;
 237     keys %{$y = $x};
 238     1;
 239 };
 240 is($@, '', 'keys %{$y = $x}');
 241
 242 eval {
 243     my $x = {}; my $y;
 244     my $foo = keys %{$y = $x};
 245     1;
 246 };
 247 is($@, '', 'my $foo = keys %{$y = $x}');
 248
 249 eval {
 250     my $x = {}; my $y;
 251     my @foo = keys %{$y = $x};
 252     1;
 253 };
 254 is($@, '', 'my @foo = keys %{$y = $x}');
 255
 256 fresh_perl_is('my ($x, $y); (($y = $x))', '', {}, '(($y = $x))');
 257 fresh_perl_is('my ($x, $y); my $z= (($y = $x))', '', {}, 'my $z= (($y = $x))');
 258 fresh_perl_is('my ($x, $y); my @z= (($y = $x))', '', {}, 'my @z= (($y = $x))');
 259
 260 done_testing();
 261
 262 __END__
 263 ref $xref                       # ref
 264 ref $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
 272 chop $chopit                    # schop
 273 (chomp (@x=@chopar))            # chomp
 274 chomp $chopit                   # schomp
 275 pos $posstr                     # pos
 276 pos $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
 309 atan2 $n,$n                     # atan2
 310 sin $n                          # sin
 311 cos $n                          # cos
 312 '???'                           # rand
 313 exp $n                          # exp
 314 log $n                          # log
 315 sqrt $n                         # sqrt
 316 int $n                          # int
 317 hex $n                          # hex
 318 oct $n                          # oct
 319 abs $n                          # abs
 320 length $posstr                  # length
 321 substr $posstr, 2, 2            # substr
 322 vec("abc",2,8)                  # vec
 323 index $posstr, 2                # index
 324 rindex $posstr, 2               # rindex
 325 sprintf "%i%i", $n, $n          # sprintf
 326 ord $n                          # ord
 327 chr $n                          # chr
 328 chr ${\256}                     # chr $wide
 329 crypt $n, $n                    # crypt
 330 ucfirst ($cstr . "a")           # ucfirst padtmp
 331 ucfirst $cstr                   # ucfirst
 332 lcfirst $cstr                   # lcfirst
 333 uc $cstr                        # uc
 334 lc $cstr                        # lc
 335 quotemeta $cstr                 # quotemeta
 336 @$aref                          # rv2av
 337 @$undefed                       # rv2av undef
 338 (each %h) % 2 == 1              # each
 339 values %h                       # values
 340 keys %h                         # keys
 341 %$href                          # rv2hv
 342 pack "C2", $n,$n                # pack
 343 split /a/, "abad"               # split
 344 join "a"; @a                    # join
 345 push @a,3==6                    # push
 346 unshift @aaa                    # unshift
 347 reverse @a                      # reverse
 348 reverse $cstr                   # reverse - scal
 349 grep $_, 1,0,2,0,3              # grepwhile
 350 map "x$_", 1,0,2,0,3            # mapwhile
 351 subb()                          # entersub
 352 caller                          # caller
 353 warn "ignore this\n"            # warn
 354 'faked'                         # die
 355 open BLAH, "<non-existent"      # open
 356 fileno STDERR                   # fileno
 357 umask 0                         # umask
 358 select STDOUT                   # sselect
 359 select undef,undef,undef,0      # select
 360 getc 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
 376 chdir 'non-existent'            # chdir
 377 '???'                           # chown
 378 '???'                           # chroot
 379 unlink 'non-existent'           # unlink
 380 chmod 'non-existent'            # chmod
 381 utime 'non-existent'            # utime
 382 rename 'non-existent', 'non-existent1'  # rename
 383 link 'non-existent', 'non-existent1' # link
 384 '???'                           # symlink
 385 readlink 'non-existent', 'non-existent1' # readlink
 386 '???'                           # mkdir
 387 '???'                           # rmdir
 388 '???'                           # telldir
 389 '???'                           # fork
 390 '???'                           # wait
 391 '???'                           # waitpid
 392 system "$runme -e 0"            # system skip(VMS)
 393 '???'                           # exec
 394 '???'                           # kill
 395 getppid                         # getppid
 396 getpgrp                         # getpgrp
 397 setpgrp                         # setpgrp
 398 getpriority $$, $$              # getpriority
 399 '???'                           # setpriority
 400 '???'                           # time
 401 localtime $^T                   # localtime
 402 gmtime $^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