## Thanks to the following (among many) for early bug reports & code ideas:
## Steven Wahl, Jan Nijtmans, Mark Crimmins, Wart
##
-## Copyright (c) 1995-2004 Jeffrey Hobbs, jeff(a)hobbs(.)org
+## Copyright (c) 1995-2009 Jeffrey Hobbs, jeff(a)hobbs(.)org
## Initiated: Thu Aug 17 15:36:47 PDT 1995
##
## source standard_disclaimer.tcl
# tkcon master set ::tkcon:PRIV(proxy) wwwproxy:8080
#
-if {$tcl_version < 8.0} {
- return -code error "tkcon requires at least Tcl/Tk8"
+if {$tcl_version < 8.4} {
+ return -code error "tkcon requires at least Tcl/Tk 8.4"
} else {
- package require Tk
+ package require Tk 8.4
}
# We need to load some package to get what's available, and we
set file [lindex $pkg 0]
set name [lindex $pkg 1]
if {![catch {set version [package require $name]}]} {
- if {[string match {} [package ifneeded $name $version]]} {
+ if {[package ifneeded $name $version] eq ""} {
package ifneeded $name $version [list load $file $name]
}
}
namespace eval ::tkcon {
# when modifying this line, make sure that the auto-upgrade check
# for version still works.
- variable VERSION "2.5"
+ variable VERSION "2.6"
# The OPT variable is an array containing most of the optional
# info to configure. COLOR has the color data.
variable OPT
}
## Evaluate maineval in slave
- if {[string compare {} $OPT(maineval)] && \
- [catch {uplevel \#0 $OPT(maineval)} merr]} {
+ if {($OPT(maineval) ne "") && [catch {uplevel \#0 $OPT(maineval)} merr]} {
puts stderr "error in eval:\n$merr"
append PRIV(errorInfo) $errorInfo\n
}
}
## Evaluate slaveeval in slave
- if {[string compare {} $OPT(slaveeval)] && \
- [catch {interp eval $OPT(exec) $OPT(slaveeval)} serr]} {
+ if {($OPT(slaveeval) ne "")
+ && [catch {interp eval $OPT(exec) $OPT(slaveeval)} serr]} {
puts stderr "error in slave eval:\n$serr"
append PRIV(errorInfo) $errorInfo\n
}
## Output any error/output that may have been returned from rcfile
- if {[info exists code] && $code && [string compare {} $err]} {
+ if {[info exists code] && $code && ($err ne "")} {
puts stderr "error in $PRIV(rcfile):\n$err"
append PRIV(errorInfo) $errorInfo
}
- if {[string compare {} $OPT(exec)]} {
+ if {$OPT(exec) ne ""} {
StateCheckpoint [concat $PRIV(name) $OPT(exec)] slave
}
StateCheckpoint $PRIV(name) slave
variable PRIV
global argv0 tcl_interactive tcl_library env auto_path tk_library
- if {[string match {} $slave]} {
+ if {$slave eq ""} {
return -code error "Don't init the master interpreter, goofball"
}
if {![interp exists $slave]} { interp create $slave }
variable PRIV
## Don't allow messing up a local master interpreter
- if {[string match namespace $type] || ([string match slave $type] && \
- [regexp {^([Mm]ain|Slave[0-9]+)$} $name])} return
+ if {($type eq "namespace")
+ || (($type eq "slave") &&
+ [regexp {^([Mm]ain|Slave[0-9]+)$} $name])} { return }
set old [Attach]
set oldname $PRIV(namesp)
catch {
} {err}
eval Attach $old
AttachNamespace $oldname
- if {[string compare {} $err]} { return -code error $err }
+ if {$err ne ""} { return -code error $err }
}
## ::tkcon::InitUI - inits UI portion (console) of tkcon
variable COLOR
set root $PRIV(root)
- if {[string match . $root]} { set w {} } else { set w [toplevel $root] }
+ if {$root eq "."} { set w {} } else { set w [toplevel $root] }
if {!$PRIV(WWW)} {
wm withdraw $root
wm protocol $root WM_DELETE_WINDOW $PRIV(protocol)
label $sbar.cursor -relief sunken -borderwidth 1 -anchor e -width 6 \
-textvariable ::tkcon::PRIV(StatusCursor)
set padx [expr {![info exists ::tcl_platform(os)]
- || ![string match "Windows CE" $::tcl_platform(os)]}]
+ || ($::tcl_platform(os) ne "Windows CE")}]
grid $PRIV(X) $PRIV(tabframe) $sbar.cursor -sticky news -padx $padx
grid configure $PRIV(tabframe) -sticky nsw
grid configure $PRIV(X) -pady 0 -padx 0
# scrollbar
set sy [scrollbar $w.sy -takefocus 0 -command [list $con yview]]
- if {!$PRIV(WWW) && [string match "Windows CE" $::tcl_platform(os)]} {
+ if {!$PRIV(WWW) && ($::tcl_platform(os) eq "Windows CE")} {
$w.sy configure -width 10
}
-insertbackground $COLOR(cursor) -borderwidth 1 -highlightthickness 0
$con mark set output 1.0
$con mark set limit 1.0
- if {[string compare {} $COLOR(bg)]} {
+ if {$COLOR(bg) ne ""} {
$con configure -background $COLOR(bg)
}
set COLOR(bg) [$con cget -background]
- if {[string compare {} $OPT(font)]} {
+ if {$OPT(font) ne ""} {
## Set user-requested font, if any
$con configure -font $OPT(font)
- } elseif {[string compare unix $::tcl_platform(platform)]} {
+ } elseif {$::tcl_platform(platform) ne "unix"} {
## otherwise make sure the font is monospace
set font [$con cget -font]
if {![font metrics $font -fixed]} {
# scrollbar
if {!$PRIV(WWW)} {
- if {[string match "Windows CE" $::tcl_platform(os)]} {
+ if {$::tcl_platform(os) eq "Windows CE"} {
font configure tkconfixed -family Tahoma -size 8
$con configure -font tkconfixed -borderwidth 0 -padx 0 -pady 0
set cw [font measure tkconfixed "0"]
# Calls: ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd
##
proc ::tkcon::Eval {w} {
- set incomplete [CmdSep [CmdGet $w] cmds last]
+ set complete [CmdSep [CmdGet $w] cmds last]
$w mark set insert end-1c
$w insert end \n
if {[llength $cmds]} {
foreach c $cmds {EvalCmd $w $c}
$w insert insert $last {}
- } elseif {!$incomplete} {
+ } elseif {$complete} {
EvalCmd $w $last
}
if {[winfo exists $w]} {
variable PRIV
$w mark set output end
- if {[string compare {} $cmd]} {
+ if {$cmd ne ""} {
set code 0
if {$OPT(subhistory)} {
set ev [EvalSlave history nextid]
incr ev -1
## FIX: calcmode doesn't work with requesting history events
- if {[string match !! $cmd]} {
+ if {$cmd eq "!!"} {
set code [catch {EvalSlave history event $ev} cmd]
if {!$code} {$w insert output $cmd\n stdin}
} elseif {[regexp {^!(.+)$} $cmd dummy event]} {
## evaluation of this command - for cases like the command
## has a vwait or something in it
$w mark set limit end
- if {$OPT(nontcl) && [string match interp $PRIV(apptype)]} {
+ if {$OPT(nontcl) && ($PRIV(apptype) eq "interp")} {
set code [catch {EvalSend $cmd} res]
if {$code == 1} {
set PRIV(errorInfo) "Non-Tcl errorInfo not available"
}
- } elseif {[string match socket $PRIV(apptype)]} {
+ } elseif {$PRIV(apptype) eq "socket"} {
set code [catch {EvalSocket $cmd} res]
if {$code == 1} {
set PRIV(errorInfo) "Socket-based errorInfo not available"
} else {
$w insert output $res\n$trailer stderr
}
- } elseif {[string compare {} $res]} {
+ } elseif {$res ne ""} {
$w insert output $res stdout $trailer stderr \n stdout
}
}
# type - (slave|interp)
##
proc ::tkcon::EvalOther { app type args } {
- if {[string compare slave $type]==0} {
+ if {$type eq "slave"} {
return [Slave $app $args]
} else {
return [uplevel 1 ::send::send [list $app] $args]
set ev [EvalSlave history nextid]
incr ev -1
set code [catch {EvalSlave history event $ev} lastCmd]
- if {$code || [string compare $cmd $lastCmd]} {
+ if {$code || $cmd ne $lastCmd} {
EvalSlave history add $cmd
}
}
set code [catch {::send::send -displayof $PRIV(displayWin) $PRIV(app) $cmd} result]
if {$code && [lsearch -exact [::send::interps] $PRIV(app)]<0} {
## Interpreter disappeared
- if {[string compare leave $OPT(dead)] && \
- ([string match ignore $OPT(dead)] || \
- [tk_messageBox -title "Dead Attachment" -type yesno \
- -icon info -message \
- "\"$PRIV(app)\" appears to have died.\
- \nReturn to primary slave interpreter?"]=="no")} {
+ if {($OPT(dead) ne "leave") &&
+ (($OPT(dead) eq "ignore") ||
+ [tk_messageBox -title "Dead Attachment" -type yesno \
+ -icon info -message \
+ "\"$PRIV(app)\" appears to have died.\
+ \nReturn to primary slave interpreter?"] eq "no")} {
set PRIV(appname) "DEAD:$PRIV(appname)"
set PRIV(deadapp) 1
} else {
variable PRIV
catch {close $sock}
- if {![string match $sock $PRIV(app)]} {
+ if {$sock ne $PRIV(app)} {
# If we are not still attached to that socket, just return.
# Might be nice to tell the user the socket closed ...
return
}
- if {[string compare leave $OPT(dead)] && \
- ([string match ignore $OPT(dead)] || \
- [tk_messageBox -title "Dead Attachment" -type yesno \
- -icon question \
- -message "\"$PRIV(app)\" appears to have died.\
- \nReturn to primary slave interpreter?"] == "no")} {
+ if {$OPT(dead) ne "leave" &&
+ ($OPT(dead) eq "ignore" ||
+ [tk_messageBox -title "Dead Attachment" -type yesno \
+ -icon question \
+ -message "\"$PRIV(app)\" appears to have died.\
+ \nReturn to primary slave interpreter?"] eq "no")} {
set PRIV(appname) "DEAD:$PRIV(appname)"
set PRIV(deadapp) 1
} else {
#
##
proc ::tkcon::Namespaces {{ns ::} {l {}}} {
- if {[string compare {} $ns]} { lappend l $ns }
+ if {$ns ne ""} { lappend l $ns }
foreach i [EvalAttached [list namespace children $ns]] {
set l [Namespaces $i $l]
}
set inc {}
set cmds {}
foreach c [split [string trimleft $cmd] \n] {
- if {[string compare $inc {}]} {
+ if {$inc ne ""} {
append inc \n$c
} else {
append inc [string trimleft $c]
set inc {}
}
}
- set i [string compare $inc {}]
- if {!$i && [string compare $cmds {}] && ![string match *\n $cmd]} {
+ set i [string equal $inc {}]
+ if {$i && $cmds ne "" && ![string match *\n $cmd]} {
set inc [lindex $cmds end]
set cmds [lreplace $cmds end end]
}
set inc {}
set cmds {}
foreach cmd [split [string trimleft $cmd] \n] {
- if {[string compare {} $inc]} {
+ if {$inc ne ""} {
append inc \n$cmd
} else {
append inc [string trimleft $cmd]
set w $PRIV(console)
if {![winfo exists $w]} { return }
- if {[string compare {} $pre]} { $w insert end $pre stdout }
+ if {$pre ne ""} { $w insert end $pre stdout }
set i [$w index end-1c]
if {!$OPT(showstatusbar)} {
- if {[string compare {} $PRIV(appname)]} {
+ if {$PRIV(appname) ne ""} {
$w insert end ">$PRIV(appname)< " prompt
}
- if {[string compare :: $PRIV(namesp)]} {
+ if {$PRIV(namesp) ne "::"} {
$w insert end "<$PRIV(namesp)> " prompt
}
}
- if {[string compare {} $prompt]} {
+ if {$prompt ne ""} {
$w insert end $prompt prompt
} else {
$w insert end [EvalSlave subst $OPT(prompt1)] prompt
$w mark set insert end
$w mark set limit insert
$w mark gravity limit left
- if {[string compare {} $post]} { $w insert end $post stdin }
+ if {$post ne ""} { $w insert end $post stdin }
ConstrainBuffer $w $OPT(buffer)
set ::tkcon::PRIV(StatusCursor) [$w index insert]
$w see end
-command ::tkcon::Destroy
$m add command -label "Clear Console" -underline 1 -accel Ctrl-l \
-command { clear; ::tkcon::Prompt }
- if {[string match unix $tcl_platform(platform)]} {
+ if {[tk windowingsystem] eq "x11"} {
$m add separator
$m add command -label "Make Xauth Secure" -und 5 \
-command ::tkcon::XauthSecure
menu $sub.name -disabledforeground $COLOR(disabled) \
-postcommand [list ::tkcon::NamespaceMenu $sub.name]
- if {$::tcl_version >= 8.3} {
- ## Attach Socket Menu
- ##
- # This uses [file channels] to create the menu, so we only
- # want it for newer versions of Tcl.
- $sub add cascade -label "Socket" -underline 0 -menu $sub.sock
- menu $sub.sock -disabledforeground $COLOR(disabled) \
- -postcommand [list ::tkcon::SocketMenu $sub.sock]
- }
+ ## Attach Socket Menu
+ ##
+ $sub add cascade -label "Socket" -underline 0 -menu $sub.sock
+ menu $sub.sock -disabledforeground $COLOR(disabled) \
+ -postcommand [list ::tkcon::SocketMenu $sub.sock]
- if {![string compare "unix" $tcl_platform(platform)]} {
+ if {[tk windowingsystem] eq "x11"} {
## Attach Display Menu
##
$sub add cascade -label "Display" -underline 0 -menu $sub.disp
$w delete 0 end
foreach {app type} [Attach] break
$w add command -label "[string toupper $type]: $app" -state disabled
- if {($OPT(nontcl) && [string match interp $type]) || $PRIV(deadapp)} {
+ if {($OPT(nontcl) && $type eq "interp") || $PRIV(deadapp)} {
$w add separator
$w add command -state disabled -label "Communication disabled to"
$w add command -state disabled -label "dead or non-Tcl interps"
# get all package names currently visible
foreach pkg [lremove [EvalAttached {package names}] Tcl] {
set version [EvalAttached [list package provide $pkg]]
- if {[string compare {} $version]} {
+ if {$version ne ""} {
set loaded($pkg) $version
} elseif {![info exists loaded($pkg)]} {
set loadable($pkg) package
$m add command -label "tkcon Interpreters" -state disabled
foreach i [lsort [array names interps]] {
- if {[string match {} $interps($i)]} { set interps($i) "no Tk" }
+ if {$interps($i) eq ""} { set interps($i) "no Tk" }
if {[regexp {^Slave[0-9]+} $i]} {
set opts [list -label "$i ($interps($i))" \
-variable ::tkcon::PRIV(app) -value $i \
-command "::tkcon::Attach [list $i] slave; $cmd"]
- if {[string match $PRIV(name) $i]} {
+ if {$PRIV(name) eq $i} {
append opts " -accel Ctrl-2"
}
eval $m add radio $opts
} else {
set name [concat Main $i]
- if {[string match Main $name]} {
+ if {$name eq "Main"} {
$m add radio -label "$name ($interps($i))" -accel Ctrl-3 \
-variable ::tkcon::PRIV(app) -value Main \
-command "::tkcon::Attach [list $name] slave; $cmd"
variable OPT
$m delete 0 end
- if {($PRIV(deadapp) || [string match socket $PRIV(apptype)] || \
- ($OPT(nontcl) && [string match interp $PRIV(apptype)]))} {
+ if {($PRIV(deadapp) || $PRIV(apptype) eq "socket" || \
+ ($OPT(nontcl) && $PRIV(apptype) eq "interp"))} {
$m add command -label "No Namespaces" -state disabled
return
}
-command [list ::tkcon::NamespacesList $names]
} else {
foreach i $names {
- if {[string match :: $i]} {
+ if {$i eq "::"} {
$m add radio -label "Main" -value $i \
-variable ::tkcon::PRIV(namesp) \
-command "::tkcon::AttachNamespace [list $i]; $cmd"
grid rowconfigure $f 0 -weight 1
#fill the listbox
foreach i $names {
- if {[string match :: $i]} {
+ if {$i eq "::"} {
$f.names insert 0 Main
} else {
$f.names insert end $i
proc ::tkcon::XauthSecure {} {
global tcl_platform
- if {[string compare unix $tcl_platform(platform)]} {
+ if {[tk windowingsystem] ne "x11"} {
# This makes no sense outside of Unix
return
}
[list $w] tag remove find 1.0 end
wm withdraw [list $base]
"
- if {[string compare {} $str]} {
+ if {$str ne ""} {
set PRIV(find) $str
$base.btn.fnd invoke
}
- if {[string compare normal [wm state $base]]} {
+ if {[wm state $base] ne "normal"} {
wm deiconify $base
} else { raise $base }
$base.f.e select range 0 end
}
}
if {![info exists case]} { lappend opts -nocase }
- if {[string match {} $str]} return
+ if {$str eq ""} { return }
$w mark set findmark 1.0
- while {[string compare {} [set ix [eval $w search $opts -count numc -- \
- [list $str] findmark end]]]} {
+ while {[set ix [eval $w search $opts -count numc -- \
+ [list $str] findmark end]] ne ""} {
$w tag add find $ix ${ix}+${numc}c
$w mark set findmark ${ix}+1c
}
set path [concat $PRIV(name) $OPT(exec)]
set PRIV(displayWin) .
- if {[string match namespace $type]} {
+ if {$type eq "namespace"} {
return [uplevel 1 ::tkcon::AttachNamespace $name]
} elseif {[string match dpy:* $type]} {
set PRIV(displayWin) [string range $type 4 end]
}
set app $name
set type socket
- } elseif {[string compare {} $name]} {
+ } elseif {$name ne ""} {
array set interps [Interps]
if {[string match {[Mm]ain} [lindex $name 0]]} {
set name [lrange $name 1 end]
}
- if {[string match $path $name]} {
+ if {$name eq $path} {
set name {}
set app $path
set type slave
} elseif {[info exists interps($name)]} {
- if {[string match {} $name]} { set name Main; set app Main }
+ if {$name eq ""} { set name Main; set app Main }
set type slave
} elseif {[interp exists $name]} {
set name [concat $PRIV(name) $name]
set name [concat $path $name]
set type slave
} elseif {[lsearch -exact [::send::interps] $name] > -1} {
- if {[EvalSlave info exists tk_library] \
- && [string match $name [EvalSlave tk appname]]} {
+ if {[EvalSlave info exists tk_library]
+ && $name eq [EvalSlave tk appname]} {
set name {}
set app $path
set type slave
set namespOK 0
switch -glob -- $type {
slave {
- if {[string match {} $name]} {
+ if {$name eq ""} {
interp alias {} ::tkcon::EvalAttached {} \
::tkcon::EvalSlave uplevel \#0
- } elseif {[string match Main $PRIV(app)]} {
+ } elseif {$PRIV(app) eq "Main"} {
interp alias {} ::tkcon::EvalAttached {} ::tkcon::Main
- } elseif {[string match $PRIV(name) $PRIV(app)]} {
+ } elseif {$PRIV(name) eq $PRIV(app)} {
interp alias {} ::tkcon::EvalAttached {} uplevel \#0
} else {
interp alias {} ::tkcon::EvalAttached {} \
a valid type: must be slave or interp"
}
}
- if {![string match {} $ns] && $namespOK} {
+ if {$ns ne "" && $namespOK} {
AttachNamespace $ns
}
return [AttachId]
# return Attach info in a form that Attach accepts again
variable PRIV
- if {[string match {} $PRIV(appname)]} {
+ if {$PRIV(appname) eq ""} {
variable OPT
set appname [concat $PRIV(name) $OPT(exec)]
} else {
set id [list $appname $PRIV(apptype)]
# only display ns info if it isn't "::" as that is what is also
# used to indicate no eval in namespace
- if {![string match :: $PRIV(namesp)]} { lappend id $PRIV(namesp) }
+ if {$PRIV(namesp) ne "::"} { lappend id $PRIV(namesp) }
if {[info exists PRIV(console)]} {
variable ATTACH
set ATTACH($PRIV(console)) $id
# We could enable 'socket' bound Tcl interps, but we'd have to create
# a return listening socket
- if {($OPT(nontcl) && [string match interp $PRIV(apptype)]) \
- || [string match socket $PRIV(apptype)] \
- || $PRIV(deadapp)} {
+ if {($OPT(nontcl) && $PRIV(apptype) eq "interp")
+ || $PRIV(apptype) eq "socket"
+ || $PRIV(deadapp)} {
return -code error "can't attach to namespace in attached environment"
}
- if {[string match Main $name]} {set name ::}
- if {[string compare {} $name] && \
- [lsearch [Namespaces ::] $name] == -1} {
+ if {$name eq "Main"} {set name ::}
+ if {$name ne "" && [lsearch [Namespaces ::] $name] == -1} {
return -code error "No known namespace \"$name\""
}
if {[regexp {^(|::)$} $name]} {
} else {
set opencmd [list tk_getOpenFile]
}
- if {
- [string match {} $fn] &&
+ if {$fn eq "" &&
([catch {tk_getOpenFile -filetypes $types \
- -title "Source File"} fn] || [string match {} $fn])
+ -title "Source File"} fn] || $fn eq "")
} { return }
EvalAttached [list source $fn]
}
} else {
set savecmd [list tk_getSaveFile]
}
- if {[string match {} $fn]} {
+ if {$fn eq ""} {
set types {
{{Tcl Files} {.tcl .tk}}
{{Text Files} {.txt}}
if {[catch {eval $savecmd [list -defaultextension .tcl \
-filetypes $types \
-title "Save $type"]} fn]
- || [string match {} $fn]} return
+ || $fn eq ""} return
}
set type [string tolower $type]
switch $type {
variable OPT
## Slave interpreter exit request
- if {[string match exit $OPT(slaveexit)]
- || [llength $PRIV(interps)] == 1} {
+ if {$OPT(slaveexit) eq "exit" || [llength $PRIV(interps)] == 1} {
## Only exit if it specifically is stated to do so, or this
## is the last interp
uplevel 1 exit $args
## FIX: This puts history in backwards!!
while {($id < $max) && ![catch \
{::tkcon::EvalSlave history event $id} cmd]} {
- if {[string compare {} $cmd]} {
+ if {$cmd ne ""} {
puts $fid "::tkcon::EvalSlave\
history add [list $cmd]"
}
}
proc ::tkcon::Interps {{ls {}} {interp {}}} {
- if {[string match {} $interp]} {
+ if {$interp eq ""} {
lappend ls {} [tk appname]
}
foreach i [interp slaves $interp] {
- if {[string compare {} $interp]} { set i "$interp $i" }
- if {[string compare {} [interp eval $i package provide Tk]]} {
+ if {$interp ne ""} { set i "$interp $i" }
+ if {[interp eval $i package provide Tk] ne ""} {
# beware safe interps with Tk
if {[catch {interp eval $i tk appname} name]} {
set name {}
set w $PRIV(console)
set nextid [EvalSlave history nextid]
- if {[string compare {} $str]} {
+ if {$str ne ""} {
## String is not empty, do an event search
set event $PRIV(event)
if {$int < 0 && $event == $nextid} { set PRIV(cmdbuf) $str }
#-----------------------------------------------------------------------
# Elements of tkPriv that are used in this file:
#
- # char - Character position on the line; kept in order
- # to allow moving up or down past short lines while
- # still remembering the desired position.
# mouseMoved - Non-zero means the mouse has moved a significant
# amount since the button went down (so, for example,
# start dragging out a selection).
- # prevPos - Used when moving up or down lines via the keyboard.
- # Keeps track of the previous insert position, so
- # we can distinguish a series of ups and downs, all
- # in a row, from a new up or down.
- # selectMode - The style of selection currently underway:
- # char, word, or line.
- # x, y - Last known mouse coordinates for scanning
- # and auto-scanning.
#-----------------------------------------------------------------------
switch -glob $tcl_platform(platform) {
projects / tkcon / commitdiff