1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9$| = 1; 10umask 0; 11$xref = \ ""; 12$runme = $^X; 13@a = (1..5); 14%h = (1..6); 15$aref = \@a; 16$href = \%h; 17open 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'; 22pos $posstr = 3; 23$nn = $n = 2; 24sub subb {"in s"} 25 26@INPUT = <DATA>; 27@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT; 28 29sub wrn {"@_"} 30 31# Check correct optimization of ucfirst etc 32my $a = "AB"; 33my $b = "\u\L$a"; 34is( $b, 'Ab', 'Check correct optimization of ucfirst, etc'); 35 36# Check correct destruction of objects: 37my $dc = 0; 38sub A::DESTROY {$dc += 1} 39$a=8; 40my $b; 41{ my $c = 6; $b = bless \$c, "A"} 42 43is($dc, 0, 'No destruction yet'); 44 45$b = $a+5; 46 47is($dc, 1, 'object descruction via reassignment to variable'); 48 49my $xxx = 'b'; 50$xxx = 'c' . ($xxx || 'e'); 51is( $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 81my ($l1, $l2, $l3, $l4); 82my $zzzz = 12; 83$zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz; 84 85is($zzz1, 13, 'chain assignment, part1'); 86is($zzz2, 13, 'chain assignment, part2'); 87is($l1, 13, 'chain assignment, part3'); 88is($l2, 13, 'chain assignment, part4'); 89is($l3, 13, 'chain assignment, part5'); 90is($l4, 13, 'chain assignment, part6'); 91 92for (@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(); 123EOE 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 138for (@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); 150EOE 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 171eval { 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}; 182is($@, '', 'ex-PVBM assert'.$@); 183 184done_testing(); 185 186__END__ 187ref $xref # ref 188ref $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 195chop $chopit # chop 196(chop (@x=@chopar)) # schop 197chomp $chopit # chomp 198(chop (@x=@chopar)) # schomp 199pos $posstr # pos 200pos $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 232atan2 $n,$n # atan2 233sin $n # sin 234cos $n # cos 235'???' # rand 236exp $n # exp 237log $n # log 238sqrt $n # sqrt 239int $n # int 240hex $n # hex 241oct $n # oct 242abs $n # abs 243length $posstr # length 244substr $posstr, 2, 2 # substr 245vec("abc",2,8) # vec 246index $posstr, 2 # index 247rindex $posstr, 2 # rindex 248sprintf "%i%i", $n, $n # sprintf 249ord $n # ord 250chr $n # chr 251crypt $n, $n # crypt 252ucfirst ($cstr . "a") # ucfirst padtmp 253ucfirst $cstr # ucfirst 254lcfirst $cstr # lcfirst 255uc $cstr # uc 256lc $cstr # lc 257quotemeta $cstr # quotemeta 258@$aref # rv2av 259@$undefed # rv2av undef 260(each %h) % 2 == 1 # each 261values %h # values 262keys %h # keys 263%$href # rv2hv 264pack "C2", $n,$n # pack 265split /a/, "abad" # split 266join "a"; @a # join 267push @a,3==6 # push 268unshift @aaa # unshift 269reverse @a # reverse 270reverse $cstr # reverse - scal 271grep $_, 1,0,2,0,3 # grepwhile 272map "x$_", 1,0,2,0,3 # mapwhile 273subb() # entersub 274caller # caller 275warn "ignore this\n" # warn 276'faked' # die 277open BLAH, "<non-existent" # open 278fileno STDERR # fileno 279umask 0 # umask 280select STDOUT # sselect 281select undef,undef,undef,0 # select 282getc 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 298chdir 'non-existent' # chdir 299'???' # chown 300'???' # chroot 301unlink 'non-existent' # unlink 302chmod 'non-existent' # chmod 303utime 'non-existent' # utime 304rename 'non-existent', 'non-existent1' # rename 305link 'non-existent', 'non-existent1' # link 306'???' # symlink 307readlink 'non-existent', 'non-existent1' # readlink 308'???' # mkdir 309'???' # rmdir 310'???' # telldir 311'???' # fork 312'???' # wait 313'???' # waitpid 314system "$runme -e 0" # system skip(VMS) 315'???' # exec 316'???' # kill 317getppid # getppid 318getpgrp # getpgrp 319'???' # setpgrp 320getpriority $$, $$ # getpriority 321'???' # setpriority 322time # time 323localtime $^T # localtime 324gmtime $^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 340