Posted to tcl by hypnotoad at Mon Jun 03 20:28:44 GMT 2019view pretty
package require clay 0.8
package provide clay::tk::console 0.1
###
# topic: 3f0e8c2797e7bd5e470fce8f117980095ea094f0
# description:
# Open a console window for direct access to the
# Tcl/Tk command interface to the IRM software suite
###
proc ::console:start {} {
if {[info command ::CONSOLE] ne {}} {
CONSOLE wake
} else {
set args [list -prompt {wish% } -title {Tcl/Tk Shell}]
::clay::tk::console create CONSOLE .tclconsole mixinmap {language ::clay::tk::console.tcl} {*}$args
}
CONSOLE redirect_stdout
}
# Create a console widget named $w. The prompt string is $prompt.
# The title at the top of the window is $title. The database connection
# object is $db
#
proc sqlitecon:create {w prompt title db} {
if {[info commands ::clay::tk::$w] ne {}} {
::clay::tk::$w wake
} else {
set args [list prompt $prompt title $title db $db]
destroy $w
::clay::tk::console create ::clay::tk::$w $w mixinmap {language ::clay::tk::console.sqlite} {*}$args
}
}
namespace eval ::clay::tk {}
###
# This file implements the clay event manager
###
::namespace eval ::clay::event {}
###
# topic: f2853d380a732845610e40375bcdbe0f
# description: Cancel a scheduled event
###
proc ::clay::event::cancel {self {task *}} {
variable timer_event
variable timer_script
foreach {id event} [array get timer_event $self:$task] {
::after cancel $event
set timer_event($id) {}
set timer_script($id) {}
}
}
###
# topic: 8ec32f6b6ba78eaf980524f8dec55b49
# description:
# Generate an event
# Adds a subscription mechanism for objects
# to see who has recieved this event and prevent
# spamming or infinite recursion
###
proc ::clay::event::generate {self event args} {
set wholist [Notification_list $self $event]
if {$wholist eq {}} return
set dictargs [::oo::meta::args_to_options {*}$args]
set info $dictargs
set strict 0
set debug 0
set sender $self
dict with dictargs {}
dict set info id [::clay::event::nextid]
dict set info origin $self
dict set info sender $sender
dict set info rcpt {}
foreach who $wholist {
catch {::clay::event::notify $who $self $event $info}
}
}
###
# topic: 891289a24b8cc52b6c228f6edb169959
# title: Return a unique event handle
###
proc ::clay::event::nextid {} {
return "event#[format %0.8x [incr ::clay::event_count]]"
}
###
# topic: 1e53e8405b4631aec17f98b3e8a5d6a4
# description:
# Called recursively to produce a list of
# who recieves notifications
###
proc ::clay::event::Notification_list {self event {stackvar {}}} {
set notify_list {}
foreach {obj patternlist} [array get ::clay::object_subscribe] {
if {$obj eq $self} continue
if {$obj in $notify_list} continue
set match 0
foreach {objpat eventlist} $patternlist {
if {![string match $objpat $self]} continue
foreach eventpat $eventlist {
if {![string match $eventpat $event]} continue
set match 1
break
}
if {$match} {
break
}
}
if {$match} {
lappend notify_list $obj
}
}
return $notify_list
}
###
# topic: b4b12f6aed69f74529be10966afd81da
###
proc ::clay::event::notify {rcpt sender event eventinfo} {
if {[info commands $rcpt] eq {}} return
if {$::clay::trace} {
puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
}
$rcpt notify $event $sender $eventinfo
}
###
# topic: 829c89bda736aed1c16bb0c570037088
###
proc ::clay::event::process {self handle script} {
variable timer_event
variable timer_script
array unset timer_event $self:$handle
array unset timer_script $self:$handle
set err [catch {uplevel #0 $script} result errdat]
if $err {
puts "BGError: $self $handle $script
ERR: $result
[dict get $errdat -errorinfo]
***"
}
}
###
# topic: eba686cffe18cd141ac9b4accfc634bb
# description: Schedule an event to occur later
###
proc ::clay::event::schedule {self handle interval script} {
variable timer_event
variable timer_script
if {$::clay::trace} {
puts [list $self schedule $handle $interval]
}
if {[info exists timer_event($self:$handle)]} {
if {$script eq $timer_script($self:$handle)} {
return
}
::after cancel $timer_event($self:$handle)
}
set timer_script($self:$handle) $script
set timer_event($self:$handle) [::after $interval [list ::clay::event::process $self $handle $script]]
}
###
# topic: e64cff024027ee93403edddd5dd9fdde
###
proc ::clay::event::subscribe {self who event} {
upvar #0 ::clay::object_subscribe($self) subscriptions
if {![info exists subscriptions]} {
set subscriptions {}
}
set match 0
foreach {objpat eventlist} $subscriptions {
if {![string match $objpat $who]} continue
foreach eventpat $eventlist {
if {[string match $eventpat $event]} {
# This rule already exists
return
}
}
}
dict lappend subscriptions $who $event
}
###
# topic: 5f74cfd01735fb1a90705a5f74f6cd8f
###
proc ::clay::event::unsubscribe {self args} {
upvar #0 ::clay::object_subscribe($self) subscriptions
if {![info exists subscriptions]} {
return
}
switch [llength $args] {
1 {
set event [lindex $args 0]
if {$event eq "*"} {
# Shortcut, if the
set subscriptions {}
} else {
set newlist {}
foreach {objpat eventlist} $subscriptions {
foreach eventpat $eventlist {
if {[string match $event $eventpat]} continue
dict lappend newlist $objpat $eventpat
}
}
set subscriptions $newlist
}
}
2 {
set who [lindex $args 0]
set event [lindex $args 1]
if {$who eq "*" && $event eq "*"} {
set subscriptions {}
} else {
set newlist {}
foreach {objpat eventlist} $subscriptions {
if {[string match $who $objpat]} {
foreach eventpat $eventlist {
if {[string match $event $eventpat]} continue
dict lappend newlist $objpat $eventpat
}
}
}
set subscriptions $newlist
}
}
}
}
set ::clay::tk::winsys [tk windowingsystem]
if {$::tcl_platform(platform) eq "windows"} {
set ::clay::tk::platform windows
catch {::ttk::style theme use xpnative}
} else {
if {$::tcl_platform(os) == "Darwin"} {
set ::clay::tk::platform macosx
} else {
set ::clay::tk::platform unix
}
catch {::ttk::style theme use clam}
}
::clay::define ::clay::tk::megawidget {
constructor {tkpath args} {
set hull $tkpath
if {![winfo exists $tkpath]} {
set toplevel $tkpath
toplevel $tkpath
} else {
set toplevel [winfo toplevel $tkpath]
destroy {*}[winfo children $tkpath]
}
my clay delegate hull $hull toplevel $toplevel
my Config_merge $args
my Hull_Populate
my content
}
destructor {
my variable ismain
if { $ismain } {
catch {rename ::console:puts ::puts}
}
my Hull_Destroy
}
Ensemble config::get args {
return [my Config_get {*}$args]
}
Ensemble config::merge args {
return [my Config_merge {*}$args]
}
Ensemble config::set args {
my Config_set {*}$args
}
method Config_get {field args} {
my variable config option_canonical option_getcmd
set field [string trimleft $field -]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
}
if {[info exists option_getcmd($field)]} {
return [eval $option_getcmd($field)]
}
if {[dict exists $config $field]} {
return [dict get $config $field]
}
if {[llength $args]} {
return [lindex $args 0]
}
return [my meta cget $field]
}
###
# topic: dc9fba12ec23a3ad000c66aea17135a5
###
method Config_merge dictargs {
my variable config option_canonical
set rawlist $dictargs
set dictargs {}
set dat [my clay get option]
foreach {field val} $rawlist {
set field [string trim $field -:/]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
}
if {$field eq "mixinmap"} {
my clay mixinmap {*}$val
} elseif {$field eq "delegate"} {
my clay delegate {*}$val
} else {
dict set dictargs $field $val
}
}
###
# Validate all inputs
###
foreach {field val} $dictargs {
set script [my clay get option $field validate-command]
if {$script ne {}} {
dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
}
}
###
# Apply all inputs with special rules
###
foreach {field val} $dictargs {
set script [my clay get option $field set-command]
dict set config $field $val
if {$script ne {}} {
{*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
}
}
return $dictargs
}
method Config_set args {
set dictargs [::clay::args_to_options {*}$args]
set dat [my Config_merge $dictargs]
my Config_triggers $dat
}
###
# topic: 543c936485189593f0b9ed79b5d5f2c0
###
method Config_triggers dictargs {
foreach {field val} $dictargs {
set script [my clay get option $field post-command]
if {$script ne {}} {
{*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
}
}
}
method content {} {}
method event {submethod args} {
::clay::event::$submethod [self] {*}$args
}
method Option_Default field {
set info [my meta getnull option $field]
set getcmd [dict getnull $info default-command:]
if {$getcmd ne {}} {
return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
} else {
return [dict getnull $info default:]
}
}
method Hull_Bind tkpath {
bind $tkpath <Destroy> [namespace code {my Hull_Destroy_From_Tk %w}]
}
method Hull_Destroy {} {
set w [my widget hull]
if {![winfo exists $w]} return
bind $w <Destroy> {}
$w destroy
}
method Hull_Destroy_From_Tk {tkpath} {
set w [my widget hull]
if { [string match "${tkpath}*" $w] } {
bind $w <Destroy> {}
my destroy
}
}
method signal args {}
# Renames the tcl command that represents the widget to
# one that resides in the object's namespace. It then renames
# the object to catch calls to the tk path.
###
method tkalias tkname {
set oldname $tkname
my variable tkalias
set tkalias $tkname
set self [self]
set hullwidget [::info object namespace $self]::tkwidget
my clay delegate tkwidget $hullwidget
rename ::$tkalias $hullwidget
my clay delegate hullwidget $hullwidget
::clay::object_rename [self] ::$tkalias
my Hull_Bind $tkname
return $hullwidget
}
method wake {} {
set hull [my clay delegate hull]
if {![winfo exists $hull]} {
my clay delegate toplevel $hull
toplevel $hull
my Hull_Populate
} else {
catch [list wm deiconify [my widget toplevel]]
update
catch [list raise [my widget toplevel]]
catch [list focus [my widget hull]]
}
}
}
###
# topic: fc7ea2899bddf6a00d04dc7515fd004702d282ef
# description:
# By the overt act of typing this comment, the author of this code
# releases it into the public domain. No claim of copyright is made.
# In place of a legal notice, here is a blessing:
#
# May you do good and not evil.
# May you find forgiveness for yourself and forgive others.
# May you share freely, never taking more than you give.
#
#
#
# This file contains code use to implement a simple command-line console
# for Tcl/Tk.
###
::clay::define ::clay::tk::console {
superclass megawidget
Variable toplevel {}
Variable ismain 0
clay set option language {
default tcl
}
clay set option title {
default {}
}
clay set option prompt {
default {tcl% }
}
set has_consolas [expr {"Consolas" in [font families]}]
if {$has_consolas} {
set font {Consolas 10}
switch $::clay::tk::platform {
macosx {
set font {Consolas 12}
}
}
} else {
set font {fixed 10}
switch $::clay::tk::platform {
macosx {
set font {system 10}
}
windows {
set font {systemfixed 9}
}
}
}
clay set option font [list \
widget font \
description {Font used on console widgets} \
default $font ]
clay set signal focus {
follows *
action {focus [my clay delegate text]}
}
destructor {
my variable ismain
if { $ismain } {
catch {rename ::console:puts ::puts}
}
my Hull_Destroy
set terminate [expr {$hull eq "."}]
if {$terminate} {
exit 0
}
}
###
# topic: 03ca79afffe63938a00a9bd124316ba6fe83443d
###
method addHistory line {
my variable v
if {$v(historycnt)>0} {
set last [lindex $v(history) [expr $v(historycnt)-1]]
if {[string compare $last $line]} {
lappend v(history) $line
incr v(historycnt)
}
} else {
set v(history) [list $line]
set v(historycnt) 1
}
set v(current) $v(historycnt)
}
###
# topic: 83fc9e18be0f0d1798c7e20e7ccb23d806e1474c
# description:
# Called whenever the mouse leaves the boundries of the widget
# while button 1 is held down.
###
method B1Leave {x y} {
my variable v
set v(y) $y
set v(x) $x
my motor
}
###
# topic: 61622cb601a30cc516a5b227c37e80444ae09911
# description: Called whenever the mouse moves while button-1 is held down.
###
method B1Motion {x y} {
my variable v
set v(y) $y
set v(x) $x
my SelectTo $x $y
}
###
# topic: b8eb39886df4395c26e911532af6c904910c735d
# description: Erase the character to the left of the cursor
###
method Backspace {} {
my variable v
scan [my <text> index insert] %d.%d row col
if {$col>$v(plength)} {
my <text> delete {insert -1c}
}
}
###
# topic: 055c60d0743072b8d18f23322164664b80fa9328
###
method build_buttons {} {
my variable v
set mb [my widget subwindow mb]
ttk::frame $mb
my clay delegate buttonframe $mb
pack $mb -side top -fill x
menubutton $mb.file -text File -menu $mb.file.m
menubutton $mb.edit -text Edit -menu $mb.edit.m
menubutton $mb.tool -text Tools -menu $mb.tool.m
pack $mb.file $mb.edit $mb.tool -side left -padx 8 -pady 1
set m [menu $mb.file.m -tearoff 0]
# $m add command -label {Source...} -command "console:SourceFile $w.t"
# $m add command -label {Save As...} -command "console:SaveFile $w.t"
# $m add separator
$m add command -label {Close} -command [list destroy [my widget hull]]
$m add command -label {Exit} -command exit
#$m add command -label {SQLite Console} -command \
# {::sqlitecon::create .sqlitecon {sqlite> } {SQLite Console} db}
set m [menu $mb.tool.m -tearoff 0]
set editmenu $mb.edit.m
set v(editmenu) $editmenu
set m [menu $editmenu -tearoff 0]
$m add command -label Cut -command [namespace code "my Cut"]
$m add command -label Copy -command [namespace code "my Copy"]
$m add command -label Paste -command [namespace code "my Paste"]
$m add command -label {Clear Screen} -command [namespace code "my Clear"]
$m add separator
$m add command -label {Source...} -command [namespace code "my SourceFile"]
$m add command -label {Save As...} -command [namespace code "my SaveFile"]
catch {$editmenu config -postcommand [namespace code "my EnableEditMenu"]}
}
method SBSET {args} {
set sb [my widget subwindow sb]
catch {$sb set {*}$args}
}
###
# topic: 93a511dc8939a3f59315d2b2016946e82cc4c12c
###
method build_console {} {
set w [my widget hull]
my variable v
array set v {
pressX 0
mouseMoved 0
}
set sb [my widget subwindow sb]
set st [my widget subwindow console]
ttk::scrollbar $sb -orient vertical -command "$st yview"
pack $sb -side right -fill y
text $st -font [my Config_get font] -yscrollcommand [namespace code {my SBSET}]
pack $st -side right -fill both -expand 1
my clay delegate text $st
set prompt [my Config_get prompt]
set v(text) $st
set v(history) 0
set v(historycnt) 0
set v(current) -1
set v(prompt) $prompt
set v(prior) {}
set v(plength) [string length $v(prompt)]
set v(x) 0
set v(y) 0
$st mark set insert end
$st tag config ok -foreground blue
$st tag config err -foreground red
$st tag config grn -foreground #00a000
$st tag config purple -foreground #c000c0
$st tag config lblue -foreground #417a9b
$st tag config orange -foreground #be9e4f
$st insert end $v(prompt)
$st mark set out 1.0
my signal focus
bindtags $st [list $st . all]
bind $st <1> [namespace code {my Button1 %x %y}]
bind $st <B1-Motion> [namespace code {my B1Motion %x %y}]
bind $st <B1-Leave> [namespace code {my B1Leave %x %y}]
bind $st <B1-Enter> [namespace code {my cancelMotor}]
bind $st <ButtonRelease-1> [namespace code {my cancelMotor}]
bind $st <KeyPress> [namespace code {my Insert %A}]
bind $st <Left> [namespace code {my Left}]
bind $st <Control-b> [namespace code {my Left}]
bind $st <Right> [namespace code {my Right}]
bind $st <Control-f> [namespace code {my Right}]
bind $st <BackSpace> [namespace code {my Backspace}]
bind $st <Control-h> [namespace code {my Backspace}]
bind $st <Delete> [namespace code {my Delete}]
bind $st <Control-d> [namespace code {my Delete}]
bind $st <Home> [namespace code {my Home}]
bind $st <Control-a> [namespace code {my Home}]
bind $st <End> [namespace code {my End}]
bind $st <Control-e> [namespace code {my End}]
bind $st <Return> [namespace code {my Enter}]
bind $st <KP_Enter> [namespace code {my Enter}]
bind $st <Up> [namespace code {my Prior}]
bind $st <Control-p> [namespace code {my Prior}]
bind $st <Down> [namespace code {my Next}]
bind $st <Control-n> [namespace code {my Next}]
bind $st <Control-k> [namespace code {my EraseEOL}]
bind $st <<Cut>> [namespace code {my Cut}]
bind $st <<Copy>> [namespace code {my Copy}]
bind $st <<Paste>> [namespace code {my Paste}]
bind $st <<Clear>> [namespace code {my Clear}]
}
###
# topic: 67ea0661809dd66ff34b45263c465789bfbb9591
# description:
# Called when the mouse button is pressed at position $x,$y on
# the console widget.
###
method Button1 {x y} {
global tkPriv
set w [my clay delegate text]
my variable v
set v(mouseMoved) 0
set v(pressX) $x
set p [my nearestBoundry $x $y]
scan [my <text> index insert] %d.%d ix iy
scan $p %d.%d px py
if {$px==$ix} {
my <text> mark set insert $p
}
my <text> mark set anchor $p
focus $w
}
###
# topic: 937a1570589f78997120e0f82d9989651a462dad
# description: This routine cancels the scrolling motor if it is active
###
method cancelMotor {} {
my event cancel motor
}
###
# topic: 968b14fc7c6cbd13fd8a23f3d635ae0da45c6561
# description:
# Return 1 if the selection exists and is contained
# entirely on the input line. Return 2 if the selection
# exists but is not entirely on the input line. Return 0
# if the selection does not exist.
###
method canCut {} {
set r [catch {
scan [my <text> index sel.first] %d.%d s1x s1y
scan [my <text> index sel.last] %d.%d s2x s2y
scan [my <text> index insert] %d.%d ix iy
}]
if {$r==1} {return 0}
if {$s1x==$ix && $s2x==$ix} {return 1}
return 2
}
###
# topic: 4a6b17559391aff67a3b8d9e850da371c89ff5ab
# description: Erase everything from the console above the insertion line.
###
method Clear {} {
my <text> delete 1.0 {insert linestart}
}
###
# topic: cca0174bee56d0c82519a22c26fa417a3d61e373
# description: Do a Copy operation on the stuff currently selected.
###
method Copy {} {
set w [my clay delegate text]
if {![catch {set text [my <text> get sel.first sel.last]}]} {
clipboard clear -displayof $w
clipboard append -displayof $w $text
}
}
###
# topic: 5600bf5544e3c2a4c7d5b2a8a8f77e3cf4fb80f1
# description:
# Do a Cut operation if possible. Cuts are only allowed
# if the current selection is entirely contained on the
# current input line.
###
method Cut {} {
if {[my canCut]==1} {
my Copy
my <text> delete sel.first sel.last
}
}
###
# topic: 340c92b30cf1d0ee90eac3cc9ee0ff99360bb42d
# description: Erase the character to the right of the cursor
###
method Delete {} {
my <text> delete insert
}
###
# topic: a11cb7a2a3118e0f46a332542e4853543f18cf8b
###
method dialog_preferences {} {
set pvar [my varname prefs]
set f [my widget hull]
if {[winfo exists $f.prefs]} {
destroy {*}[winfo children $f.prefs]
wm deiconify $f.prefs
raise $f.prefs
$f.prefs signal build_content
} else {
::clay::tk::preference_panel $f.prefs object [self]
}
}
###
# topic: 0c0ea9da28a51f2440c58c80021e67e605d750db
# description: Enable or disable entries in the Edit menu
###
method EnableEditMenu {} {
my variable v
set m $v(editmenu)
if {$m=="" || ![winfo exists $m]} return
switch [my canCut] {
0 {
$m entryconf Copy -state disabled
$m entryconf Cut -state disabled
}
1 {
$m entryconf Copy -state normal
$m entryconf Cut -state normal
}
2 {
$m entryconf Copy -state normal
$m entryconf Cut -state disabled
}
}
}
###
# topic: b6157a20658fef4530840f60f8163984a8c0bd6b
# description: Move the cursor to the end of the current line
###
method End {} {
my <text> mark set insert {insert lineend}
}
###
# topic: ade17f15ff8a2b984f503c9570066952844ddf4e
# description: Erase to the end of the line
###
method EraseEOL {} {
my variable v
scan [my <text> index insert] %d.%d row col
if {$col>=$v(plength)} {
my <text> delete insert {insert lineend}
}
}
###
# topic: ab0549c4965bf2dabdd74d318531a3a2bc90cf85
# description: Move the cursor to the beginning of the current line
###
method Home {} {
my variable v
scan [my <text> index insert] %d.%d row col
my <text> mark set insert $row.$v(plength)
}
###
# topic: 04d56668301bb768d53522d5754828bf8b8e2cfa
###
method Hull_Populate {} {
set t [my widget toplevel]
set w [my widget hull]
set prompt [my Config_get prompt]
set title [my Config_get title]
upvar #0 $w.t v
if {[info exists v]} {unset v}
wm title $w $title
wm iconname $w $title
my clay delegate hull $t
my build_buttons
my build_console
}
###
# topic: f21c52fa306df0b911649a088f634792260f9bc3
# description: Insert a single character at the insertion cursor
###
method Insert a {
my <text> insert insert $a
my <text> yview insert
}
###
# topic: a86a704912089f9f69a51608a795ca78846e1c59
###
method insert text {
my insert $a
my Enter
}
###
# topic: a893a71497eca915ca47f88a86f296a05ce1fcab
# description: Move the cursor one character to the left
###
method Left {} {
my variable v
scan [my <text> index insert] %d.%d row col
if {$col>$v(plength)} {
my <text> mark set insert "insert -1c"
}
}
###
# topic: f7d39c17edaa0287b478e6e9924e1ad6c5376ddc
# description:
# This routine is called to automatically scroll the window when
# the mouse drags offscreen.
###
method motor {} {
my variable v
set w [my clay delegate text]
if {![winfo exists $w]} return
if {$v(y)>=[winfo height $w]} {
$w yview scroll 1 units
} elseif {$v(y)<0} {
$w yview scroll -1 units
} else {
return
}
my SelectTo $v(x) $v(y)
my event schedule motor 50 [namespace code {my motor}]
}
###
# topic: 9089b1e19d4d54d37830de5832c94ed317abfc54
# description:
# Find the boundry between characters that is nearest
# to $x,$y
###
method nearestBoundry {x y} {
my variable v
set p [my <text> index @$x,$y]
set bb [my <text> bbox $p]
if {![string compare $bb ""]} {return $p}
if {($x-[lindex $bb 0])<([lindex $bb 2]/2)} {return $p}
my <text> index "$p + 1 char"
}
###
# topic: f2543342648de822341ab839b19fc875549c0d71
# description: Change the line to the next line
###
method Next {} {
my variable v
if {$v(current)>=$v(historycnt)} return
incr v(current) 1
set line [lindex $v(history) $v(current)]
my SetLine $line
}
###
# topic: 1fbaa6cd76c0ba81725f87e67e30c28f13a42de4
###
method Option_set::font newvalue {
my <text> configure -font $newvalue
}
###
# topic: c2f59206f13fc6cd17ba0cc916d4b64853545642
# description: Do a paste opeation.
###
method Paste {} {
my variable v
if {[my canCut]==1} {
my <text> delete sel.first sel.last
}
set w [my clay delegate text]
if {[catch {selection get -displayof $w -selection CLIPBOARD} topaste]
&& [catch {selection get -displayof $w -selection PRIMARY} topaste]} {
return
}
set prior 0
foreach line [split $topaste \n] {
if {$prior} {
my Enter
update
}
set prior 1
my <text> insert insert $line
}
}
###
# topic: 1bdd01f30493ccdf242fcb581c188a861bc51246
# description: Change the line to the previous line
###
method Prior {} {
my variable v
if {$v(current)<=0} return
incr v(current) -1
set line [lindex $v(history) $v(current)]
my SetLine $line
}
###
# topic: f58b9ac700bd1dc6748c89a4d346e7cc4a068bf6
# description:
# Insert test at the "out" mark. The "out" mark is always
# before the input line. New text appears on the line prior
# to the current input line.
###
method puts {t tag} {
set nc [string length $t]
set endc [string index $t [expr $nc-1]]
if {$endc=="\n"} {
if {[my <text> index out]<[my <text> index {insert linestart}]} {
my <text> insert out [string range $t 0 [expr $nc-2]] $tag
my <text> mark set out {out linestart +1 lines}
} else {
my <text> insert out $t $tag
}
} else {
if {[my <text> index out]<[my <text> index {insert linestart}]} {
my <text> insert out $t $tag
} else {
my <text> insert out $t\n $tag
my <text> mark set out {out -1 char}
}
}
my <text> yview insert
}
###
# topic: c7a8603d316f43da21effe7223902dd2853ded43
# description: Move the cursor one character to the right
###
method Right {} {
my <text> mark set insert "insert +1c"
}
###
# topic: 0833547d2ad5522b8a54fa0d92d339e4197ab635
# description:
# Prompt the user for the name of a writable file. Then write the
# entire contents of the console screen to that file.
###
method SaveFile {} {
set types {
{{Text Files} {.txt}}
{{All Files} *}
}
set f [tk_getSaveFile -filetypes $types -title "Write Screen To..."]
if {$f!=""} {
if {[catch {open $f w} fd]} {
::clay::tk::dialog -type ok -icon error -message {Error writing file} -detail $fd
} else {
puts $fd [string trimright [my <text> get 1.0 end] \n]
close $fd
}
}
}
###
# topic: 71af63e2fb369f7677c165caa724b99b2ac0ca26
# description: This routine extends the selection to the point specified by {$x,$y}
###
method SelectTo {x y} {
my variable v
set cur [my nearestBoundry $x $y]
if {[catch {my <text> index anchor}]} {
my <text> mark set anchor $cur
}
set anchor [my <text> index anchor]
if {[my <text> compare $cur != $anchor] || (abs($v(pressX) - $x) >= 3)} {
if {$v(mouseMoved)==0} {
my <text> tag remove sel 0.0 end
}
set v(mouseMoved) 1
}
if {[my <text> compare $cur < anchor]} {
set first $cur
set last anchor
} else {
set first anchor
set last $cur
}
if {$v(mouseMoved)} {
my <text> tag remove sel 0.0 $first
my <text> tag add sel $first $last
my <text> tag remove sel $last end
update idletasks
}
}
###
# topic: d832f029f5a3c95ebbbc0c7f46b053151dbecd2e
# description: Change the contents of the entry line
###
method SetLine line {
my variable v
scan [my <text> index insert] %d.%d row col
set start $row.$v(plength)
my <text> delete $start end
my <text> insert end $line
my <text> mark set insert end
my <text> yview insert
}
Ensemble widget::toplevel {} {
return [my clay delegate toplevel]
}
Ensemble widget::hull {} {
return [my clay delegate hull]
}
Ensemble widget::parent {} {
return [winfo parent [my clay delegate hull]]
}
Ensemble widget::subwindow path {
set tl [string trimleft [my widget hull] .]
if { $tl eq {} } {
return .[string trimleft $path .]
}
return .$tl.[string trimleft $path .]
}
}
::clay::define ::clay::tk::console.tcl {
###
# topic: c3d3bed792724df80d4ee0a5b1bc486d2501fd69
# description:
# Called when "Enter" is pressed. Do something with the line
# of text that was entered.
###
method Enter {} {
my variable v
set w [my clay delegate text]
scan [my <text> index insert] %d.%d row col
set start $row.$v(plength)
set line [my <text> get $start "$start lineend"]
my addHistory $line
my <text> insert end \n
my <text> mark set out end
if {$v(prior)==""} {
set cmd $line
} else {
set cmd $v(prior)\n$line
}
if {[info complete $cmd]} {
set rc [catch {uplevel #0 $cmd} res]
if {![winfo exists $w]} return
if {$rc} {
my <text> insert end $res\n err
} elseif {[string length $res]>0} {
my <text> insert end $res\n ok
}
set v(prior) {}
my <text> insert end $v(prompt)
} else {
set v(prior) $cmd
regsub -all {[^ ]} $v(prompt) . x
my <text> insert end $x
}
my <text> mark set insert end
my <text> mark set out {insert linestart}
my <text> yview insert
}
###
# topic: adb57b892b7da0eb46ab54c904f0de9cb1e31e01
###
method redirect_stdout {} {
my variable ismain
if { $ismain } return
set nspace [namespace current]
set my [namespace which my]
set newproc ::console:puts
if {[info command $newproc] eq {}} {
catch {rename puts $newproc}
}
proc ::puts args [string map [list %newproc% $newproc %nspace% $nspace %self% $my] {
if {[info command %self%] eq {} } {
uplevel #0 %newproc% $args
::rename ::puts {}
::rename %newproc% ::puts
return
}
switch -glob -- "[llength $args] $args" {
{1 *} {
set msg [lindex $args 0]\n
set tag ok
}
{2 stdout *} {
set msg [lindex $args 1]\n
set tag ok
}
{2 stderr *} {
set msg [lindex $args 1]\n
set tag err
}
{2 green *} {
set msg [lindex $args 1]\n
set tag grn
}
{2 purple *} {
set msg [lindex $args 1]\n
set tag purple
}
{2 lightblue *} {
set msg [lindex $args 1]\n
set tag lblue
}
{2 orange *} {
set msg [lindex $args 1]\n
set tag orange
}
{2 -nonewline *} {
set msg [lindex $args 1]
set tag ok
}
{3 -nonewline stdout *} {
set msg [lindex $args 2]
set tag ok
}
{3 -nonewline stderr *} {
set msg [lindex $args 2]
set tag err
}
default {
uplevel #0 %newproc% $args
return
}
}
%self% puts $msg $tag
}]
set ismain 1
return {}
}
###
# topic: 85c1d45d5027823e4407e59dbdfadca12a15d689
# description: Prompt for the user to select an input file, the source that file.
###
method SourceFile {} {
set types {
{{TCL Scripts} {.tcl}}
{{All Files} *}
}
set f [tk_getOpenFile -filetypes $types -title "TCL Script To Source..."]
if {$f!=""} {
uplevel #0 [list source [file normalize $f]]
}
}
}
::clay::define ::clay::tk::console.sqlite {
clay set option db {class organ}
clay set option prompt {default {sqlite-> }}
clay set option title {default {SQLite Console}}
clay set option header {datatype boolean default 1}
clay set option mode {widget select default column values {line list column csv multicolumn}}
###
# topic: 43e235cf3b612e95c590e5de400d4bcc39d622a4
# description:
# Execute a single SQL command. Pay special attention to control
# directives that begin with "."
#
# The return value is the text output from the command, properly
# formatted.
###
method DoCommand cmd {
my clay delegate db [my Config_get db]
my variable v
set mode [my Config_get mode]
set header [my Config_get header]
if {[regexp {^(\.[a-z]+)} $cmd all word]} {
if {$word==".tcl"} {
my tcl_console
return {}
} elseif {$word==".mode"} {
regexp {^.[a-z]+ +([a-z]+)} $cmd all newvalue
my config set [list mode $newvalue]
return {}
} elseif {$word==".exit"} {
my destroy
return {}
} elseif {$word==".header"} {
regexp {^.[a-z]+ +([a-z]+)} $cmd all newvalue
my config set [list header $newvalue]
return {}
} elseif {$word==".tables"} {
set mode multicolumn
set cmd {SELECT name FROM sqlite_master WHERE type='table'
UNION ALL
SELECT name FROM sqlite_temp_master WHERE type='table'}
my <db> eval {PRAGMA database_list} {
if {$name!="temp" && $name!="main"} {
append cmd "UNION ALL SELECT name FROM $name.sqlite_master\
WHERE type='table'"
}
}
append cmd { ORDER BY 1}
} elseif {$word==".fullschema"} {
set pattern %
regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
set mode list
set header 0
set cmd "SELECT sql FROM sqlite_master WHERE tbl_name LIKE '$pattern'
AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
my <db> eval {PRAGMA database_list} {
if {$name!="temp" && $name!="main"} {
append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
}
}
} elseif {$word==".schema"} {
set pattern %
regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
set mode list
set header 0
set cmd "SELECT sql FROM sqlite_master WHERE name LIKE '$pattern'
AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
WHERE name LIKE '$pattern' AND sql NOT NULL"
my <db> eval {PRAGMA database_list} {
if {$name!="temp" && $name!="main"} {
append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
WHERE name LIKE '$pattern' AND sql NOT NULL"
}
}
} else {
return \
".exit\n.mode line|list|column|csv\n.schema ?TABLENAME?\n.tables\n.tcl"
}
}
set res {}
if {$mode=="list"} {
my <db> eval $cmd x {
set sep {}
foreach col $x(*) {
append res $sep$x($col)
set sep |
}
append res \n
}
if {[info exists x(*)] && $header} {
set sep {}
set hdr {}
foreach col $x(*) {
append hdr $sep$col
set sep |
}
set res $hdr\n$res
}
} elseif {[string range $mode 0 2]=="col"} {
set y {}
my <db> eval $cmd x {
foreach col $x(*) {
if {![info exists cw($col)] || $cw($col)<[string length $x($col)]} {
set cw($col) [string length $x($col)]
}
lappend y $x($col)
}
}
if {[info exists x(*)] && $header} {
set hdr {}
set ln {}
set dash ---------------------------------------------------------------
append dash ------------------------------------------------------------
foreach col $x(*) {
if {![info exists cw($col)] || $cw($col)<[string length $col]} {
set cw($col) [string length $col]
}
lappend hdr $col
lappend ln [string range $dash 1 $cw($col)]
}
set y [concat $hdr $ln $y]
}
if {[info exists x(*)]} {
set format {}
set arglist {}
set arglist2 {}
set i 0
foreach col $x(*) {
lappend arglist x$i
append arglist2 " \$x$i"
incr i
append format " %-$cw($col)s"
}
set format [string trimleft $format]\n
if {[llength $arglist]>0} {
foreach $arglist $y "append res \[format [list $format] $arglist2\]"
}
}
} elseif {$mode=="multicolumn"} {
set y [my <db> eval $cmd]
set max 0
foreach e $y {
if {$max<[string length $e]} {set max [string length $e]}
}
set ncol [expr {int(80/($max+2))}]
if {$ncol<1} {set ncol 1}
set nelem [llength $y]
set nrow [expr {($nelem+$ncol-1)/$ncol}]
set format "%-${max}s"
for {set i 0} {$i<$nrow} {incr i} {
set j $i
while 1 {
append res [format $format [lindex $y $j]]
incr j $nrow
if {$j>=$nelem} break
append res { }
}
append res \n
}
} elseif {$mode=="csv"} {
my <db> eval $cmd x {
set sep {}
foreach col $x(*) {
set val $x($col)
if {$val=="" || [regexp {[\s",]} $val]} {
set val \"[string map [list \" \"\"] $val]\"
}
append res $sep$val
set sep ,
}
append res \n
}
} else {
my <db> eval $cmd x {
foreach col $x(*) {append res "$col = $x($col)\n"}
append res \n
}
}
return [string trimright $res]
}
###
# topic: 93d94ab333ba8ad804eefcc8bba8afa95b1e0dcf
###
method Enter {} {
my variable v
set w [my clay delegate text]
scan [my <text> index insert] %d.%d row col
set start $row.$v(plength)
set line [my <text> get $start "$start lineend"]
my <text> insert end \n
my <text> mark set out end
if {$v(prior)==""} {
set cmd $line
} else {
set cmd $v(prior)\n$line
}
if {[string index $cmd 0]=="." || [my <db> complete $cmd]} {
regsub -all {\n} [string trim $cmd] { } cmd2
my addHistory $cmd2
set rc [catch {my DoCommand $cmd} res]
if {![winfo exists $w]} return
if {$rc} {
my <text> insert end $res\n err
} elseif {[string length $res]>0} {
my <text> insert end $res\n ok
}
set v(prior) {}
my <text> insert end $v(prompt)
} else {
set v(prior) $cmd
regsub -all {[^ ]} $v(prompt) . x
my <text> insert end $x
}
my <text> mark set insert end
my <text> mark set out {insert linestart}
my <text> yview insert
}
method tcl_console {} {
set w [my widget toplevel]
if {$w ne "."} {
console:start
} else {
if {[winfo exists .tclconsole]} {
catch {wm deiconify .tclconsole}
update
catch {raise .tclconsole}
} else {
set args [list -prompt {wish% } -title {Tcl/Tk Shell}]
taotk::console .tclconsole {*}$args
}
.tclconsole redirect_stdout
wm title .tclconsole "TCL [my Config_get title]"
.tclconsole puts "SQL Object Available as [my Config_get db]" green
}
}
}
# Start the console
#
# console:create {.@console} {% } {Tcl/Tk Console}