| 1 | #!./perl
|
|---|
| 2 |
|
|---|
| 3 | BEGIN {
|
|---|
| 4 | chdir 't' if -d 't';
|
|---|
| 5 | @INC = '../lib';
|
|---|
| 6 | }
|
|---|
| 7 |
|
|---|
| 8 | $| = 1;
|
|---|
| 9 | umask 0;
|
|---|
| 10 | $xref = \ "";
|
|---|
| 11 | $runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X;
|
|---|
| 12 | @a = (1..5);
|
|---|
| 13 | %h = (1..6);
|
|---|
| 14 | $aref = \@a;
|
|---|
| 15 | $href = \%h;
|
|---|
| 16 | open 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';
|
|---|
| 21 | pos $posstr = 3;
|
|---|
| 22 | $nn = $n = 2;
|
|---|
| 23 | sub subb {"in s"}
|
|---|
| 24 |
|
|---|
| 25 | @INPUT = <DATA>;
|
|---|
| 26 | @simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT;
|
|---|
| 27 | print "1..", (10 + @INPUT + @simple_input), "\n";
|
|---|
| 28 | $ord = 0;
|
|---|
| 29 |
|
|---|
| 30 | sub wrn {"@_"}
|
|---|
| 31 |
|
|---|
| 32 | # Check correct optimization of ucfirst etc
|
|---|
| 33 | $ord++;
|
|---|
| 34 | my $a = "AB";
|
|---|
| 35 | my $b = "\u\L$a";
|
|---|
| 36 | print "not " unless $b eq 'Ab';
|
|---|
| 37 | print "ok $ord\n";
|
|---|
| 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 | $ord++;
|
|---|
| 47 | print "not " unless $dc == 0;
|
|---|
| 48 | print "ok $ord\n";
|
|---|
| 49 |
|
|---|
| 50 | $b = $a+5;
|
|---|
| 51 |
|
|---|
| 52 | $ord++;
|
|---|
| 53 | print "not " unless $dc == 1;
|
|---|
| 54 | print "ok $ord\n";
|
|---|
| 55 |
|
|---|
| 56 | $ord++;
|
|---|
| 57 | my $xxx = 'b';
|
|---|
| 58 | $xxx = 'c' . ($xxx || 'e');
|
|---|
| 59 | print "not " unless $xxx eq 'cb';
|
|---|
| 60 | print "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 |
|
|---|
| 101 | my ($l1, $l2, $l3, $l4);
|
|---|
| 102 | my $zzzz = 12;
|
|---|
| 103 | $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz;
|
|---|
| 104 |
|
|---|
| 105 | $ord++;
|
|---|
| 106 | print "# $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;
|
|---|
| 109 | print "ok $ord\n";
|
|---|
| 110 |
|
|---|
| 111 | for (@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";
|
|---|
| 135 | EOE
|
|---|
| 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 |
|
|---|
| 146 | for (@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";
|
|---|
| 161 | EOE
|
|---|
| 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 | __END__
|
|---|
| 174 | ref $xref # ref
|
|---|
| 175 | ref $cstr # ref nonref
|
|---|
| 176 | `$runme -e "print qq[1\\n]"` # backtick skip(MSWin32)
|
|---|
| 177 | `$undefed` # backtick undef skip(MSWin32)
|
|---|
| 178 | <*> # glob
|
|---|
| 179 | <OP> # readline
|
|---|
| 180 | 'faked' # rcatline
|
|---|
| 181 | (@z = (1 .. 3)) # aassign
|
|---|
| 182 | chop $chopit # chop
|
|---|
| 183 | (chop (@x=@chopar)) # schop
|
|---|
| 184 | chomp $chopit # chomp
|
|---|
| 185 | (chop (@x=@chopar)) # schomp
|
|---|
| 186 | pos $posstr # pos
|
|---|
| 187 | pos $chopit # pos returns undef
|
|---|
| 188 | $nn++==2 # postinc
|
|---|
| 189 | $nn++==3 # i_postinc
|
|---|
| 190 | $nn--==4 # postdec
|
|---|
| 191 | $nn--==3 # i_postdec
|
|---|
| 192 | $n ** $n # pow
|
|---|
| 193 | $n * $n # multiply
|
|---|
| 194 | $n * $n # i_multiply
|
|---|
| 195 | $n / $n # divide
|
|---|
| 196 | $n / $n # i_divide
|
|---|
| 197 | $n % $n # modulo
|
|---|
| 198 | $n % $n # i_modulo
|
|---|
| 199 | $n x $n # repeat
|
|---|
| 200 | $n + $n # add
|
|---|
| 201 | $n + $n # i_add
|
|---|
| 202 | $n - $n # subtract
|
|---|
| 203 | $n - $n # i_subtract
|
|---|
| 204 | $n . $n # concat
|
|---|
| 205 | $n . $a=='2fake' # concat with self
|
|---|
| 206 | "3$a"=='3fake' # concat with self in stringify
|
|---|
| 207 | "$n" # stringify
|
|---|
| 208 | $n << $n # left_shift
|
|---|
| 209 | $n >> $n # right_shift
|
|---|
| 210 | $n <=> $n # ncmp
|
|---|
| 211 | $n <=> $n # i_ncmp
|
|---|
| 212 | $n cmp $n # scmp
|
|---|
| 213 | $n & $n # bit_and
|
|---|
| 214 | $n ^ $n # bit_xor
|
|---|
| 215 | $n | $n # bit_or
|
|---|
| 216 | -$n # negate
|
|---|
| 217 | -$n # i_negate
|
|---|
| 218 | ~$n # complement
|
|---|
| 219 | atan2 $n,$n # atan2
|
|---|
| 220 | sin $n # sin
|
|---|
| 221 | cos $n # cos
|
|---|
| 222 | '???' # rand
|
|---|
| 223 | exp $n # exp
|
|---|
| 224 | log $n # log
|
|---|
| 225 | sqrt $n # sqrt
|
|---|
| 226 | int $n # int
|
|---|
| 227 | hex $n # hex
|
|---|
| 228 | oct $n # oct
|
|---|
| 229 | abs $n # abs
|
|---|
| 230 | length $posstr # length
|
|---|
| 231 | substr $posstr, 2, 2 # substr
|
|---|
| 232 | vec("abc",2,8) # vec
|
|---|
| 233 | index $posstr, 2 # index
|
|---|
| 234 | rindex $posstr, 2 # rindex
|
|---|
| 235 | sprintf "%i%i", $n, $n # sprintf
|
|---|
| 236 | ord $n # ord
|
|---|
| 237 | chr $n # chr
|
|---|
| 238 | crypt $n, $n # crypt
|
|---|
| 239 | ucfirst ($cstr . "a") # ucfirst padtmp
|
|---|
| 240 | ucfirst $cstr # ucfirst
|
|---|
| 241 | lcfirst $cstr # lcfirst
|
|---|
| 242 | uc $cstr # uc
|
|---|
| 243 | lc $cstr # lc
|
|---|
| 244 | quotemeta $cstr # quotemeta
|
|---|
| 245 | @$aref # rv2av
|
|---|
| 246 | @$undefed # rv2av undef
|
|---|
| 247 | (each %h) % 2 == 1 # each
|
|---|
| 248 | values %h # values
|
|---|
| 249 | keys %h # keys
|
|---|
| 250 | %$href # rv2hv
|
|---|
| 251 | pack "C2", $n,$n # pack
|
|---|
| 252 | split /a/, "abad" # split
|
|---|
| 253 | join "a"; @a # join
|
|---|
| 254 | push @a,3==6 # push
|
|---|
| 255 | unshift @aaa # unshift
|
|---|
| 256 | reverse @a # reverse
|
|---|
| 257 | reverse $cstr # reverse - scal
|
|---|
| 258 | grep $_, 1,0,2,0,3 # grepwhile
|
|---|
| 259 | map "x$_", 1,0,2,0,3 # mapwhile
|
|---|
| 260 | subb() # entersub
|
|---|
| 261 | caller # caller
|
|---|
| 262 | warn "ignore this\n" # warn
|
|---|
| 263 | 'faked' # die
|
|---|
| 264 | open BLAH, "<non-existent" # open
|
|---|
| 265 | fileno STDERR # fileno
|
|---|
| 266 | umask 0 # umask
|
|---|
| 267 | select STDOUT # sselect
|
|---|
| 268 | select undef,undef,undef,0 # select
|
|---|
| 269 | getc OP # getc
|
|---|
| 270 | '???' # read
|
|---|
| 271 | '???' # sysread
|
|---|
| 272 | '???' # syswrite
|
|---|
| 273 | '???' # send
|
|---|
| 274 | '???' # recv
|
|---|
| 275 | '???' # tell
|
|---|
| 276 | '???' # fcntl
|
|---|
| 277 | '???' # ioctl
|
|---|
| 278 | '???' # flock
|
|---|
| 279 | '???' # accept
|
|---|
| 280 | '???' # shutdown
|
|---|
| 281 | '???' # ftsize
|
|---|
| 282 | '???' # ftmtime
|
|---|
| 283 | '???' # ftatime
|
|---|
| 284 | '???' # ftctime
|
|---|
| 285 | chdir 'non-existent' # chdir
|
|---|
| 286 | '???' # chown
|
|---|
| 287 | '???' # chroot
|
|---|
| 288 | unlink 'non-existent' # unlink
|
|---|
| 289 | chmod 'non-existent' # chmod
|
|---|
| 290 | utime 'non-existent' # utime
|
|---|
| 291 | rename 'non-existent', 'non-existent1' # rename
|
|---|
| 292 | link 'non-existent', 'non-existent1' # link
|
|---|
| 293 | '???' # symlink
|
|---|
| 294 | readlink 'non-existent', 'non-existent1' # readlink
|
|---|
| 295 | '???' # mkdir
|
|---|
| 296 | '???' # rmdir
|
|---|
| 297 | '???' # telldir
|
|---|
| 298 | '???' # fork
|
|---|
| 299 | '???' # wait
|
|---|
| 300 | '???' # waitpid
|
|---|
| 301 | system "$runme -e 0" # system skip(VMS)
|
|---|
| 302 | '???' # exec
|
|---|
| 303 | '???' # kill
|
|---|
| 304 | getppid # getppid
|
|---|
| 305 | getpgrp # getpgrp
|
|---|
| 306 | '???' # setpgrp
|
|---|
| 307 | getpriority $$, $$ # getpriority
|
|---|
| 308 | '???' # setpriority
|
|---|
| 309 | time # time
|
|---|
| 310 | localtime $^T # localtime
|
|---|
| 311 | gmtime $^T # gmtime
|
|---|
| 312 | '???' # sleep: can randomly fail
|
|---|
| 313 | '???' # alarm
|
|---|
| 314 | '???' # shmget
|
|---|
| 315 | '???' # shmctl
|
|---|
| 316 | '???' # shmread
|
|---|
| 317 | '???' # shmwrite
|
|---|
| 318 | '???' # msgget
|
|---|
| 319 | '???' # msgctl
|
|---|
| 320 | '???' # msgsnd
|
|---|
| 321 | '???' # msgrcv
|
|---|
| 322 | '???' # semget
|
|---|
| 323 | '???' # semctl
|
|---|
| 324 | '???' # semop
|
|---|
| 325 | '???' # getlogin
|
|---|
| 326 | '???' # syscall
|
|---|
