1# -*- tcl -*-
2# # ## ### ##### ######## #############
3# (C) 2009 Andreas Kupries
4
5# @@ Meta Begin
6# Package tcl::chan::events 1
7# Meta as::author {Andreas Kupries}
8# Meta as::copyright 2009
9# Meta as::license BSD
10# Meta description Support package handling a core
11# Meta description aspect of reflected base channels
12# Meta description (timer
13# Meta description driven file event support). Controls a
14# Meta description timer generating the expected read/write
15# Meta description events. It is expected that this class
16# Meta description is used as either one superclass of the
17# Meta description class C for a specific channel, or is
18# Meta description mixed into C.
19# Meta platform tcl
20# Meta require tcl::chan::core
21# Meta require TclOO
22# Meta require {Tcl 8.5}
23# @@ Meta End
24
25# TODO :: set/get accessor methods for the timer delay
26
27# # ## ### ##### ######## #############
28
29package require Tcl 8.5
30package require TclOO
31package require tcl::chan::core
32
33# # ## ### ##### ######## #############
34
35oo::class create ::tcl::chan::events {
36    superclass ::tcl::chan::core ; # -> initialize, finalize, destructor
37
38    constructor {} {
39	array set allowed {
40	    read  0
41	    write 0
42	}
43	set requested {}
44	set delay     10
45	return
46    }
47
48    # # ## ### ##### ######## #############
49
50    method finalize {c} {
51	my disallow read write
52	next $c
53    }
54
55    # Allow/disallow the posting of events based on the
56    # events requested by Tcl's IO system, and the mask of
57    # events the instance's channel can handle, per all
58    # preceding calls of allow and disallow.
59
60    method watch {c requestmask} {
61	if {$requestmask eq $requested} return
62	set requested $requestmask
63	my Update
64	return
65    }
66
67    # # ## ### ##### ######## #############
68
69    # Declare that the named events are handled by the
70    # channel. This may start a timer to periodically post
71    # these events to the instance's channel.
72
73    method allow {args} {
74	my Allowance $args yes
75	return
76    }
77
78    # Declare that the named events are not handled by the
79    # channel. This may stop the periodic posting of events
80    # to the instance's channel.
81
82    method disallow {args} {
83	my Allowance $args no
84	return
85    }
86
87    # # ## ### ##### ######## #############
88
89    # Event System State - Timer driven
90
91    variable timer allowed requested posting delay
92
93    # channel   = The channel to post events to - provided by superclass
94    # timer     = Timer controlling the posting.
95    # allowed   = Set of events allowed to post.
96    # requested = Set of events requested by core.
97    # posting   = Set of events we are posting.
98    # delay     = Millisec interval between posts.
99
100    # 'allowed' is an Array (event name -> boolean). The
101    # value is true if the named event is allowed to be
102    # posted.
103
104    # Common code used by both allow and disallow to enter
105    # the state change.
106
107    method Allowance {events enable} {
108	set changed no
109	foreach event $events {
110	    if {$allowed($event) == $enable} continue
111	    set allowed($event) $enable
112	    set changed yes
113	}
114	if {!$changed} return
115	my Update
116	return
117    }
118
119    # Merge the current event allowance and the set of
120    # requested events into one datum, the set of events to
121    # post. From that then derive whether we need a timer or
122    # not and act accordingly.
123
124    method Update {} {
125	catch { after cancel $timer }
126	set posting {}
127	foreach event $requested {
128	    if {!$allowed($event)} continue
129	    lappend posting $event
130	}
131	if {[llength $posting]} {
132	    set timer [after $delay \
133			   [namespace code [list my Post]]]
134	} else {
135	    catch { unset timer }
136	}
137	return
138    }
139
140    # Post the current set of events, then reschedule to
141    # make this periodic.
142
143    method Post {} {
144	my variable channel
145	set timer [after $delay \
146		       [namespace code [list my Post]]]
147	chan postevent $channel $posting
148	return
149    }
150}
151
152# # ## ### #####
153package provide tcl::chan::events 1
154return
155