Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. |
2 | # This program is free software; you can redistribute it and/or | |
3 | # modify it under the same terms as Perl itself. | |
4 | package Tk::After; | |
5 | use Carp; | |
6 | ||
7 | use vars qw($VERSION); | |
8 | $VERSION = '3.015'; # $Id: //depot/Tk8/Tk/After.pm#15 $ | |
9 | ||
10 | sub _cancelAll | |
11 | { | |
12 | my $w = shift; | |
13 | my $h = delete $w->{_After_}; | |
14 | foreach my $obj (values %$h) | |
15 | { | |
16 | # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName; | |
17 | $obj->cancel; | |
18 | } | |
19 | } | |
20 | ||
21 | sub submit | |
22 | { | |
23 | my $obj = shift; | |
24 | my $w = $obj->[0]; | |
25 | my $id = $obj->[1]; | |
26 | my $t = $obj->[2]; | |
27 | my $method = $obj->[3]; | |
28 | delete($w->{_After_}{$id}) if (defined $id); | |
29 | $id = $w->Tk::after($t,[$method => $obj]); | |
30 | unless (exists $w->{_After_}) | |
31 | { | |
32 | $w->{_After_} = {}; | |
33 | $w->OnDestroy([\&_cancelAll, $w]); | |
34 | } | |
35 | $w->{_After_}{$id} = $obj; | |
36 | $obj->[1] = $id; | |
37 | return $obj; | |
38 | } | |
39 | ||
40 | sub DESTROY | |
41 | { | |
42 | my $obj = shift; | |
43 | @{$obj} = (); | |
44 | } | |
45 | ||
46 | sub new | |
47 | { | |
48 | my ($class,$w,$t,$method,@cb) = @_; | |
49 | my $cb = (@cb == 1) ? shift(@cb) : [@cb]; | |
50 | my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class; | |
51 | return $obj->submit; | |
52 | } | |
53 | ||
54 | sub cancel | |
55 | { | |
56 | my $obj = shift; | |
57 | my $id = $obj->[1]; | |
58 | my $w = $obj->[0]; | |
59 | if ($id) | |
60 | { | |
61 | $w->Tk::after('cancel'=> $id); | |
62 | delete $w->{_After_}{$id} if exists $w->{_After_}; | |
63 | $obj->[1] = undef; | |
64 | } | |
65 | return $obj; | |
66 | } | |
67 | ||
68 | sub repeat | |
69 | { | |
70 | my $obj = shift; | |
71 | $obj->submit; | |
72 | local $Tk::widget = $obj->[0]; | |
73 | $obj->[4]->Call; | |
74 | } | |
75 | ||
76 | sub once | |
77 | { | |
78 | my $obj = shift; | |
79 | my $w = $obj->[0]; | |
80 | my $id = $obj->[1]; | |
81 | delete $w->{_After_}{$id}; | |
82 | local $Tk::widget = $w; | |
83 | $obj->[4]->Call; | |
84 | } | |
85 | ||
86 | 1; | |
87 | __END__ | |
88 |