## Steven Wahl <steven@indra.com>, Jan Nijtmans <nijtmans@nici.kun.nl>
## Crimmins <markcrim@umich.edu>, Wart <wart@ugcs.caltech.edu>
##
-## Copyright 1995-1998 Jeffrey Hobbs
+## Copyright 1995-1999 Jeffrey Hobbs
## Initiated: Thu Aug 17 15:36:47 PDT 1995
##
## jeff.hobbs@acm.org
return -code error "TkCon requires at least Tcl7.6/Tk4.2"
}
+catch {package require bogus-package-name}
foreach pkg [info loaded {}] {
set file [lindex $pkg 0]
set name [lindex $pkg 1]
slaveeval {}
slaveexit close
subhistory 1
+ maxmenu 15
exec slave
app {}
find,reg 0
errorInfo {}
slavealias { tkcon }
+ slaveappalias { edit more less }
slaveprocs {
alias auto_execok clear dir dump echo idebug lremove
tkcon_puts tclindex observe observe_var unalias which
}
- version 1.3
- release {27 May 1998}
- docs {http://www.cs.uoregon.edu/research/tcl/script/tkcon/}
+ version 1.4
+ release {February 1999}
+ docs "http://www.purl.org/net/hobbs/tcl/script/tkcon/\nhttp://www.hobbs.wservice.com/tcl/script/tkcon/"
email {jeff.hobbs@acm.org}
root .
}
+ ## NOTES FOR STAYING IN PRIMARY INTERPRETER:
+ ## If you set TKCON(exec) to {}, then instead of a multiple interpreter
+ ## model, you get TkCon operating in the main interp by default.
+ ## This can be useful when attaching to programs that like to operate
+ ## in the main interpter (for example, based on special wish'es.
+ #set TKCON(exec) {}
if {$TKCON(WWW)} {
lappend TKCON(slavealias) history
interp eval $slave {
catch {rename puts tkcon_tcl_puts}
#catch {rename gets tkcon_tcl_gets}
+ catch {package require bogus-package-name}
}
foreach cmd $TKCON(slaveprocs) { $slave eval [dump proc $cmd] }
foreach cmd $TKCON(slavealias) { $slave alias $cmd $cmd }
+ foreach cmd $TKCON(slaveappalias) { $slave alias $cmd $cmd $slave slave }
interp alias $slave ls $slave dir -full
interp alias $slave puts $slave tkcon_puts
#interp alias $slave gets $slave tkcon_gets
if {[string match namespace $type] || ([string match slave $type] && \
[regexp {^([Mm]ain|Slave[0-9]+)$} $name])} return
set old [tkConAttach]
+ if {$TKCON(A:version) >= 8.0} { set oldname $TKCON(namesp) }
catch {
tkConAttach $name $type
tkConEvalAttached {
foreach cmd $TKCON(slavealias) {
tkConMain interp alias $name $cmd $TKCON(name) $cmd
}
+ foreach cmd $TKCON(slaveappalias) {
+ tkConMain interp alias $name $cmd $TKCON(name) $cmd \
+ $name $type
+ }
}
interp {
- set name [tk appname]
+ set thistkcon [tk appname]
foreach cmd $TKCON(slavealias) {
- tkConEvalAttached "proc $cmd args { send [list $name] $cmd \$args }"
+ tkConEvalAttached "proc $cmd args { send [list $thistkcon] $cmd \$args }"
+ }
+ foreach cmd $TKCON(slaveappalias) {
+ tkConEvalAttached "proc $cmd args { send [list $thistkcon] $cmd [list $name] $type \$args }"
}
}
}
return
} {err}
eval tkConAttach $old
+ if {$TKCON(A:version) >= 8.0} { tkConAttachNamespace $oldname }
if {[string compare {} $err]} { return -code error $err }
}
;proc tkConEvalNamespace { attached namespace args } {
global TKCON
if {[string compare {} $args]} {
- if {$TKCON(A:itcl)} {
+ if {$TKCON(A:itcl2)} {
uplevel \#0 $attached namespace [list $namespace $args]
} else {
uplevel \#0 $attached namespace eval [list $namespace $args]
##
;proc tkConNamespaces { {ns ::} } {
global TKCON
- if {$TKCON(A:itcl)} {
+ if {$TKCON(A:itcl2)} {
return [tkConNamespacesItcl $ns]
} else {
return [tkConNamespacesTcl8 $ns]
$w.text tag config title -justify center -font *Courier*Bold*18*
}
$w.text insert 1.0 "About TkCon v$TKCON(version)" title \
- "\n\nCopyright 1995-1998 Jeffrey Hobbs, $TKCON(email)\
+ "\n\nCopyright 1995-1999 Jeffrey Hobbs, $TKCON(email)\
\nRelease Date: v$TKCON(version), $TKCON(release)\
\nDocumentation available at:\n$TKCON(docs)\
\nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
}
}
-
## tkConInitMenus - inits the menubar and popup for the console
# ARGS: w - console text widget
##
;proc tkConInitMenus {w title} {
- global TKCON
+ global TKCON tcl_platform
if {[catch {menu $w.pop -tearoff 0}]} {
label $w.label -text "Menus not available in plugin mode"
pack $w.label
return
}
- bind [winfo toplevel $w] <Button-3> [list tk_popup $w.pop %X %Y]
+ menu $w.context -tearoff 0 -disabledforeground $TKCON(color,prompt)
+ set TKCON(context) $w.context
+ set TKCON(popup) $w.pop
if {[info tclversion] >= 8.0} {
proc tkConMenuButton {w m l} {
-command tkConDestroy
$m add command -label "Clear Console" -und 1 -accel Ctrl-l \
-command { clear; tkConPrompt }
+ if {[string match unix $tcl_platform(platform)]} {
+ $m add separator
+ $m add command -label "Make Xauth Secure" -und 5 \
+ -command tkConXauthSecure
+ }
$m add separator
- $m add cascade -label "Attach Console" -und 0 -menu $m.apps
- $m add cascade -label "Attach Namespace" -und 1 -menu $m.name
+ $m add cascade -label "Attach To ..." -und 0 -menu $m.attach
## Attach Console Menu
##
- menu $m.apps -disabledforeground $TKCON(color,prompt) \
- -postcommand [list tkConAttachMenu $m.apps]
+ set sub [menu $m.attach -disabledforeground $TKCON(color,prompt)]
+ $sub add cascade -label "Interpreter" -und 0 -menu $sub.apps
+ $sub add cascade -label "Namespace" -und 1 -menu $sub.name
+ $sub add cascade -label "Socket" -und 1 -menu $sub.sock -state disabled
+
+ ## Attach Console Menu
+ ##
+ menu $sub.apps -disabledforeground $TKCON(color,prompt) \
+ -postcommand [list tkConAttachMenu $sub.apps]
## Attach Namespace Menu
##
- menu $m.name -disabledforeground $TKCON(color,prompt) -tearoff 0 \
- -postcommand [list tkConNamespaceMenu $m.name]
+ menu $sub.name -disabledforeground $TKCON(color,prompt) -tearoff 0 \
+ -postcommand [list tkConNamespaceMenu $sub.name]
+
+ ## Attach Socket Menu
+ ##
+ menu $sub.sock -disabledforeground $TKCON(color,prompt) -tearoff 0 \
+ -postcommand [list tkConSocketMenu $sub.sock]
}
## Edit Menu
if {$TKCON(histid)==$id} return
set TKCON(histid) $id
$m delete 0 end
- while {($id>$TKCON(histid)-10) && \
+ while {$id && ($id>$TKCON(histid)-10) && \
![catch {tkConEvalSlave history event [incr id -1]} tmp]} {
set lbl [lindex [split $tmp "\n"] 0]
if {[string len $lbl]>32} { set lbl [string range $tmp 0 28]... }
$TKCON(console) delete limit end
$TKCON(console) insert limit [list $tmp]
$TKCON(console) see end
- tkConEval $TKCON(console)
- "
+ tkConEval $TKCON(console)"
+ }
+}
+
+## tkConSocketMenu - dynamically build the menu for attached interpreters
+##
+# ARGS: m - menu widget
+##
+;proc tkConSocketMenu m {
+ global TKCON
+
+ if {![winfo exists $m]} return
+ $m delete 0 end
+ for {set i 1} {$i <= 500} {incr i} {
+ if {![tkConEvalAttached "catch {fconfigure sock$i}"]} {
+ $m add command -label "sock$i" \
+ -command [list tkConAttach sock$i socket]
+ }
}
}
$w delete 0 end
foreach {app type} [tkConAttach] break
$w add command -label "[string toupper $type]: $app" -state disabled
- $w add separator
if {($TKCON(nontcl) && [string match interp $type]) || $TKCON(deadapp)} {
+ $w add separator
$w add command -state disabled -label "Communication disabled to"
$w add command -state disabled -label "dead or non-Tcl interps"
return
}
+ ## Packages Cascaded Menu
+ ##
if {$TKCON(A:version) > 7.4} {
- ## Packages Cascaded Menu
- ##
- $w add cascade -label Packages -und 0 -menu $w.pkg
+ $w add separator
+ $w add cascade -label Packages -underline 0 -menu $w.pkg
set m $w.pkg
- if {[winfo exists $m]} {
- $m delete 0 end
- } else {
- menu $m -tearoff no -disabledfore $TKCON(color,prompt)
- }
-
- foreach pkg [tkConEvalAttached [list info loaded {}]] {
- set loaded([lindex $pkg 1]) [package provide $pkg]
- }
- foreach pkg [lremove [tkConEvalAttached {package names}] Tcl] {
- set version [tkConEvalAttached [list package provide $pkg]]
- if {[string compare {} $version]} {
- set loaded($pkg) $version
- } elseif {![info exists loaded($pkg)]} {
- set loadable($pkg) [list package require $pkg]
- }
- }
- foreach pkg [tkConEvalAttached {info loaded}] {
- set pkg [lindex $pkg 1]
- if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} {
- set loadable($pkg) [list load {} $pkg]
- }
- }
- foreach pkg [array names loadable] {
- $m add command -label "Load $pkg ([tkConEvalAttached \
- [list package version $pkg]])"\
- -command "tkConEvalOther [list $app] $type $loadable($pkg)"
- }
- if {[info exists loaded] && [info exists loadable]} {
- $m add separator
- }
- foreach pkg [array names loaded] {
- $m add command -label "${pkg}$loaded($pkg) Loaded" -state disabled
+ if {![winfo exists $m]} {
+ menu $m -tearoff no -disabledforeground $TKCON(color,prompt) \
+ -postcommand [list tkConPkgMenu $m $app $type]
}
}
-command [list tkConInitInterp $app $type]
}
+## tkConPkgMenu - fill in in the applications sub-menu
+## with a list of all the applications that currently exist.
+##
+;proc tkConPkgMenu {m app type} {
+ global TKCON
+
+ set lopt [expr {([info tclversion] >= 8.0)?"-dictionary":"-ascii"}]
+
+ # just in case stuff has been added to the auto_path
+ tkConEvalAttached {catch {package require bogus-package-name}}
+ $m delete 0 end
+ foreach pkg [tkConEvalAttached [list info loaded {}]] {
+ set loaded([lindex $pkg 1]) [package provide $pkg]
+ }
+ foreach pkg [lremove [tkConEvalAttached {package names}] Tcl] {
+ set version [tkConEvalAttached [list package provide $pkg]]
+ if {[string compare {} $version]} {
+ set loaded($pkg) $version
+ } elseif {![info exists loaded($pkg)]} {
+ set loadable($pkg) [list package require $pkg]
+ }
+ }
+ foreach pkg [tkConEvalAttached {info loaded}] {
+ set pkg [lindex $pkg 1]
+ if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} {
+ set loadable($pkg) [list load {} $pkg]
+ }
+ }
+ foreach pkg [lsort $lopt [array names loadable]] {
+ foreach v [tkConEvalAttached [list package version $pkg]] {
+ $m add command -label "Load $pkg ($v)" -command \
+ "tkConEvalOther [list $app] $type $loadable($pkg) $v"
+ }
+ }
+ if {[info exists loaded] && [info exists loadable]} {
+ $m add separator
+ }
+ foreach pkg [lsort $lopt [array names loaded]] {
+ $m add command -label "${pkg}$loaded($pkg) Loaded" -state disabled
+ }
+}
+
## tkConAttachMenu - fill in in the applications sub-menu
## with a list of all the applications that currently exist.
##
## Same command as for tkConAttachMenu items
set cmd {tkConPrompt \n [tkConCmdGet $TKCON(console)]}
- foreach i [tkConNamespaces ::] {
+ set names [lsort [tkConNamespaces ::]]
+ if {[llength $names] > $TKCON(maxmenu)} {
+ $m add command -label "List Namespaces" \
+ -command [list tkConNamespacesList $names]
+ } else {
+ foreach i $names {
+ if {[string match :: $i]} {
+ $m add radio -label "Main" -variable TKCON(namesp) -value $i \
+ -command "tkConAttachNamespace [list $i]; $cmd"
+ } else {
+ $m add radio -label $i -variable TKCON(namesp) -value $i \
+ -command "tkConAttachNamespace [list $i]; $cmd"
+ }
+ }
+ }
+}
+
+## Namepaces List
+##
+;proc tkConNamespacesList {names} {
+ global TKCON
+
+ set f $TKCON(base).tkConNamespaces
+ catch {destroy $f}
+ toplevel $f
+ listbox $f.names -width 30 -height 15 -selectmode single \
+ -yscrollcommand [list $f.scrollv set] \
+ -xscrollcommand [list $f.scrollh set]
+ scrollbar $f.scrollv -command [list $f.names yview]
+ scrollbar $f.scrollh -command [list $f.names xview] -orient horizontal
+ frame $f.buttons
+ button $f.cancel -text "Cancel" -command [list destroy $f]
+
+ grid $f.names $f.scrollv -sticky nesw
+ grid $f.scrollh -sticky ew
+ grid $f.buttons -sticky nesw
+ grid $f.cancel -in $f.buttons -pady 6
+
+ grid columnconfigure $f 0 -weight 1
+ grid rowconfigure $f 0 -weight 1
+ #fill the listbox
+ foreach i $names {
if {[string match :: $i]} {
- $m add radio -label "Main" -variable TKCON(namesp) -value $i \
- -command "tkConAttachNamespace [list $i]; $cmd"
+ $f.names insert 0 Main
} else {
- $m add radio -label $i -variable TKCON(namesp) -value $i \
- -command "tkConAttachNamespace [list $i]; $cmd"
+ $f.names insert end $i
}
}
+ #Bindings
+ bind $f.names <Double-1> {
+ ## Catch in case the namespace disappeared on us
+ catch { tkConAttachNamespace [%W get [%W nearest %y]] }
+ tkConPrompt "\n" [tkConCmdGet $TKCON(console)]
+ destroy [winfo toplevel %W]
+ }
+}
+
+# tkConXauthSecure --
+#
+# This removes all the names in the xhost list, and secures
+# the display for Tk send commands. Of course, this prevents
+# what might have been otherwise allowable X connections
+#
+# Arguments:
+# none
+# Results:
+# Returns nothing
+#
+proc tkConXauthSecure {} {
+ global tcl_platform
+ if {[string compare unix $tcl_platform(platform)]} {
+ # This makes no sense outside of Unix
+ return
+ }
+ set hosts [exec xhost]
+ # the first line is info only
+ foreach host [lrange [split $hosts \n] 1 end] {
+ exec xhost -$host
+ }
+ exec xhost -
+ tk_messageBox -title "Xhost secured" -message "Xhost secured" -icon info
}
## tkConFindBox - creates minimal dialog interface to tkConFind
if {[string match namespace $type]} {
return [uplevel tkConAttachNamespace $name]
+ } elseif {[string match socket $type]} {
+ return [uplevel tkConAttachSocket $name]
} elseif {[string compare {} $name]} {
array set interps [tkConInterps]
if {[string match {[Mm]ain} [lindex $name 0]]} {
interp {
if {$TKCON(nontcl)} {
interp alias {} tkConEvalAttached {} tkConEvalSlave
- array set TKCON {A:version 0 A:namespace 0 A:itcl 0 namesp ::}
+ array set TKCON {A:version 0 A:namespace 0 A:itcl2 0 namesp ::}
} else {
interp alias {} tkConEvalAttached {} tkConEvalSend
}
set TKCON(A:version) [tkConEvalAttached {info tclversion}]
set TKCON(A:namespace) [string compare {} \
[tkConEvalAttached {info commands namespace}]]
- set TKCON(A:itcl) [string match *i \
+ # Itcl3.0 for Tcl8.0 should have Tcl8 namespace semantics
+ # and not effect the patchlevel
+ set TKCON(A:itcl2) [string match *i* \
[tkConEvalAttached {info patchlevel}]]
set TKCON(namesp) ::
}
return
}
-## tkConAttach - called to attach tkCon to an interpreter
+## tkConAttachNamespace - called to attach tkCon to a namespace
# ARGS: name - namespace name in which tkCon should eval commands
# Results: tkConEvalAttached will be modified
##
|| $TKCON(deadapp)} {
return -code error "can't attach to namespace in bad environment"
}
+ if {[string match Main $name]} {set name ::}
if {[string compare {} $name] && \
[lsearch [tkConNamespaces ::] $name] == -1} {
return -code error "No known namespace \"$name\""
set TKCON(namesp) $name
}
+## tkConAttachSocket - called to attach tkCon to a socket
+# ARGS: name - socket name to which tkCon should send commands
+# Results: tkConEvalAttached will be modified
+##
+;proc tkConAttachSocket { name } {
+ global TKCON
+ return
+ if {($TKCON(nontcl) && [string match interp $TKCON(apptype)]) \
+ || $TKCON(deadapp)} {
+ return -code error "can't attach to socket in bad environment"
+ }
+ if {[tkConEvalAttached "catch {fconfigure $name}"]} {
+ return -code error "Unknown socket \"$name\""
+ }
+ interp alias {} tkConEvalAttached {} tkConEvalSocket \
+ [interp alias {} tkConEvalAttached] [list $name]
+ set TKCON(sock) $name
+}
+
## tkConLoad - sources a file into the console
## The file is actually sourced in the currently attached's interp
# ARGS: fn - (optional) filename to source in
grid columnconfig $t 0 -weight 1
grid rowconfig $t 1 -weight 1
wm transient $t $TKCON(root)
- wm geometry $t +[expr ([winfo screenwidth $t]-[winfo \
- reqwidth $t]) / 2]+[expr ([winfo \
- screenheight $t]-[winfo reqheight $t]) / 2]
+ wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
+ reqwidth $t]) / 2}]+[expr {([winfo \
+ screenheight $t]-[winfo reqheight $t]) / 2}]
}
$t.data delete 1.0 end
wm deiconify $t
}
return [uplevel \#0 set $args]
}
+ append {
+ return [uplevel \#0 append $args]
+ }
+ lappend {
+ return [uplevel \#0 lappend $args]
+ }
sh* - dei* {
## 'show|deiconify' - deiconifies the console.
wm deiconify $TKCON(root)
set masterVar [lindex $args 0]
set slaveVar [lindex $args 1]
if {[info exists $masterVar]} {
- interp eval $TKCON(exec) [list set $myVar [set $masterVar]]
+ interp eval $TKCON(exec) [list set $slaveVar [set $masterVar]]
} else {
- catch {interp eval $TKCON(exec) [list unset $myVar]}
+ catch {interp eval $TKCON(exec) [list unset $slaveVar]}
}
- interp eval $TKCON(exec) [list trace variable $myVar rwu \
+ interp eval $TKCON(exec) [list trace variable $slaveVar rwu \
[list tkcon set $masterVar $TKCON(exec)]]
return
}
return $data
}
+## edit - opens a file/proc/var for reading/editing
+##
+# Arguments:
+# app The app (and namespace) this belongs to
+# apptype The app type this belongs to
+# type proc/file/var
+# what the actual name of the item
+# Returns: nothing
+##
+;proc edit {app type args} {
+ global TKCON
+
+ # Create unique edit window toplevel
+ set w $TKCON(base).__edit
+ set i 0
+ while {[winfo exists $w[incr i]]} {}
+ append w $i
+ toplevel $w
+
+ text $w.text -wrap none \
+ -xscrollcommand [list $w.sx set] \
+ -yscrollcommand [list $w.sy set]
+ scrollbar $w.sx -orient h -takefocus 0 -bd 1 -command [list $w.text xview]
+ scrollbar $w.sy -orient v -takefocus 0 -bd 1 -command [list $w.text yview]
+
+ button $w.dismiss -text "Dismiss" -command [list destroy $w]
+ button $w.send -text "Send To $app" \
+ -command "tkConEvalOther [list $app] $type \[$w.text get 1.0 end\]"
+
+ grid $w.text - $w.sy -sticky news
+ grid $w.sx - -sticky ew
+ grid $w.dismiss $w.send -sticky ew -padx 4 -pady 4
+ grid columnconfigure $w 0 -weight 1
+ grid columnconfigure $w 1 -weight 1
+ grid rowconfigure $w 0 -weight 1
+
+ if {[llength $args]==1} {
+ set word [lindex $args 0]
+ if {[string compare {} [tkConEvalOther $app $type info commands [list $word]]]} {
+ set what "proc"
+ } elseif {[string compare {} [tkConEvalOther $app $type info vars [list $word]]]} {
+ set what "var"
+ } elseif {[tkConEvalOther $app $type file isfile [list $word]]} {
+ set what "file"
+ }
+ } elseif {[llength $args]} {
+ set word [lindex $args 1]
+ set what [lindex $args 0]
+ }
+ switch -glob -- $what {
+ all - text {
+ $w.text insert 1.0 [join [lrange $args 1 end] \n]]
+ }
+ proc* {
+ $w.text insert 1.0 [tkConEvalOther $app $type dump proc [list $word]]
+ }
+ var* {
+ $w.text insert 1.0 [tkConEvalOther $app $type dump var [list $word]]
+ }
+ file {
+ $w.text insert 1.0 [tkConEvalOther $app $type eval \
+ [subst -nocommands {set __tkcon(fid) [open $word r]
+ set __tkcon(data) [read \$__tkcon(fid)]
+ close \$__tkcon(fid)
+ after 2000 unset __tkcon
+ return \$__tkcon(data)}]]
+ }
+ }
+}
+interp alias {} more {} edit
+interp alias {} less {} edit
+
+
## echo
## Relaxes the one string restriction of 'puts'
# ARGS: any number of strings to output to stdout
} else { continue }
}
foreach var [lsort $vars] {
+ if {[info tclversion] > 8} {
+ set var [uplevel [list namespace which -variable $var]]
+ }
upvar $var v
if {[array exists v] || [catch {string length $v}]} {
set nst {}
## any - try to dump as var, then command, then widget...
if {
[catch {uplevel dump v -- $args} res] &&
- [catch {uplevel dump c -- $args} res] &&
- [catch {uplevel dump w -- $args} res]
+ [catch {uplevel dump w -- $args} res] &&
+ [catch {uplevel dump c -- $args} res]
} {
set res "dump was unable to resolve type for \"$args\""
set code error
}
if {[string match {} $line]} continue
set key [lindex $line 0]
- if {![regexp {^([\#-]?[0-9]+)} [lreplace $line 0 0] lvl]} {
+ if {![regexp {^([#-]?[0-9]+)} [lreplace $line 0 0] lvl]} {
set lvl \#$level
}
set res {}; set c 0
}
}
bo* {
- if {[regexp {^([\#-]?[0-9]+)} $args level]} {
+ if {[regexp {^([#-]?[0-9]+)} $args level]} {
return [uplevel $level {dump c -no [lindex [info level 0] 0]}]
}
}
t* {
if {[llength $args]<2} return
set min [set max [set lvl $level]]
- set exp {^\#?([0-9]+)? ?\#?([0-9]+) ?\#?([0-9]+)? ?(VERBOSE)?}
+ set exp {^#?([0-9]+)? ?#?([0-9]+) ?#?([0-9]+)? ?(VERBOSE)?}
if {![regexp $exp $args junk min max lvl verbose]} return
for {set i $max} {
$i>=$min && ![catch {uplevel \#$i info level 0} info]
s* {
#var, local, global
set level \#$level
- if {![regexp {^([vgl][^ ]*) ?([\#-]?[0-9]+)? ?(VERBOSE)?} \
+ if {![regexp {^([vgl][^ ]*) ?([#-]?[0-9]+)? ?(VERBOSE)?} \
$args junk type level verbose]} return
switch -glob -- $type {
v* { set vars [uplevel $level {lsort [info vars]}] }
}
## lremove - remove items from a list
-# OPTS: -all remove all instances of each item
+# OPTS:
+# -all remove all instances of each item
+# -pattern remove all instances matching regexp pattern
# ARGS: l a list to remove items from
# args items to remove (these are 'join'ed together)
##
proc lremove {args} {
set all 0
+ set type -exact
if {[string match \-a* [lindex $args 0]]} {
set all 1
set args [lreplace $args 0 0]
}
+ if {[string match \-p* [lindex $args 0]]} {
+ set type -regexp
+ set args [lreplace $args 0 0]
+ }
set l [lindex $args 0]
foreach i [join [lreplace $args 0 0]] {
- if {[set ix [lsearch -exact $l $i]] == -1} continue
+ if {[set ix [lsearch $type $l $i]] == -1} continue
set l [lreplace $l $ix $ix]
if {$all} {
- while {[set ix [lsearch -exact $l $i]] != -1} {
+ while {[set ix [lsearch $type $l $i]] != -1} {
set l [lreplace $l $ix $ix]
}
}
global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon
global errorCode errorInfo
+ # If the command word has the form "namespace inscope ns cmd"
+ # then concatenate its arguments onto the end and evaluate it.
+
+ set cmd [lindex $args 0]
+ if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
+ set arglist [lrange $args 1 end]
+ set ret [catch {uplevel $cmd $arglist} result]
+ if {$ret == 0} {
+ return $result
+ } else {
+ return -code $ret -errorcode $errorCode $result
+ }
+ }
+
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
return -code error "self-referential recursion in \"unknown\" for command \"$name\""
}
set unknown_pending($name) pending
- set ret [catch {auto_load $name} msg]
+ if {[info tclversion] < 8.0} {
+ set ret [catch {auto_load $name} msg]
+ } else {
+ set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
+ }
unset unknown_pending($name)
if {$ret} {
return -code $ret -errorcode $errorCode \
if {$msg} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
- set code [catch {uplevel $args} msg]
+ set code [catch {uplevel 1 $args} msg]
if {$code == 1} {
#
# Strip the last five lines off the error stack (they're
if {$new != ""} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
- return [uplevel exec [list $new] [lrange $args 1 end]]
+ return [uplevel exec $new [lrange $args 1 end]]
#return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]]
}
}
"ambiguous command name \"$name\": [lsort $cmds]"
}
}
+ ## We've got nothing so far
+ ## Check and see if Tk wasn't loaded, but it appears to be a Tk cmd
+ if {![uplevel \#0 info exists tk_version]} {
+ lappend tkcmds bell bind bindtags button \
+ canvas checkbutton clipboard destroy \
+ entry event focus font frame grab grid image \
+ label listbox lower menu menubutton message \
+ option pack place radiobutton raise \
+ scale scrollbar selection send \
+ text tk tkwait toplevel winfo wm
+ if {[lsearch -exact $tkcmds $name] >= 0 && \
+ [tkcon main tk_messageBox -icon question -parent . \
+ -title "Load Tk?" -type retrycancel -default retry \
+ -message "This appears to be a Tk command, but Tk\
+ has not yet been loaded. Shall I retry the command\
+ with loading Tk first?"] == "retry"} {
+ return [uplevel "[list load {} Tk]; $args"]
+ }
+ }
}
return -code continue
}
<<TkCon_Transpose>> <Control-t>
<<TkCon_ClearLine>> <Control-u>
<<TkCon_SaveCommand>> <Control-z>
+ <<TkCon_Popup>> <Button-3>
}] {
event add $ev $key
## Make sure the specific key won't be defined
tkConAttach Main
tkConPrompt "\n" [tkConCmdGet $TKCON(console)]
}
+ bind $TKCON(root) <<TkCon_Popup>> {
+ tkConPopupMenu %X %Y
+ }
## Menu items need null PostCon bindings to avoid the TagProc
##
}
}
-## tkConTagProc - tags a procedure in the console if it's recognized
-## This procedure is not perfect. However, making it perfect wastes
-## too much CPU time...
##
-## These are separated by version only because they are called so often
-## (every keypress) that I didn't want to have if's around the reg exps
-if {[info tclversion] > 8.0} {;
-;proc tkConTagProc w {
- set exp {[^\E][[ \t\n\r;\{\"$]}
- set i [$w search -backwards -regexp $exp insert-1c limit-1c]
- if {[string compare {} $i]} {append i +2c} {set i limit}
- regsub -all {[[\E\?\*]} [$w get $i "insert-1c wordend"] {\\\0} c
- if {[string compare {} [tkConEvalAttached info commands [list $c]]]} {
- $w tag add proc $i "insert-1c wordend"
- } else {
- $w tag remove proc $i "insert-1c wordend"
+# tkConPopupMenu - what to do when the popup menu is requested
+##
+;proc tkConPopupMenu {X Y} {
+ global TKCON
+ set w $TKCON(console)
+ if {[info tclversion] < 8.0 || \
+ [string compare $w [winfo containing $X $Y]]} {
+ tk_popup $TKCON(popup) $X $Y
+ return
}
- if {[string compare {} [tkConEvalAttached info vars [list $c]]]} {
- $w tag add var $i "insert-1c wordend"
- } else {
- $w tag remove var $i "insert-1c wordend"
+ set x [expr {$X-[winfo rootx $w]}]
+ set y [expr {$Y-[winfo rooty $w]}]
+ if {[llength [set tags [$w tag names @$x,$y]]]} {
+ if {[lsearch -exact $tags "proc"] >= 0} {
+ lappend type "proc"
+ foreach {first last} [$w tag prevrange proc @$x,$y] {
+ set word [$w get $first $last]; break
+ }
+ }
+ if {[lsearch -exact $tags "var"] >= 0} {
+ lappend type "var"
+ foreach {first last} [$w tag prevrange var @$x,$y] {
+ set word [$w get $first $last]; break
+ }
+ }
}
+ if {![info exists type]} {
+ set exp "(^|\[^\\\\]\[ \t\n\r])"; set exp2 {[[\\\?\*]}
+ set i [$w search -backwards -regexp $exp @$x,$y "@$x,$y linestart"]
+ if {[string compare {} $i]} {
+ if {![string match *.0 $i]} {append i +2c}
+ if {[string compare {} \
+ [set j [$w search -regexp $exp $i "$i lineend"]]]} {
+ append j +1c
+ } else {
+ set j "$i lineend"
+ }
+ regsub -all $exp2 [$w get $i $j] {\\\0} word
+ set word [string trim $word {\"$[]{}',?#*}]
+ if {[string compare {} [tkConEvalAttached info commands [list $word]]]} {
+ lappend type "proc"
+ }
+ if {[string compare {} [tkConEvalAttached info vars [list $word]]]} {
+ lappend type "var"
+ }
+ if {[tkConEvalAttached file isfile [list $word]]} {
+ lappend type "file"
+ }
+ }
+ }
+ if {![info exists type] || ![info exists word]} {
+ tk_popup $TKCON(popup) $X $Y
+ return
+ }
+ $TKCON(context) delete 0 end
+ $TKCON(context) add command -label "$word" -state disabled
+ $TKCON(context) add separator
+ if {[lsearch $type proc] != -1} {
+ $TKCON(context) add command -label "View Procedure"
+ }
+ if {[lsearch $type var] != -1} {
+ $TKCON(context) add command -label "View Variable"
+ }
+ if {[lsearch $type file] != -1} {
+ $TKCON(context) add command -label "View File"
+ }
+ tk_popup $TKCON(context) $X $Y
}
-} else {;
+
+## tkConTagProc - tags a procedure in the console if it's recognized
+## This procedure is not perfect. However, making it perfect wastes
+## too much CPU time...
+##
;proc tkConTagProc w {
- set exp "\[^\\]\[ \t\n\r\[\;\{\"\$]"
+ set exp "\[^\\\\]\[\[ \t\n\r\;{}\"\$]"
set i [$w search -backwards -regexp $exp insert-1c limit-1c]
if {[string compare {} $i]} {append i +2c} {set i limit}
regsub -all {[[\\\?\*]} [$w get $i "insert-1c wordend"] {\\\0} c
$w tag remove var $i "insert-1c wordend"
}
}
-}
## tkConMatchPair - blinks a matching pair of characters
## c2 is assumed to be at the text index 'insert'.
##
;proc tkConExpand {w {type ""}} {
global TKCON
- if {[info tclversion] > 8.0} {
- set exp {[^\E][[ \t\n\r\{\"$]}
- } else {
- set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
- }
+ set exp "\[^\\\\]\[\[ \t\n\r\{\"\\\$]"
set tmp [$w search -backwards -regexp $exp insert-1c limit-1c]
if {[string compare {} $tmp]} {append tmp +2c} {set tmp limit}
if {[$w compare $tmp >= insert]} return
} else {
if {[llength $m] > 1} {
global tcl_platform
- if {[string match windows $tcl_platform(platform)] \
- && [string compare "Windows NT" $tcl_platform(os)]} {
+ if {[string match windows $tcl_platform(platform)]} {
## Windows is screwy because it's case insensitive
set tmp [tkConExpandBestMatch [string tolower $m] \
- [string tolower [file tail $str]]]
+ [string tolower $dir]]
} else {
- set tmp [tkConExpandBestMatch $m [file tail $str]]
+ set tmp [tkConExpandBestMatch $m $dir]
}
if {[string match ?*/* $str]} {
set tmp [file dirname $str]/$tmp
global TKCON
set match [tkConEvalAttached [list info commands $str*]]
if {[llength $match] == 0 && $TKCON(A:namespace)} {
- if {$TKCON(A:itcl)} {
+ if {$TKCON(A:itcl2)} {
## They are [incr Tcl] namespaces
set ns [tkConEvalAttached [list info namespace all $str*]]
if {[llength $ns]==1} {
projects / tkcon / commitdiff