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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
# -*- tcl -*-
# # ## ### ##### ######## #############
# (C) 2009 Andreas Kupries
# @@ Meta Begin
# Package tcl::chan::events 1.1
# Meta as::author {Andreas Kupries}
# Meta as::copyright 2009
# Meta as::license BSD
# Meta description Support package handling a core
# Meta description aspect of reflected base channels
# Meta description (timer
# Meta description driven file event support). Controls a
# Meta description timer generating the expected read/write
# Meta description events. It is expected that this class
# Meta description is used as either one superclass of the
# Meta description class C for a specific channel, or is
# Meta description mixed into C.
# Meta platform tcl
# Meta require tcl::chan::core
# Meta require TclOO
# Meta require {Tcl 8.5}
# @@ Meta End
# TODO :: set/get accessor methods for the timer delay
# # ## ### ##### ######## #############
package require Tcl 8.5 9
if {[catch {package require tcl::oo}]} {
package require TclOO
}
package require tcl::chan::core
# # ## ### ##### ######## #############
oo::class create ::tcl::chan::events {
superclass ::tcl::chan::core ; # -> initialize, finalize, destructor
constructor {} {
array set allowed {
read 0
write 0
}
set requested {}
set delay 10
return
}
# # ## ### ##### ######## #############
method finalize {c} {
my disallow read write
next $c
}
# Allow/disallow the posting of events based on the
# events requested by Tcl's IO system, and the mask of
# events the instance's channel can handle, per all
# preceding calls of allow and disallow.
method watch {c requestmask} {
if {$requestmask eq $requested} return
set requested $requestmask
my Update
return
}
# # ## ### ##### ######## #############
# Declare that the named events are handled by the
# channel. This may start a timer to periodically post
# these events to the instance's channel.
method allow {args} {
my Allowance $args yes
return
}
# Declare that the named events are not handled by the
# channel. This may stop the periodic posting of events
# to the instance's channel.
method disallow {args} {
my Allowance $args no
return
}
# # ## ### ##### ######## #############
# Event System State - Timer driven
variable timer allowed requested posting delay
# channel = The channel to post events to - provided by superclass
# timer = Timer controlling the posting.
# allowed = Set of events allowed to post.
# requested = Set of events requested by core.
# posting = Set of events we are posting.
# delay = Millisec interval between posts.
# 'allowed' is an Array (event name -> boolean). The
# value is true if the named event is allowed to be
# posted.
# Common code used by both allow and disallow to enter
# the state change.
method Allowance {events enable} {
set changed no
foreach event $events {
if {$allowed($event) == $enable} continue
set allowed($event) $enable
set changed yes
}
if {!$changed} return
my Update
return
}
# Merge the current event allowance and the set of
# requested events into one datum, the set of events to
# post. From that then derive whether we need a timer or
# not and act accordingly.
method Update {} {
catch { after cancel $timer }
set posting {}
foreach event $requested {
if {!$allowed($event)} continue
lappend posting $event
}
if {[llength $posting]} {
set timer [after $delay \
[namespace code [list my Post]]]
} else {
catch { unset timer }
}
return
}
# Post the current set of events, then reschedule to
# make this periodic.
method Post {} {
my variable channel
set timer [after $delay \
[namespace code [list my Post]]]
chan postevent $channel $posting
return
}
}
# # ## ### #####
package provide tcl::chan::events 1.1
return
|
