« back to all changes in this revision
Viewing changes to sql.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
sql.tcl
1
# sql.tcl
2
3
# The purpose of this program is to implement a GUI frontend for a
4
# command line sql program sql (like psql of postgresql).
5
6
# Commands to sql are typed in the upper text widget. When pressing
7
# Run, the command is transferred to sql via a command pipe. This pipe
8
# is opened in the method connect_sql of the $::dbObject and creates
9
# a channel psqlChan. Wirting to this pipe sends input to the sql
10
# command line tool (e.g. psql in the case of postgresql). The
11
# stdout and stderr from this pipe are redirected to channels outChan
12
# and errChan respectively.
13
14
# The are based on a simple script "cat.tcl" wich mimics
15
# the UNIX cat utility: it prints everything it reads on stdin to
16
# stdout. Each channel runs in a separate instance of the tcl interpreter.
17
# They are setup in the methods openOutChannel and openErrChannel of
18
# the Sql objects.
19
20
# The following procedures in the global namespace read the channels
21
# outChan and errChan, and display everyting that is received on a
22
# txtWidget. The errChan writes with tag "redTag". These procedures
23
# are bound to the "channel readable event".
24
25
# Before deleting this object, first call the destroyWindow method.
26
# Otherwise, the window and the psql connection become orphans.
27
28
29
class Sql {
30
public variable window
31
protected variable windowTag
32
protected variable txtSQL
33
protected variable txtResult
34
protected variable wrapOutput
35
protected variable parent
36
protected variable dbname
37
protected variable errChan
38
protected variable outChan
39
protected variable sqlChan
40
protected variable history
41
protected variable top
42
protected variable cursor
43
protected variable btn
44
45
constructor {c_parent} {
46
set parent $c_parent
47
set dbname [$::dbObject cget -dbname]
48
initHistory
49
setupWindow
50
connectSql
51
return
52
}
53
54
destructor {
55
return
56
}
57
58
public method showWindow {} {
59
if {$window ne {}} then {
60
wm deiconify $window
61
raise $window
62
focus $window
63
} else {
64
setupWindow
65
connectSql
66
}
67
return
68
}
69
70
public method destroyWindow {} {
71
destroy $window
72
return
73
}
74
75
public method onDestroyWindow {} {
76
set window {}
77
disconnectSql
78
return
79
}
80
81
public method processOutChan {} {
82
if {![chan eof $outChan]} then {
83
$txtResult insert end "[chan gets $outChan]\n"
84
$txtResult see end
85
} else {
86
chan event $outChan readable {}
87
}
88
return
89
}
90
91
public method processErrChan {} {
92
if {![chan eof $errChan]} then {
93
$txtResult insert end "[chan gets $errChan]\n" {redTag}
94
$txtResult see end
95
} else {
96
chan event $errChan readable {}
97
}
98
return
99
}
100
public method onClear {} {
101
$txtSQL delete 1.0 end
102
set history($top) {}
103
set cursor $top
104
if {$top > 0} then {
105
$btn(Prev) state {!disabled}
106
} else {
107
$btn(Prev) state {disabled}
108
}
109
$btn(Next) state {disabled}
110
return
111
}
112
113
public method onPrev {} {
114
if {$cursor == $top} then {
115
set history($top) [$txtSQL get 1.0 "end - 1 chars"]
116
}
117
if {$cursor > 0} then {
118
incr cursor -1
119
$txtSQL delete 1.0 end
120
$txtSQL insert end $history($cursor)
121
$btn(Next) state {!disabled}
122
if {$cursor == 0} then {
123
$btn(Prev) state {disabled}
124
}
125
} else {
126
bell
127
}
128
return
129
}
130
131
public method onNext {} {
132
if {$cursor < $top} then {
133
incr cursor
134
$txtSQL delete 1.0 end
135
$txtSQL insert end $history($cursor)
136
if {$cursor == $top} then {
137
$btn(Next) state {disabled}
138
}
139
$btn(Prev) state {!disabled}
140
} else {
141
bell
142
}
143
return
144
}
145
146
public method onReturn {} {
147
if {([$txtSQL get "end - 3 chars"] eq {;}) || \
148
([$txtSQL get 1.0] eq "\\")} then {
149
onRun
150
}
151
return
152
}
153
154
public method onRun {} {
155
set cmd [string trim [$txtSQL get 1.0 end]]
156
storeCommand $cmd
157
chan puts $sqlChan $cmd
158
chan flush $sqlChan
159
$txtSQL delete 1.0 end
160
if {$cmd eq [$::dbObject getSpecialCommand quit]} then {
161
destroy $window
162
}
163
return
164
}
165
166
public method connectSql {} {
167
set errChan [openErrChannel]
168
set outChan [openOutChannel]
169
set status [$::dbObject connect_sql $errChan $outChan sqlChan]
170
return $status
171
}
172
173
public method disconnectSql {} {
174
chan close $sqlChan
175
chan close $outChan
176
chan close $errChan
177
return
178
}
179
180
public method wrapChanged {} {
181
$txtResult configure -wrap $wrapOutput
182
return
183
}
184
185
public method executeScript {filename encoding} {
186
set convertedFile [convertToUTF-8 $filename $encoding $window]
187
$txtSQL delete 1.0 end
188
set cmd [$::dbObject getSpecialCommand importFile]
189
$txtSQL insert end "$cmd '${convertedFile}'"
190
onRun
191
return
192
}
193
194
public method onListDatabases {} {
195
set cmd [$::dbObject getSpecialCommand listDatabases]
196
$txtSQL delete 1.0 end
197
$txtSQL insert end $cmd
198
onRun
199
return
200
}
201
202
public method onListTables {} {
203
set cmd [$::dbObject getSpecialCommand listTables]
204
$txtSQL delete 1.0 end
205
$txtSQL insert end $cmd
206
onRun
207
return
208
}
209
210
public method onImport {} {
211
set initialDir [file normalize ~]
212
set fromEncoding [encoding system]
213
set fileTypes {
214
{{SQL statements} {.sql} }
215
{{All files} *}
216
}
217
set defaultExt ".sql"
218
set fileName [tk_getOpenFile -title [mc sqlGetImportFile] \
219
-filetypes $fileTypes \
220
-defaultextension $defaultExt -parent $window \
221
-initialdir $initialDir]
222
if {$fileName ne {}} then {
223
set dlg [ImportDlg "#auto" $window]
224
if {[$dlg wait fromEncoding importType]} then {
225
switch -- $importType {
226
direct {
227
if {[catch {open $fileName r} inFile]} then {
228
pfm_message $inFile $window
229
} else {
230
chan configure $inFile -encoding $fromEncoding
231
$txtSQL delete 1.0 end
232
$txtSQL insert end [chan read -nonewline $inFile]
233
chan close $inFile
234
}
235
}
236
execute {
237
executeScript $fileName $fromEncoding
238
}
239
}
240
}
241
}
242
return
243
}
244
245
public method onSaveSQL {} {
246
set fileTypes {
247
{{SQL statements} {.sql} }
248
{{All files} *}
249
}
250
set defaultExt ".sql"
251
set filename [tk_getSaveFile -title [mc sqlSelectSaveSQL] \
252
-filetypes $fileTypes \
253
-defaultextension $defaultExt -parent $window \
254
-initialdir [file normalize ~]]
255
if {$filename ne {}} then {
256
if {[catch {open $filename w} saveChan]} then {
257
pfm_message $saveChan $window
258
} else {
259
chan puts $saveChan [$txtSQL get 1.0 end]
260
chan close $saveChan
261
}
262
}
263
return
264
}
265
266
public method onSaveOutput {} {
267
saveTxtFromWidget $txtResult $window
268
return
269
}
270
271
public method onClearOutput {} {
272
$txtResult delete 1.0 end
273
$txtResult yview 0
274
return
275
}
276
277
public method onPrintOutput {} {
278
printTextWidget $txtResult $window
279
return
280
}
281
282
public method onHelpSql {} {
283
set cmd [$::dbObject getSpecialCommand helpSQL]
284
$txtSQL delete 1.0 end
285
$txtSQL insert end $cmd
286
onRun
287
return
288
}
289
290
public method onHelpSqlCommand {} {
291
set cmd "--[mc sqlTypeCmd]\n[$::dbObject getSpecialCommand helpSQL] "
292
$txtSQL delete 1.0 end
293
$txtSQL insert end $cmd
294
return
295
}
296
297
public method onHelpSpecial {} {
298
set cmd [$::dbObject getSpecialCommand helpTool]
299
$txtSQL delete 1.0 end
300
$txtSQL insert end $cmd
301
onRun
302
return
303
}
304
305
protected method setupWindow {} {
306
set window [toplevel [appendToPath $parent [namespace tail $this]]]
307
lappend windowList $window
308
wm title $window [mc sqlTitle $dbname]
309
wm geometry $window [join $::geometry::sql {x}]
310
setupMenus
311
set pw [ttk::panedwindow $window.pw -orient vertical]
312
set frm1 [ttk::labelframe $pw.frm1 -text [mc sqlStatement] \
313
-labelanchor n]
314
set txtSQL [text $frm1.txt -wrap word -width 1 -height 1]
315
set vsbSQL [ttk::scrollbar $frm1.vsb -orient vertical \
316
-command [list $txtSQL yview]]
317
$txtSQL configure -yscrollcommand [list $vsbSQL set]
318
grid $txtSQL -column 0 -row 0 -sticky wens
319
grid $vsbSQL -column 1 -row 0 -sticky ns
320
grid columnconfigure $frm1 0 -weight 1
321
grid rowconfigure $frm1 0 -weight 1
322
set frmButtons [ttk::frame $frm1.btns]
323
foreach name {Run Next Prev Clear} {
324
set btn($name) [defineButton $frmButtons.btn$name $window btn$name \
325
[list $this on$name]]
326
pack $btn($name) -side right
327
}
328
bind $window <Control-KeyPress-Up> \
329
[list $btn(Prev) instate {!disabled} [list $btn(Prev) invoke]]
330
bind $window <Control-KeyPress-Down> \
331
[list $btn(Next) instate {!disabled} [list $btn(Next) invoke]]
332
if {$cursor < $top} then {
333
$btn(Next) state {!disabled}
334
} else {
335
$btn(Next) state {disabled}
336
}
337
if {$cursor > 0} then {
338
$btn(Prev) state {!disabled}
339
} else {
340
$btn(Prev) state {disabled}
341
}
342
grid $frmButtons -column 0 -columnspan 2 -row 1 -sticky we \
343
-pady {10 10} -padx {10 10}
344
$pw add $frm1 -weight 2
345
set frm2 [ttk::labelframe $pw.frm2 -text [mc sqlOutput] \
346
-labelanchor n]
347
set txtResult [text $frm2.txt -wrap none -width 1 -height 1 \
348
-takefocus 0]
349
set vsbResult [ttk::scrollbar $frm2.vsb -orient vertical \
350
-command [list $txtResult yview]]
351
set hsbResult [ttk::scrollbar $frm2.hsb -orient horizontal \
352
-command [list $txtResult xview]]
353
$txtResult configure \
354
-xscrollcommand [list $hsbResult set] \
355
-yscrollcommand [list $vsbResult set]
356
$txtResult tag configure redTag -foreground {red3}
357
set btnWrap [defineCheckbutton $frm2.btnWrap $window \
358
btnWrap [list $this wrapChanged] [scope wrapOutput] \
359
word none]
360
grid $txtResult -column 0 -row 0 -sticky wens
361
grid $vsbResult -column 1 -row 0 -sticky ns
362
grid $hsbResult -column 0 -row 1 -sticky we
363
grid $btnWrap -column 0 -row 2 -sticky w
364
grid columnconfigure $frm2 0 -weight 1
365
grid rowconfigure $frm2 0 -weight 1
366
$pw add $frm2 -weight 3
367
pack $pw -side top -expand 1 -fill both
368
pack [ttk::sizegrip ${window}.sg] -side top -anchor e
369
set tpOnly [bindToplevelOnly $window <Destroy> \
370
[list $this onDestroyWindow]]
371
bind $tpOnly <Configure> {set ::geometry::sql {%w %h}}
372
bind $window <KeyPress-Escape> [list destroy $window]
373
focus $txtSQL
374
bind $txtSQL <KeyPress-Return> [list after idle [list $this onReturn]]
375
return
376
}
377
378
protected method setupMenus {} {
379
set menubar [menu ${window}.mb -tearoff 0]
380
# Menu SQL
381
set mnuSql [menu ${menubar}.sql -tearoff 0]
382
addMenuItem $mnuSql sqlMnuDatabases command [list $this onListDatabases]
383
addMenuItem $mnuSql sqlMnuImport command [list $this onImport]
384
addMenuItem $mnuSql sqlMnuListTables command [list $this onListTables]
385
addMenuItem $mnuSql sqlMnuSaveToFile command [list $this onSaveSQL]
386
$mnuSql add separator
387
addMenuItem $mnuSql sqlMnuClose command [list destroy $window]
388
# Menu Output
389
set mnuOutput [menu ${menubar}.output -tearoff 0]
390
addMenuItem $mnuOutput sqlMnuOutputSave command [list $this onSaveOutput]
391
addMenuItem $mnuOutput sqlMnuOutputPrint command [list $this onPrintOutput]
392
addMenuItem $mnuOutput sqlMnuOutputClear command [list $this onClearOutput]
393
# Menu Help
394
set mnuHelp [menu ${menubar}.help -tearoff 0]
395
addMenuItem $mnuHelp sqlMnuHelpSQL command [list $this onHelpSql]
396
addMenuItem $mnuHelp sqlMnuHelpSpecial command [list $this onHelpSpecial]
397
addMenuItem $mnuHelp sqlMnuHelpSQLcommand command [list $this onHelpSqlCommand]
398
# Add alle menus to menubar
399
addMenuItem $menubar sqlMnuSql cascade $mnuSql
400
addMenuItem $menubar sqlMnuOutput cascade $mnuOutput
401
addMenuItem $menubar sqlMnuHelp cascade $mnuHelp
402
$window configure -menu $menubar
403
return
404
}
405
406
protected method openErrChannel {} {
407
global tcl_platform
408
set cat [file join $::config::installDir cat.tcl]
409
if {$tcl_platform(platform) eq {windows}} then {
410
set tclshell [file join $::config::installDir tclkitsh.exe]
411
} else {
412
set tclshell [info nameofexecutable]
413
}
414
set errChan [open [list | $tclshell $cat] RDWR]
415
chan configure $errChan -encoding utf-8 -buffering line
416
chan event $errChan readable [list $this processErrChan]
417
return $errChan
418
}
419
420
protected method openOutChannel {} {
421
global tcl_platform
422
set cat [file join $::config::installDir cat.tcl]
423
if {$tcl_platform(platform) eq {windows}} then {
424
set tclshell [file join $::config::installDir tclkitsh.exe]
425
} else {
426
set tclshell [info nameofexecutable]
427
}
428
set outChan [open [list | $tclshell $cat] RDWR]
429
chan configure $outChan -encoding utf-8 -buffering line
430
chan event $outChan readable [list $this processOutChan]
431
return $outChan
432
}
433
434
protected method initHistory {} {
435
set top 0
436
set cursor 0
437
set history(0) {}
438
return
439
}
440
441
protected method storeCommand {cmd} {
442
if {[string range $cmd 0 1] ne \
443
[$::dbObject getSpecialCommand importFile]} then {
444
set history($top) $cmd
445
incr top
446
set history($top) {}
447
set cursor $top
448
$btn(Prev) state {!disabled}
449
$btn(Next) state {disabled}
450
}
451
return
452
}
453
454
}
455
456
class ImportDlg {
457
protected variable window
458
protected variable charEncoding
459
protected variable importType
460
protected variable pressedOK 0
461
462
constructor {parent} {
463
set charEncoding [encoding system]
464
set importType execute
465
setupWindow $parent
466
return
467
}
468
469
destructor {
470
471
return
472
}
473
474
public method wait {fromEncodingName importTypeName} {
475
upvar $fromEncodingName charEncodingToReturn
476
upvar $importTypeName importTypeToReturn
477
tkwait window $window
478
set charEencodingToReturn $charEncoding
479
set importTypeToReturn $importType
480
after idle [list delete object $this]
481
return $pressedOK
482
}
483
484
public method onOK {} {
485
set pressedOK 1
486
destroy $window
487
return
488
}
489
490
protected method setupWindow {parent} {
491
set window [toplevel ${parent}.import]
492
wm title $window [mc sqlImportTitle]
493
wm transient $window $parent
494
set lbHelpEncoding [ttk::label ${window}.lb1 \
495
-text [mc sqlHelpEncoding] -padding {10 10 10 10}]
496
set lbCharEncoding [ttk::label ${window}.lb2 \
497
-text [mc sqlCharEncoding]]
498
set cmbEncoding [ttk::combobox ${window}.cmbenc \
499
-textvariable [scope charEncoding] \
500
-values [encoding names]]
501
set cmd [$::dbObject getSpecialCommand importFile]
502
set lbHelpType [ttk::label ${window}.lb3 \
503
-text [mc sqlHelpImportType $cmd] -padding {10 10 10 10}]
504
set rbExecute [defineRadiobutton ${window}.rb0 $window \
505
[mc sqlRbExecute $cmd] {} [scope importType] execute]
506
set rbImport [defineRadiobutton ${window}.rb1 $window \
507
[mc sqlRbImport] {} [scope importType] direct]
508
set frmBtns [ttk::frame ${window}.frmbtns]
509
set btnOK [defineButton ${frmBtns}.btnOK $window btnOK \
510
[list $this onOK]]
511
set btnCancel [defineButton ${frmBtns}.btnCancel $window btnCancel \
512
[list destroy $window]]
513
grid $lbHelpEncoding -column 0 -row 0 -columnspan 2
514
grid $lbCharEncoding -column 0 -row 1
515
grid $cmbEncoding -column 1 -row 1
516
grid $lbHelpType -column 0 -row 2 -columnspan 2
517
grid $rbExecute -column 0 -columnspan 2 -row 3 -sticky w -padx 10
518
grid $rbImport -column 0 -columnspan 2 -row 4 -sticky w -padx 10
519
pack $btnCancel -side right
520
pack $btnOK -side right
521
grid $frmBtns -column 1 -row 5 -sticky e
522
return
523
}
524
}
525
Loggerhead is a web-based interface for Breezy
Version: 2.0.1