Annotation of embedaddon/sqlite3/contrib/sqlitecon.tcl, revision 1.1.1.1
1.1 misho 1: # A Tk console widget for SQLite. Invoke sqlitecon::create with a window name,
2: # a prompt string, a title to set a new top-level window, and the SQLite
3: # database handle. For example:
4: #
5: # sqlitecon::create .sqlcon {sql:- } {SQL Console} db
6: #
7: # A toplevel window is created that allows you to type in SQL commands to
8: # be processed on the spot.
9: #
10: # A limited set of dot-commands are supported:
11: #
12: # .table
13: # .schema ?TABLE?
14: # .mode list|column|multicolumn|line
15: # .exit
16: #
17: # In addition, a new SQL function named "edit()" is created. This function
18: # takes a single text argument and returns a text result. Whenever the
19: # the function is called, it pops up a new toplevel window containing a
20: # text editor screen initialized to the argument. When the "OK" button
21: # is pressed, whatever revised text is in the text editor is returned as
22: # the result of the edit() function. This allows text fields of SQL tables
23: # to be edited quickly and easily as follows:
24: #
25: # UPDATE table1 SET dscr = edit(dscr) WHERE rowid=15;
26: #
27:
28:
29: # Create a namespace to work in
30: #
31: namespace eval ::sqlitecon {
32: # do nothing
33: }
34:
35: # Create a console widget named $w. The prompt string is $prompt.
36: # The title at the top of the window is $title. The database connection
37: # object is $db
38: #
39: proc sqlitecon::create {w prompt title db} {
40: upvar #0 $w.t v
41: if {[winfo exists $w]} {destroy $w}
42: if {[info exists v]} {unset v}
43: toplevel $w
44: wm title $w $title
45: wm iconname $w $title
46: frame $w.mb -bd 2 -relief raised
47: pack $w.mb -side top -fill x
48: menubutton $w.mb.file -text File -menu $w.mb.file.m
49: menubutton $w.mb.edit -text Edit -menu $w.mb.edit.m
50: pack $w.mb.file $w.mb.edit -side left -padx 8 -pady 1
51: set m [menu $w.mb.file.m -tearoff 0]
52: $m add command -label {Close} -command "destroy $w"
53: sqlitecon::create_child $w $prompt $w.mb.edit.m
54: set v(db) $db
55: $db function edit ::sqlitecon::_edit
56: }
57:
58: # This routine creates a console as a child window within a larger
59: # window. It also creates an edit menu named "$editmenu" if $editmenu!="".
60: # The calling function is responsible for posting the edit menu.
61: #
62: proc sqlitecon::create_child {w prompt editmenu} {
63: upvar #0 $w.t v
64: if {$editmenu!=""} {
65: set m [menu $editmenu -tearoff 0]
66: $m add command -label Cut -command "sqlitecon::Cut $w.t"
67: $m add command -label Copy -command "sqlitecon::Copy $w.t"
68: $m add command -label Paste -command "sqlitecon::Paste $w.t"
69: $m add command -label {Clear Screen} -command "sqlitecon::Clear $w.t"
70: $m add separator
71: $m add command -label {Save As...} -command "sqlitecon::SaveFile $w.t"
72: catch {$editmenu config -postcommand "sqlitecon::EnableEditMenu $w"}
73: }
74: scrollbar $w.sb -orient vertical -command "$w.t yview"
75: pack $w.sb -side right -fill y
76: text $w.t -font fixed -yscrollcommand "$w.sb set"
77: pack $w.t -side right -fill both -expand 1
78: bindtags $w.t Sqlitecon
79: set v(editmenu) $editmenu
80: set v(history) 0
81: set v(historycnt) 0
82: set v(current) -1
83: set v(prompt) $prompt
84: set v(prior) {}
85: set v(plength) [string length $v(prompt)]
86: set v(x) 0
87: set v(y) 0
88: set v(mode) column
89: set v(header) on
90: $w.t mark set insert end
91: $w.t tag config ok -foreground blue
92: $w.t tag config err -foreground red
93: $w.t insert end $v(prompt)
94: $w.t mark set out 1.0
95: after idle "focus $w.t"
96: }
97:
98: bind Sqlitecon <1> {sqlitecon::Button1 %W %x %y}
99: bind Sqlitecon <B1-Motion> {sqlitecon::B1Motion %W %x %y}
100: bind Sqlitecon <B1-Leave> {sqlitecon::B1Leave %W %x %y}
101: bind Sqlitecon <B1-Enter> {sqlitecon::cancelMotor %W}
102: bind Sqlitecon <ButtonRelease-1> {sqlitecon::cancelMotor %W}
103: bind Sqlitecon <KeyPress> {sqlitecon::Insert %W %A}
104: bind Sqlitecon <Left> {sqlitecon::Left %W}
105: bind Sqlitecon <Control-b> {sqlitecon::Left %W}
106: bind Sqlitecon <Right> {sqlitecon::Right %W}
107: bind Sqlitecon <Control-f> {sqlitecon::Right %W}
108: bind Sqlitecon <BackSpace> {sqlitecon::Backspace %W}
109: bind Sqlitecon <Control-h> {sqlitecon::Backspace %W}
110: bind Sqlitecon <Delete> {sqlitecon::Delete %W}
111: bind Sqlitecon <Control-d> {sqlitecon::Delete %W}
112: bind Sqlitecon <Home> {sqlitecon::Home %W}
113: bind Sqlitecon <Control-a> {sqlitecon::Home %W}
114: bind Sqlitecon <End> {sqlitecon::End %W}
115: bind Sqlitecon <Control-e> {sqlitecon::End %W}
116: bind Sqlitecon <Return> {sqlitecon::Enter %W}
117: bind Sqlitecon <KP_Enter> {sqlitecon::Enter %W}
118: bind Sqlitecon <Up> {sqlitecon::Prior %W}
119: bind Sqlitecon <Control-p> {sqlitecon::Prior %W}
120: bind Sqlitecon <Down> {sqlitecon::Next %W}
121: bind Sqlitecon <Control-n> {sqlitecon::Next %W}
122: bind Sqlitecon <Control-k> {sqlitecon::EraseEOL %W}
123: bind Sqlitecon <<Cut>> {sqlitecon::Cut %W}
124: bind Sqlitecon <<Copy>> {sqlitecon::Copy %W}
125: bind Sqlitecon <<Paste>> {sqlitecon::Paste %W}
126: bind Sqlitecon <<Clear>> {sqlitecon::Clear %W}
127:
128: # Insert a single character at the insertion cursor
129: #
130: proc sqlitecon::Insert {w a} {
131: $w insert insert $a
132: $w yview insert
133: }
134:
135: # Move the cursor one character to the left
136: #
137: proc sqlitecon::Left {w} {
138: upvar #0 $w v
139: scan [$w index insert] %d.%d row col
140: if {$col>$v(plength)} {
141: $w mark set insert "insert -1c"
142: }
143: }
144:
145: # Erase the character to the left of the cursor
146: #
147: proc sqlitecon::Backspace {w} {
148: upvar #0 $w v
149: scan [$w index insert] %d.%d row col
150: if {$col>$v(plength)} {
151: $w delete {insert -1c}
152: }
153: }
154:
155: # Erase to the end of the line
156: #
157: proc sqlitecon::EraseEOL {w} {
158: upvar #0 $w v
159: scan [$w index insert] %d.%d row col
160: if {$col>=$v(plength)} {
161: $w delete insert {insert lineend}
162: }
163: }
164:
165: # Move the cursor one character to the right
166: #
167: proc sqlitecon::Right {w} {
168: $w mark set insert "insert +1c"
169: }
170:
171: # Erase the character to the right of the cursor
172: #
173: proc sqlitecon::Delete w {
174: $w delete insert
175: }
176:
177: # Move the cursor to the beginning of the current line
178: #
179: proc sqlitecon::Home w {
180: upvar #0 $w v
181: scan [$w index insert] %d.%d row col
182: $w mark set insert $row.$v(plength)
183: }
184:
185: # Move the cursor to the end of the current line
186: #
187: proc sqlitecon::End w {
188: $w mark set insert {insert lineend}
189: }
190:
191: # Add a line to the history
192: #
193: proc sqlitecon::addHistory {w line} {
194: upvar #0 $w v
195: if {$v(historycnt)>0} {
196: set last [lindex $v(history) [expr $v(historycnt)-1]]
197: if {[string compare $last $line]} {
198: lappend v(history) $line
199: incr v(historycnt)
200: }
201: } else {
202: set v(history) [list $line]
203: set v(historycnt) 1
204: }
205: set v(current) $v(historycnt)
206: }
207:
208: # Called when "Enter" is pressed. Do something with the line
209: # of text that was entered.
210: #
211: proc sqlitecon::Enter w {
212: upvar #0 $w v
213: scan [$w index insert] %d.%d row col
214: set start $row.$v(plength)
215: set line [$w get $start "$start lineend"]
216: $w insert end \n
217: $w mark set out end
218: if {$v(prior)==""} {
219: set cmd $line
220: } else {
221: set cmd $v(prior)\n$line
222: }
223: if {[string index $cmd 0]=="." || [$v(db) complete $cmd]} {
224: regsub -all {\n} [string trim $cmd] { } cmd2
225: addHistory $w $cmd2
226: set rc [catch {DoCommand $w $cmd} res]
227: if {![winfo exists $w]} return
228: if {$rc} {
229: $w insert end $res\n err
230: } elseif {[string length $res]>0} {
231: $w insert end $res\n ok
232: }
233: set v(prior) {}
234: $w insert end $v(prompt)
235: } else {
236: set v(prior) $cmd
237: regsub -all {[^ ]} $v(prompt) . x
238: $w insert end $x
239: }
240: $w mark set insert end
241: $w mark set out {insert linestart}
242: $w yview insert
243: }
244:
245: # Execute a single SQL command. Pay special attention to control
246: # directives that begin with "."
247: #
248: # The return value is the text output from the command, properly
249: # formatted.
250: #
251: proc sqlitecon::DoCommand {w cmd} {
252: upvar #0 $w v
253: set mode $v(mode)
254: set header $v(header)
255: if {[regexp {^(\.[a-z]+)} $cmd all word]} {
256: if {$word==".mode"} {
257: regexp {^.[a-z]+ +([a-z]+)} $cmd all v(mode)
258: return {}
259: } elseif {$word==".exit"} {
260: destroy [winfo toplevel $w]
261: return {}
262: } elseif {$word==".header"} {
263: regexp {^.[a-z]+ +([a-z]+)} $cmd all v(header)
264: return {}
265: } elseif {$word==".tables"} {
266: set mode multicolumn
267: set cmd {SELECT name FROM sqlite_master WHERE type='table'
268: UNION ALL
269: SELECT name FROM sqlite_temp_master WHERE type='table'}
270: $v(db) eval {PRAGMA database_list} {
271: if {$name!="temp" && $name!="main"} {
272: append cmd "UNION ALL SELECT name FROM $name.sqlite_master\
273: WHERE type='table'"
274: }
275: }
276: append cmd { ORDER BY 1}
277: } elseif {$word==".fullschema"} {
278: set pattern %
279: regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
280: set mode list
281: set header 0
282: set cmd "SELECT sql FROM sqlite_master WHERE tbl_name LIKE '$pattern'
283: AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
284: WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
285: $v(db) eval {PRAGMA database_list} {
286: if {$name!="temp" && $name!="main"} {
287: append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
288: WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
289: }
290: }
291: } elseif {$word==".schema"} {
292: set pattern %
293: regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
294: set mode list
295: set header 0
296: set cmd "SELECT sql FROM sqlite_master WHERE name LIKE '$pattern'
297: AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
298: WHERE name LIKE '$pattern' AND sql NOT NULL"
299: $v(db) eval {PRAGMA database_list} {
300: if {$name!="temp" && $name!="main"} {
301: append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
302: WHERE name LIKE '$pattern' AND sql NOT NULL"
303: }
304: }
305: } else {
306: return \
307: ".exit\n.mode line|list|column\n.schema ?TABLENAME?\n.tables"
308: }
309: }
310: set res {}
311: if {$mode=="list"} {
312: $v(db) eval $cmd x {
313: set sep {}
314: foreach col $x(*) {
315: append res $sep$x($col)
316: set sep |
317: }
318: append res \n
319: }
320: if {[info exists x(*)] && $header} {
321: set sep {}
322: set hdr {}
323: foreach col $x(*) {
324: append hdr $sep$col
325: set sep |
326: }
327: set res $hdr\n$res
328: }
329: } elseif {[string range $mode 0 2]=="col"} {
330: set y {}
331: $v(db) eval $cmd x {
332: foreach col $x(*) {
333: if {![info exists cw($col)] || $cw($col)<[string length $x($col)]} {
334: set cw($col) [string length $x($col)]
335: }
336: lappend y $x($col)
337: }
338: }
339: if {[info exists x(*)] && $header} {
340: set hdr {}
341: set ln {}
342: set dash ---------------------------------------------------------------
343: append dash ------------------------------------------------------------
344: foreach col $x(*) {
345: if {![info exists cw($col)] || $cw($col)<[string length $col]} {
346: set cw($col) [string length $col]
347: }
348: lappend hdr $col
349: lappend ln [string range $dash 1 $cw($col)]
350: }
351: set y [concat $hdr $ln $y]
352: }
353: if {[info exists x(*)]} {
354: set format {}
355: set arglist {}
356: set arglist2 {}
357: set i 0
358: foreach col $x(*) {
359: lappend arglist x$i
360: append arglist2 " \$x$i"
361: incr i
362: append format " %-$cw($col)s"
363: }
364: set format [string trimleft $format]\n
365: if {[llength $arglist]>0} {
366: foreach $arglist $y "append res \[format [list $format] $arglist2\]"
367: }
368: }
369: } elseif {$mode=="multicolumn"} {
370: set y [$v(db) eval $cmd]
371: set max 0
372: foreach e $y {
373: if {$max<[string length $e]} {set max [string length $e]}
374: }
375: set ncol [expr {int(80/($max+2))}]
376: if {$ncol<1} {set ncol 1}
377: set nelem [llength $y]
378: set nrow [expr {($nelem+$ncol-1)/$ncol}]
379: set format "%-${max}s"
380: for {set i 0} {$i<$nrow} {incr i} {
381: set j $i
382: while 1 {
383: append res [format $format [lindex $y $j]]
384: incr j $nrow
385: if {$j>=$nelem} break
386: append res { }
387: }
388: append res \n
389: }
390: } else {
391: $v(db) eval $cmd x {
392: foreach col $x(*) {append res "$col = $x($col)\n"}
393: append res \n
394: }
395: }
396: return [string trimright $res]
397: }
398:
399: # Change the line to the previous line
400: #
401: proc sqlitecon::Prior w {
402: upvar #0 $w v
403: if {$v(current)<=0} return
404: incr v(current) -1
405: set line [lindex $v(history) $v(current)]
406: sqlitecon::SetLine $w $line
407: }
408:
409: # Change the line to the next line
410: #
411: proc sqlitecon::Next w {
412: upvar #0 $w v
413: if {$v(current)>=$v(historycnt)} return
414: incr v(current) 1
415: set line [lindex $v(history) $v(current)]
416: sqlitecon::SetLine $w $line
417: }
418:
419: # Change the contents of the entry line
420: #
421: proc sqlitecon::SetLine {w line} {
422: upvar #0 $w v
423: scan [$w index insert] %d.%d row col
424: set start $row.$v(plength)
425: $w delete $start end
426: $w insert end $line
427: $w mark set insert end
428: $w yview insert
429: }
430:
431: # Called when the mouse button is pressed at position $x,$y on
432: # the console widget.
433: #
434: proc sqlitecon::Button1 {w x y} {
435: global tkPriv
436: upvar #0 $w v
437: set v(mouseMoved) 0
438: set v(pressX) $x
439: set p [sqlitecon::nearestBoundry $w $x $y]
440: scan [$w index insert] %d.%d ix iy
441: scan $p %d.%d px py
442: if {$px==$ix} {
443: $w mark set insert $p
444: }
445: $w mark set anchor $p
446: focus $w
447: }
448:
449: # Find the boundry between characters that is nearest
450: # to $x,$y
451: #
452: proc sqlitecon::nearestBoundry {w x y} {
453: set p [$w index @$x,$y]
454: set bb [$w bbox $p]
455: if {![string compare $bb ""]} {return $p}
456: if {($x-[lindex $bb 0])<([lindex $bb 2]/2)} {return $p}
457: $w index "$p + 1 char"
458: }
459:
460: # This routine extends the selection to the point specified by $x,$y
461: #
462: proc sqlitecon::SelectTo {w x y} {
463: upvar #0 $w v
464: set cur [sqlitecon::nearestBoundry $w $x $y]
465: if {[catch {$w index anchor}]} {
466: $w mark set anchor $cur
467: }
468: set anchor [$w index anchor]
469: if {[$w compare $cur != $anchor] || (abs($v(pressX) - $x) >= 3)} {
470: if {$v(mouseMoved)==0} {
471: $w tag remove sel 0.0 end
472: }
473: set v(mouseMoved) 1
474: }
475: if {[$w compare $cur < anchor]} {
476: set first $cur
477: set last anchor
478: } else {
479: set first anchor
480: set last $cur
481: }
482: if {$v(mouseMoved)} {
483: $w tag remove sel 0.0 $first
484: $w tag add sel $first $last
485: $w tag remove sel $last end
486: update idletasks
487: }
488: }
489:
490: # Called whenever the mouse moves while button-1 is held down.
491: #
492: proc sqlitecon::B1Motion {w x y} {
493: upvar #0 $w v
494: set v(y) $y
495: set v(x) $x
496: sqlitecon::SelectTo $w $x $y
497: }
498:
499: # Called whenever the mouse leaves the boundries of the widget
500: # while button 1 is held down.
501: #
502: proc sqlitecon::B1Leave {w x y} {
503: upvar #0 $w v
504: set v(y) $y
505: set v(x) $x
506: sqlitecon::motor $w
507: }
508:
509: # This routine is called to automatically scroll the window when
510: # the mouse drags offscreen.
511: #
512: proc sqlitecon::motor w {
513: upvar #0 $w v
514: if {![winfo exists $w]} return
515: if {$v(y)>=[winfo height $w]} {
516: $w yview scroll 1 units
517: } elseif {$v(y)<0} {
518: $w yview scroll -1 units
519: } else {
520: return
521: }
522: sqlitecon::SelectTo $w $v(x) $v(y)
523: set v(timer) [after 50 sqlitecon::motor $w]
524: }
525:
526: # This routine cancels the scrolling motor if it is active
527: #
528: proc sqlitecon::cancelMotor w {
529: upvar #0 $w v
530: catch {after cancel $v(timer)}
531: catch {unset v(timer)}
532: }
533:
534: # Do a Copy operation on the stuff currently selected.
535: #
536: proc sqlitecon::Copy w {
537: if {![catch {set text [$w get sel.first sel.last]}]} {
538: clipboard clear -displayof $w
539: clipboard append -displayof $w $text
540: }
541: }
542:
543: # Return 1 if the selection exists and is contained
544: # entirely on the input line. Return 2 if the selection
545: # exists but is not entirely on the input line. Return 0
546: # if the selection does not exist.
547: #
548: proc sqlitecon::canCut w {
549: set r [catch {
550: scan [$w index sel.first] %d.%d s1x s1y
551: scan [$w index sel.last] %d.%d s2x s2y
552: scan [$w index insert] %d.%d ix iy
553: }]
554: if {$r==1} {return 0}
555: if {$s1x==$ix && $s2x==$ix} {return 1}
556: return 2
557: }
558:
559: # Do a Cut operation if possible. Cuts are only allowed
560: # if the current selection is entirely contained on the
561: # current input line.
562: #
563: proc sqlitecon::Cut w {
564: if {[sqlitecon::canCut $w]==1} {
565: sqlitecon::Copy $w
566: $w delete sel.first sel.last
567: }
568: }
569:
570: # Do a paste opeation.
571: #
572: proc sqlitecon::Paste w {
573: if {[sqlitecon::canCut $w]==1} {
574: $w delete sel.first sel.last
575: }
576: if {[catch {selection get -displayof $w -selection CLIPBOARD} topaste]
577: && [catch {selection get -displayof $w -selection PRIMARY} topaste]} {
578: return
579: }
580: if {[info exists ::$w]} {
581: set prior 0
582: foreach line [split $topaste \n] {
583: if {$prior} {
584: sqlitecon::Enter $w
585: update
586: }
587: set prior 1
588: $w insert insert $line
589: }
590: } else {
591: $w insert insert $topaste
592: }
593: }
594:
595: # Enable or disable entries in the Edit menu
596: #
597: proc sqlitecon::EnableEditMenu w {
598: upvar #0 $w.t v
599: set m $v(editmenu)
600: if {$m=="" || ![winfo exists $m]} return
601: switch [sqlitecon::canCut $w.t] {
602: 0 {
603: $m entryconf Copy -state disabled
604: $m entryconf Cut -state disabled
605: }
606: 1 {
607: $m entryconf Copy -state normal
608: $m entryconf Cut -state normal
609: }
610: 2 {
611: $m entryconf Copy -state normal
612: $m entryconf Cut -state disabled
613: }
614: }
615: }
616:
617: # Prompt the user for the name of a writable file. Then write the
618: # entire contents of the console screen to that file.
619: #
620: proc sqlitecon::SaveFile w {
621: set types {
622: {{Text Files} {.txt}}
623: {{All Files} *}
624: }
625: set f [tk_getSaveFile -filetypes $types -title "Write Screen To..."]
626: if {$f!=""} {
627: if {[catch {open $f w} fd]} {
628: tk_messageBox -type ok -icon error -message $fd
629: } else {
630: puts $fd [string trimright [$w get 1.0 end] \n]
631: close $fd
632: }
633: }
634: }
635:
636: # Erase everything from the console above the insertion line.
637: #
638: proc sqlitecon::Clear w {
639: $w delete 1.0 {insert linestart}
640: }
641:
642: # An in-line editor for SQL
643: #
644: proc sqlitecon::_edit {origtxt {title {}}} {
645: for {set i 0} {[winfo exists .ed$i]} {incr i} continue
646: set w .ed$i
647: toplevel $w
648: wm protocol $w WM_DELETE_WINDOW "$w.b.can invoke"
649: wm title $w {Inline SQL Editor}
650: frame $w.b
651: pack $w.b -side bottom -fill x
652: button $w.b.can -text Cancel -width 6 -command [list set ::$w 0]
653: button $w.b.ok -text OK -width 6 -command [list set ::$w 1]
654: button $w.b.cut -text Cut -width 6 -command [list ::sqlitecon::Cut $w.t]
655: button $w.b.copy -text Copy -width 6 -command [list ::sqlitecon::Copy $w.t]
656: button $w.b.paste -text Paste -width 6 -command [list ::sqlitecon::Paste $w.t]
657: set ::$w {}
658: pack $w.b.cut $w.b.copy $w.b.paste $w.b.can $w.b.ok\
659: -side left -padx 5 -pady 5 -expand 1
660: if {$title!=""} {
661: label $w.title -text $title
662: pack $w.title -side top -padx 5 -pady 5
663: }
664: text $w.t -bg white -fg black -yscrollcommand [list $w.sb set]
665: pack $w.t -side left -fill both -expand 1
666: scrollbar $w.sb -orient vertical -command [list $w.t yview]
667: pack $w.sb -side left -fill y
668: $w.t insert end $origtxt
669:
670: vwait ::$w
671:
672: if {[set ::$w]} {
673: set txt [string trimright [$w.t get 1.0 end]]
674: } else {
675: set txt $origtxt
676: }
677: destroy $w
678: return $txt
679: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to sqlitecon.tcl CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / sqlite3 / contrib