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
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
|
# 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: dbgui.tcl,v 1.55 2005/01/02 00:45:07 jfontain Exp $
class database {
# dialog box used to display module instances in database, eventually SQL query that can be used to retrieve data for a
# specific instance, and is also used as a drag site for database module instances to drop in database instances container
proc displayAndSelectInstances {} { ;# invoking code must insure that there is a valid database connection before invocation
if {[info exists (dialog)]} { ;# exists
raise $widget::($dialog::($(dialog),dialog),path) ;# make it visible
} else {
set (dialog) [new dialog .] ;# display instances from database
dialog::deleteCommand $(dialog) {unset database::(dialog)}
}
}
proc removeInstances {} { ;# instances dialog object can only be deleted via its GUI
if {![info exists (dialog)]} return
delete $dialog::($(dialog),dialog)
}
proc displayAndSelectRange {} {
if {[info exists (range)]} { ;# exists
raise $widget::($rangeDialog::($(range),dialog),path) ;# make it visible
} else {
set (range) [new rangeDialog . {unset database::(range)}] ;# display database range dialog box
}
}
proc setRange {from to} {
if {[info exists (range)]} {
rangeDialog::update $(range) $from $to
}
}
class dialog {
proc dialog {this parentPath args} switched {$args} {
set dialog [new dialogBox .\
-buttons hoc -default o -title [mc {moodss: Database instances}] -otherbuttons SQL\
-helpcommand {generalHelpWindow #menus.file.database.load} -x [winfo pointerx .] -y [winfo pointery .]\
-grab release -command "database::dialog::validated $this" -deletecommand "delete $this"\
]
wm geometry $widget::($dialog,path) 500x400
composite::configure $dialog ok -state disabled ;# OK button disabled until proper cell selection
lappend ($this,tips) [linkedHelpWidgetTip $composite::($dialog,help,path)]\
[new widgetTip -path $composite::($dialog,SQL,path)\
-text [mc {toggles the display of the SQL query that can be used to retrieve the data cell history}]\
]
set frame [frame $widget::($dialog,path).frame]
set scroll [new scroll tree $frame]
set tree $composite::($scroll,scrolled,path)
$tree bindText <Control-Button-1> {}; $tree bindImage <Control-Button-1> {} ;# prevent multiple selections
$tree configure\
-dragenabled 0 -dropenabled 0 -deltay [expr {[font metrics $font::(mediumNormal) -linespace] + 4}]\
-background $widget::option(listbox,background) -selectbackground $widget::option(listbox,selectbackground)\
-closecmd "database::dialog::stateChange $this 0" -opencmd "database::dialog::stateChange $this 1"\
-linestipple gray50 -crossopenimage $configuration::minusIcon -crosscloseimage $configuration::plusIcon\
-selectcommand "database::dialog::processEvent $this" ;# to detect instance and cell selections
set treeScrollPath $widget::($scroll,path)
grid $treeScrollPath -row 0 -sticky nsew
grid rowconfigure $frame 0 -weight 1
lappend ($this,objects) $scroll
set range [frame $frame.range]
set label [label $range.fromLabel -font $font::(mediumBold) -text [mc from:]]
grid $label -row 0 -column 0 -sticky w
set ($this,from) [label $range.from -font $font::(mediumNormal)]
grid $($this,from) -row 0 -column 1 -sticky w -padx 2
set label [label $range.toLabel -font $font::(mediumBold) -text [mc to:]]
grid $label -row 1 -column 0 -sticky w
set ($this,to) [label $range.to -font $font::(mediumNormal)]
grid $($this,to) -row 1 -column 1 -sticky w -padx 2
lappend ($this,tips) [new widgetTip -path $range -text [mc {selected item database time range}]]
grid columnconfigure $range 1 -weight 1
grid $range -row 1 -sticky ew
grid columnconfigure $frame 0 -weight 1
set scroll [new scroll text $frame -vertical 0]
set query $composite::($scroll,scrolled,path)
$query configure -background white -height 4 -state disabled -wrap none -font $font::(mediumNormal)
$query tag configure italic -font $font::(mediumItalic)
# leave enough vertical room so that scrollbar can appear and disappear without changing the tree height:
composite::configure $scroll\
-height [expr {[winfo reqheight $query] + [winfo reqheight $composite::($scroll,horizontal,path)]}]
lappend ($this,objects) $scroll
composite::configure $dialog SQL\
-command "database::dialog::toggleSQLDisplay $this $widget::($scroll,path) $treeScrollPath"
set ($this,scrollPath) $widget::($scroll,path)
set canvas [$tree getcanvas]
set ($this,drag) [new dragSite -path $canvas -validcommand "database::dialog::validateDrag $this"]
# module database instance is a list: database name, instance, start and end instants from instance and history tables
dragSite::provide $($this,drag) INSTANCES "database::dialog::dragData $this"
dialogBox::display $dialog $frame
set ($this,tree) $tree
set ($this,query) $query
set ($this,dialog) $dialog
set ($this,deleteCommand) {}
set ($this,nodeTips) {}
switched::complete $this
refresh $this
}
proc ~dialog {this} { ;# note: this object must be deleted by its GUI dialog object only
eval delete $($this,nodeTips) $($this,objects) $($this,tips) $($this,drag)
if {[string length $($this,deleteCommand)] > 0} {
uplevel #0 $($this,deleteCommand) ;# always invoke command at global level
}
if {[string length $switched::($this,-deletecommand)] > 0} {
uplevel #0 $switched::($this,-deletecommand) ;# always invoke command at global level
}
}
proc options {this} {
return [list\
[list -command {} {}]\
[list -deletecommand {} {}]\
]
}
proc set-command {this value} {} ;# command is invoked with instance data appended only when there is one selected
proc set-deletecommand {this value} {}
proc deleteCommand {this command} { ;# for internal usage, as opposed to -deletecommand option
set ($this,deleteCommand) $command
}
proc refresh {this} {
lifoLabel::push $global::messenger [mc {retrieving module instances from database...}]
busy 1 [list . $widget::($($this,dialog),path)]
set database $global::database
set tree $($this,tree)
set canvas [$tree getcanvas]
$tree delete [$tree nodes root] ;# clear whole tree
array unset {} $this,*Data,* ;# clear nodes data
eval delete $($this,nodeTips)
set data(modules) {}
foreach module [database::modules $database] { ;# note: could be no modules in case of database error
set data(instances,$module) {}
foreach instance [database::instances $database $module] { ;# note: could be no instances in case of database error
# note: a query result is empty in case of database error:
set data(identifier,$instance) [database::identifier $database $instance]
if {[string length $database::($database,error)] > 0} break
set data(arguments,$instance) [database::arguments $database $instance]
if {[string length $database::($database,error)] > 0} break
set data(version,$instance) [database::version $database $instance]
if {[string length $database::($database,error)] > 0} break
set data(cellsData,$instance) [database::cellsData $database $instance]
if {[string length $database::($database,error)] > 0} break
lappend data(instances,$module) $instance
}
if {[string length $database::($database,error)] > 0} break
lappend data(modules) $module
}
if {[string length $database::($database,error)] > 0} { ;# display nothing in case of any unexpected database error
set data(modules) {}
}
foreach module $data(modules) {
set node [$tree insert end root #auto -font $font::(mediumBold) -text $module -image $configuration::closedIcon]
set ($this,moduleData,$node) $module
}
foreach node [$tree nodes root] {
set module [$tree itemcget $node -text]
foreach instance $data(instances,$module) {
set arguments $data(arguments,$instance)
set noOption [expr {[string length $arguments] == 0}]
if {$noOption} {
set arguments {without options}
} else { ;# eliminate empty values for boolean options
set string {}
foreach {option value} $arguments {
if {[string length $string] > 0} {append string { }}
append string $option
if {[string length $value] > 0} { ;# boolean switch: no value
append string { } $value
}
}
set arguments $string
}
set new [$tree insert end $node #auto -data $instance -text $arguments -image $configuration::closedIcon]
if {$noOption} {
$tree itemconfigure $new -font $font::(mediumItalic)
} else {
$tree itemconfigure $new -font $font::(mediumNormal)
}
set ($this,instanceData,$new) [list $instance $module $data(identifier,$instance) $arguments]
lappend ($this,nodeTips) [new widgetTip -path $canvas -itemortag n:$new\
-text [format [mc {instance of module %1$s version %2$s}] $module $data(version,$instance)]\
] ;# note: the node name (n:*) comes from the BWidget tree source code
}
}
foreach node [$tree nodes root] {
foreach node [$tree nodes $node] {
set instance [$tree itemcget $node -data]
foreach {row entry label comment} $data(cellsData,$instance) {
if {[string length $comment] > 0} {
append label " ($comment)"
}
regsub -all {\n} $label { } label ;# replace all new lines, which tree cannot handle
set new [$tree insert end $node #auto\
-data $row,$entry -text $label -font $font::(mediumNormal) -image $configuration::leafIcon\
]
set ($this,cellData,$new) [list $instance $row $entry]
}
}
}
busy 0 [list . $widget::($($this,dialog),path)]
lifoLabel::pop $global::messenger
}
proc updateQuery {this instance row entry start end} {
set query $($this,query)
$query configure -state normal
$query delete 1.0 end ;# clear
foreach {start optional end} [database::historyQuery $global::database $instance $row $entry $start $end] {}
$query insert end $start
if {[string length $optional] > 0} {
$query insert end \n$optional
$query tag add italic 3.0 3.end ;# highlight timestamp selection optional part
}
$query insert end \n$end
$query configure -state disabled
}
proc clearQuery {this} {
set query $($this,query)
$query configure -state normal
$query delete 1.0 end
$query configure -state disabled
}
proc toggleSQLDisplay {this queryScrollPath treeScrollPath} {
if {[llength [grid info $queryScrollPath]] == 0} { ;# display SQL
# make sure query remains visible when shrinking window vertically:
grid $queryScrollPath -row 2 -sticky ew
set node [$($this,tree) selection get] ;# node may be empty
if {[info exists ($this,cellData,$node)]} { ;# a cell is selected
foreach {instance row entry} $($this,cellData,$node) {}
set start {}; set end {} ;# initialize in case of database error
foreach {start end} [cellRange $this $instance $row $entry] {}
updateQuery $this $instance $row $entry $start $end
}
} else {
grid forget $queryScrollPath
clearQuery $this
}
}
proc validateDrag {this x y} {
return [info exists ($this,instanceData)]
}
proc dragData {this format} {
return [list $($this,instanceData)]
}
proc validated {this} {
if {[string length $switched::($this,-command)] == 0} return
wm withdraw $widget::($($this,dialog),path) ;# remove dialog box from view so that main window message can be read
update ;# wait until dialog box is no longer visible (do not always work)
uplevel #0 $switched::($this,-command) [list $($this,instanceData)]
}
proc processEvent {this tree node} {
set start {}; set end {} ;# initialize in case of error in database queries
composite::configure $($this,dialog) ok -state disabled
catch {unset ($this,instanceData)}
if {![catch {set data $($this,moduleData,$node)}]} { ;# a module is selected
foreach {start end} [moduleRange $this $data] {}
}
if {![catch {set data $($this,cellData,$node)}]} { ;# a cell is selected
foreach {instance row entry} $data {}
foreach {start end} [cellRange $this $instance $row $entry] {}
if {[llength [grid info $($this,scrollPath)]] > 0} { ;# display corresponding SQL
updateQuery $this $instance $row $entry $start $end
}
} else {
clearQuery $this
}
if {![catch {set data $($this,instanceData,$node)}] && ([llength [$tree nodes $node]] > 0)} {
# an instance with data cells history is selected
foreach {start end} [instanceRange $this [lindex $data 0]] {}
set ($this,instanceData) $data
composite::configure $($this,dialog) ok -state normal
}
$($this,from) configure -text $start; $($this,to) configure -text $end
}
proc moduleRange {this module} {
if {[info exists ($this,moduleRange,$module)]} { ;# cache time limits because retrieval can be slow
return $($this,moduleRange,$module)
} else {
return [set ($this,moduleRange,$module)\
[database::moduleRange $global::database $module [list . $widget::($($this,dialog),path)]]\
]
}
}
proc instanceRange {this instance} {
if {[info exists ($this,instanceRange,$instance)]} { ;# cache time limits because retrieval can be slow
return $($this,instanceRange,$instance)
} else {
return [set ($this,instanceRange,$instance)\
[database::instanceRange $global::database $instance [list . $widget::($($this,dialog),path)]]\
]
}
}
proc cellRange {this instance row entry} {
if {[info exists ($this,cellRange,$instance,$row,$entry)]} { ;# cache time limits because retrieval can be slow
return $($this,cellRange,$instance,$row,$entry)
} else {
return [set ($this,cellRange,$instance,$row,$entry)\
[database::cellRange $global::database $instance $row $entry {} {} [list . $widget::($($this,dialog),path)]]\
]
}
}
proc stateChange {this opened node} {
if {$opened} {
$($this,tree) itemconfigure $node -image $configuration::openedIcon
} else {
$($this,tree) itemconfigure $node -image $configuration::closedIcon
}
}
}
class rangeDialog {
proc rangeDialog {this parentPath {deleteCommand {}}} {
variable singleton
if {[info exists singleton]} {
error {only 1 database range dialog object can exist}
}
set singleton $this
set dialog [new dialogBox $parentPath\
-buttons hoc -default o -title [mc {moodss: Database history range}] -x [winfo pointerx .] -y [winfo pointery .]\
-helpcommand {generalHelpWindow #menus.view.database.range} -deletecommand "delete $this" -grab release\
-command "database::rangeDialog::apply $this 1" -die 0 -otherbuttons apply\
]
composite::configure $dialog apply -text [mc Apply] -command "database::rangeDialog::apply $this 0"
set ($this,tip) [linkedHelpWidgetTip $composite::($dialog,help,path)]
set frame [frame $widget::($dialog,path).frame]
set message [message $frame.message\
-width [winfo screenwidth .] -font $font::(mediumNormal) -justify center\
-text [mc {Select history range for database views:}]
]
pack $message -pady 5
set from [frame $frame.from]
pack $from -fill x -expand 1 -pady 2
pack [label $from.label -text [mc from:]] -side left -padx 2
set input [new input $from]
set ($this,from) $input
pack $widget::($input,path) -side right
set to [frame $frame.to]
pack $to -fill x -expand 1 -pady 2
pack [label $to.label -text [mc to:]] -side left -padx 2
set input [new input $to]
set ($this,to) $input
pack $widget::($input,path) -side right
composite::configure $($this,from) -command "database::rangeDialog::updated $this from"
composite::configure $($this,to) -command "database::rangeDialog::updated $this to"
if {[info exists databaseInstances::singleton]} { ;# should always be the case at this point
foreach {minimum maximum} [databaseInstances::limits $databaseInstances::singleton] {}
composite::configure $($this,from) -minimum $minimum -maximum $maximum
composite::configure $($this,to) -minimum $minimum -maximum $maximum
foreach {minimum maximum} [databaseInstances::cursorsRange] {}
input::set $($this,from) $minimum
input::set $($this,to) $maximum
}
set ($this,deleteCommand) $deleteCommand
set ($this,dialog) $dialog
dialogBox::display $dialog $frame
}
proc ~rangeDialog {this} {
variable singleton
delete $($this,tip) $($this,from) $($this,to)
if {[string length $($this,deleteCommand)] > 0} {
uplevel #0 $($this,deleteCommand) ;# always invoke command at global level
}
unset singleton
}
proc apply {this close} {
if {![info exists databaseInstances::singleton]} return ;# should never be the case at this point
set from [input::get $($this,from)]
set to [input::get $($this,to)]
if {($from < 0) || ($to < 0)} {
bell
return
}
databaseInstances::setCursors $databaseInstances::singleton $from $to
if {$close} {
delete $($this,dialog) ;# which in turn should delete this object
}
after idle ::refresh ;# update all database related views
}
proc updated {this side seconds} { ;# user changed date or time: check consistency and eventually bring corrections
if {[string equal $side from]} {
set value [input::get $($this,to)]
if {($value >= 0) && ($seconds > $value)} {
input::set $($this,to) $seconds
}
} else { ;# side is to
set value [input::get $($this,from)]
if {($value >= 0) && ($seconds < $value)} {
input::set $($this,from) $seconds
}
}
# synchronize with database instances viewer cursors:
databaseInstances::setCursors $databaseInstances::singleton [input::get $($this,from)] [input::get $($this,to)]
}
proc update {this from to} { ;# public procedure for setting from external source
input::set $($this,from) $from
input::set $($this,to) $to
}
class input {
variable hours
for {::set value 0} {$value < 24} {incr value} {
lappend hours [format %02u $value]
}
variable sixties
for {::set value 0} {$value < 60} {incr value} {
lappend sixties [format %02u $value]
}
unset value
variable minimum 0 ;# choose reasonable minimum and maximum values far from extreme values
variable maximum [clock scan 2029-12-31]
proc input {this parentPath args} composite {[new frame $parentPath] $args} {
variable days
variable daysWidth
variable months
variable monthsWidth
variable hours
variable sixties
variable maximumYear
variable minimum
variable maximum
if {![info exists days]} {
::set days [mc {Sunday Monday Tuesday Wednesday Thursday Friday Saturday}]
::set daysWidth 0
foreach value $days {
::set value [string length $value]
if {$value > $daysWidth} {::set daysWidth $value}
}
}
if {![info exists months]} {
::set months [mc {January February March April May June July August September October November December}]
::set monthsWidth 0
foreach value $months {
::set value [string length $value]
if {$value > $monthsWidth} {::set monthsWidth $value}
}
}
::set path $widget::($this,path)
::set delay 200 ;# repeat delay in milliseconds
if {[package vcompare $::tcl_version 8.4] < 0} {
composite::manage $this\
[new spinEntry $path\
-font $font::(mediumBold) -width $daysWidth -list $days -justify right -editable 0 -wrap 1\
-repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 86400"\
] dayOfWeek\
[new spinEntry $path\
-font $font::(mediumBold) -width 2 -range {1 31 1} -justify right -editable 0 -wrap 1\
-repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 86400"\
] day\
[new spinEntry $path\
-font $font::(mediumBold) -width $monthsWidth -list $months -justify right -editable 0 -wrap 1\
-repeatdelay $delay -command "database::rangeDialog::input::setMonth $this %d"\
] month\
[new spinEntry $path\
-font $font::(mediumBold) -width 4 -justify right -editable 0\
-range [list [clock format $minimum -format %Y] [clock format $maximum -format %Y] 1]\
-repeatdelay $delay -command "database::rangeDialog::input::setYear $this %d"\
] year\
[new frame $path -width 10] separator1\
[new spinEntry $path\
-font $font::(mediumBold) -width 2 -list $hours -justify right -wrap 1\
-repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 3600"\
] hours\
[new label $path -font $font::(mediumBold) -text :] separator2\
[new spinEntry $path\
-font $font::(mediumBold) -width 2 -list $sixties -justify right -wrap 1\
-repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 60"\
] minutes\
[new label $path -font $font::(mediumBold) -text :] separator3\
[new spinEntry $path\
-font $font::(mediumBold) -width 2 -list $sixties -justify right -wrap 1\
-repeatdelay $delay -command "database::rangeDialog::input::increment $this %d 1"\
] seconds
foreach entry {hours minutes seconds} { ;# filter on positive integers
setupEntryValidation $composite::($composite::($this,$entry),entry,path) {{check31BitUnsignedInteger %P}}
}
} else { ;# use native widget if possible
composite::manage $this\
[new spinbox $path\
-font $font::(mediumBold) -width $daysWidth -values $days -justify right -state readonly -wrap 1\
-repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 86400 %s"\
] dayOfWeek\
[new spinbox $path\
-font $font::(mediumBold) -width 2 -from 1 -to 31 -increment 1 -justify right -state readonly -wrap 1\
-repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 86400 %s"\
] day\
[new spinbox $path\
-font $font::(mediumBold) -width $monthsWidth -values $months -justify right -state readonly -wrap 1\
-repeatinterval $delay -command "database::rangeDialog::input::setMonth $this %d %s"\
] month\
[new spinbox $path\
-font $font::(mediumBold) -width 4 -justify right -state readonly\
-from [clock format $minimum -format %Y] -to [clock format $maximum -format %Y] -increment 1\
-repeatinterval $delay -command "database::rangeDialog::input::setYear $this %d %s"\
] year\
[new frame $path -width 10] separator1\
[new spinbox $path\
-font $font::(mediumBold) -width 2 -values $hours -justify right -wrap 1\
-repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 3600 %s"\
] hours\
[new label $path -font $font::(mediumBold) -text :] separator2\
[new spinbox $path\
-font $font::(mediumBold) -width 2 -values $sixties -justify right -wrap 1\
-repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 60 %s"\
] minutes\
[new label $path -font $font::(mediumBold) -text :] separator3\
[new spinbox $path\
-font $font::(mediumBold) -width 2 -values $sixties -justify right -wrap 1\
-repeatinterval $delay -command "database::rangeDialog::input::increment $this %d 1 %s"\
] seconds
foreach entry {hours minutes seconds} { ;# filter on positive integers
setupEntryValidation $composite::($this,$entry,path) {{check31BitUnsignedInteger %P}}
}
}
pack $composite::($this,dayOfWeek,path) $composite::($this,day,path) $composite::($this,month,path)\
$composite::($this,year,path) $composite::($this,separator1,path) $composite::($this,hours,path)\
$composite::($this,separator2,path) $composite::($this,minutes,path) $composite::($this,separator3,path)\
$composite::($this,seconds,path) -side left
composite::complete $this
set $this $minimum
}
proc ~input {this} {}
proc options {this} {
variable minimum
variable maximum
return [list\
[list -command {} {}]\
[list -maximum $maximum $maximum]\
[list -minimum $minimum $minimum]\
]
}
proc set-command {this value} {}
proc set-maximum {this value} {}
proc set-minimum {this value} {}
proc get {this} {
variable months
if {[package vcompare $::tcl_version 8.4] < 0} {
::set day [spinEntry::get $composite::($this,day)]
::set month [expr {[lsearch -exact $months [spinEntry::get $composite::($this,month)]] + 1}]
::set year [spinEntry::get $composite::($this,year)]
::set hours [spinEntry::get $composite::($this,hours)]
::set minutes [spinEntry::get $composite::($this,minutes)]
::set seconds [spinEntry::get $composite::($this,seconds)]
} else {
::set day [$composite::($this,day,path) get]
::set month [expr {[lsearch -exact $months [$composite::($this,month,path) get]] + 1}]
::set year [$composite::($this,year,path) get]
::set hours [$composite::($this,hours,path) get]
::set minutes [$composite::($this,minutes,path) get]
::set seconds [$composite::($this,seconds,path) get]
}
if {[catch {::set value [clock scan "$year-$month-$day $hours:$minutes:$seconds"]}]} {
# year, month and day are always valid since they are drawn from a fixed list
if {[catch {clock scan "$hours:00:00"}]} {
::set entry hours
} elseif {[catch {clock scan "$hours:$minutes:00"}]} {
::set entry minutes
} else {
::set entry seconds
}
# point at the first error location
if {[package vcompare $::tcl_version 8.4] < 0} {
focus $composite::($composite::($this,$entry),entry,path)
} else {
focus $composite::($this,$entry,path)
}
return -1
}
return $value
}
proc set {this value} { ;# value is in seconds
variable days
variable months
variable minimum
variable maximum
if {$value < $minimum} {
::set value $minimum
} elseif {$value > $maximum} {
::set value $maximum
}
foreach {dayOfWeek day month year hours minutes seconds} [clock format $value -format {%w %e %m %Y %H %M %S}] {}
::set dayOfWeek [lindex $days $dayOfWeek]
::set month [string trimleft $month 0] ;# avoid problems with octal number interpretation
::set month [lindex $months [expr {$month - 1}]]
if {[package vcompare $::tcl_version 8.4] < 0} {
spinEntry::set $composite::($this,dayOfWeek) $dayOfWeek
spinEntry::set $composite::($this,day) $day
spinEntry::set $composite::($this,month) $month
spinEntry::set $composite::($this,year) $year
spinEntry::set $composite::($this,hours) $hours
spinEntry::set $composite::($this,minutes) $minutes
spinEntry::set $composite::($this,seconds) $seconds
} else {
$composite::($this,dayOfWeek,path) set $dayOfWeek
$composite::($this,day,path) set $day
$composite::($this,month,path) set $month
$composite::($this,year,path) set $year
$composite::($this,hours,path) set $hours
$composite::($this,minutes,path) set $minutes
$composite::($this,seconds,path) set $seconds
}
::set ($this,seconds) $value
if {[string length $composite::($this,-command)] > 0} {
uplevel #0 $composite::($this,-command) $value ;# always invoke command at global level
}
}
proc increment {this direction value ignore} {
switch $direction {
down {set $this [expr {$($this,seconds) - $value}]}
up {set $this [expr {$($this,seconds) + $value}]}
}
}
proc setMonth {this direction ignore} {
foreach {day month year time} [clock format $($this,seconds) -format {%e %m %Y %T}] {}
::set month [string trimleft $month 0] ;# avoid problems with octal number interpretation
switch $direction {
down {incr month -1}
up {incr month}
default return
}
if {$month <= 0} {
incr year -1
::set month 12
} elseif {$month > 12} {
incr year
::set month 1
}
while {[catch {::set seconds [clock scan "$year-$month-$day $time"]}]} {
incr day -1 ;# handle months with less days than current value
}
set $this $seconds
}
proc setYear {this direction year} {
foreach {day month current time} [clock format $($this,seconds) -format {%e %m %Y %T}] {}
if {$year == $current} return ;# no change
while {[catch {::set seconds [clock scan "$year-$month-$day $time"]} message]} {
incr day -1 ;# handle months with less days than current value
}
set $this $seconds
}
}
}
}
|
