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