t/op/lex_assign.t

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