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
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
|
# copyright (C) 1997-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu
# $Id: viewer.tcl,v 2.76 2005/02/13 16:46:22 jfontain Exp $
class viewer { ;# handle viewers related functionalities
# viewers do not derive from a common interface class but rather support a common set a options through the composite class
set (list) {}
if {$global::withGUI} {
set (background) $widget::option(label,background) ;# so that all viewers have the same background on all platforms
set (rightRedArrow) [image create photo -data {R0lGODlhBQAJAIAAAP8AAP8AACH5BAEKAAEALAAAAAAFAAkAAAIMRB5gp9v2YlJsJRQKADs=}]
set (rightDarkGrayArrow) [image create photo -data {R0lGODlhBQAJAIAAAKCgoP///yH5BAEKAAEALAAAAAAFAAkAAAIMRB5gp9v2YlJsJRQKADs=}]
set (limitAreaWidth) 40
set (limitAreaHeight) 20
}
proc viewer {this} {
lappend (list) $this
}
proc ~viewer {this} {
dataTrace::unregister $this ;# remove all array traces
if {[info exists ($this,drop)]} {
delete $($this,drop)
}
ldelete (list) $this
if {$global::withGUI} {
pages::monitorActiveCells ;# refresh pages monitored cells since cells with thresholds could have disappeared
thresholdLabel::monitorActiveCells ;# refresh global thresholds viewer as well
}
}
virtual proc supportedTypes {this}
proc view {this cells} { ;# cells is a list of data array cells
set list {}
foreach cell $cells {
parse $cell array row column type
# no corresponding module (happens when loading a viewer from a save file without the corresponding module):
if {![info exists $array]} continue
if {[lsearch -exact [supportedTypes $this] $type] < 0} { ;# type must exist since cell array exists
if {$global::withGUI} {
wrongTypeMessage $type
}
return 0 ;# give up on all cells
}
set update($array) {}
lappend list $array $row $column
}
# warning: it is important to monitor cell in the original order as some viewers, such as freetext, expect it:
foreach {array row column} $list {
monitorCell $this $array $row $column
if {$global::withGUI} {
# possibly initialize cell thresholds data:
foreach {color level summary} [thresholds::cellData $array $row $column] {
thresholdCondition $this $array $row $column $color $level $summary
}
setCellColor $this ${array}($row,$column) [cellThresholdColor $array $row $column]
}
}
foreach array [array names update] { ;# update viewer with current values immediately
update $this $array
}
return 1 ;# cells accepted for viewing
}
virtual proc monitorCell {this array row column}
# public procedure. note that type will be set only if the cell array actually exists when this procedure is invoked
proc parse {dataCell arrayName rowName columnName typeName} {
upvar 1 $arrayName cellArray $rowName cellRow $columnName cellColumn $typeName cellType
if {([scan $dataCell {%[^(](%lu,%u)} array row column] != 3) || ($column < 0)} {
error "\"$dataCell\" is not a valid array cell"
}
set cellArray $array; set cellRow $row; set cellColumn $column; catch {set cellType [set ${array}($column,type)]}
}
proc updateInterval {value} { ;# static procedure for updating all viewers intervals
foreach viewer $(list) {
catch {composite::configure $viewer -interval $value} ;# some viewers do not support the interval option
}
}
# Derive a label from cell using the tabular data index columns (array name must be qualified) and return it along with the
# incomplete status, meaning that the label could not be fully determined, as can happen, for example, when the data cell no
# longer exists.
proc label {array row column {identify {}}} { ;# allow forcing module header
set label {}
if {[string length $identify] == 0} {
set identify $global::cellsLabelModuleHeader ;# use default behavior
}
if {$identify} {
set identifier [modules::identifier $array] ;# see if array needs identification
if {[string length $identifier] > 0} { ;# data comes from a module array (could come from a summary table)
regsub {<0>$} $identifier {} identifier ;# remove trailing namespace index for first instance of a module
set label "$identifier: "
}
}
if {[catch {set ${array}(indexColumns)} columns]} { ;# no index columns (note: they are used to generate the cell label)
set columns 0 ;# use first column as single index column
}
foreach index $columns { ;# use index columns for label
if {[catch {set ${array}($row,$index)} value]} {
append label {? } ;# cell may no longer exist if originating from a save file, give user some feedback
} elseif {[string length $value] > 0} { ;# ignore empty cells
append label "$value "
}
}
append label [set ${array}($column,label)]
# consider the label incomplete if it contains any question mark characters, reflecting the presence of missing data rows,
# void numeric data cells, or existing cells from a summary table pointing to void data. note that is valid data contains
# question mark characters, then the incomplete status is incorrect, which should be rare and have only a minor impact on
# performance (it causes the corresponding data labels to be updated at each poll in data viewers).
return [list $label [string match {*\?*} $label]]
}
virtual proc update {this array} ;# update display using cells data
proc registerTrace {this array {last 0}} {
dataTrace::register $this $array "viewer::update $this $array" $last
}
proc unregisterTrace {this array} {
dataTrace::unregister $this $array
}
# note: cells must always been returned in the same order (dictionary sorting suggested) so that record layer does not detect
# erroneous changes, incorrectly requiring the user to save dashboard when exiting application
virtual proc cells {this}
if {$global::withGUI} {
virtual proc initializationConfiguration {this} { ;# configuration with switch / value option pairs for initialization from file
return {}
}
proc setupDropSite {this path} { ;# allow dropping of data cells, viewer mutation or kill action
set ($this,drop) [new dropSite -path $path -formats {DATACELLS VIEWER KILL} -command "viewer::handleDrop $this"]
}
proc handleDrop {this} {
if {![catch {set data $dragSite::data(DATACELLS)}]} {
view $this $data
} elseif {![catch {set data $dragSite::data(VIEWER)}]} {
mutate $this $data
} elseif {[info exists dragSite::data(KILL)]} {
delete $this ;# self destructs
}
}
proc mutate {this class} {
if {[string equal $class [classof $this]]} return ;# no need to create a viewer of the same class
set draggable [composite::cget $this -draggable]
switch $class {
::currentValueTable { ;# needs to know mode (real time or database) at construction time
set viewer [new currentValueTable $global::canvas $global::pollTime -draggable $draggable]
}
::canvas::iconic {
if {[string length [set name [canvas::iconic::chooseFile]]] == 0} return ;# canceled
set viewer [new $class $global::canvas -draggable $draggable -static $global::static -file $name]
}
default {
set viewer [new $class $global::canvas -draggable $draggable]
}
}
foreach list [composite::configure $viewer] {
if {[string equal [lindex $list 0] -interval]} { ;# viewer supports interval option
composite::configure $viewer -interval $global::pollTime ;# so use current interval
break ;# done
}
}
# only attempt to view cells that still exist (for example, some cells may come from a vanished summary table)
set cells {}
set count 0
foreach cell [cells $this] {
if {[info exists $cell]} {
lappend cells $cell
}
incr count
}
if {[llength $cells] > 0} {
view $viewer $cells
}
if {[llength $cells] < $count} { ;# warn user when necessary
lifoLabel::flash $global::messenger [mc {some data cells no longer exist}]
}
if {[manageable $this]} {
foreach {x y width height} [canvasWindowManager::getGeometry $global::windowManager $widget::($this,path)] {}
set level [canvasWindowManager::getStackLevel $global::windowManager $widget::($this,path)]
} else { ;# must be a canvas viewer
set x [composite::cget $this -x]; set y [composite::cget $this -y] ;# a viewer is a composite
set width {}; set height {}; set level {}
}
delete $this ;# delete existing viewer
if {[manageable $viewer]} {
# viewer is as destroyable as previously deleted viewer
manageViewer $viewer 1 -static $global::static -setx $x -sety $y -setwidth $width -setheight $height -level $level\
-dragobject $viewer
} else { ;# must be a canvas viewer
composite::configure $viewer -x $x -y $y
}
}
proc cellThresholdColor {array row column} {
set manager [new thresholdsManager]
set cell ${array}($row,$column)
foreach {color level summary} [thresholds::cellData $array $row $column] {
thresholdsManager::condition $manager $cell $color $level $summary
}
set color [lindex [lindex [thresholdsManager::colorsAndTexts $manager] 0] 0]
delete $manager
return $color
}
proc cellThresholdCondition {array row column color level summary} {
set topColor [cellThresholdColor $array $row $column]
foreach viewer $(list) {
thresholdCondition $viewer $array $row $column $color $level $summary
setCellColor $viewer ${array}($row,$column) $topColor
}
}
# viewers should implement at most one of the following procedures:
# note: viewers using a dataTable object might need none, as ::cellThresholdCondition{} may be enough to do the job
# latest threshold condition (reset if summary is not defined (empty)):
virtual proc thresholdCondition {this array row column color level summary} {}
# gives the color of the most important and recent threshold (reset if color is empty):
virtual proc setCellColor {this cell color} {}
virtual proc manageable {this} {return 1} ;# whether it should be managed by the internal window manager
proc monitoring {cell} { ;# viewers monitoring a cell
set viewers {}
foreach viewer $(list) {
if {[monitored $viewer $cell]} {
lappend viewers $viewer
}
}
return $viewers
}
virtual proc monitored {this cell}
# If this is the first time a color is requested for that cell, give a new color, else give the color already used by that cell,
# so that a cell always has the same color in all its container viewers, until it is no longer monitored by any viewer.
# When the cell is no longer displayed by the viewer, the color must be returned using returnDisplayColor{}, so that the color
# can be made available for other cells.
proc getDisplayColor {cell} {
variable colorIndex ;# cell to color index mapping (index in global viewers colors)
variable usageCount ;# number of times a cell is displayed using its color
if {![info exists colorIndex($cell)]} { ;# return a new color, if possible, not used by any viewer
set colors [llength $global::viewerColors]
for {set index 0} {$index < $colors} {incr index} {
set count($index) 0
}
foreach {name index} [array get colorIndex] { ;# scan used colors
incr count($index)
}
set color 0
set minimum $global::32BitIntegerMaximum
for {set index 0} {$index < $colors} {incr index} { ;# find the next least used color
if {$count($index) < $minimum} {
set minimum $count($index)
set color $index
}
}
set colorIndex($cell) $color
set usageCount($cell) 0
}
incr usageCount($cell)
return [lindex $global::viewerColors $colorIndex($cell)]
}
proc returnDisplayColor {cell} { ;# use to return display color obtained using getDisplayColor{}
variable colorIndex
variable usageCount
if {[catch {incr usageCount($cell) -1}]} return ;# cell color came from save file
if {$usageCount($cell) == 0} { ;# cell no longer displayed in color
unset colorIndex($cell) usageCount($cell)
}
}
proc limitEntry {this path anchor x y option name font command yCommand type} { ;# note: Y command may be empty
set entry [entry $path.maximum -borderwidth 0 -highlightthickness 0 -width 10 -font $font]
switch $type {
float {setupEntryValidation $entry {{checkFloatingPoint %P}}; set type double}
signed {setupEntryValidation $entry {{check32BitSignedInteger %P}}; set type integer}
unsigned {setupEntryValidation $entry {{check31BitUnsignedInteger %P}}; set type integer}
default error
}
lifoLabel::push $global::messenger\
[format [mc {enter %s value (empty for automatic scale, Return to valid, Escape to abort)}] $name]
# when Return or Enter is pressed, pass new value (if valid type) as limit, else if Escape is pressed, abort:
foreach key {<KP_Enter> <Return>} {
bind $entry $key "
if {\[string is $type \[%W get\]\]} {
$command \[%W get\]
destroy %W
lifoLabel::pop $global::messenger
}
"
}
bind $entry <Escape> "destroy %W; lifoLabel::pop $global::messenger"
$entry insert 0 [composite::cget $this $option]
$entry selection range 0 end ;# initially select all characters, which is a common behavior
if {[string length $yCommand] > 0} {set y [uplevel #0 $yCommand]} ;# allow dynamic ordinate
place $entry -anchor $anchor -x $x -y $y
focus $entry
::update idletasks ;# so entry is visible and grab works
grab $entry
}
proc wrongTypeMessage {type} {
lifoLabel::flash $global::messenger [format [mc {cannot display data of type %s}] $type]
bell
if {![info exists (wrongTypeDrop)]} {
set (wrongTypeDrop) {}
tk_messageBox -title {moodss: drag and drop} -type ok -icon info -message [format [mc\
{Some viewers only accept a limited set of data types (if this case, this viewer cannot display data of type %s)}\
] $type]
}
}
proc createColorsMenu {parentPath command} {
set menu [menu $parentPath.colorsMenu -tearoff 0]
set spaces { } ;### Tk bug: use 6 spaces for windows because otherwise labels look too thin ###
if {[string equal $::tcl_platform(platform) windows]} {set spaces { }}
set rows 0
set index 0
foreach color $global::viewerColors {
$menu add command -label $spaces -background $color -activebackground $color
regsub -all %c $command $color string ;# use color in command
$menu entryconfigure $index -hidemargin 1 -command $string
if {$rows >= 3} {
$menu entryconfigure $index -columnbreak 1
set rows 0
}
incr rows
incr index
}
return $menu
}
virtual proc updateLabels {this} {}
}
proc numericType {type} {
switch $type {
integer - real {return 1}
default {return 0}
}
}
virtual proc saved {this} {return 1} ;# whether it is supposed to be saved in a configuration file
}
|
