[perl5.git] / t / op / lex_assign.t

#!./perl

BEGIN {
    chdir 't' if -d 't';
    @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;
  chomp;
  $op = "$op==$op" unless $op =~ /==/;
  ($op, $expectop) = $op =~ /(.*)==(.*)/;
  
  $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i)
	  ? "skip" : "# '$_'\nnot";
  $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 "# '$_'\nnot ok $ord\n";
    }
  }
}

for (@simple_input) {
  $ord++;
  ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
  $comment = $op unless defined $comment;
  chomp;
  ($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 "# '$_'\nnot 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: can randomly fail
'???'				# alarm
'???'				# shmget
'???'				# shmctl
'???'				# shmread
'???'				# shmwrite
'???'				# msgget
'???'				# msgctl
'???'				# msgsnd
'???'				# msgrcv
'???'				# semget
'???'				# semctl
'???'				# semop
'???'				# getlogin
'???'				# syscall
Commit	Line	Data
317982ac IZ	1	#!./perl
	2
	3	BEGIN {
	4	chdir 't' if -d 't';
20822f61	5	@INC = '../lib';
317982ac	6	}
98f7afd0	7	$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
317982ac IZ	8
	9	umask 0;
	10	$xref = \ "";
562a7b0c	11	$runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X;
317982ac IZ	12	@a = (1..5);
	13	%h = (1..6);
	14	$aref = \@a;
	15	$href = \%h;
562a7b0c	16	open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"\|};
317982ac IZ	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>;
3dbf192b	26	@simple_input = grep /^\s\w+\s\$\w+\s*[#\n]/, @INPUT;
6b66af17	27	print "1..", (10 + @INPUT + @simple_input), "\n";
317982ac IZ	28	$ord = 0;
	29
	30	sub wrn {"@_"}
	31
ed7ab888 GS	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
69b47968 GS	56	$ord++;
	57	my $xxx = 'b';
	58	$xxx = 'c' . ($xxx \|\| 'e');
	59	print "not " unless $xxx eq 'cb';
	60	print "ok $ord\n";
	61
ed7ab888 GS	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
6b66af17 GS	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
317982ac IZ	111	for (@INPUT) {
	112	$ord++;
	113	($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
	114	$comment = $op unless defined $comment;
ee8c7f54	115	chomp;
317982ac IZ	116	$op = "$op==$op" unless $op =~ /==/;
	117	($op, $expectop) = $op =~ /(.)==(.)/;
	118
0f4592ef	119	$skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.\Q$^O\E.\)/i)
ee8c7f54	120	? "skip" : "# '$_'\nnot";
317982ac IZ	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 $@;
ee8c7f54	141	print "# '$_'\nnot ok $ord\n";
317982ac IZ	142	}
	143	}
	144	}
3dbf192b IZ	145
	146	for (@simple_input) {
	147	$ord++;
	148	($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
	149	$comment = $op unless defined $comment;
ee8c7f54	150	chomp;
3dbf192b IZ	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 $@;
ee8c7f54	169	print "# '$_'\nnot ok $ord\n";
3dbf192b IZ	170	}
	171	}
	172	}
317982ac IZ	173	__END__
	174	ref $xref # ref
	175	ref $cstr # ref nonref
75f2fcd2	176	`$runme -e "print qq[1\\n]"` # backtick skip(MSWin32)
0f4592ef	177	`$undefed` # backtick undef skip(MSWin32)
317982ac IZ	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==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 "","","",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
ecece5d6	293	'???' # symlink
317982ac IZ	294	readlink 'non-existent', 'non-existent1' # readlink
	295	'???' # mkdir
	296	'???' # rmdir
	297	'???' # telldir
	298	'???' # fork
	299	'???' # wait
	300	'???' # waitpid
562a7b0c	301	system "$runme -e 0" # system skip(VMS)
317982ac	302	'???' # exec
0f4592ef	303	'???' # kill
317982ac IZ	304	getppid # getppid
	305	getpgrp # getpgrp
	306	'???' # setpgrp
	307	getpriority $$, $$ # getpriority
	308	'???' # setpriority
	309	time # time
7e3cfbc1 MG	310	localtime $^T # localtime
7e3cfbc1 MG	311	gmtime $^T # gmtime
dbb6c582	312	'???' # sleep: can randomly fail
317982ac IZ	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