diff options
Diffstat (limited to 'contrib/perl5/t/op/lex_assign.t')
| -rwxr-xr-x | contrib/perl5/t/op/lex_assign.t | 324 |
1 files changed, 324 insertions, 0 deletions
diff --git a/contrib/perl5/t/op/lex_assign.t b/contrib/perl5/t/op/lex_assign.t new file mode 100755 index 0000000..2fb059d --- /dev/null +++ b/contrib/perl5/t/op/lex_assign.t @@ -0,0 +1,324 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + +umask 0; +$xref = \ ""; +$runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X; +@a = (1..5); +%h = (1..6); +$aref = \@a; +$href = \%h; +open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"|}; +$chopit = 'aaaaaa'; +@chopar = (113 .. 119); +$posstr = '123456'; +$cstr = 'aBcD.eF'; +pos $posstr = 3; +$nn = $n = 2; +sub subb {"in s"} + +@INPUT = <DATA>; +@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT; +print "1..", (10 + @INPUT + @simple_input), "\n"; +$ord = 0; + +sub wrn {"@_"} + +# Check correct optimization of ucfirst etc +$ord++; +my $a = "AB"; +my $b = "\u\L$a"; +print "not " unless $b eq 'Ab'; +print "ok $ord\n"; + +# Check correct destruction of objects: +my $dc = 0; +sub A::DESTROY {$dc += 1} +$a=8; +my $b; +{ my $c = 6; $b = bless \$c, "A"} + +$ord++; +print "not " unless $dc == 0; +print "ok $ord\n"; + +$b = $a+5; + +$ord++; +print "not " unless $dc == 1; +print "ok $ord\n"; + +$ord++; +my $xxx = 'b'; +$xxx = 'c' . ($xxx || 'e'); +print "not " unless $xxx eq 'cb'; +print "ok $ord\n"; + +{ # Check calling STORE + my $sc = 0; + sub B::TIESCALAR {bless [11], 'B'} + sub B::FETCH { -(shift->[0]) } + sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift } + + my $m; + tie $m, 'B'; + $m = 100; + + $ord++; + print "not " unless $sc == 1; + print "ok $ord\n"; + + my $t = 11; + $m = $t + 89; + + $ord++; + print "not " unless $sc == 2; + print "ok $ord\n"; + + $ord++; + print "# $m\nnot " unless $m == -117; + print "ok $ord\n"; + + $m += $t; + + $ord++; + print "not " unless $sc == 3; + print "ok $ord\n"; + + $ord++; + print "# $m\nnot " unless $m == 89; + print "ok $ord\n"; + +} + +# Chains of assignments + +my ($l1, $l2, $l3, $l4); +my $zzzz = 12; +$zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz; + +$ord++; +print "# $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 13\nnot " + unless $zzz1 == 13 and $zzz2 == 13 and $l1 == 13 + and $l2 == 13 and $l3 == 13 and $l4 == 13; +print "ok $ord\n"; + +for (@INPUT) { + $ord++; + ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; + $comment = $op unless defined $comment; + $op = "$op==$op" unless $op =~ /==/; + ($op, $expectop) = $op =~ /(.*)==(.*)/; + + $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i) + ? "skip" : "not"; + $integer = ($comment =~ /^i_/) ? "use integer" : '' ; + (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip'; + + eval <<EOE; + local \$SIG{__WARN__} = \\&wrn; + my \$a = 'fake'; + $integer; + \$a = $op; + \$b = $expectop; + if (\$a ne \$b) { + print "# \$comment: got `\$a', expected `\$b'\n"; + print "\$skip " if \$a ne \$b or \$skip eq 'skip'; + } + print "ok \$ord\\n"; +EOE + if ($@) { + if ($@ =~ /is unimplemented/) { + print "# skipping $comment: unimplemented:\nok $ord\n"; + } else { + warn $@; + print "not ok $ord\n"; + } + } +} + +for (@simple_input) { + $ord++; + ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; + $comment = $op unless defined $comment; + ($operator, $variable) = /^\s*(\w+)\s*\$(\w+)/ or warn "misprocessed '$_'\n"; + eval <<EOE; + local \$SIG{__WARN__} = \\&wrn; + my \$$variable = "Ac# Ca\\nxxx"; + \$$variable = $operator \$$variable; + \$toself = \$$variable; + \$direct = $operator "Ac# Ca\\nxxx"; + print "# \\\$$variable = $operator \\\$$variable\\nnot " + unless \$toself eq \$direct; + print "ok \$ord\\n"; +EOE + if ($@) { + if ($@ =~ /is unimplemented/) { + print "# skipping $comment: unimplemented:\nok $ord\n"; + } elsif ($@ =~ /Can't (modify|take log of 0)/) { + print "# skipping $comment: syntax not good for selfassign:\nok $ord\n"; + } else { + warn $@; + print "not ok $ord\n"; + } + } +} +__END__ +ref $xref # ref +ref $cstr # ref nonref +`$runme -e "print qq[1\n]"` # backtick skip(MSWin32) +`$undefed` # backtick undef skip(MSWin32) +<*> # glob +<OP> # readline +'faked' # rcatline +(@z = (1 .. 3)) # aassign +chop $chopit # chop +(chop (@x=@chopar)) # schop +chomp $chopit # chomp +(chop (@x=@chopar)) # schomp +pos $posstr # pos +pos $chopit # pos returns undef +$nn++==2 # postinc +$nn++==3 # i_postinc +$nn--==4 # postdec +$nn--==3 # i_postdec +$n ** $n # pow +$n * $n # multiply +$n * $n # i_multiply +$n / $n # divide +$n / $n # i_divide +$n % $n # modulo +$n % $n # i_modulo +$n x $n # repeat +$n + $n # add +$n + $n # i_add +$n - $n # subtract +$n - $n # i_subtract +$n . $n # concat +$n . $a=='2fake' # concat with self +"3$a"=='3fake' # concat with self in stringify +"$n" # stringify +$n << $n # left_shift +$n >> $n # right_shift +$n <=> $n # ncmp +$n <=> $n # i_ncmp +$n cmp $n # scmp +$n & $n # bit_and +$n ^ $n # bit_xor +$n | $n # bit_or +-$n # negate +-$n # i_negate +~$n # complement +atan2 $n,$n # atan2 +sin $n # sin +cos $n # cos +'???' # rand +exp $n # exp +log $n # log +sqrt $n # sqrt +int $n # int +hex $n # hex +oct $n # oct +abs $n # abs +length $posstr # length +substr $posstr, 2, 2 # substr +vec("abc",2,8) # vec +index $posstr, 2 # index +rindex $posstr, 2 # rindex +sprintf "%i%i", $n, $n # sprintf +ord $n # ord +chr $n # chr +crypt $n, $n # crypt +ucfirst ($cstr . "a") # ucfirst padtmp +ucfirst $cstr # ucfirst +lcfirst $cstr # lcfirst +uc $cstr # uc +lc $cstr # lc +quotemeta $cstr # quotemeta +@$aref # rv2av +@$undefed # rv2av undef +each %h==1 # each +values %h # values +keys %h # keys +%$href # rv2hv +pack "C2", $n,$n # pack +split /a/, "abad" # split +join "a"; @a # join +push @a,3==6 # push +unshift @aaa # unshift +reverse @a # reverse +reverse $cstr # reverse - scal +grep $_, 1,0,2,0,3 # grepwhile +map "x$_", 1,0,2,0,3 # mapwhile +subb() # entersub +caller # caller +warn "ignore this\n" # warn +'faked' # die +open BLAH, "<non-existent" # open +fileno STDERR # fileno +umask 0 # umask +select STDOUT # sselect +select "","","",0 # select +getc OP # getc +'???' # read +'???' # sysread +'???' # syswrite +'???' # send +'???' # recv +'???' # tell +'???' # fcntl +'???' # ioctl +'???' # flock +'???' # accept +'???' # shutdown +'???' # ftsize +'???' # ftmtime +'???' # ftatime +'???' # ftctime +chdir 'non-existent' # chdir +'???' # chown +'???' # chroot +unlink 'non-existent' # unlink +chmod 'non-existent' # chmod +utime 'non-existent' # utime +rename 'non-existent', 'non-existent1' # rename +link 'non-existent', 'non-existent1' # link +'???' # symlink +readlink 'non-existent', 'non-existent1' # readlink +'???' # mkdir +'???' # rmdir +'???' # telldir +'???' # fork +'???' # wait +'???' # waitpid +system "$runme -e 0" # system skip(VMS) +'???' # exec +'???' # kill +getppid # getppid +getpgrp # getpgrp +'???' # setpgrp +getpriority $$, $$ # getpriority +'???' # setpriority +time # time +localtime $^T # localtime +gmtime $^T # gmtime +sleep 1 # sleep +'???' # alarm +'???' # shmget +'???' # shmctl +'???' # shmread +'???' # shmwrite +'???' # msgget +'???' # msgctl +'???' # msgsnd +'???' # msgrcv +'???' # semget +'???' # semctl +'???' # semop +'???' # getlogin +'???' # syscall |
