blob: e5eac8b20a8a9dcc7320d3a802d9a5dec3a79a5d (
plain)
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
81
82
83
84
85
86
87
88
|
# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Tk::After;
use Carp;
use vars qw($VERSION);
$VERSION = '3.015'; # $Id: //depot/Tk8/Tk/After.pm#15 $
sub _cancelAll
{
my $w = shift;
my $h = delete $w->{_After_};
foreach my $obj (values %$h)
{
# carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName;
$obj->cancel;
}
}
sub submit
{
my $obj = shift;
my $w = $obj->[0];
my $id = $obj->[1];
my $t = $obj->[2];
my $method = $obj->[3];
delete($w->{_After_}{$id}) if (defined $id);
$id = $w->Tk::after($t,[$method => $obj]);
unless (exists $w->{_After_})
{
$w->{_After_} = {};
$w->OnDestroy([\&_cancelAll, $w]);
}
$w->{_After_}{$id} = $obj;
$obj->[1] = $id;
return $obj;
}
sub DESTROY
{
my $obj = shift;
@{$obj} = ();
}
sub new
{
my ($class,$w,$t,$method,@cb) = @_;
my $cb = (@cb == 1) ? shift(@cb) : [@cb];
my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class;
return $obj->submit;
}
sub cancel
{
my $obj = shift;
my $id = $obj->[1];
my $w = $obj->[0];
if ($id)
{
$w->Tk::after('cancel'=> $id);
delete $w->{_After_}{$id} if exists $w->{_After_};
$obj->[1] = undef;
}
return $obj;
}
sub repeat
{
my $obj = shift;
$obj->submit;
local $Tk::widget = $obj->[0];
$obj->[4]->Call;
}
sub once
{
my $obj = shift;
my $w = $obj->[0];
my $id = $obj->[1];
delete $w->{_After_}{$id};
local $Tk::widget = $w;
$obj->[4]->Call;
}
1;
__END__
|