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
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
|
# 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: dbview.tcl,v 1.45 2005/02/02 20:15:02 jfontain Exp $
# A displayed container for module instances stored in database. Accepts drops from database modules instances dialog box.
class databaseInstances {
proc databaseInstances {this parentPath args} composite {[new frame $parentPath] $args} {
variable singleton
if {[info exists singleton]} {
error {only 1 database instances object can exist}
}
set singleton $this
set path $widget::($this,path)
set viewer [blt::stripchart $path.graph -title {} -leftmargin 1 -topmargin 1 -bufferelements 0 -plotborderwidth 1\
-background $viewer::(background) -cursor {} -highlightthickness 0 -plotpadx 2 -plotpady 0 -width 400 -height 200\
]
$viewer xaxis configure -hide 1
$viewer yaxis configure -hide 1 -descending 1
set graph [new bltGraph $viewer]
bind $viewer <Configure> "+ databaseInstances::resized $this" ;# as BLT graph, also track size updates
set ($this,cursors) [list\
[new cursor $viewer -command "databaseInstances::cursorMoved $this" -hide 1]\
[new cursor $viewer -command "databaseInstances::cursorMoved $this" -hide 1]\
]
set ($this,labels) [frame $path.labels]
grid $viewer -row 0 -column 0 -sticky nwes
grid rowconfigure $path 0 -weight 1
grid columnconfigure $path 0 -weight 1
grid $($this,labels) -row 0 -column 1 -sticky nwes\
-pady 5 ;# plot padding plus border width plus a few extra pixels experimentally determined
set ($this,drop)\
[new dropSite -path $path -formats {INSTANCES DATETIME KILL} -command "databaseInstances::handleDrop $this"]
set ($this,graph) $graph
set ($this,viewer) $viewer
composite::complete $this
updateMessage $this
}
proc ~databaseInstances {this} {
variable singleton
variable ${this}instance
eval delete [array names ${this}instance] ;# delete elements first
if {[info exists ($this,drag)]} {
delete $($this,drag)
}
eval delete $($this,drop) $($this,graph) $($this,cursors)
eval delete [array names ${this}instance]
if {[info exists ($this,selector)]} {
delete $($this,selector)
}
if {[string length $composite::($this,-deletecommand)] > 0} {
uplevel #0 $composite::($this,-deletecommand) ;# always invoke command at global level
}
if {[info exists ($this,selfDelete)] && ([string length $composite::($this,-selfdeletecommand)] > 0)} {
uplevel #0 $composite::($this,-selfdeletecommand) ;# always invoke command at global level
}
unset singleton
}
proc options {this} { ;# force X axis labels rotation
return [list\
[list -deletecommand {} {}]\
[list -draggable 0 0]\
[list -plotbackground $global::graphPlotBackground]\
[list -selfdeletecommand {} {}]\
[list -xlabelsrotation $global::graphXAxisLabelsRotation]\
]
}
proc set-deletecommand {this value} {}
proc set-selfdeletecommand {this value} {}
proc set-plotbackground {this value} {
variable ${this}instance
$($this,viewer) configure -plotbackground $value
set color [visibleForeground $value]
foreach element [array names ${this}instance] {
switched::configure $element -color $color
}
}
proc set-draggable {this value} {
if {$composite::($this,complete)} {
error {option -draggable cannot be set dynamically}
}
if {!$value} return ;# no dragging
# allow dragging empty viewer for deletion:
set ($this,drag) [new dragSite -path $($this,viewer) -validcommand "databaseInstances::validateDrag $this 0"]
dragSite::provide $($this,drag) OBJECTS "databaseInstances::dragData $this"
set ($this,selector) [new objectSelector -selectcommand "databaseInstances::setLabelsState $this"]
}
proc set-xlabelsrotation {this value} {
bltGraph::xRotateLabels $($this,graph) $value
}
proc setLabelsState {this elements select} {
variable ${this}label
if {$select} {set relief sunken} else {set relief flat}
foreach element $elements {
[set ${this}label($element)] configure -relief $relief
}
}
proc validateDrag {this element x y} {
variable ${this}instance
if {($element == 0) && ([array size ${this}instance] == 0)} {
return 1 ;# allow drag of empty viewer
} elseif {[lsearch -exact [selector::selected $($this,selector)] $element] >= 0} {
return 1 ;# also dragging from selected element only
} else {
return 0
}
}
proc dragData {this format} { ;# format can only be OBJECTS
variable ${this}instance
set elements [selector::selected $($this,selector)]
if {[llength $elements] > 0} {
return $elements ;# return selected elements if there are any
} elseif {[array size ${this}instance] == 0} {
set ($this,selfDelete) {} ;# consider this action as self deletion
return $this ;# return instances viewer object itself if empty
} else {
return {} ;# return nothing otherwise
}
}
proc handleDrop {this} {
if {[info exists dragSite::data(KILL)]} {
set ($this,selfDelete) {}
delete $this ;# self destructs
} elseif {[info exists dragSite::data(INSTANCES)]} {
foreach instance $dragSite::data(INSTANCES) {
monitor $this $instance
}
} else { ;# must be DATETIME
set value $dragSite::data(DATETIME) ;# in seconds
foreach cursor $($this,cursors) {
lappend list [list $cursor [expr {abs([switched::cget $cursor -x] - $value)}]]
}
switched::configure [lindex [lindex [lsort -real -index end $list] 0] 0] -x $value ;# move closest cursor to value
}
}
proc monitor {this instanceData {launch 1}} { ;# module instance in database
variable ${this}label
variable ${this}instance
variable ${this}tip
foreach {instance module identifier arguments} $instanceData {}
foreach {element value} [array get ${this}instance] {
if {$value == $instance} return ;# already displayed
}
# retrieve instance range from database, which may take a while:
foreach {start end} [database::instanceRange $global::database $instance] {}
if {[string length $database::($global::database,error)] > 0} return ;# abort if database error
set label [label $($this,labels).$instance -font $font::(mediumNormal)]
if {[string length $identifier] > 0} {set title $identifier} else {set title $module}
regsub {<0>$} $title {} title ;# remove trailing namespace index for first instance of a module
$label configure -text $title
pack $label -anchor w
if {![info exists (labelHeight)]} {
set (labelHeight) [winfo reqheight $label]
}
set element [new element $($this,viewer) -color [visibleForeground $composite::($this,-plotbackground)]]
if {[string length $end] > 0} {
switched::configure $element -start [clock scan $start] -end [clock scan $end]
} ;# else no recorded data for that instance (start is also empty)
switched::configure $element -deletecommand "databaseInstances::deleted $this $element"
set ${this}instance($element) $instance
set ${this}label($element) $label
set ${this}tip($element) [new widgetTip -path $label -text "$module: $arguments"]
if {$composite::($this,-draggable)} {
set drag [new dragSite -path $label -validcommand "databaseInstances::validateDrag $this $element"]
dragSite::provide $drag OBJECTS "databaseInstances::dragData $this"
set ($this,drag,$element) $drag
set selector $($this,selector)
selector::add $selector $element
bind $label <ButtonPress-1> "databaseInstances::buttonPress $selector $element"
bind $label <Control-ButtonPress-1> "selector::toggle $selector $element"
bind $label <Shift-ButtonPress-1> "selector::extend $selector $element"
bind $label <ButtonRelease-1> "databaseInstances::buttonRelease $selector $element 0"
bind $label <Control-ButtonRelease-1> "databaseInstances::buttonRelease $selector $element 1"
bind $label <Shift-ButtonRelease-1> "databaseInstances::buttonRelease $selector $element 1"
}
resized $this
updateElements $this
$($this,viewer) xaxis configure -hide 0
updateAxis $this
if {$launch} {
launchInstanceModule $instance $module $identifier $arguments
}
updateMessage $this
}
proc deleted {this element} {
variable ${this}label
variable ${this}instance
variable ${this}tip
if {$composite::($this,-draggable)} {
delete $($this,drag,$element)
selector::remove $($this,selector) $element
}
destroy [set ${this}label($element)]
delete [set ${this}tip($element)]
set namespace instance<[set ${this}instance($element)]>
if {[modules::loadedNamespace $namespace]} { ;# may have been unloaded already when, for example, user unloaded all modules
dynamicallyUnloadModule $namespace ;# happens when dragging and dropping in eraser
}
unset ${this}instance($element) ${this}label($element)
if {[array size ${this}instance] == 0} { ;# no more instances
$($this,viewer) xaxis configure -hide 1
foreach cursor $($this,cursors) {
switched::configure $cursor -hide 0 -x 0
}
$($this,labels) configure -width 1 ;# so that frame does not keep its last width
} else {
updateElements $this
}
updateAxis $this
updateMessage $this
}
proc updateElements {this} { ;# vertically realign time lines relative to their corresponding labels (idempotent)
variable ${this}label
set index 0
foreach label [pack slaves $($this,labels)] {
foreach {element value} [array get ${this}label] {
if {[string equal $value $label]} break
}
switched::configure $element -ordinate [expr {$index * $(labelHeight)}]
incr index
}
}
proc limits {this} { ;# return minimum and maximum timestamps in seconds
variable ${this}instance
set minimum $global::32BitIntegerMaximum
set maximum 0
foreach {element instance} [array get ${this}instance] {
foreach {start end} [element::range $element] {}
if {$start == 0} continue ;# element contains no data
if {$start < $minimum} {set minimum $start}
if {$end > $maximum} {set maximum $end}
}
if {$maximum == 0} { ;# nothing to display
set minimum 0
}
return [list $minimum $maximum]
}
proc updateAxis {this} {
foreach {minimum maximum} [limits $this] {}
if {($minimum > 0) && ($minimum == $maximum)} { ;# sole sample
set minimum [expr {$maximum - 60}] ;# use a reasonable minimum range
}
set graph $($this,graph)
set range [expr {$maximum - $minimum}]
bltGraph::setRange $graph $range
bltGraph::xUpdateGraduations $graph
bltGraph::xAxisUpdateRange $graph $maximum
set cursors $($this,cursors)
if {$maximum == 0} { ;# nothing to display
foreach cursor $cursors {switched::configure $cursor -hide 1 -x 0} ;# reset and hide cursors
return
}
foreach cursor $cursors {switched::configure $cursor -hide 0} ;# show cursors
if {([switched::cget [lindex $cursors 0] -x] == 0) && ([switched::cget [lindex $cursors 1] -x] == 0)} { ;# cursors are reset
# show at least 1 day or 10% of the data history:
switched::configure [lindex $cursors 0] -x [expr {$maximum - [maximum [expr {$range / 10}] 86400]}]
switched::configure [lindex $cursors 1] -x $maximum
}
foreach cursor $cursors { ;# constrain cursors to visible range if necessary
set x [switched::cget $cursor -x]
if {$x < $minimum} {
switched::configure $cursor -x $minimum
} elseif {$x > $maximum} {
switched::configure $cursor -x $maximum
}
}
}
proc resized {this} { ;# synchronize y axis with labels according to their height
variable ${this}instance
if {[array size ${this}instance] == 0} return ;# nothing displayed
set half [expr {$(labelHeight) / 2.0}]
$($this,viewer) yaxis configure -min -$half -max [expr {[$($this,viewer) extents plotheight] - $half}]
}
proc launchInstanceModule {instance module identifier arguments} { ;# instance is index in database instance table
set database $global::database
foreach list [database::cellsData $database $instance] { ;# list: row entry label comment, none if database error
lappend cellsData $list
}
if {[string length $database::($database,error)] > 0} return ;# abort if database error
set entries {}; set indexes {}; set labels {}; set types {}; set messages {}; set anchors {}
foreach list [database::moduleData $database $instance] {
if {[llength $list] == 0} break
foreach {entry indexed label type message anchor} $list {}
lappend entries $entry
lappend indexes $indexed
lappend labels $label
lappend types $type
lappend messages $message
lappend anchors $anchor
}
if {[llength $entries] == 0} return ;# database error: abort
# carry instance number with module name so that for example, history data can be retrieved from a cell name, storing and
# restoring modules work, ...
# wrap arguments in a list so that the first character of switch value is not a - (disallowed by the getopt implementation)
dynamicallyLoadModules [list instance<$instance>\
-module $module -identifier $identifier -arguments \{$arguments\} -instance $instance -cellsdata $cellsData\
-entries $entries -types $types -messages $messages -anchors $anchors\
]
if {$global::pollTime != 0} {error {poll time should be 0}} ;# poll time should have been set above to flag history mode
}
# cell history between cursors (actual intersection between database history and period determined by the cursors)
# note: directly invoked by instance module
proc cellHistory {instance row entry {last 0}} { ;# return a list of: timestamp, value, timestamp, value, ...
variable singleton
if {![info exists singleton] || ($global::database == 0)} { ;# (just in case check database connection)
return {} ;# happens when loading from a configuration file and database instances viewer has not been created yet
}
foreach {start end} [cursorsRange] {}
if {$last} { ;# return sample at cursor (actually at the time or before what the right cursor points to)
return [database::cellHistory $global::database $instance $row $entry $start $end 1]
} else { ;# return all samples between cursors
return [database::cellHistory $global::database $instance $row $entry $start $end 0]
}
}
proc history {cell} { ;# invoked by viewers, ...
foreach {instance row entry} [cellIndex $cell] {}
if {[info exists instance]} {
return [cellHistory $instance $row $entry]
} else { ;# instance module was unloaded
return {}
}
}
proc range {cell} { ;# range from database (list of 2 empty strings if no history data)
foreach {instance row entry} [cellIndex $cell] {}
if {![info exists instance] || ($global::database == 0)} { ;# instance module was unloaded or database disconnected
return [list {} {}]
}
foreach {start end} [cursorsRange] {}
set list [database::cellRange $global::database $instance $row $entry $start $end] ;# limit timestamps (may be empty)
if {[string length $database::($global::database,error)] > 0} {
set list [list {} {}] ;# return empty range in case of database error
}
return $list
}
proc cellIndex {cell} { ;# cell index in database history table (cell must be data from an instance module instance)
if {([scan $cell {%[^<]<%u>::data(%u,%u)} module instance row column] != 4) || ![string equal $module instance]} {
error "invalid database instance cell: $cell"
}
if {[modules::loadedNamespace instance<$instance>]} { ;# get database row and entry kept in instance module
foreach {row entry} [::instance<$instance>::mapping $row $column] {}
return [list $instance $row $entry]
} else { ;# instance module was unloaded
return {}
}
}
proc fromTo {this} {
return [lsort -integer [list\
[expr {round([switched::cget [lindex $($this,cursors) 0] -x])}]\
[expr {round([switched::cget [lindex $($this,cursors) 1] -x])}]\
]] ;# make sure to return seconds as integers
}
proc cursorsRange {} { ;# return start and end timestamps in seconds from cursors current position
variable singleton
return [fromTo $singleton]
}
proc cursorMoved {this x} {
eval database::setRange [fromTo $this]
}
proc deleteEmpty {} { ;# delete singleton if it displays no instances
variable singleton
if {![info exists singleton]} return ;# already deleted
variable ${singleton}instance
if {[array size ${singleton}instance] == 0} {
set ($singleton,selfDelete) {} ;# consider this action as self deletion
delete $singleton ;# delete if empty
}
}
proc setCursors {this from to} {
switched::configure [lindex $($this,cursors) 0] -x $from
switched::configure [lindex $($this,cursors) 1] -x $to
}
proc buttonPress {selector element} {
foreach selected [selector::selected $selector] {
if {[string equal $selected $element]} return ;# in an already selected element, do not change selection
}
selector::select $selector $element
}
proc buttonRelease {selector element extended} { ;# extended means that there is an extended selection in process
if {$extended} return
set list [selector::selected $selector]
if {[llength $list] <= 1} return ;# nothing to do if there is no multiple selection
foreach selected $list {
if {[string equal $selected $element]} { ;# in an already selected element
selector::select $selector $element ;# set selection to sole element
return
}
}
}
proc entryData {cell} { ;# return label, type, message, anchor, for module column of the cell, in a list
foreach {instance row entry} [cellIndex $cell] {}
if {![info exists instance]} { ;# instance module was unloaded
return {}
}
foreach list [database::moduleData $global::database $instance] {
if {[llength $list] == 0} break
foreach {index indexed label type message anchor} $list {}
if {$index == $entry} { ;# found entry
return [list $label $type $message $anchor]
}
}
return {} ;# must be some database error
}
proc updateMessage {this} {
variable ${this}instance
if {[array size ${this}instance] == 0} {
centerMessage $widget::($this,path) "database instances viewer:\ndrop or load instance(s)"\
$composite::($this,-plotbackground) $global::viewerMessageColor
} else {
centerMessage $widget::($this,path) {}
}
}
class element {
proc element {this path args} switched {$args} {
variable x$this
variable y$this
blt::vector create x${this}(2)
blt::vector create y${this}(2)
# use object identifier as element identifier and a reasonably sized dot at each end
$path element create $this -label {} -xdata x$this -ydata y$this -pixels 2 -dashes 3 ;# show dashes till valid data
set ($this,path) $path
switched::complete $this
}
proc ~element {this} {
variable x$this
variable y$this
blt::vector destroy x$this y$this
$($this,path) element delete $this
if {[string length $switched::($this,-deletecommand)]>0} {
uplevel #0 $switched::($this,-deletecommand) ;# always invoke command at global level
}
}
proc options {this} { ;# force default color, start and end range
return [list\
[list -color white]\
[list -deletecommand {} {}]\
[list -end $global::32BitIntegerMaximum]\
[list -start 0]\
[list -ordinate 0 0]\
]
}
proc set-color {this value} {
$($this,path) element configure $this -color $value
}
proc set-deletecommand {this value} {}
proc set-ordinate {this value} {
variable y$this
y${this} index : $value
}
proc set-start {this value} { ;# (note: a minimum of 0 means that element contains no data)
variable x$this
x${this} index 0 $value
if {[x${this} index 1] < $global::32BitIntegerMaximum} { ;# data complete and valid: remove dashes
$($this,path) element configure $this -dash {}
}
}
proc set-end {this value} {
variable x$this
x${this} index 1 $value
if {[x${this} index 0] > 0} { ;# data complete and valid: remove dashes
$($this,path) element configure $this -dash {}
}
}
proc range {this} {
variable x$this
return [x${this} index :]
}
}
class cursor {
variable downArrow [image create photo -data {R0lGODlhCQAEAIAAAAAA/////yH5BAEAAAEALAAAAAAJAAQAAAIIhH+BGYoNWSgAOw==}]
variable upArrow [image create photo -data {R0lGODlhCQAEAIAAAP///wAA/yH5BAEAAAAALAAAAAAJAAQAAAIIhIOmyMv9YgEAOw==}]
proc cursor {this path args} switched {$args} {
variable downArrow
variable upArrow
$path marker create line -name ${this}line -outline blue
$path marker create image -name ${this}top -image $downArrow -anchor nw -xoffset -4 ;# as BLT does not properly center
$path marker create image -name ${this}bottom -image $upArrow -anchor sw -xoffset -4
foreach marker [list ${this}line ${this}top ${this}bottom] {
$path marker bind $marker <Enter> "$path configure -cursor sb_h_double_arrow" ;# horizontal double arrow
$path marker bind $marker <Leave> "$path configure -cursor {}"
$path marker bind $marker <ButtonPress-1> "databaseInstances::cursor::button $this 1 %x"
$path marker bind $marker <ButtonRelease-1> "databaseInstances::cursor::button $this 0 %x"
$path marker bind $marker <Button1-Motion> "databaseInstances::cursor::motion $this %x"
}
set ($this,path) $path
switched::complete $this
}
proc ~cursor {this} {
set path $($this,path)
foreach marker [list ${this}line ${this}top ${this}bottom] {
$path marker delete $marker
}
}
proc options {this} { ;# force x initialization
return [list\
[list -command {} {}]\
[list -hide 0 0]\
[list -x 0]\
]
}
proc set-command {this value} {} ;# callback invoked when cursor was moved by user to a new abscissa
proc set-hide {this value} {
set path $($this,path)
foreach marker [list ${this}line ${this}top ${this}bottom] {
$path marker configure $marker -hide $value
}
}
proc set-x {this value} {
set path $($this,path)
foreach {minimum maximum} [$path xaxis limits] {}
if {$value < $minimum} {set value $minimum} elseif {$value > $maximum} {set value $maximum} ;# clip
$path marker configure ${this}line -coords [list $value -Inf $value Inf]
$path marker configure ${this}top -coords [list $value -Inf]
$path marker configure ${this}bottom -coords [list $value Inf]
}
proc button {this pressed x} { ;# or released, abscissa is in pixels
set x [$($this,path) xaxis invtransform $x] ;# convert to axis units
if {$pressed} { ;# show displayed value, not value at mouse cursor
lifoLabel::push $global::messenger [bltGraph::axisTime $($this,path) $switched::($this,-x)]
} else { ;# released
lifoLabel::pop $global::messenger
if {($x != $($this,x)) && ([string length $switched::($this,-command)] > 0)} { ;# do nothing if no change
uplevel #0 $switched::($this,-command) $x ;# always invoke command at global level
}
}
set ($this,x) $x
}
proc motion {this x} { ;# in pixels
set x [$($this,path) xaxis invtransform $x] ;# convert to axis units
switched::configure $this -x $x
lifoLabel::pop $global::messenger
lifoLabel::push $global::messenger [bltGraph::axisTime $($this,path) $x]
}
}
}
|
