File: var.t

package info (click to toggle)
libtcl-perl 1.32%2Bds-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 288 kB
  • sloc: perl: 417; tcl: 19; makefile: 14
file content (62 lines) | stat: -rw-r--r-- 1,267 bytes parent folder | download
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
use Tcl;

$| = 1;

print "1..8\n";

sub foo {
    my $interp = $_[1];
    my $glob = $interp->GetVar("bar", Tcl::GLOBAL_ONLY);
    my $loc = $interp->GetVar("bar");
    print "$glob $loc\n";
    $interp->Eval('puts $four', Tcl::EVAL_GLOBAL);
}

$i = Tcl->new;

$i->SetVar("foo", "ok 1");
$i->Eval('puts $foo');

$i->Eval('set foo "ok 2\n"');
print $i->GetVar("foo");

$i->CreateCommand("foo", \&foo);
$i->Eval(<<'EOT');
set bar ok
set four "ok 4"
proc baz {} {
    set bar 3
    set four "not ok 4"
    foo
}
baz
EOT

$i->Eval('set a(OK) ok; set a(five) 5');
$ok = $i->GetVar2("a", "OK");
$five = $i->GetVar2("a", "five");
print "$ok $five\n";

print defined($i->GetVar("nonesuch")) ? "not ok 6\n" : "ok 6\n";

# some Unicode tests
if ($]>=5.006) {
    $i->SetVar("univar","\x{abcd}\x{1234}");
    if ($i->GetVar("univar") ne "\x{abcd}\x{1234}") {
	print "not ";
    }
    print "ok 7 # Unicode persistence during [SG]etVar\n";
    my $r;
    tie $r, Tcl::Var, $i, "perl_r";
    $r = "\x{abcd}\x{1234}";
    if ($r ne "\x{abcd}\x{1234}") {
	print "not ";
    }
    print "ok 8 # Unicode persistence for tied variable\n";
    binmode(STDOUT, ":utf8") if $] >= 5.008;
    print "# $r\n";
}
else {
    for (7..8) {print "ok $_  # skipped: not Unicode-aware Perl\n";}
}