t/op/lex_assign.t

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