« back to all changes in this revision
Viewing changes to forms.tcl
- browse files at revision 1.1.1
- compare with another revision
- download diff
- download tarball
- view history from revision 1.1.1
- Committer: Package Import Robot
- Author(s): Mark Hindley
- Date: 2013-02-13 10:54:36 UTC
- mto: This revision was merged to the branch mainline in revision 3.
- Revision ID: package-import@ubuntu.com-20130213105436-w8flw5ecbt8s7w2d
Tags: upstream-2.0.7
Import upstream version 2.0.7
- files added:
- arrow-end.xbm
- doc/en
- license
- msgs
- files removed:
- arrow_down.xbm
- help
- pgintcl-1.5.0
- pgintcl-3.0.1
- tclkit
- files modified:
- CHANGE_LOG.txt
added
removed
forms.tcl
1
# forms.tcl
2
3
image create bitmap ::img::arrow_left \
4
-file [file join $::config::installDir arrow-left.xbm] \
5
-foreground #000000
6
image create bitmap ::img::arrow_right \
7
-file [file join $::config::installDir arrow-right.xbm] \
8
-foreground #000000
9
image create bitmap ::img::arrow_home \
10
-file [file join $::config::installDir arrow-home.xbm] \
11
-foreground #000000
12
image create bitmap ::img::arrow_end \
13
-file [file join $::config::installDir arrow-end.xbm] \
14
-foreground #000000
15
16
17
class FormWindow {
18
protected common windowList {}
19
public variable window {}
20
protected variable parent
21
public variable formName
22
protected variable noteBook
23
protected variable formDef
24
protected variable attribDef
25
protected variable attribList
26
protected variable modAttribList
27
protected variable tabList {}
28
protected variable tabObject
29
30
proc closeAllWindows {} {
31
foreach window $windowList {
32
destroy $window
33
}
34
return
35
}
36
37
constructor {c_parent c_formName} {
38
set parent $c_parent
39
set formName $c_formName
40
setupWindow
41
return
42
}
43
44
destructor {
45
foreach tab $tabList {
46
delete object $tab
47
}
48
set indexDeleted [lsearch -exact $windowList $window]
49
set windowList [lreplace $windowList $indexDeleted $indexDeleted]
50
return
51
}
52
53
protected method setupWindow {} {
54
set window [toplevel [appendToPath $parent [namespace tail $this]]]
55
lappend windowList $window
56
wm geometry $window [join $::geometry::form {x}]
57
set noteBook [ttk::notebook $window.nb -takefocus 0]
58
set tabOpen [OpenTab "#auto" $noteBook $this]
59
addNotebookTab $noteBook [$tabOpen cget -widget] tabOpen
60
lappend tabList $tabOpen
61
set tabObject([$tabOpen cget -widget]) $tabOpen
62
pack $noteBook -side top -expand 1 -fill both
63
pack [ttk::sizegrip ${window}.sg] -side top -anchor e
64
ttk::notebook::enableTraversal $noteBook
65
bind $noteBook <<NotebookTabChanged>> [list $this onTabChange]
66
set tpOnly [bindToplevelOnly $window <Destroy> [list delete object $this]]
67
bind $tpOnly <Configure> {set ::geometry::form {%w %h}}
68
return
69
}
70
71
public method removeTab {removedTab} {
72
set indexDeleted [lsearch -exact $tabList $removedTab]
73
if {$indexDeleted >= 0} then {
74
set tabList [lreplace $tabList $indexDeleted $indexDeleted]
75
}
76
delete object $removedTab
77
if {[llength $tabList] == 0} then {
78
destroy $window
79
} else {
80
[lindex $tabList end] setTabLock 0
81
}
82
return
83
}
84
85
public method deleteTabsAbove {tab} {
86
set thisTabIdx [lsearch -exact $tabList $tab]
87
foreach tabAbove [lrange $tabList [expr $thisTabIdx + 1] end] {
88
delete object $tabAbove
89
}
90
set tabList [lrange $tabList 0 $thisTabIdx]
91
return
92
}
93
94
public method newFormTab {newFormName formDefDict history} {
95
[lindex $tabList end] setTabLock 1
96
set newTab [FormTab "#auto" $noteBook $this $newFormName \
97
$formDefDict $history]
98
lappend tabList $newTab
99
set widget [$newTab cget -widget]
100
set tabObject($widget) $newTab
101
$noteBook add $widget -text $newFormName
102
$noteBook select $widget
103
return
104
}
105
106
public method getTabList {} {
107
return $tabList
108
}
109
110
public method onTabChange {} {
111
set selectedTab $tabObject([$noteBook select])
112
focus [$noteBook select]
113
$selectedTab tabSelected
114
return
115
}
116
117
public method setMenubar {menubar} {
118
$window configure -menu $menubar
119
return
120
}
121
122
public method setTitle {title} {
123
wm title $window $title
124
return
125
}
126
127
}
128
129
class GenTab {
130
public variable widget
131
protected variable parent
132
protected variable formWindow
133
public variable formWinPath
134
protected variable formName
135
protected variable menubar
136
protected variable mnForm
137
protected variable title
138
protected variable tabLock 0
139
protected variable tabStatus
140
protected variable btnCloseTab
141
protected variable btnUnlockTab
142
protected variable tabStatBar
143
144
constructor {c_parent c_formWindow c_formName} {
145
set parent $c_parent
146
set formWindow $c_formWindow
147
set formName $c_formName
148
set formWinPath [$formWindow cget -window]
149
set widget [ttk::frame [appendToPath $parent [namespace tail $this]] \
150
-takefocus 0]
151
set tabStatBar [ttk::frame $widget.sb]
152
set tabStatus [ttk::label $tabStatBar.lbl -text {} \
153
-foreground {red3}]
154
set btnCloseTab [defineButton $tabStatBar.btnClose $widget \
155
btnCloseTab [list $this closeTab]]
156
$btnCloseTab configure -style SButton
157
set btnUnlockTab [defineButton $tabStatBar.btnUnlock $widget \
158
btnUnlockTab [list $this unlockTab]]
159
$btnUnlockTab configure -style SButton
160
$btnUnlockTab state {disabled}
161
grid $tabStatus -column 0 -row 0
162
grid $btnUnlockTab -column 1 -row 0 -pady {5 5}
163
grid $btnCloseTab -column 2 -row 0 -pady {5 5}
164
grid columnconfigure $tabStatBar 0 -weight 1
165
pack $tabStatBar -side top -fill x
166
set menubar [menu [appendToPath $formWinPath \
167
mb[namespace tail $this]] -tearoff 0]
168
set mnForm [menu $menubar.mnForm -tearoff 0]
169
addMenuItem $mnForm mnuUnlockTab command [list $this unlockTab]
170
$mnForm entryconfigure 0 -state disabled -accelerator {Esc}
171
addMenuItem $mnForm mnuCloseTab command [list $this closeTab]
172
$mnForm entryconfigure 1 -accelerator {Esc}
173
$mnForm add separator
174
addMenuItem $mnForm mnuCloseForm command [list destroy $formWinPath]
175
addMenuItem $menubar mnuForm cascade $mnForm
176
set title "pfm - [$::dbObject cget -dbname]: $formName"
177
bind $widget <KeyPress-Escape> [list $this onEscape]
178
return
179
}
180
181
destructor {
182
# $formWindow tabDestroyed [namespace tail $this]
183
destroy $widget
184
return
185
}
186
187
public method tabSelected {} {
188
$formWindow setMenubar $menubar
189
$formWindow setTitle $title
190
return
191
}
192
193
public method onEscape {} {
194
if {!$tabLock} then {
195
closeTab
196
} else {
197
unlockTab
198
}
199
return
200
}
201
202
public method unlockTab {} {
203
$formWindow deleteTabsAbove [namespace tail $this]
204
setTabLock 0
205
return
206
}
207
208
public method closeTab {} {
209
$formWindow removeTab [namespace tail $this]
210
return
211
}
212
213
public method setTabLock {state} {
214
set tabLock $state
215
if {$state} then {
216
$tabStatus configure -text [mc lbTabLocked]
217
$btnCloseTab state {disabled}
218
$btnUnlockTab state {!disabled}
219
$mnForm entryconfigure 0 -state normal
220
$mnForm entryconfigure 1 -state disabled
221
} else {
222
$tabStatus configure -text {}
223
$btnCloseTab state {!disabled}
224
$btnUnlockTab state {disabled}
225
$mnForm entryconfigure 0 -state disabled
226
$mnForm entryconfigure 1 -state normal
227
}
228
$this propagateTabLock $state
229
return
230
}
231
232
}
233
234
class OpenTab {
235
inherit GenTab
236
protected variable formDef
237
protected variable attribDef
238
protected variable attribList
239
protected variable modAttribList
240
protected variable whereSelected 1
241
protected variable txt
242
protected variable btnRun
243
protected variable rbWhere
244
protected variable rbOrderby
245
protected variable pasteValueMenu 0
246
protected variable listBoxList {}
247
248
constructor {c_parent c_formWindow} \
249
{GenTab::constructor $c_parent $c_formWindow [$c_formWindow cget -formName]} {
250
getFormDef $::dbObject $formName $formWinPath formDef
251
getAttribDef $::dbObject $formName $formWinPath \
252
attribDef attribList modAttribList
253
setupWidget
254
}
255
256
destructor {
257
deleteAllListBoxes
258
}
259
260
protected method setupWidget {} {
261
# define menus
262
set mnPasteName [menu $menubar.mnPasteName -tearoff 0]
263
foreach attrib $attribList {
264
$mnPasteName add command -label $attrib \
265
-command [list $this pasteName $attrib]
266
}
267
set mnPasteValue [menu $menubar.mnPasteValue -tearoff 0]
268
set pasteValueMenu 0
269
foreach attrib $attribList {
270
if {$attribDef($attrib,typeofget) in {tgLink tgList}} then {
271
$mnPasteValue add command -label $attrib \
272
-command [list $this pasteValue $attrib]
273
set pasteValueMenu 1
274
}
275
}
276
addMenuItem $menubar mnuPasteName cascade $mnPasteName
277
addMenuItem $menubar mnuPasteValue cascade $mnPasteValue
278
if {!$pasteValueMenu} then {
279
$menubar entryconfigure 2 -state disabled
280
}
281
set frmQuery [ttk::frame $widget.frmquery]
282
foreach field {Query Where Orderby} {
283
set txt($field) [text $frmQuery.txt$field -width 1 -height 1 \
284
-wrap word]
285
set vsb($field) [ttk::scrollbar $frmQuery.vsb$field \
286
-orient vertical -command [list $txt($field) yview]]
287
$txt($field) configure -yscrollcommand [list $vsb($field) set]
288
}
289
$txt(Query) configure -takefocus 0
290
$txt(Query) insert end "SELECT $formDef(sqlselect)\n"
291
$txt(Query) insert end "FROM $formDef(sqlfrom)\n"
292
if {$formDef(groupby) ne {}} then {
293
$txt(Query) insert end "GROUP BY $formDef(groupby)\n"
294
}
295
if {$formDef(sqllimit) ne {}} then {
296
$txt(Query) insert end "LIMIT $formDef(sqllimit)\n"
297
}
298
$txt(Query) configure -state disabled \
299
-background $::readonlyBackground
300
if {$formDef(sqlorderby) ne {}} then {
301
$txt(Orderby) insert end $formDef(sqlorderby)
302
}
303
set rbWhere [ttk::radiobutton $frmQuery.rbWhere \
304
-text WHERE -underline 0 -variable [scope whereSelected] \
305
-value 1 -command [list focus $txt(Where)] -takefocus 0]
306
if {$formDef(groupby) ne {}} then {
307
$rbWhere configure -text HAVING
308
}
309
set rbOrderby [ttk::radiobutton $frmQuery.rbOrderby \
310
-text {ORDER BY} -underline 0 -variable [scope whereSelected] \
311
-value 0 -command [list focus $txt(Orderby)] -takefocus 0]
312
grid $txt(Query) -column 0 -columnspan 2 -row 0 -sticky wens
313
grid $vsb(Query) -column 2 -row 0 -sticky ns
314
grid $rbWhere -column 0 -row 1 -sticky n
315
grid $txt(Where) -column 1 -row 1 -sticky wens
316
grid $vsb(Where) -column 2 -row 1 -sticky ns
317
grid $rbOrderby -column 0 -row 2 -sticky n
318
grid $txt(Orderby) -column 1 -row 2 -sticky wens
319
grid $vsb(Orderby) -column 2 -row 2 -sticky ns
320
grid columnconfigure $frmQuery 1 -weight 1
321
grid rowconfigure $frmQuery 0 -weight 2
322
foreach row {1 2} {
323
grid rowconfigure $frmQuery $row -weight 1
324
}
325
bind $txt(Where) <FocusIn> [list set [scope whereSelected] 1]
326
bind $txt(Orderby) <FocusIn> [list set [scope whereSelected] 0]
327
focus $txt(Where)
328
set btnRun [defineButton $frmQuery.btnRun $widget btnRun \
329
[list $this onRun]]
330
grid $btnRun -column 0 -columnspan 3 -row 3 -sticky e \
331
-pady {10 10} -padx {10 10}
332
pack $frmQuery -side top -expand 1 -fill both
333
# The following makes $widget receive all events that are sent
334
# to its children. This makes it possible to bind keyboard
335
# shortcuts that apply to the frame of this tab only
336
recursiveAppendTag $widget $widget
337
if {$formDef(groupby) ne {}} then {
338
bind $widget <Alt-KeyPress-h> \
339
[list $rbWhere instate {!disabled} [list $rbWhere invoke]]
340
} else {
341
bind $widget <Alt-KeyPress-w> \
342
[list $rbWhere instate {!disabled} [list $rbWhere invoke]]
343
}
344
bind $widget <Alt-KeyPress-o> \
345
[list $rbOrderby instate {!disabled} [list $rbOrderby invoke]]
346
return
347
}
348
349
public method propagateTabLock {state} {
350
if {$state} then {
351
$rbWhere state {disabled}
352
$rbOrderby state {disabled}
353
$txt(Where) configure -state disabled
354
$txt(Orderby) configure -state disabled
355
$btnRun state {disabled}
356
$menubar entryconfigure 1 -state disabled
357
$menubar entryconfigure 2 -state disabled
358
} else {
359
$rbWhere state {!disabled}
360
$rbOrderby state {!disabled}
361
$txt(Where) configure -state normal
362
$txt(Orderby) configure -state normal
363
$btnRun state {!disabled}
364
$menubar entryconfigure 1 -state normal
365
if {$pasteValueMenu} then {
366
$menubar entryconfigure 2 -state normal
367
}
368
}
369
return
370
}
371
372
public method onRun {} {
373
deleteAllListBoxes
374
set formDef(sqlwhere) [string trim [$txt(Where) get 1.0 end]]
375
set formDef(sqlorderby) [string trim [$txt(Orderby) get 1.0 end]]
376
setTabLock 1
377
set history [dict create from {} link {} to [mc histOpenForm $formName]]
378
$formWindow newFormTab $formName [array get formDef] [list $history]
379
return
380
}
381
382
public method pasteName {attrib} {
383
if {$whereSelected} then {
384
$txt(Where) insert insert "\"${attrib}\""
385
} else {
386
$txt(Orderby) insert insert "\"${attrib}\""
387
}
388
return
389
}
390
391
public method pasteValue {attrib} {
392
switch -- $attribDef($attrib,typeofget) {
393
tgLink {
394
set query $attribDef($attrib,sqlselect)
395
}
396
tgList {
397
set query "SELECT value, description FROM pfm_value "
398
append query "WHERE valuelist = '$attribDef($attrib,valuelist)' "
399
append query "ORDER BY value"
400
}
401
default {
402
set query {}
403
}
404
}
405
if {[$::dbObject select_query_list $query numTuples headerList valueList errMsg]} then {
406
set lsbTitle [mc selectValueFor $attrib]
407
set lsb [ListBox "#auto" $formWinPath $lsbTitle $headerList \
408
$valueList 0]
409
lappend listBoxList [list $lsb $attrib]
410
if {[$lsb wait result]} then {
411
if {$attribDef($attrib,typeofattrib) eq {taQuoted}} then {
412
set value "'[lindex $result 0]'"
413
} else {
414
set value [lindex $result 0]
415
}
416
if {$whereSelected} then {
417
$txt(Where) insert insert $value
418
} else {
419
$txt(Orderby) insert insert $value
420
}
421
}
422
set lsbToRemove [lsearch -exact -index 0 $listBoxList $lsb]
423
set listBoxList [lreplace $listBoxList $lsbToRemove $lsbToRemove]
424
} else {
425
pfm_message $errMsg $formWinPath
426
}
427
return
428
}
429
430
public method deleteAllListBoxes {} {
431
foreach lsb $listBoxList {
432
[lindex $lsb 0] destroyWindow
433
}
434
return
435
}
436
437
}
438
439
class FormTab {
440
inherit GenTab
441
protected variable formDef
442
protected variable history
443
protected variable attribDef
444
protected variable attribList
445
protected variable modAttribList
446
protected variable linkDef
447
protected variable lastLink
448
protected variable frmHistory
449
protected variable txtHistory
450
protected variable canvas
451
protected variable frmForm
452
protected variable frmButtons
453
protected variable btnArray
454
protected variable btnSelect
455
protected variable txtMessages
456
protected variable control
457
protected variable formState {browse}
458
protected variable statusbar
459
protected variable sbNr
460
protected variable sbStatus
461
protected variable buffer
462
protected variable record
463
protected variable recordIdx
464
protected variable textEditList
465
protected variable listBoxList
466
protected variable matchCase 0
467
protected variable searchPattern
468
protected variable searchAttribute
469
protected variable searchFrame {}
470
471
472
constructor {c_parent c_formWindow c_formName formDefDict c_history} \
473
{GenTab::constructor $c_parent $c_formWindow $c_formName} {
474
array set formDef $formDefDict
475
set history $c_history
476
set textEditList(0) {}
477
set textEditList(1) {}
478
set listBoxList {}
479
getAttribDef $::dbObject $formName $formWinPath \
480
attribDef attribList modAttribList
481
getLinkDef $::dbObject $formName $formWinPath linkDef lastLink
482
# Bug 1070:
483
# "record" is a Tcl array which always contains the current
484
# record. Originally, the array elements record($attrib) were
485
# bound to the entry widgets of the form and the element names
486
# were the attribute names. However, a bug in Itcl caused the
487
# attribute value not to be displayed if the attribute name
488
# consists of more than one word. Therefore, the following work
489
# around is implemented. Instead of record($attrib),
490
# record($recordIdx($attrib)) is bound to the form's entry
491
# widgets where recordIdx acts as a conversion table which maps
492
# the attribute names ($attrib) to integers.
493
# recordIdx is initialised here.
494
set index 1
495
foreach attrib $attribList {
496
set recordIdx($attrib) $index
497
incr index
498
}
499
setupWidget
500
set buffer [FormBuf "#auto" [array get formDef] [array get attribDef] \
501
$this $attribList $modAttribList]
502
$buffer getFirstRecord record recNr status
503
updateStatusBar $recNr $status
504
return
505
}
506
507
destructor {
508
delete object $buffer
509
deleteAllTextEdits 0
510
deleteAllTextEdits 1
511
deleteAllListBoxes
512
return
513
}
514
515
public method propagateTabLock {state} {
516
if {$state} then {
517
if {$formDef(view) eq {f}} then {
518
foreach op {Update Add Delete} {
519
$btnArray($op) state {disabled}
520
}
521
}
522
disableBrowseMenus
523
for {set link 0} {$link <= $lastLink} {incr link} {
524
$btnArray($link) state {disabled}
525
}
526
527
bind $widget <KeyPress-Next> {}
528
bind $widget <KeyPress-Prior> {}
529
bind $widget <KeyPress-Right> {}
530
bind $widget <KeyPress-Left> {}
531
bind $widget <KeyPress-Home> {}
532
bind $widget <KeyPress-End> {}
533
foreach btn {Home Prev Next End} {
534
$btnArray($btn) state {disabled}
535
}
536
bind $widget <KeyPress-F3> {}
537
if {$searchFrame ne {}} then {
538
foreach op {FindNext Hide} {
539
$btnArray($op) state {disabled}
540
}
541
}
542
} else {
543
if {$formDef(view) eq {f}} then {
544
foreach op {Update Add Delete} {
545
$btnArray($op) state {!disabled}
546
}
547
}
548
for {set link 0} {$link <= $lastLink} {incr link} {
549
$btnArray($link) state {!disabled}
550
}
551
enableBrowseMenus
552
bind $widget <KeyPress-Next> [list $this nextRecord]
553
bind $widget <KeyPress-Prior> [list $this prevRecord]
554
bind $widget <KeyPress-Right> [list $this nextRecord]
555
bind $widget <KeyPress-Left> [list $this prevRecord]
556
bind $widget <KeyPress-Home> [list $this firstRecord]
557
bind $widget <KeyPress-End> [list $this lastRecord]
558
foreach btn {Home Prev Next End} {
559
$btnArray($btn) state {!disabled}
560
}
561
bind $widget <KeyPress-F3> [list $this searchForRecord]
562
if {$searchFrame ne {}} then {
563
foreach op {FindNext Hide} {
564
$btnArray($op) state {!disabled}
565
}
566
}
567
}
568
return
569
}
570
571
public method mouseWheel {platform arg} {
572
switch $platform {
573
windows {
574
if {$arg < 0} then {
575
set direction 1
576
} else {
577
set direction -1
578
}
579
}
580
unix {
581
set direction $arg
582
}
583
}
584
set mouse_x [winfo pointerx $formWinPath]
585
set mouse_y [winfo pointery $formWinPath]
586
set x1 [winfo rootx $frmForm]
587
set y1 [winfo rooty $frmForm]
588
set x2 [expr $x1 + [winfo width $frmForm]]
589
set y2 [expr $y1 + [winfo height $frmForm]]
590
if {($x1 <= $mouse_x) && ($mouse_x <= $x2) && \
591
($y1 <= $mouse_y) && ($mouse_y <= $y2)} then {
592
$canvas yview scroll $direction unit
593
}
594
return
595
}
596
597
public method scrollForm {i} {
598
599
# Scroll form such that attribute i is visible in the middle
600
# of the form.
601
#
602
# Let: n1 be index of first visible attribute before scrolling
603
# n2 be index of last visible attribute before scrolling
604
# nn1 be index of first visible attribute after scrolling
605
# nn2 be index of last visible attribute after scrolling
606
# f1 = 1st fraction returned by yview before scrolling (known)
607
# f2 = 2nd fraction returned by yview before scrolling (known)
608
# nf1 = 1st fraction to be given to yview for scrolling
609
# nf2 = 2nd fraction returned by yview after scrolling
610
# n = nr of attributes on form (known)
611
# i = index of attribute with input focus (arg of function)
612
# s = number of visible attributes on screen
613
# Known data:
614
# n, f1, f2, i
615
# To be calculated:
616
# nf1
617
# Calculation:
618
# f1 = (y-coord of first visible horizontal line)
619
# /(height of canvas)
620
# = (n1 + 1)/(n + 2)
621
# f2 = (y-coord of last visible horizontal line)
622
# /(height of canvas)
623
# = (n2 + 1)/(n + 2)
624
# -- to take into account the empty space at top and bottom
625
# -- we assume 2 dummy attributes, one at top (index "-1"),
626
# -- one at bottom (index "n")
627
# n1 = (n + 2) * f1 - 1
628
# n2 = (n + 2) * f2 - 1
629
# s = n2 - n1 + 1
630
# = (n + 2) * (f2 - f1) + 1 (1)
631
# Afters scrolling, same relationship:
632
# nn1 = (n + 2) * nf1 - 1
633
# nn2 = (n + 2) * nf2 - 1
634
# s = (n + 2) * (nf2 - nf1) + 1 (2)
635
# After scrolling we want i to be in the middle between nn1 and nn2
636
# i = (nn1 + nn2)/2
637
# = (nf1 + nf2) * (n + 2)/2 - 1 (3)
638
# s we can calculate with (1)
639
# From (2) and (3) it follows:
640
# nf1 = (2*i - s + 3)/(2 * (n + 2))
641
642
set n [llength $attribList]
643
set yviewList [$canvas yview]
644
set f1 [lindex $yviewList 0]
645
set f2 [lindex $yviewList 1]
646
set s [expr ($n + 2) * ($f2 - $f1) + 1.0]
647
set nf1 [expr (2.0*$i - $s + 3.0)/(2.0 * ($n + 2.0))]
648
if {$nf1 < 0} then {
649
set nf1 0
650
}
651
if {$nf1 > 1} then {
652
set nf1 1
653
}
654
$canvas yview moveto $nf1
655
return
656
}
657
658
public method showError {message} {
659
$txtMessages configure -state normal
660
$txtMessages insert end "${message}\n" red
661
$txtMessages see end
662
$txtMessages configure -state disabled
663
bell
664
return
665
}
666
667
public method showQuery {intro query result resultColor} {
668
$txtMessages configure -state normal
669
$txtMessages insert end "${intro}\n" blue
670
$txtMessages insert end "${query}\n"
671
$txtMessages insert end "${result}\n" $resultColor
672
$txtMessages see end
673
$txtMessages configure -state disabled
674
if {$resultColor eq {red}} then {
675
bell
676
}
677
return
678
}
679
680
public method firstRecord {} {
681
if {(!$tabLock) && ($formState eq {browse})} then {
682
$buffer getFirstRecord record recNr status
683
updateStatusBar $recNr $status
684
updateAllTextEdits 1
685
}
686
return
687
}
688
689
public method lastRecord {} {
690
if {(!$tabLock) && ($formState eq {browse})} then {
691
$buffer getLastRecord record recNr status
692
updateStatusBar $recNr $status
693
updateAllTextEdits 1
694
}
695
return
696
}
697
698
public method nextRecord {} {
699
if {(!$tabLock) && ($formState eq {browse})} then {
700
$buffer getNextRecord record recNr status
701
updateStatusBar $recNr $status
702
updateAllTextEdits 1
703
}
704
return
705
}
706
707
public method prevRecord {} {
708
if {(!$tabLock) && ($formState eq {browse})} then {
709
$buffer getPrevRecord record recNr status
710
updateStatusBar $recNr $status
711
updateAllTextEdits 1
712
}
713
return
714
}
715
716
public method onExpand {attrib} {
717
if {$formState eq {browse}} then {
718
set readOnly 1
719
} else {
720
set readOnly 0
721
}
722
set textEdit [TextEdit "#auto" $formWinPath $attrib \
723
$record($recordIdx($attrib)) $readOnly]
724
lappend textEditList($readOnly) [list $textEdit $attrib]
725
$textEdit defineCallBack \
726
[list $this textEditCallBack $textEdit $attrib $readOnly]
727
return
728
}
729
730
public method textEditCallBack {textEdit attrib readOnly} {
731
$textEdit getText record($recordIdx($attrib))
732
set itemToRemove [lsearch -exact -index 0 \
733
$textEditList($readOnly) $textEdit]
734
set textEditList($readOnly) [lreplace $textEditList($readOnly) \
735
$itemToRemove $itemToRemove]
736
return
737
}
738
739
public method onUpdate {} {
740
if {[$buffer getStatus] ni {statAfterLast statNotAdded statDeleted}} then {
741
# deleteAllTextEdits 1
742
set reloaded [$buffer reloadRecord record recNr status]
743
updateStatusBar $recNr $status
744
updateAllTextEdits 1
745
if {$reloaded} then {
746
setFormState update
747
} else {
748
pfm_message [mc reloadFailed] $formWinPath
749
}
750
}
751
return
752
}
753
754
public method onAdd {} {
755
# deleteAllTextEdits 1
756
foreach attrib $modAttribList {
757
if {$attribDef($attrib,default) ne {}} then {
758
if {[string index $attribDef($attrib,default) 0] eq {=}} then {
759
set query [string range $attribDef($attrib,default) 1 end]
760
if {[$::dbObject select_query_list $query numTuples \
761
namesList tuples errMsg]} then {
762
showQuery [mc getDefaultValue $attrib] \
763
$query [mc queryOK] green
764
if {$numTuples == 1} then {
765
set record($recordIdx($attrib)) [lindex $tuples 0 0]
766
} else {
767
showError [mc defaultNumTuplesErr $attrib $numTuples]
768
}
769
} else {
770
showQuery [mc getDefaultValue $attrib] \
771
$query $errMsg red
772
}
773
} else {
774
set record($recordIdx($attrib)) $attribDef($attrib,default)
775
}
776
}
777
}
778
setFormState add
779
return
780
}
781
782
public method onDelete {} {
783
if {[$buffer getStatus] ni {statAfterLast statNotAdded statDeleted}} then {
784
# deleteAllTextEdits 1
785
set reloaded [$buffer reloadRecord record recNr status]
786
updateStatusBar $recNr $status
787
if {$status ni {statAfterLast statNotAdded statDeleted}} then {
788
set arg [dict create \
789
parent $formWinPath \
790
title [mc questionDeleteTitle] \
791
message [mc questionDeleteMessage] \
792
msgWidth 400 \
793
defaultButton btnNo \
794
buttonList {btnYes btnNo}]
795
set dlg [GenDialog "#auto" $arg]
796
if {[$dlg wait] eq {btnYes}} then {
797
$buffer deleteRecord record recNr status
798
updateStatusBar $recNr $status
799
updateAllTextEdits 1
800
}
801
}
802
}
803
return
804
}
805
806
public method onOK {} {
807
if {[llength $textEditList(0)] > 0} then {
808
set attributes {}
809
foreach item $textEditList(0) {
810
append attributes "[lindex $item 1]\n"
811
}
812
pfm_message [mc editWindowsOpen $attributes] $formWinPath
813
} else {
814
if {[llength $listBoxList] > 0} then {
815
set attributes {}
816
foreach item $listBoxList {
817
append attributes "[lindex $item 1]\n"
818
}
819
pfm_message [mc listBoxOpen $attributes] $formWinPath
820
} else {
821
switch -- $formState {
822
"update" {
823
$buffer updateRecord record
824
$buffer reloadRecord record recNr status
825
updateStatusBar $recNr $status
826
updateAllTextEdits 1
827
}
828
"add" {
829
if {[$buffer addRecord record]} then {
830
$buffer reloadRecord record recNr status
831
updateStatusBar $recNr $status
832
updateAllTextEdits 1
833
} else {
834
updateStatusBar {} statNotAdded
835
updateAllTextEdits 1
836
}
837
}
838
}
839
setFormState browse
840
}
841
}
842
return
843
}
844
845
public method onCancel {} {
846
deleteAllListBoxes
847
deleteAllTextEdits 0
848
setFormState browse
849
$buffer getCurRecord record recNr status
850
updateStatusBar $recNr $status
851
return
852
}
853
854
public method onSelect {attrib} {
855
switch -- $attribDef($attrib,typeofget) {
856
tgLink {
857
set query $attribDef($attrib,sqlselect)
858
}
859
tgList {
860
set query "SELECT value, description FROM pfm_value "
861
append query "WHERE valuelist = '$attribDef($attrib,valuelist)' "
862
append query "ORDER BY value"
863
}
864
default {
865
set query {}
866
}
867
}
868
if {[$::dbObject select_query_list $query numTuples headerList valueList errMsg]} then {
869
set lsbTitle [mc selectValueFor $attrib]
870
set selected [lsearch -exact -index 0 $valueList $record($recordIdx($attrib))]
871
if {$selected < 0} then {
872
set selected 0
873
}
874
set lsb [ListBox "#auto" $formWinPath $lsbTitle $headerList \
875
$valueList $selected]
876
lappend listBoxList [list $lsb $attrib]
877
if {[$lsb wait result]} then {
878
set record($recordIdx($attrib)) [lindex $result 0]
879
}
880
set lsbToRemove [lsearch -exact -index 0 $listBoxList $lsb]
881
set listBoxList [lreplace $listBoxList $lsbToRemove $lsbToRemove]
882
} else {
883
pfm_message $errMsg $formWinPath
884
}
885
return
886
}
887
888
public method followLink {link} {
889
if {!$tabLock && \
890
([$buffer getStatus] ni {statDeleted statAfterLast statNotAdded})} then {
891
set from $formName
892
set displayValues {}
893
foreach attrib $linkDef($link,displayattrib) {
894
lappend displayValues $record($recordIdx($attrib))
895
}
896
set displayValues [join $displayValues {, }]
897
append from " (${displayValues})"
898
set to "$linkDef($link,toform)"
899
set newEntry [dict create from $from link \
900
$linkDef($link,linkname) to $linkDef($link,toform)]
901
set newhistory $history
902
lappend newhistory $newEntry
903
array unset toformDef
904
if {[getFormDef $::dbObject $linkDef($link,toform) \
905
$formWinPath toformDef]} then {
906
set toformDef(sqlwhere) [expandSqlWhere $link]
907
# Next statement added for bug 1072
908
set toformDef(sqlorderby) $linkDef($link,orderby)
909
$formWindow newFormTab $linkDef($link,toform) \
910
[array get toformDef] $newhistory
911
}
912
}
913
return
914
}
915
916
public method onSearch {attrib} {
917
if {$searchFrame eq {}} then {
918
set searchFrame [setupsearchbar $frmHistory $attrib]
919
pack $searchFrame -side top -fill x
920
} else {
921
set searchAttribute $attrib
922
}
923
return
924
}
925
926
public method onSearchHide {} {
927
if {$searchFrame ne {}} then {
928
destroy $searchFrame
929
set searchFrame {}
930
focus [tk_focusNext [focus]]
931
}
932
return
933
}
934
935
public method searchForRecord {} {
936
if {($formState eq {browse}) && ($searchFrame ne {}) && !$tabLock} then {
937
$buffer searchRecord $searchAttribute \
938
"*${searchPattern}*" $matchCase
939
$buffer getCurRecord record recNr status
940
updateStatusBar $recNr $status
941
updateAllTextEdits 1
942
}
943
return
944
}
945
946
public method onHelp {} {
947
set query "SELECT help FROM pfm_form WHERE name = '${formName}'"
948
if {[$::dbObject select_query_list $query numTuples \
949
names tuples errMsg]} then {
950
if {$numTuples == 1} then {
951
set txtEdit [TextEdit "#auto" $formWinPath \
952
[mc formHelp $formName] [lindex $tuples 0 0] 1]
953
}
954
} else {
955
pfm_message $errMsg $formWinPath
956
}
957
return
958
}
959
960
protected method setupWidget {} {
961
setupMenus
962
set vpanes [ttk::panedwindow $widget.vpanes -orient vertical]
963
set frmHistory [historyPane $vpanes]
964
set hpanes [ttk::panedwindow $vpanes.hpanes -orient horizontal]
965
set frmForm [formPane $hpanes]
966
set frmLink [linkPane $hpanes]
967
$hpanes add $frmForm -weight 6
968
$hpanes add $frmLink -weight 1
969
set frmMessages [messagePane $vpanes]
970
$vpanes add $frmHistory -weight 1
971
$vpanes add $hpanes -weight 3
972
$vpanes add $frmMessages -weight 1
973
pack $vpanes -side top -expand 1 -fill both
974
recursiveAppendTag $widget $widget
975
update
976
set bbox [$canvas bbox all]
977
set rightEdge [expr [lindex $bbox 2] + 20]
978
set bottomEdge [expr [lindex $bbox 3] + 20]
979
$canvas configure -scrollregion [list 0 0 $rightEdge $bottomEdge]
980
bind $widget <KeyPress-Next> [list $this nextRecord]
981
bind $widget <KeyPress-Prior> [list $this prevRecord]
982
bind $widget <KeyPress-Right> [list $this nextRecord]
983
bind $widget <KeyPress-Left> [list $this prevRecord]
984
bind $widget <KeyPress-Home> [list $this firstRecord]
985
bind $widget <KeyPress-End> [list $this lastRecord]
986
bind $widget <KeyPress-Up> {focus [tk_focusPrev [focus]]}
987
bind $widget <KeyPress-Down> {focus [tk_focusNext [focus]]}
988
showHistory
989
return
990
}
991
992
protected method setupMenus {} {
993
set mnRecord [menu $menubar.record -tearoff 0]
994
foreach op {Update Add Delete} {
995
addMenuItem $mnRecord mnu${op}Record command [list $this on$op]
996
}
997
set mnGoTo [menu $menubar.goto -tearoff 0]
998
foreach dir {next prev first last} {
999
addMenuItem $mnGoTo mnuGoTo$dir command [list $this ${dir}Record]
1000
}
1001
$mnGoTo entryconfigure 0 -accelerator {PgDn}
1002
$mnGoTo entryconfigure 1 -accelerator {PgUp}
1003
$mnGoTo entryconfigure 2 -accelerator {Home}
1004
$mnGoTo entryconfigure 3 -accelerator {End}
1005
set mnSearch [menu $menubar.search -tearoff 0]
1006
foreach attrib $attribList {
1007
$mnSearch add command -label $attrib \
1008
-command [list $this onSearch $attrib]
1009
}
1010
$mnSearch add separator
1011
$mnSearch add checkbutton \
1012
-label [lindex [mcunderline mnuSearchCase] 0] \
1013
-underline [lindex [mcunderline mnuSearchCase] 1] \
1014
-variable [scope matchCase] -onvalue 1 -offvalue 0 \
1015
-indicatoron 1 -selectcolor black
1016
$mnSearch add separator
1017
addMenuItem $mnSearch mnuSearchHide command [list $this onSearchHide]
1018
addMenuItem $menubar mnuRecordMenu cascade $mnRecord
1019
addMenuItem $menubar mnuGoToMenu cascade $mnGoTo
1020
addMenuItem $menubar mnuSearchMenu cascade $mnSearch
1021
addMenuItem $menubar mnuFormHelp command [list $this onHelp]
1022
if {$formDef(view) eq {t}} then {
1023
$menubar entryconfigure 1 -state disabled
1024
}
1025
return
1026
}
1027
1028
protected method enableBrowseMenus {} {
1029
if {$formDef(view) eq {f}} then {
1030
$menubar entryconfigure 1 -state normal
1031
}
1032
foreach item {2 3} {
1033
$menubar entryconfigure $item -state normal
1034
}
1035
return
1036
}
1037
1038
protected method disableBrowseMenus {} {
1039
foreach item {1 2 3} {
1040
$menubar entryconfigure $item -state disabled
1041
}
1042
return
1043
}
1044
1045
protected method historyPane {parent} {
1046
set frm [ttk::frame $parent.frmhistory]
1047
set frm2 [ttk::frame $frm.frm2]
1048
set txtHistory [text $frm2.txt -width 1 -height 1 \
1049
-takefocus 0 -state disabled]
1050
set vsbHistory [ttk::scrollbar $frm2.vsb -orient vertical \
1051
-command [list $txtHistory yview]]
1052
$txtHistory configure -yscrollcommand [list $vsbHistory set]
1053
$txtHistory tag configure blue -foreground {medium blue}
1054
$txtHistory tag configure red -foreground {red3}
1055
$txtHistory tag configure green -foreground {green4}
1056
pack $txtHistory -side left -expand 1 -fill both
1057
pack $vsbHistory -side left -fill y
1058
pack $frm2 -side top -expand 1 -fill both
1059
return $frm
1060
}
1061
1062
protected method formPane {parent} {
1063
global tcl_platform
1064
set frmForm [ttk::frame $parent.frmform -borderwidth 1 -relief raised]
1065
# relief modified
1066
set statusbar [ttk::frame $frmForm.sb]
1067
set frmRecNr [ttk::frame $statusbar.frmRecNr]
1068
set btnArray(Home) [ttk::button $frmRecNr.btnHome -image ::img::arrow_home \
1069
-command [list $this firstRecord] -style SButton -takefocus 0]
1070
set btnArray(Prev) [ttk::button $frmRecNr.btnPrev -image ::img::arrow_left \
1071
-command [list $this prevRecord] -style SButton -takefocus 0]
1072
set sbNr [ttk::label $frmRecNr.sbnr -text {0/0} \
1073
-background white]
1074
set btnArray(Next) [ttk::button $frmRecNr.btnNext -image ::img::arrow_right \
1075
-command [list $this nextRecord] -style SButton -takefocus 0]
1076
set btnArray(End) [ttk::button $frmRecNr.btnEnd -image ::img::arrow_end \
1077
-command [list $this lastRecord] -style SButton -takefocus 0]
1078
pack $btnArray(Home) -side left
1079
pack $btnArray(Prev) -side left
1080
pack $sbNr -side left -padx {8 8}
1081
pack $btnArray(Next) -side left
1082
pack $btnArray(End) -side left
1083
set sbForm [ttk::label $statusbar.sbform -text $formName \
1084
-foreground {medium blue}]
1085
set sbStatus [ttk::label $statusbar.sbStatus -text {state}]
1086
grid $frmRecNr -column 0 -row 0 -sticky w
1087
grid $sbForm -column 1 -row 0
1088
grid $sbStatus -column 2 -row 0 -sticky e
1089
grid columnconfigure $statusbar 0 -weight 1
1090
grid columnconfigure $statusbar 1 -weight 1
1091
grid columnconfigure $statusbar 2 -weight 1
1092
set frmBody [ttk::frame $frmForm.frmbody -borderwidth 2 \
1093
-relief sunken]
1094
set canvas [canvas $frmBody.canvas -width 100 -height 100]
1095
set canvsb [ttk::scrollbar $frmBody.vsb -orient vertical \
1096
-command [list $canvas yview]]
1097
$canvas configure -yscrollcommand [list $canvsb set]
1098
set embWindow [formControls $canvas]
1099
$canvas create window 20 20 -window $embWindow -anchor nw
1100
pack $canvas -side left -expand 1 -fill both
1101
pack $canvsb -side left -fill y
1102
pack $statusbar -side top -fill x
1103
pack $frmBody -side top -expand 1 -fill both
1104
if {$formDef(view) eq {f}} then {
1105
set frmButtons [ttk::frame $frmForm.frmbtns]
1106
foreach op {Update Add Delete OK Cancel} {
1107
set btnArray($op) [defineButton $frmButtons.btn$op $widget btn$op \
1108
[list $this on$op]]
1109
$btnArray($op) configure -style SButton
1110
}
1111
set col 0
1112
foreach op {Update Add Delete} {
1113
grid $btnArray($op) -column $col -row 0 -pady {5 5}
1114
incr col
1115
}
1116
foreach op {OK Cancel} {
1117
$btnArray($op) state {disabled}
1118
}
1119
grid anchor $frmButtons center
1120
pack $frmButtons -side top -fill x
1121
}
1122
switch -- $tcl_platform(platform) {
1123
"windows" {
1124
bind $widget <MouseWheel> [list $this mouseWheel windows %D]
1125
}
1126
"unix" -
1127
default {
1128
# On X Window system, mouse wheel sends <4> and <5> events.
1129
bind $widget <4> [list $this mouseWheel unix -1]
1130
bind $widget <5> [list $this mouseWheel unix 1]
1131
}
1132
}
1133
return $frmForm
1134
}
1135
1136
protected method formControls {parent} {
1137
set frame [ttk::frame $parent.controls]
1138
set row 0
1139
foreach attrib $attribList {
1140
set lbl [ttk::label $frame.lbl$row -text $attrib -takefocus 0]
1141
set record($recordIdx($attrib)) {}
1142
set control($attrib) [entry $frame.ent$row -width 35 \
1143
-textvariable [scope record($recordIdx($attrib))]]
1144
$control($attrib) configure -state {readonly}
1145
bind $control($attrib) <FocusIn> [list $this scrollForm $row]
1146
set btn [defineButton $frame.btn$row $control($attrib) \
1147
btnExpand [list $this onExpand $attrib]]
1148
$btn configure -style SButton
1149
if {$attribDef($attrib,typeofget) in {tgList tgLink}} then {
1150
set btnSelect($attrib) [defineButton $frame.sel$row \
1151
$control($attrib) btnSelect \
1152
[list $this onSelect $attrib]]
1153
$btnSelect($attrib) state {disabled}
1154
$btnSelect($attrib) configure -style SButton
1155
bind $control($attrib) <KeyPress-Return> \
1156
[list $btnSelect($attrib) instate {!disabled} \
1157
[list $btnSelect($attrib) invoke]]
1158
grid $lbl -column 0 -row $row -sticky w
1159
grid $control($attrib) -column 1 -row $row -sticky wens
1160
grid $btnSelect($attrib) -column 2 -row $row -sticky we
1161
grid $btn -column 3 -row $row
1162
} else {
1163
grid $lbl -column 0 -row $row -sticky w
1164
grid $control($attrib) -column 1 -columnspan 2 \
1165
-row $row -sticky wens
1166
grid $btn -column 3 -row $row
1167
}
1168
incr row
1169
}
1170
focus $control([lindex $attribList 0])
1171
return $frame
1172
}
1173
1174
protected method linkPane {parent} {
1175
set frmLink [ttk::frame $parent.frmlink -borderwidth 1 -relief raised]
1176
# relief modified
1177
set frmTitle [ttk::frame $frmLink.frmtitle]
1178
set lbTitle [ttk::label $frmTitle.lbl -text [mc lbLinks]]
1179
pack $lbTitle -side top
1180
set linksBody [ttk::frame $frmLink.body -borderwidth 2 \
1181
-relief sunken]
1182
for {set link 0} {$link<= $lastLink} {incr link} {
1183
set btnNr [expr $link + 1]
1184
set btnArray($link) [ttk::button $linksBody.btn$btnNr \
1185
-text "${btnNr}: $linkDef($link,linkname)" \
1186
-takefocus 0 -style LButton -underline 0 \
1187
-command [list $this followLink $link]]
1188
grid $btnArray($link) -column 0 -row $link -sticky we
1189
if {$btnNr < 10} then {
1190
bind $widget <Alt-KeyPress-$btnNr> \
1191
[list after 200 [list $btnArray($link) instate {!disabled} \
1192
[list $btnArray($link) invoke]]]
1193
}
1194
}
1195
grid anchor $linksBody center
1196
pack $frmTitle -side top -fill x
1197
pack $linksBody -side top -expand 1 -fill both
1198
return $frmLink
1199
}
1200
1201
protected method messagePane {parent} {
1202
set frmMessages [ttk::frame $parent.frmmsg]
1203
set txtMessages [text $frmMessages.txt -width 1 -height 1 -takefocus 0]
1204
set vsb [ttk::scrollbar $frmMessages.vsb -orient vertical \
1205
-command [list $txtMessages yview]]
1206
$txtMessages configure -yscrollcommand [list $vsb set]
1207
$txtMessages tag configure blue -foreground {medium blue}
1208
$txtMessages tag configure red -foreground {red3}
1209
$txtMessages tag configure green -foreground {green4}
1210
pack $txtMessages -side left -expand 1 -fill both
1211
pack $vsb -side left -fill y
1212
return $frmMessages
1213
}
1214
1215
protected method setupsearchbar {parent attrib} {
1216
set searchAttribute $attrib
1217
set frm [ttk::frame $parent.frmsearch]
1218
set searchFor [ttk::label $frm.lb1 -text [mc lbSearchFor]]
1219
set searchEntry [entry $frm.entry \
1220
-textvariable [scope searchPattern]]
1221
set searchIn [ttk::label $frm.lb2 -text [mc lbSearchIn]]
1222
set searchCombo [ttk::combobox $frm.combo -values $attribList \
1223
-textvariable [scope searchAttribute] -takefocus 0]
1224
set btnArray(FindNext) [defineButton $frm.btnFindNext $widget \
1225
btnFindNext [list $this searchForRecord]]
1226
$btnArray(FindNext) configure -style SButton
1227
bind $widget <KeyPress-F3> [list $this searchForRecord]
1228
set btnCase [defineCheckbutton $frm.btncase $widget \
1229
btnMatchCase {} [scope matchCase] 1 0]
1230
set btnArray(Hide) [defineButton $frm.btnHide $widget \
1231
btnHide [list $this onSearchHide]]
1232
$btnArray(Hide) configure -style SButton
1233
recursiveAppendTag $frm $widget
1234
grid $searchIn -column 0 -row 0 -sticky w
1235
grid $searchCombo -column 1 -row 0 -sticky we
1236
grid $searchFor -column 2 -row 0 -sticky w
1237
grid $searchEntry -column 3 -row 0 -sticky we
1238
grid $btnArray(FindNext) -column 4 -row 0 -sticky e
1239
grid $btnCase -column 5 -row 0 -sticky w
1240
grid $btnArray(Hide) -column 6 -row 0 -sticky w
1241
grid columnconfigure $frm {1 3} -weight 1
1242
bind $searchEntry <KeyPress-Return> [list $this searchForRecord]
1243
focus $searchEntry
1244
return $frm
1245
}
1246
1247
protected method updateStatusBar {recNr status} {
1248
$sbNr configure -text $recNr
1249
setRecordStatus $status
1250
return
1251
}
1252
1253
protected method setRecordStatus {status} {
1254
switch -- $status {
1255
"statUpdated" -
1256
"statAdded" -
1257
"statDeleted" {
1258
set colour {green4}
1259
}
1260
"statUpdating" -
1261
"statAdding" {
1262
set colour {red3}
1263
}
1264
"statNotAdded" -
1265
"statAfterLast" {
1266
set colour {medium blue}
1267
}
1268
"statNotModified" -
1269
default {
1270
set colour {black}
1271
}
1272
}
1273
$sbStatus configure -text [mc $status] -foreground $colour
1274
return
1275
}
1276
1277
protected method expandSqlWhere {link} {
1278
set expandWhere $linkDef($link,sqlwhere)
1279
set first [string first "\$(" $expandWhere]
1280
while {$first >= 0} {
1281
set last [string first ")" $expandWhere $first]
1282
set parName [string range $expandWhere [expr $first + 2] [expr $last -1]]
1283
if {[info exists record($recordIdx($parName))]} then {
1284
set parameter [string map {' ''} $record($recordIdx($parName))]
1285
set expandWhere [string replace $expandWhere $first $last $parameter]
1286
} else {
1287
pfm_message \
1288
[mc expandSqlWhereErr $linkDef($link,linkname) $parName $formName] \
1289
$formWinPath
1290
}
1291
set first [string first "\$(" $expandWhere $last]
1292
}
1293
return $expandWhere
1294
}
1295
1296
protected method showHistory {} {
1297
$txtHistory configure -state normal
1298
$txtHistory delete 1.0 end
1299
set indent {}
1300
# first entry doesn't have 'from' and 'link'. Therefore, next loop
1301
# starts from 2nd entry
1302
foreach entry [lrange $history 1 end] {
1303
set from [dict get $entry from]
1304
$txtHistory insert end "${indent}${from}\n" blue
1305
set link [dict get $entry link]
1306
$txtHistory insert end \
1307
"${indent} | ${link}\n${indent} v\n" green
1308
append indent { }
1309
}
1310
# The 'to' only has to be printed for the last entry. Therefoe,
1311
# it is outside the previous loop
1312
set lastEntry [lindex $history end]
1313
$txtHistory insert end "${indent}[dict get $lastEntry to]" blue
1314
$txtHistory see end
1315
$txtHistory configure -state disabled
1316
return
1317
}
1318
1319
protected method setFormState {newstate} {
1320
set formState $newstate
1321
switch -- $newstate {
1322
"browse" {
1323
disableEditButtons
1324
disableEditControls
1325
enableLinkButtons
1326
enableBrowseMenus
1327
}
1328
"update" {
1329
setRecordStatus statUpdating
1330
disableLinkButtons
1331
enableEditButtons
1332
enableEditControls
1333
disableBrowseMenus
1334
}
1335
"add" {
1336
setRecordStatus statAdding
1337
disableLinkButtons
1338
enableEditButtons
1339
enableEditControls
1340
disableBrowseMenus
1341
}
1342
}
1343
return
1344
}
1345
1346
protected method disableLinkButtons {} {
1347
for {set link 0} {$link <= $lastLink} {incr link} {
1348
$btnArray($link) state {disabled}
1349
}
1350
return
1351
}
1352
1353
protected method enableLinkButtons {} {
1354
for {set link 0} {$link <= $lastLink} {incr link} {
1355
$btnArray($link) state {!disabled}
1356
}
1357
return
1358
}
1359
1360
protected method disableEditButtons {} {
1361
foreach op {OK Cancel} {
1362
$btnArray($op) state {disabled}
1363
if {$btnArray($op) in [grid slaves $frmButtons]} then {
1364
grid forget $btnArray($op)
1365
}
1366
}
1367
bind $widget <KeyPress-Escape> [list $this onEscape]
1368
set col 0
1369
foreach op {Update Add Delete} {
1370
$btnArray($op) state {!disabled}
1371
if {$btnArray($op) ni [grid slaves $frmButtons]} then {
1372
grid $btnArray($op) -column $col -row 0 -pady {5 5}
1373
incr col
1374
}
1375
}
1376
for {set link 0} {$link <= $lastLink} {incr link} {
1377
$btnArray($link) state {!disabled}
1378
}
1379
return
1380
}
1381
1382
protected method enableEditButtons {} {
1383
foreach op {Update Add Delete} {
1384
$btnArray($op) state {disabled}
1385
if {$btnArray($op) in [grid slaves $frmButtons]} then {
1386
grid forget $btnArray($op)
1387
}
1388
}
1389
set col 0
1390
foreach op {OK Cancel} {
1391
$btnArray($op) state {!disabled}
1392
if {$btnArray($op) ni [grid slaves $frmButtons]} then {
1393
grid $btnArray($op) -column $col -row 0 -pady {5 5}
1394
}
1395
incr col
1396
}
1397
bind $widget <KeyPress-Escape> [list $this onCancel]
1398
for {set link 0} {$link <= $lastLink} {incr link} {
1399
$btnArray($link) state {disabled}
1400
}
1401
return
1402
}
1403
1404
protected method enableEditControls {} {
1405
foreach attrib $modAttribList {
1406
if {$attribDef($attrib,typeofget) ni {tgList tgLink tgReadOnly}} {
1407
$control($attrib) configure -state normal
1408
} else {
1409
if {$attribDef($attrib,typeofget) ne {tgReadOnly}} then {
1410
$btnSelect($attrib) state {!disabled}
1411
}
1412
}
1413
}
1414
return
1415
}
1416
1417
protected method disableEditControls {} {
1418
foreach attrib $modAttribList {
1419
if {$attribDef($attrib,typeofget) ni {tgList tgLink tgReadOnly}} {
1420
$control($attrib) configure -state readonly
1421
} else {
1422
if {$attribDef($attrib,typeofget) ne {tgReadOnly}} then {
1423
$btnSelect($attrib) state {disabled}
1424
}
1425
}
1426
}
1427
return
1428
}
1429
1430
protected method updateAllTextEdits {readonly} {
1431
foreach item $textEditList($readonly) {
1432
[lindex $item 0] setText record($recordIdx([lindex $item 1]))
1433
}
1434
return
1435
}
1436
1437
protected method deleteAllTextEdits {readOnly} {
1438
foreach item $textEditList($readOnly) {
1439
[lindex $item 0] destroyWindow
1440
}
1441
set textEditList($readOnly) {}
1442
return
1443
}
1444
1445
protected method deleteAllListBoxes {} {
1446
foreach item $listBoxList {
1447
[lindex $item 0] destroyWindow
1448
}
1449
set listBoxList {}
1450
return
1451
}
1452
1453
}
1454
1455
class FormBuf {
1456
protected variable formDef
1457
protected variable attribDef
1458
protected variable attribList
1459
protected variable modAttribList
1460
protected variable formTab
1461
protected variable buffer
1462
protected variable status
1463
protected variable bufferFilled 0
1464
protected variable curRecord
1465
protected variable lastRecord
1466
protected variable lastChunk
1467
protected variable offset
1468
protected variable recordIdx
1469
1470
constructor {c_formDef c_attribDef c_formTab c_attribList c_modAttribList} {
1471
array set formDef $c_formDef
1472
array set attribDef $c_attribDef
1473
set attribList $c_attribList
1474
set modAttribList $c_modAttribList
1475
set formTab $c_formTab
1476
# Bug 1070:
1477
# The same calculation is done in the constructor of class FormTab.
1478
# See there for more information.
1479
set index 1
1480
foreach attrib $attribList {
1481
set recordIdx($attrib) $index
1482
incr index
1483
}
1484
return
1485
}
1486
1487
destructor {
1488
return
1489
}
1490
1491
proc quoteIfNecessary {tablename} {
1492
# Procedure added for bug 1071
1493
set double "\""
1494
if {[string first $double $tablename] >= 0} then {
1495
# If tablename already contains double quotes, just leave it
1496
# alone
1497
set result $tablename
1498
} else {
1499
# replace . with "." and enclose everything in double quotes
1500
set dot "."
1501
set quotedDot "\".\""
1502
set result [string map [list $dot $quotedDot] $tablename]
1503
set result "${double}${result}${double}"
1504
}
1505
# puts stdout $result
1506
return $result
1507
}
1508
1509
public method getFirstRecord {recordName recNrName statusName} {
1510
upvar $recordName record
1511
upvar $recNrName recNr
1512
upvar $statusName recordStatus
1513
if {(!$bufferFilled) || ($offset != 0)} then {
1514
loadDataChunk 0
1515
}
1516
set curRecord 0
1517
getCurRecord record recNr recordStatus
1518
return
1519
}
1520
1521
public method getNextRecord {recordName recNrName statusName} {
1522
upvar $recordName record
1523
upvar $recNrName recNr
1524
upvar $statusName recordStatus
1525
if {$curRecord <= [expr $lastRecord - 2]} then {
1526
incr curRecord
1527
} else {
1528
if {!$lastChunk} then {
1529
loadDataChunk 1
1530
set curRecord 0
1531
} else {
1532
set curRecord $lastRecord
1533
}
1534
}
1535
getCurRecord record recNr recordStatus
1536
return
1537
}
1538
1539
public method getPrevRecord {recordName recNrName statusName} {
1540
upvar $recordName record
1541
upvar $recNrName recNr
1542
upvar $statusName recordStatus
1543
if {$curRecord >= 1} then {
1544
incr curRecord -1
1545
} else {
1546
if {$offset > 0} then {
1547
loadDataChunk -1
1548
set curRecord [expr $lastRecord - 1]
1549
}
1550
}
1551
getCurRecord record recNr recordStatus
1552
return
1553
}
1554
1555
public method getLastRecord {recordName recNrName statusName} {
1556
upvar $recordName record
1557
upvar $recNrName recNr
1558
upvar $statusName recordStatus
1559
while {!$lastChunk} {
1560
loadDataChunk 1
1561
}
1562
set curRecord [expr $lastRecord - 1]
1563
if {$curRecord < 0} then {
1564
set curRecord 0
1565
}
1566
getCurRecord record recNr recordStatus
1567
return
1568
}
1569
1570
public method getCurRecord {recordName recNrName statusName} {
1571
upvar $recordName record
1572
upvar $recNrName recNr
1573
upvar $statusName recordStatus
1574
array unset record
1575
foreach attrib $attribList {
1576
set record($recordIdx($attrib)) $buffer($curRecord,$attrib)
1577
}
1578
set recordStatus $status($curRecord)
1579
# set recNr [expr $curRecord + $offset + 1]
1580
if {$lastChunk} then {
1581
set recNr "[expr $curRecord + $offset + 1]/[expr $lastRecord + $offset]"
1582
} else {
1583
set recNr "[expr $curRecord + $offset + 1]/?"
1584
}
1585
return
1586
}
1587
1588
public method searchRecord {attribute pattern matchCase} {
1589
if {($curRecord == $lastRecord) && $lastChunk} then {
1590
loadDataChunk 0
1591
set startSearch 0
1592
} else {
1593
set startSearch [expr $curRecord + 1]
1594
}
1595
set searching 1
1596
while {$searching} {
1597
set found 0
1598
for {set tuple $startSearch} {$tuple < $lastRecord} {incr tuple} {
1599
if {$matchCase} then {
1600
set found [string match $pattern \
1601
$buffer($tuple,$attribute)]
1602
} else {
1603
set found [string match -nocase $pattern \
1604
$buffer($tuple,$attribute)]
1605
}
1606
if {$found} then {
1607
set curRecord $tuple
1608
break
1609
}
1610
}
1611
if {$found} then {
1612
set searching 0
1613
} else {
1614
if {!$lastChunk} then {
1615
loadDataChunk 1
1616
set startSearch 0
1617
} else {
1618
set searching 0
1619
set curRecord $lastRecord
1620
}
1621
}
1622
}
1623
return $found
1624
}
1625
1626
public method getStatus {} {
1627
return $status($curRecord)
1628
}
1629
1630
public method deleteRecord {recordName recNrName statusName} {
1631
upvar $recordName record
1632
upvar $recNrName recNr
1633
upvar $statusName recordStatus
1634
set command "DELETE FROM [quoteIfNecessary $formDef(tablename)]"
1635
append command "\nWHERE [identCurRecord 0]"
1636
if {[$::dbObject send_command $command errMsg]} then {
1637
foreach attrib $attribList {
1638
set buffer($curRecord,$attrib) {}
1639
set status($curRecord) statDeleted
1640
}
1641
$formTab showQuery [mc deleteRecord] $command [mc commandOK] green
1642
} else {
1643
$formTab showQuery [mc deleteRecord] $command $errMsg red
1644
}
1645
getCurRecord record recNr recordStatus
1646
return
1647
}
1648
1649
public method addRecord {recordName} {
1650
upvar $recordName record
1651
set query "INSERT INTO [quoteIfNecessary $formDef(tablename)]"
1652
set attribSpec {}
1653
set valueList {}
1654
foreach attrib $modAttribList {
1655
lappend attribSpec "\"${attrib}\""
1656
set value $record($recordIdx($attrib))
1657
if {$attribDef($attrib,typeofget) eq {tgExpression}} then {
1658
set value [expr $value]
1659
}
1660
if {$attribDef($attrib,typeofattrib) eq {taQuoted}} then {
1661
set value "'[string map {{'} {''}} ${value}]'"
1662
}
1663
lappend valueList $value
1664
}
1665
append query " ([join $attribSpec {, }])"
1666
append query "\nVALUES ([join $valueList {, }])"
1667
if {[$::dbObject send_command $query errMsg]} then {
1668
set result 1
1669
$formTab showQuery [mc addRecord] $query [mc commandOK] green
1670
set curRecord $lastRecord
1671
incr lastRecord
1672
foreach attrib $modAttribList {
1673
set buffer($curRecord,$attrib) $record($recordIdx($attrib))
1674
}
1675
set status($curRecord) statAdded
1676
foreach attrib $attribList {
1677
set buffer($lastRecord,$attrib) {}
1678
}
1679
set status($lastRecord) statAfterLast
1680
} else {
1681
$formTab showQuery [mc addRecord] $query $errMsg red
1682
set result 0
1683
}
1684
return $result
1685
}
1686
1687
public method updateRecord {recordName} {
1688
upvar $recordName record
1689
if {[transactionCommand [mc startTransaction] {START TRANSACTION}]} then {
1690
if {[selectForUpdate]} then {
1691
if {[basicUpdateRecord record]} then {
1692
if {[transactionCommand [mc commitTransaction] {COMMIT}]} then {
1693
set result 1
1694
foreach attrib $modAttribList {
1695
set buffer($curRecord,$attrib) $record($recordIdx($attrib))
1696
}
1697
set status($curRecord) statUpdated
1698
} else {
1699
set result 0
1700
}
1701
} else {
1702
set result 0
1703
transactionCommand [mc rollBack] {ROLLBACK}
1704
}
1705
} else {
1706
set result 0
1707
transactionCommand [mc rollBack] {ROLLBACK}
1708
}
1709
} else {
1710
set result 0
1711
}
1712
return $result
1713
}
1714
1715
protected method basicUpdateRecord {recordName} {
1716
upvar $recordName record
1717
set updateList {}
1718
foreach attrib $modAttribList {
1719
if {$record($recordIdx($attrib)) ne $buffer($curRecord,$attrib)} then {
1720
set value $record($recordIdx($attrib))
1721
if {$attribDef($attrib,typeofget) eq {tgExpression}} then {
1722
set value [expr $value]
1723
}
1724
if {$attribDef($attrib,typeofattrib) eq {taQuoted}} then {
1725
set value "'[string map {{'} {''}} ${value}]'"
1726
}
1727
lappend updateList "\"${attrib}\" = $value"
1728
}
1729
}
1730
if {[llength $updateList] > 0} then {
1731
set command "UPDATE [quoteIfNecessary $formDef(tablename)]"
1732
append command "\nSET [join $updateList {, }]"
1733
append command "\nWHERE [identCurRecord 0]"
1734
if {[$::dbObject send_command $command errMsg]} then {
1735
set result 1
1736
$formTab showQuery [mc updateRecord] $command \
1737
[mc commandOK] green
1738
} else {
1739
set result 0
1740
$formTab showQuery [mc updateRecord] $command \
1741
$errMsg red
1742
}
1743
} else {
1744
set result 0
1745
$formTab showError [mc noUpdates]
1746
}
1747
return $result
1748
}
1749
1750
protected method selectForUpdate {} {
1751
set sqlattrib {}
1752
foreach attrib $modAttribList {
1753
lappend sqlattrib "\"${attrib}\""
1754
}
1755
set sqlattrib [join $sqlattrib {, }]
1756
set query "SELECT $sqlattrib"
1757
append query "\nFROM [quoteIfNecessary $formDef(tablename)]"
1758
append query "\nWHERE [identCurRecord 0] FOR UPDATE"
1759
if {[$::dbObject select_query_list $query numTuples namesList \
1760
resultList errMsg]} then {
1761
switch -- $numTuples {
1762
1 {
1763
set idx 0
1764
set result 1
1765
foreach attrib $namesList {
1766
if {$buffer($curRecord,$attrib) ne [lindex $resultList 0 $idx]} then {
1767
set result 0
1768
break
1769
}
1770
incr idx
1771
}
1772
if {$result} then {
1773
$formTab showQuery [mc selectForUpdate] $query [mc queryOK] green
1774
} else {
1775
set idx 0
1776
foreach attrib $namesList {
1777
set buffer($curRecord,$attrib) [lindex $resultList 0 $idx]
1778
set status($curRecord) statNotModified
1779
incr idx
1780
}
1781
$formTab showQuery [mc selectForUpdate] $query \
1782
[mc recordModified] red
1783
pfm_message [mc recordModified] [$formTab cget -formWinPath]
1784
}
1785
}
1786
0 {
1787
set result 0
1788
$formTab showQuery [mc selectForUpdate] $query \
1789
[mc recordDeleted] red
1790
pfm_message [mc recordDeleted] [$formTab cget -formWinPath]
1791
}
1792
default {
1793
set result 0
1794
$formTab showQuery [mc selectForUpdate] $query \
1795
[mc wrongNumTuples $numTuples] red
1796
pfm_message [mc wrongNumTuples $numTuples] \
1797
[$formTab cget -formWinPath]
1798
}
1799
}
1800
} else {
1801
set result 0
1802
$formTab showQuery [mc selectForUpdate] $query $errMsg red
1803
pfm_message $errMsg [$formTab cget -formWinPath]
1804
}
1805
return $result
1806
}
1807
1808
protected method transactionCommand {intro command} {
1809
if {[$::dbObject send_command $command errMsg]} then {
1810
$formTab showQuery $intro $command [mc commandOK] green
1811
set result 1
1812
} else {
1813
$formTab showQuery $intro $command $errMsg red
1814
set result 0
1815
}
1816
return $result
1817
}
1818
1819
public method reloadRecord {recordName recNrName statusName} {
1820
upvar $recordName record
1821
upvar $recNrName recNr
1822
upvar $statusName recordStatus
1823
set query "SELECT $formDef(sqlselect)"
1824
append query "\nFROM $formDef(sqlfrom) "
1825
if {$formDef(groupby) eq {}} then {
1826
append query "\nWHERE [identCurRecord 1]"
1827
} else {
1828
append query "\nGROUP BY $formDef(groupby) "
1829
append query "\nHAVING [identCurRecord 1]"
1830
}
1831
if {[$::dbObject select_query_list $query numTuples namesList \
1832
resultList errMsg]} then {
1833
switch -- $numTuples {
1834
1 {
1835
set idx 0
1836
foreach attrib $namesList {
1837
set buffer($curRecord,$attrib) [lindex $resultList 0 $idx]
1838
incr idx
1839
}
1840
$formTab showQuery [mc reloadRecord] $query [mc queryOK] green
1841
set result 1
1842
}
1843
0 {
1844
$formTab showQuery [mc reloadRecord] $query \
1845
[mc recordDeleted] red
1846
foreach attrib $attribList {
1847
set buffer($curRecord,$attrib) {}
1848
}
1849
set status($curRecord) statDeleted
1850
set result 0
1851
}
1852
default {
1853
$formTab showQuery [mc reloadRecord] $query \
1854
[mc wrongNumTuples $numTuples] red
1855
set result 0
1856
}
1857
}
1858
} else {
1859
$formTab showQuery [mc reloadRecord] $query $errMsg red
1860
set result 0
1861
}
1862
getCurRecord record recNr recordStatus
1863
return $result
1864
}
1865
1866
protected method identCurRecord {withTable} {
1867
set whereClause {}
1868
set table [quoteIfNecessary $formDef(tablename)]
1869
foreach pkey $formDef(pkey) {
1870
if {$attribDef($pkey,typeofattrib) eq {taQuoted}} then {
1871
set value "'[string map {{'} {''}} $buffer($curRecord,$pkey)]'"
1872
} else {
1873
set value $buffer($curRecord,$pkey)
1874
}
1875
if {$withTable} then {
1876
lappend whereClause "(${table}.\"${pkey}\" = $value)"
1877
} else {
1878
lappend whereClause "(\"${pkey}\" = $value)"
1879
}
1880
}
1881
return [join $whereClause { AND }]
1882
}
1883
1884
protected method loadDataChunk {arg} {
1885
switch -- $arg {
1886
0 {
1887
set offset 0
1888
}
1889
1 {
1890
if {$formDef(sqllimit) ne {}} then {
1891
incr offset $formDef(sqllimit)
1892
}
1893
}
1894
-1 {
1895
if {$formDef(sqllimit) ne {}} then {
1896
incr offset -$formDef(sqllimit)
1897
if {$offset < 0} then {
1898
set offset 0
1899
}
1900
}
1901
}
1902
}
1903
set query "SELECT $formDef(sqlselect)"
1904
append query "\nFROM $formDef(sqlfrom)"
1905
if {$formDef(groupby) ne {}} then {
1906
append query "\nGROUP BY $formDef(groupby)"
1907
if {$formDef(sqlwhere) ne {}} then {
1908
append query "\nHAVING $formDef(sqlwhere)"
1909
}
1910
} else {
1911
if {$formDef(sqlwhere) ne {}} then {
1912
append query "\nWHERE $formDef(sqlwhere)"
1913
}
1914
}
1915
if {$formDef(sqlorderby) ne {}} then {
1916
append query "\nORDER BY $formDef(sqlorderby)"
1917
}
1918
if {$formDef(sqllimit) ne {}} then {
1919
append query "\nLIMIT $formDef(sqllimit) OFFSET $offset"
1920
}
1921
array unset buffer
1922
array unset status
1923
if {[$::dbObject select_query $query lastRecord buffer errMsg]} then {
1924
if {$formDef(sqllimit) ne {}} then {
1925
set lastChunk [expr $lastRecord < $formDef(sqllimit)]
1926
} else {
1927
set lastChunk 1
1928
}
1929
if {[checkResult errMsg]} then {
1930
$formTab showQuery [mc loadDataChunk] $query [mc queryOK] green
1931
} else {
1932
$formTab showQuery [mc loadDataChunk] $query $errMsg red
1933
}
1934
set bufferFilled 1
1935
} else {
1936
set lastRecord 0
1937
set lastChunk 1
1938
$formTab showQuery [mc loadDataChunk] $query $errMsg red
1939
set bufferFilled 0
1940
}
1941
for {set tuple 0} {$tuple < $lastRecord} {incr tuple} {
1942
set status($tuple) statNotModified
1943
}
1944
foreach attrib $attribList {
1945
set buffer($lastRecord,$attrib) {}
1946
}
1947
set status($lastRecord) statAfterLast
1948
return
1949
}
1950
1951
protected method checkResult {errMsgName} {
1952
upvar $errMsgName errMsg
1953
set result 1
1954
set errMsg {}
1955
if {$lastRecord > 0} then {
1956
foreach attrib $attribList {
1957
if {![info exists buffer(0,$attrib)]} then {
1958
set result 0
1959
append errMsg "[mc attribMissing $attrib]\n"
1960
for {set tuple 0} {$tuple < $lastRecord} {incr tuple} {
1961
set buffer($tuple,$attrib) {}
1962
}
1963
}
1964
}
1965
foreach attrib $formDef(pkey) {
1966
if {![info exists buffer(0,$attrib)]} then {
1967
set result 0
1968
append errMsg "[mc pkeyMissing $attrib]\n"
1969
for {set tuple 0} {$tuple < $lastRecord} {incr tuple} {
1970
set buffer($tuple,$attrib) {}
1971
}
1972
}
1973
if {$attrib ni $attribList} then {
1974
append errMsg "[mc attribDefPkeyMissing $attrib]\n"
1975
set attribDef($attrib,typeofattrib) taQuoted
1976
set attribbDef($attrib,typeofget) tgDirect
1977
}
1978
}
1979
}
1980
return $result
1981
}
1982
}
1983
Loggerhead is a web-based interface for Breezy
Version: 2.0.1