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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
|
# copyright (C) 1997-1999 Jean-Luc Fontaine (mailto:jfontain@multimania.com)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu
set rcsId {$Id: modules.tcl,v 2.4 1999/09/22 11:09:17 jfontain Exp $}
class modules {
set ::modules::(names) {}
set ::modules::(namespaces) {}
proc modules {this} error ;# object-less class
proc printAvailable {} { ;# using Tcl built-in package management facilities, seek and print available moodss modules
catch {package require {}} ;# make sure Tcl package auto loading search is done
foreach package [package names] {
if {[catch {package require $package}]||![info exists ::${package}::data(updates)]} continue ;# ignore invalid packages
puts -nonewline "$package: possibly in"
set count 0
foreach directory $::auto_path {
if {[file readable [file join $directory $package pkgIndex.tcl]]} {
if {$count>0} {
puts -nonewline ,
}
puts -nonewline " [file join $directory $package]"
incr count
}
}
puts {}
}
}
# recursive procedure: eventually initialize next module and its eventual options in command line arguments
proc parse {arguments} { ;# arguments list format is: module [-option [value] -option ...] module [-option ...]
if {[llength $arguments]==0} return ;# nothing to do
set module [lindex $arguments 0]
set arguments [lrange $arguments 1 end] ;# point to start of switches or next module
# eventually split module into its name and its index (if coming from a save file)
foreach {module index} [decoded $module] {}
if {![info exists ::packageDirectory($module)]} { ;# not a valid module (usually a wrong switch)
puts stderr "error: \"$module\" is not a valid moodss module name"
exit 1
}
if {![validName $module]} {
puts stderr "\"$module\" module name contains invalid characters"
exit
}
lifoLabel::push $global::messenger "loading $module..."
update idletasks
set namespace [load $module $index]
lifoLabel::pop $global::messenger
lappend modules::(namespaces) $namespace ;# we never get here if there is an error when the module is loaded
if {[lsearch -exact $(names) $module]<0} { ;# keep track of loaded module names
lappend modules::(names) $module
}
if {[catch {set ::${namespace}::data(switches)} switches]} { ;# module takes no options
set modules::($namespace,arguments) {} ;# save module arguments for eventual saving in file
} else { ;# module takes options
if {[llength $switches]==0} {
puts stderr "module \"$module\" switches are empty"
exit 1
}
if {[catch {set next [parseCommandLineArguments $switches $arguments options]} message]} {
puts stderr "module \"$module\" options error: $message"
exit 1
}
if {!$($namespace,initialize)} {
puts stderr "module \"$module\" has no initialize procedure"
exit 1
}
set modules::($namespace,options) [array get options]
# save module arguments for eventual saving in file
set modules::($namespace,arguments) [lrange $arguments 0 [expr {[llength $arguments]-[llength $next]-1}]]
set arguments $next
}
parse $arguments ;# process the rest
update idletasks ;# make sure latest loading message is not left showing meaninglessly
}
proc helpHTMLData {namespace} { ;# return HTML formatted help no matter whether provided plain or preformatted from module
if {[catch {set ${namespace}::data(helpText)} text]} {
set text {no help available}
}
set header "<h6>module $namespace</h6><i>version $($namespace,version)"
if {[string length $($namespace,arguments)]>0} {
append header ", invoked with arguments: $($namespace,arguments)"
}
append header </i><br><br>
if {[regsub -nocase <body> $text <body>$header text]==0} { ;# insert header if HTML formatted help
regsub -all \n $text <br> text ;# regular help, keep original formatting
return ${header}$text
} else { ;# HTML formatted help
return $text
}
}
proc initialize {} { ;# eventually invoke modules initialization procedures. modules must be loaded first (see parse{})
foreach namespace $(namespaces) {
if {!$($namespace,initialize)} continue
lifoLabel::push $global::messenger "initializing $namespace..."
update idletasks
if {[info exists ($namespace,options)]} {
::${namespace}::initialize $($namespace,options) ;# let module initialize self
} else { ;# module takes no options
::${namespace}::initialize ;# let module initialize self
}
synchronize $namespace ;# in case data was updated
if {![catch {set ${namespace}::data(identifier)} identifier]} { ;# store identifier if it exists and is valid
if {![validName $identifier]} {
puts stderr "\"$namespace\" module identifier: \"$identifier\" contains invalid characters"
exit
}
set ($namespace,identifier) $identifier
}
lifoLabel::pop $global::messenger
}
update idletasks ;# make sure latest initialization message is not left showing meaninglessly
}
proc setPollTimes {{override {}}} {
set default 0
set minimum 0
foreach namespace $(namespaces) {
set times [set ${namespace}::data(pollTimes)]
if {[llength $times]==0} {
error "module $namespace poll times list is empty"
}
# for an asynchronous module, the sole time value would be negative and is used as graph interval, for example
set time [lindex $times 0]
if {$time<0} { ;# asynchronous module, poll time is a viewer interval (negated)
set intervals($time) {}
continue
}
if {$time>$default} { ;# default value is the first in list
set default $time ;# keep the greater default time of all modules
}
set times [lsort -integer $times] ;# sort poll times
set time [lindex $times 0]
if {$time>$minimum} {
set minimum $time ;# keep the greater minimum time of all modules
set minimumModule $namespace
}
foreach time $times { ;# poll times list is the combination of all modules poll times
set data($time) {}
}
}
# sort and restrict poll times above maximum module minimum poll time
set global::pollTimes [lsort -integer [array names data]]
set global::pollTimes [lrange $global::pollTimes [lsearch -exact $global::pollTimes $minimum] end]
set global::pollTime $default
if {[string length $override]>0} { ;# eventually validate command line override
if {$override<$minimum} {
puts stderr "$::argv0: minimum poll time is $minimum seconds for module $minimumModule"
exit 1
}
set global::pollTime $override
}
if {$global::pollTime==0} {
# all modules are asynchronous, so use an average time as a viewer interval for viewers that need it, such as graphs.
# the poll times list is empty at this point so the user cannot change the poll time.
# note that the viewer interval can still be forced by the command line poll time option.
set sum 0
set number 0
foreach interval [array names intervals] {
incr sum $interval
incr number
}
set global::pollTime [expr {round(double($sum)/-$number)}]
}
}
# load a module in its own interpreter, in order to allow multiple instances of the same module
proc load {module index} { ;# index may be forced (when coming from a save file), left empty for automatic generation
variable nextIndex
if {[string length $index]==0} {
if {[catch {set index $nextIndex($module)}]} { ;# first instance of a module
set namespace $module ;# use original module name
set index 0
} else {
set namespace ${module}<$index> ;# this is another instance of an existing module
}
} else { ;# index was passed as parameter
set namespace ${module}<$index>
}
set nextIndex($module) [incr index]
set ($namespace,module) $module
set interpreter [interp create] ;# use a separate interpreter for each module
set ($namespace,interpreter) $interpreter
set ::packageDirectory($namespace) $::packageDirectory($module) ;# set module package directory
$interpreter eval { ;# since Tk is not loaded in module interpreter, provide a background error procedure
proc bgerror {error} {
puts stderr $::errorInfo
exit 1
}
}
$interpreter eval "
set auto_path [list $::auto_path] ;# copy a few required global variables in module interpreter
set ::packageDirectory($module) $::packageDirectory($module)
package require $module ;# module is loaded here
"
# we never get here if there is an error when the module is loaded
# the new namespace, "interface' to the protected module namespace in its interpreter, is child of the global namespace
namespace eval ::$namespace [subst -nocommands {
proc update {} {$interpreter eval ::${module}::update}
}]
set ($namespace,initialize)\
[$interpreter eval [subst -nocommands {expr {[string length [namespace eval ::$module {info proc initialize}]]>0}}]]
if {$($namespace,initialize)} { ;# initialize procedure exists
namespace eval ::$namespace [subst -nocommands { ;# create an interface initialize procedure within new namespace
proc initialize {arguments} { ;# arguments are a list of option / value (eventually empty) pairs
$interpreter eval "
array set _options [list \$arguments]
::${module}::initialize _options
unset _options
"
}
}]
}
set ($namespace,version) [$interpreter eval "package provide $module"]
synchronize $namespace ;# initialize namespace data from module in its interpreter
# keep on eye on special module data array member "update"
$interpreter alias _updated ::modules::updated $namespace
$interpreter eval "trace variable ::${module}::data(updates) w _updated"
# setup interface to messenger:
$interpreter alias pushMessage ::lifoLabel::push $::global::messenger
$interpreter alias popMessage ::lifoLabel::pop $::global::messenger
$interpreter alias flashMessage ::lifoLabel::flash $::global::messenger
return $namespace ;# new name for module
}
proc updated {namespace args} { ;# module data was just updated. ignore already known trace arguments
synchronize $namespace {[0-9]*,[0-9]*} ;# just copy all dynamic data from module array
# and copy updates counter
set ::${namespace}::data(updates) [$($namespace,interpreter) eval "set ::$modules::($namespace,module)::data(updates)"]
}
proc synchronize {namespace {pattern *}} { ;# copy data from module in its interpreter to module namespace here
array set ::${namespace}::data [$($namespace,interpreter) eval "array get ::$($namespace,module)::data {$pattern}"]
}
proc identifier {array} { ;# from an array name, eventually deduce a unique module identifier if needed (used in viewer labels)
variable nextIndex
set namespace [string trimleft [namespace qualifiers [namespace which -variable $array]] :]
if {[lsearch -exact $(namespaces) $namespace]>=0} { ;# this is a module array
if {[info exists ($namespace,identifier)]} {
return $($namespace,identifier) ;# favor identifier if it exists
}
foreach {module index} [decoded $namespace] {}
if {$nextIndex($module)>1} { ;# there are more than 1 instance of this module, so identification is needed
return $namespace
}
}
return {} ;# not a module array or identification unneeded
}
proc decoded {module} { ;# return module and index list (index may be empty if module is not indexed: name instead of name<N>)
set index {}
scan $module {%[^<]<%u>} module index ;# eventually split module into its name and its index
return [list $module $index]
}
proc validName {string} {
return [regexp {^[ 0-9a-zA-Z~!@%^&*()_=+|;:',.?-]+$} $string]
}
}
|
