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