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
68
69
70
71
72
73
74
75
76
77
78
79
80
|
BEGIN { $|=1; $^W=1; }
use Test;
use Tk;
use Tk::Trace;
use strict;
plan test => 18;
my $mw = MainWindow->new;
$mw->geometry("+10+10");
my $v = 0;
my $e = $mw->Entry(-textvariable => \$v)->pack;
my ($r, $w, $u ) = (0, 0, 0 );
$e->traceVariable( \$v, 'rwu', [ \&trace_v, $e, 123 ] );
foreach my $k ( 1 .. 5 ) {
$mw->after(100);
$v++;
$mw->update;
}
$e->traceVdelete( \$v );
ok( $v, 5, 'traced variable != 5' );
ok( $r, 5, 'read trace not called 5 times' );
ok( $w, 6, 'write trace not called 5 times' );
ok( $u, 1, 'undef trace not called once' );
my $read_only = $v;
$e->traceVariable( \$v, 'w', sub { $read_only } );
$v = 777;
$e->traceVdelete( \$v );
ok( $v, 5, 'read-only variable failed != 5' );
ok( $v, 5, 'final value != 5' );
if ($Tk::VERSION < 804.027501) {
warn "# This test segfaults in Tk804.027\n";
ok(1);
} else {
# Similar code is part of the CPAN module Tk::LCD
my $c = $mw->Canvas->pack;
my $foo;
my $vref = \$foo;
my $st = [sub {
my ($index, $new_val, $op, $lcd) = @_;
return unless $op eq 'w';
# Problem: $c is not alive (or half-alive only) here
# and internal data structures seem not to be valid
$c->move("foo", 20,30);
$new_val;
}, $c];
$c->traceVariable($vref, 'w' => $st);
$c->{watch} = $vref;
$c->createPolygon(10,10,20,10,20,20,10,20,-tags=>"foo");
$c->OnDestroy( [sub {$_[0]->traceVdelete($_[0]->{watch})}, $c] );
$c->update;
$c->destroy;
ok(1);
}
sub trace_v {
my( $index, $value, $op, $ent, $num ) = @_;
if ( $op eq 'r' ) {
ok( $e, $ent, 'arguments out of order' );
$r++;
} elsif ( $op eq 'w' ) {
ok( $num, 123, '$num != 123' );
$w++;
} elsif ( $op eq 'u' ) {
$u++;
}
$value;
}
|
