1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
# call.t
#
# Tests for the 'call' and 'icall' functions.
#
use Tcl;
$| = 1;
print "1..15\n";
my $i = Tcl->new;
my (@res, $res, $a, $b);
$res = $i->call('set', 'var', "ok 1");
print "$res\n";
$res = $i->icall('set', 'var', "ok 2");
print "$res\n";
@res = $i->call('set', 'var', ['ok', '3']);
print STDOUT join(' ', @res), "\n";
@res = $i->icall('set', 'var', ['ok', '4']);
print STDOUT join(' ', @res), "\n";
($a, $b) = $i->call('list', '5', 'ok');
print "$b $a\n";
($a, $b) = $i->icall('list', '6', 'ok');
print "$b $a\n";
$i->call("puts", "ok 7");
$i->icall("puts", "ok 8");
$a = $i->call("list", 1, $i->call("list", 2, 3), 4);
print "not " unless @$a == 4 && $a->[1] == 2 && $a eq "1 2 3 4";
print "ok 9\n";
$a = $i->call("list", 1, scalar($i->call("list", 2, 3)), 4);
print "not " unless @$a == 3 && $a->[1][0] == 2 && $a eq "1 {2 3} 4";
print "ok 10\n";
my $v = 1;
$i->call("after", 250, sub { print "ok 11\n"; $v++; });
$i->call("vwait", \$v);
print "not " unless $v == 2;
print "ok 12\n";
$i->call("eval", <<'EOT');
proc f1 {h v} {
upvar $h arr
puts "ok $arr(ok)"
set arr(foo) 14
incr $v
}
EOT
my %h = (foo => 1, bar => 2, ok => 13);
$i->call("after", 250, "f1", \%h, \$v);
$i->call("vwait", \$v);
print "ok $h{foo}\n";
print "not " unless $v == 3;
print "ok 15\n";
|
