luke
/
netgen
mirror of https://github.com/RTimothyEdwards/netgen.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Made changes to tkcon.tcl to ensure compatibility with Tcl version 9.

This commit is contained in:
Tim Edwards 2025-01-04 14:18:21 -05:00
parent 1d286f9973
commit 021dfa6e8a
2 changed files with 124 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
VERSION
View File

@ -1 +1 @@
1.5.290 1.5.291

203
tcltk/tkcon.tcl
View File

@ -36,7 +36,7 @@ exec ${NETGEN_WISH:=wish} "$0" ${1+"$@"}
# #
# set ::tkcon::PRIV(proxy) {wwwproxy:8080 1} # set ::tkcon::PRIV(proxy) {wwwproxy:8080 1}
# #
# Or you can set the above variable from within tkcon by calling # Or you can set the above variable from within tkcon by calling
# #
# tkcon master set ::tkcon:PRIV(proxy) wwwproxy:8080 # tkcon master set ::tkcon:PRIV(proxy) wwwproxy:8080
# #
@ -44,6 +44,8 @@ exec ${NETGEN_WISH:=wish} "$0" ${1+"$@"}
if {$tcl_version < 8.0} { if {$tcl_version < 8.0} {
return -code error "tkcon requires at least Tcl/Tk8" return -code error "tkcon requires at least Tcl/Tk8"
} else { } else {
# Prevent breaking on version 8.5.2
# package require -exact Tk $tcl_version
package require Tk $tcl_version package require Tk $tcl_version
} }
@ -59,18 +61,6 @@ foreach pkg [info loaded {}] {
} }
catch {unset pkg file name version} catch {unset pkg file name version}
# Tk 8.4 makes previously exposed stuff private.
# FIX: Update tkcon to not rely on the private Tk code.
#
if {![llength [info globals tkPriv]]} {
::tk::unsupported::ExposePrivateVariable tkPriv
}
foreach cmd {SetCursor UpDownLine Transpose ScrollPages} {
if {![llength [info commands tkText$cmd]]} {
::tk::unsupported::ExposePrivateCommand tkText$cmd
}
}
# Initialize the ::tkcon namespace # Initialize the ::tkcon namespace
# #
namespace eval ::tkcon { namespace eval ::tkcon {
@ -196,7 +186,7 @@ proc ::tkcon::Init {} {
tkcon_puts tkcon_gets observe observe_var unalias which what tkcon_puts tkcon_gets observe observe_var unalias which what
} }
version 2.3 version 2.3
RCS {RCS: @(#) $Id: tkcon.tcl,v 1.2 2008/05/23 00:20:17 tim Exp $} RCS {RCS: @(#) $Id: tkcon.tcl,v 1.2 2008/04/18 16:28:13 tim Exp $}
HEADURL {http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/tkcon/tkcon/tkcon.tcl?rev=HEAD} HEADURL {http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/tkcon/tkcon/tkcon.tcl?rev=HEAD}
docs "http://tkcon.sourceforge.net/" docs "http://tkcon.sourceforge.net/"
email {jeff@hobbs.org} email {jeff@hobbs.org}
@ -654,7 +644,7 @@ proc ::tkcon::GarbageCollect {} {
## ::tkcon::EvalCmd) in turn. Any uncompleted command will not be eval'ed. ## ::tkcon::EvalCmd) in turn. Any uncompleted command will not be eval'ed.
# ARGS: w - console text widget # ARGS: w - console text widget
# Calls: ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd # Calls: ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd
## ##
proc ::tkcon::Eval {w} { proc ::tkcon::Eval {w} {
set incomplete [CmdSep [CmdGet $w] cmds last] set incomplete [CmdSep [CmdGet $w] cmds last]
$w mark set insert end-1c $w mark set insert end-1c
@ -674,7 +664,7 @@ proc ::tkcon::Eval {w} {
# Calls: ::tkcon::Prompt # Calls: ::tkcon::Prompt
# Outputs: result of command to stdout (or stderr if error occured) # Outputs: result of command to stdout (or stderr if error occured)
# Returns: next event number # Returns: next event number
## ##
proc ::tkcon::EvalCmd {w cmd} { proc ::tkcon::EvalCmd {w cmd} {
variable OPT variable OPT
variable PRIV variable PRIV
@ -745,7 +735,7 @@ proc ::tkcon::EvalCmd {w cmd} {
$w tag bind $tag <Leave> \ $w tag bind $tag <Leave> \
[list $w tag configure $tag -underline 0] [list $w tag configure $tag -underline 0]
$w tag bind $tag <ButtonRelease-1> \ $w tag bind $tag <ButtonRelease-1> \
"if {!\[info exists tkPriv(mouseMoved)\] || !\$tkPriv(mouseMoved)} \ "if {!\[info exists ::tk::Priv(mouseMoved)\] || !\$::tk::Priv(mouseMoved)} \
{[list edit -attach [Attach] -type error -- $PRIV(errorInfo)]}" {[list edit -attach [Attach] -type error -- $PRIV(errorInfo)]}"
} else { } else {
$w insert output $res\n stderr $w insert output $res\n stderr
@ -905,7 +895,7 @@ proc ::tkcon::EvalSocketClosed {} {
## ::tkcon::EvalNamespace - evaluates the args in a particular namespace ## ::tkcon::EvalNamespace - evaluates the args in a particular namespace
## This is an override for ::tkcon::EvalAttached for when the user wants ## This is an override for ::tkcon::EvalAttached for when the user wants
## to attach to a particular namespace of the attached interp ## to attach to a particular namespace of the attached interp
# ARGS: attached # ARGS: attached
# namespace the namespace to evaluate in # namespace the namespace to evaluate in
# args the args to evaluate # args the args to evaluate
# RETURNS: the result of the command # RETURNS: the result of the command
@ -933,7 +923,7 @@ proc ::tkcon::Namespaces {{ns ::} {l {}}} {
## ::tkcon::CmdGet - gets the current command from the console widget ## ::tkcon::CmdGet - gets the current command from the console widget
# ARGS: w - console text widget # ARGS: w - console text widget
# Returns: text which compromises current command line # Returns: text which compromises current command line
## ##
proc ::tkcon::CmdGet w { proc ::tkcon::CmdGet w {
if {![llength [$w tag nextrange prompt limit end]]} { if {![llength [$w tag nextrange prompt limit end]]} {
$w tag add stdin limit end-1c $w tag add stdin limit end-1c
@ -947,7 +937,7 @@ proc ::tkcon::CmdGet w {
# last - varname of any remainder (like an incomplete final command). # last - varname of any remainder (like an incomplete final command).
# If there is only one command, it's placed in this var. # If there is only one command, it's placed in this var.
# Returns: constituent command info in varnames specified by list & rmd. # Returns: constituent command info in varnames specified by list & rmd.
## ##
proc ::tkcon::CmdSep {cmd list last} { proc ::tkcon::CmdSep {cmd list last} {
upvar 1 $list cmds $last inc upvar 1 $list cmds $last inc
set inc {} set inc {}
@ -974,7 +964,7 @@ proc ::tkcon::CmdSep {cmd list last} {
## ::tkcon::CmdSplit - splits multiple commands into a list ## ::tkcon::CmdSplit - splits multiple commands into a list
# ARGS: cmd - (possible) multiple command to separate # ARGS: cmd - (possible) multiple command to separate
# Returns: constituent commands in a list # Returns: constituent commands in a list
## ##
proc ::tkcon::CmdSplit {cmd} { proc ::tkcon::CmdSplit {cmd} {
set inc {} set inc {}
set cmds {} set cmds {}
@ -998,7 +988,7 @@ proc ::tkcon::CmdSplit {cmd} {
## Called by ::tkcon::EvalCmd ## Called by ::tkcon::EvalCmd
# ARGS: w - text widget # ARGS: w - text widget
# Outputs: tag name guaranteed unique in the widget # Outputs: tag name guaranteed unique in the widget
## ##
proc ::tkcon::UniqueTag {w} { proc ::tkcon::UniqueTag {w} {
set tags [$w tag names] set tags [$w tag names]
set idx 0 set idx 0
@ -1011,7 +1001,7 @@ proc ::tkcon::UniqueTag {w} {
# ARGS: w - console text widget # ARGS: w - console text widget
# size - # of lines to constrain to # size - # of lines to constrain to
# Outputs: may delete data in console widget # Outputs: may delete data in console widget
## ##
proc ::tkcon::ConstrainBuffer {w size} { proc ::tkcon::ConstrainBuffer {w size} {
if {[$w index end] > $size} { if {[$w index end] > $size} {
$w delete 1.0 [expr {int([$w index end])-$size}].0 $w delete 1.0 [expr {int([$w index end])-$size}].0
@ -1021,7 +1011,7 @@ proc ::tkcon::ConstrainBuffer {w size} {
## ::tkcon::Prompt - displays the prompt in the console widget ## ::tkcon::Prompt - displays the prompt in the console widget
# ARGS: w - console text widget # ARGS: w - console text widget
# Outputs: prompt (specified in ::tkcon::OPT(prompt1)) to console # Outputs: prompt (specified in ::tkcon::OPT(prompt1)) to console
## ##
proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} { proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} {
variable OPT variable OPT
variable PRIV variable PRIV
@ -1053,7 +1043,7 @@ proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} {
} }
## ::tkcon::About - gives about info for tkcon ## ::tkcon::About - gives about info for tkcon
## ##
proc ::tkcon::About {} { proc ::tkcon::About {} {
variable OPT variable OPT
variable PRIV variable PRIV
@ -1088,7 +1078,7 @@ proc ::tkcon::About {} {
## ::tkcon::InitMenus - inits the menubar and popup for the console ## ::tkcon::InitMenus - inits the menubar and popup for the console
# ARGS: w - console text widget # ARGS: w - console text widget
## ##
proc ::tkcon::InitMenus {w title} { proc ::tkcon::InitMenus {w title} {
variable OPT variable OPT
variable PRIV variable PRIV
@ -1521,7 +1511,7 @@ proc ::tkcon::NamespaceMenu m {
} }
} }
## Namepaces List ## Namepaces List
## ##
proc ::tkcon::NamespacesList {names} { proc ::tkcon::NamespacesList {names} {
variable PRIV variable PRIV
@ -1894,7 +1884,7 @@ proc ::tkcon::NewSocket {} {
## The file is actually sourced in the currently attached's interp ## The file is actually sourced in the currently attached's interp
# ARGS: fn - (optional) filename to source in # ARGS: fn - (optional) filename to source in
# Returns: selected filename ({} if nothing was selected) # Returns: selected filename ({} if nothing was selected)
## ##
proc ::tkcon::Load { {fn ""} } { proc ::tkcon::Load { {fn ""} } {
set types { set types {
{{Tcl Files} {.tcl .tk}} {{Tcl Files} {.tcl .tk}}
@ -1913,7 +1903,7 @@ proc ::tkcon::Load { {fn ""} } {
## This does not eval in a slave because it's not necessary ## This does not eval in a slave because it's not necessary
# ARGS: w - console text widget # ARGS: w - console text widget
# fn - (optional) filename to save to # fn - (optional) filename to save to
## ##
proc ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } { proc ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } {
variable PRIV variable PRIV
@ -1983,7 +1973,7 @@ proc ::tkcon::MainInit {} {
## Creates a slave interpreter and sources in this script. ## Creates a slave interpreter and sources in this script.
## All other interpreters also get a command to eval function in the ## All other interpreters also get a command to eval function in the
## new interpreter. ## new interpreter.
## ##
proc ::tkcon::New {} { proc ::tkcon::New {} {
variable PRIV variable PRIV
global argv0 argc argv global argv0 argc argv
@ -2020,7 +2010,7 @@ proc ::tkcon::MainInit {} {
## ::tkcon::Exit - full exit OR destroy slave console ## ::tkcon::Exit - full exit OR destroy slave console
## This proc should only be called in the main interpreter from a slave. ## This proc should only be called in the main interpreter from a slave.
## The master determines whether we do a full exit or just kill the slave. ## The master determines whether we do a full exit or just kill the slave.
## ##
proc ::tkcon::Exit {slave args} { proc ::tkcon::Exit {slave args} {
variable PRIV variable PRIV
variable OPT variable OPT
@ -2043,7 +2033,7 @@ proc ::tkcon::MainInit {} {
## This proc should only be called by the main interpreter. If it is ## This proc should only be called by the main interpreter. If it is
## called from there, it will ask before exiting tkcon. All others ## called from there, it will ask before exiting tkcon. All others
## (slaves) will just have their slave interpreter deleted, closing them. ## (slaves) will just have their slave interpreter deleted, closing them.
## ##
proc ::tkcon::Destroy {{slave {}}} { proc ::tkcon::Destroy {{slave {}}} {
variable PRIV variable PRIV
@ -2474,7 +2464,7 @@ proc ::tkcon::ErrorHighlight w {
$w tag configure $tag -foreground $COLOR(stdout) $w tag configure $tag -foreground $COLOR(stdout)
$w tag bind $tag <Enter> [list $w tag configure $tag -underline 1] $w tag bind $tag <Enter> [list $w tag configure $tag -underline 1]
$w tag bind $tag <Leave> [list $w tag configure $tag -underline 0] $w tag bind $tag <Leave> [list $w tag configure $tag -underline 0]
$w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \ $w tag bind $tag <ButtonRelease-1> "if {!\$::tk::Priv(mouseMoved)} \
{[list edit -attach $app -type proc -find $what -- $cmd]}" {[list edit -attach $app -type proc -find $what -- $cmd]}"
} }
set info [string range $info $c1 end] set info [string range $info $c1 end]
@ -2503,7 +2493,7 @@ proc ::tkcon::ErrorHighlight w {
$w tag configure $tag -foreground $COLOR(proc) $w tag configure $tag -foreground $COLOR(proc)
$w tag bind $tag <Enter> [list $w tag configure $tag -underline 1] $w tag bind $tag <Enter> [list $w tag configure $tag -underline 1]
$w tag bind $tag <Leave> [list $w tag configure $tag -underline 0] $w tag bind $tag <Leave> [list $w tag configure $tag -underline 0]
$w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \ $w tag bind $tag <ButtonRelease-1> "if {!\$::tk::Priv(mouseMoved)} \
{[list edit -attach $app -type proc -- $cmd]}" {[list edit -attach $app -type proc -- $cmd]}"
} }
} }
@ -2513,7 +2503,7 @@ proc ::tkcon::ErrorHighlight w {
## This always exists in the main interpreter, and is aliased into ## This always exists in the main interpreter, and is aliased into
## other connected interpreters ## other connected interpreters
# ARGS: totally variable, see internal comments # ARGS: totally variable, see internal comments
## ##
proc tkcon {cmd args} { proc tkcon {cmd args} {
global errorInfo global errorInfo
@ -2552,8 +2542,8 @@ proc tkcon {cmd args} {
## 'congets' a replacement for [gets stdin] ## 'congets' a replacement for [gets stdin]
# Use the 'gets' alias of 'tkcon_gets' command instead of # Use the 'gets' alias of 'tkcon_gets' command instead of
# calling the *get* methods directly for best compatability # calling the *get* methods directly for best compatability
if {[llength $args]} { if {[llength $args] > 1} {
return -code error "wrong # args: must be \"tkcon congets\"" return -code error "wrong # args: must be \"tkcon congets [pfix]\""
} }
tkcon show tkcon show
set old [bind TkConsole <<TkCon_Eval>>] set old [bind TkConsole <<TkCon_Eval>>]
@ -2561,7 +2551,12 @@ proc tkcon {cmd args} {
set w $::tkcon::PRIV(console) set w $::tkcon::PRIV(console)
# Make sure to move the limit to get the right data # Make sure to move the limit to get the right data
$w mark set insert end $w mark set insert end
$w mark set limit insert if {[llength $args]} {
$w mark set limit insert
$w insert end $args
} else {
$w mark set limit insert
}
$w see end $w see end
vwait ::tkcon::PRIV(wait) vwait ::tkcon::PRIV(wait)
set line [::tkcon::CmdGet $w] set line [::tkcon::CmdGet $w]
@ -2790,21 +2785,27 @@ proc tkcon {cmd args} {
## This allows me to capture all stdout/stderr to the console window ## This allows me to capture all stdout/stderr to the console window
## This will be renamed to 'puts' at the appropriate time during init ## This will be renamed to 'puts' at the appropriate time during init
## ##
# ARGS: same as usual # ARGS: same as usual
# Outputs: the string with a color-coded text tag # Outputs: the string with a color-coded text tag
## ##
proc tkcon_puts args { proc tkcon_puts args {
set len [llength $args] set len [llength $args]
foreach {arg1 arg2 arg3} $args { break } foreach {arg1 arg2 arg3} $args { break }
if {$len == 1} { if {$len == 1} {
tkcon console insert output "$arg1\n" stdout set sarg $arg1
set nl 1
set farg stdout
} elseif {$len == 2} { } elseif {$len == 2} {
if {![string compare $arg1 -nonewline]} { if {![string compare $arg1 -nonewline]} {
tkcon console insert output $arg2 stdout set sarg $arg2
set farg stdout
set nl 0
} elseif {![string compare $arg1 stdout] \ } elseif {![string compare $arg1 stdout] \
|| ![string compare $arg1 stderr]} { || ![string compare $arg1 stderr]} {
tkcon console insert output "$arg2\n" $arg1 set sarg $arg2
set farg $arg1
set nl 1
} else { } else {
set len 0 set len 0
} }
@ -2812,11 +2813,15 @@ proc tkcon_puts args {
if {![string compare $arg1 -nonewline] \ if {![string compare $arg1 -nonewline] \
&& (![string compare $arg2 stdout] \ && (![string compare $arg2 stdout] \
|| ![string compare $arg2 stderr])} { || ![string compare $arg2 stderr])} {
tkcon console insert output $arg3 $arg2 set sarg $arg3
set farg $arg2
set nl 0
} elseif {(![string compare $arg1 stdout] \ } elseif {(![string compare $arg1 stdout] \
|| ![string compare $arg1 stderr]) \ || ![string compare $arg1 stderr]) \
&& ![string compare $arg3 nonewline]} { && ![string compare $arg3 nonewline]} {
tkcon console insert output $arg2 $arg1 set sarg $arg2
set farg $arg1
set nl 0
} else { } else {
set len 0 set len 0
} }
@ -2826,7 +2831,42 @@ proc tkcon_puts args {
## $len == 0 means it wasn't handled by tkcon above. ## $len == 0 means it wasn't handled by tkcon above.
## ##
if {$len == 0} {
if {$len != 0} {
## "poor man's" \r substitution---erase everything on the output
## line and print from character after the \r
set rpt [string last \r $sarg]
if {$rpt >= 0} {
tkcon console delete "insert linestart" "insert lineend"
set sarg [string range $sarg [expr {$rpt + 1}] end]
}
set bpt [string first \b $sarg]
if {$bpt >= 0} {
set narg [string range $sarg [expr {$bpt + 1}] end]
set sarg [string range $sarg 0 [expr {$bpt - 1}]]
set nl 0
}
if {$nl == 0} {
tkcon console insert output $sarg $farg
} else {
tkcon console insert output "$sarg\n" $farg
}
if {$bpt >= 0} {
tkcon console delete "insert -1 char" insert
if {$nl == 0} {
tkcon_puts $farg $narg nonewline
} else {
tkcon_puts $farg $narg
}
}
} else {
global errorCode errorInfo global errorCode errorInfo
if {[catch "tkcon_tcl_puts $args" msg]} { if {[catch "tkcon_tcl_puts $args" msg]} {
regsub tkcon_tcl_puts $msg puts msg regsub tkcon_tcl_puts $msg puts msg
@ -2849,7 +2889,7 @@ proc tkcon_puts args {
## This allows me to capture all stdin input without needing to stdin ## This allows me to capture all stdin input without needing to stdin
## This will be renamed to 'gets' at the appropriate time during init ## This will be renamed to 'gets' at the appropriate time during init
## ##
# ARGS: same as gets # ARGS: same as gets
# Outputs: same as gets # Outputs: same as gets
## ##
proc tkcon_gets args { proc tkcon_gets args {
@ -2873,12 +2913,12 @@ proc tkcon_gets args {
} }
## edit - opens a file/proc/var for reading/editing ## edit - opens a file/proc/var for reading/editing
## ##
# Arguments: # Arguments:
# type proc/file/var # type proc/file/var
# what the actual name of the item # what the actual name of the item
# Returns: nothing # Returns: nothing
## ##
proc edit {args} { proc edit {args} {
array set opts {-find {} -type {} -attach {}} array set opts {-find {} -type {} -attach {}}
while {[string match -* [lindex $args 0]]} { while {[string match -* [lindex $args 0]]} {
@ -3030,7 +3070,7 @@ proc echo args { puts [concat $args] }
## clear - clears the buffer of the console (not the history though) ## clear - clears the buffer of the console (not the history though)
## This is executed in the parent interpreter ## This is executed in the parent interpreter
## ##
proc clear {{pcnt 100}} { proc clear {{pcnt 100}} {
if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
return -code error \ return -code error \
@ -3048,7 +3088,7 @@ proc clear {{pcnt 100}} {
## If called with one arg, returns the alias of that arg (or {} if none) ## If called with one arg, returns the alias of that arg (or {} if none)
# ARGS: newcmd - (optional) command to bind alias to # ARGS: newcmd - (optional) command to bind alias to
# args - command and args being aliased # args - command and args being aliased
## ##
proc alias {{newcmd {}} args} { proc alias {{newcmd {}} args} {
if {[string match {} $newcmd]} { if {[string match {} $newcmd]} {
set res {} set res {}
@ -3065,7 +3105,7 @@ proc alias {{newcmd {}} args} {
## unalias - unaliases an alias'ed command ## unalias - unaliases an alias'ed command
# ARGS: cmd - command to unbind as an alias # ARGS: cmd - command to unbind as an alias
## ##
proc unalias {cmd} { proc unalias {cmd} {
interp alias {} $cmd {} interp alias {} $cmd {}
} }
@ -3085,7 +3125,7 @@ proc unalias {cmd} {
# -- forcibly ends options recognition # -- forcibly ends options recognition
# #
# Returns: the values of the requested items in a 'source'able form # Returns: the values of the requested items in a 'source'able form
## ##
proc dump {type args} { proc dump {type args} {
set whine 1 set whine 1
set code ok set code ok
@ -3637,13 +3677,13 @@ proc observe_var {name el op} {
## which - tells you where a command is found ## which - tells you where a command is found
# ARGS: cmd - command name # ARGS: cmd - command name
# Returns: where command is found (internal / external / unknown) # Returns: where command is found (internal / external / unknown)
## ##
proc which cmd { proc which cmd {
## This tries to auto-load a command if not recognized ## This tries to auto-load a command if not recognized
set types [uplevel 1 [list what $cmd 1]] set types [uplevel 1 [list what $cmd 1]]
if {[llength $types]} { if {[llength $types]} {
set out {} set out {}
foreach type $types { foreach type $types {
switch -- $type { switch -- $type {
alias { set res "$cmd: aliased to [alias $cmd]" } alias { set res "$cmd: aliased to [alias $cmd]" }
@ -3674,7 +3714,7 @@ proc which cmd {
## what - tells you what a string is recognized as ## what - tells you what a string is recognized as
# ARGS: str - string to id # ARGS: str - string to id
# Returns: id types of command as list # Returns: id types of command as list
## ##
proc what {str {autoload 0}} { proc what {str {autoload 0}} {
set types {} set types {}
if {[llength [info commands $str]] || ($autoload && \ if {[llength [info commands $str]] || ($autoload && \
@ -3721,7 +3761,7 @@ proc what {str {autoload 0}} {
# -long - list in full format "permissions size date filename" # -long - list in full format "permissions size date filename"
# -full - displays / after directories and link paths for links # -full - displays / after directories and link paths for links
# Returns: a directory listing # Returns: a directory listing
## ##
proc dir {args} { proc dir {args} {
array set s { array set s {
all 0 full 0 long 0 all 0 full 0 long 0
@ -4106,7 +4146,7 @@ proc ::tkcon::Bindings {} {
global tcl_platform tk_version global tcl_platform tk_version
#----------------------------------------------------------------------- #-----------------------------------------------------------------------
# Elements of tkPriv that are used in this file: # Elements of ::tk::Priv that are used in this file:
# #
# char - Character position on the line; kept in order # char - Character position on the line; kept in order
# to allow moving up or down past short lines while # to allow moving up or down past short lines while
@ -4131,9 +4171,12 @@ proc ::tkcon::Bindings {} {
} }
## Get all Text bindings into TkConsole ## Get all Text bindings into TkConsole
foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] } foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] }
## We really didn't want the newline insertion ## We really didn't want the newline insertion
bind TkConsole <Control-Key-o> {} bind TkConsole <Control-Key-o> {}
## in 8.6b3, the virtual events <<NextLine>> and <<PrevLine>>
# mess up our history feature
bind TkConsole <<NextLine>> {} bind TkConsole <<NextLine>> {}
bind TkConsole <<PrevLine>> {} bind TkConsole <<PrevLine>> {}
@ -4342,9 +4385,9 @@ proc ::tkcon::Bindings {} {
bind TkConsole <Control-a> { bind TkConsole <Control-a> {
if {[%W compare {limit linestart} == {insert linestart}]} { if {[%W compare {limit linestart} == {insert linestart}]} {
tkTextSetCursor %W limit ::tk::TextSetCursor %W limit
} else { } else {
tkTextSetCursor %W {insert linestart} ::tk::TextSetCursor %W {insert linestart}
} }
} }
bind TkConsole <Key-Home> [bind TkConsole <Control-a>] bind TkConsole <Key-Home> [bind TkConsole <Control-a>]
@ -4368,14 +4411,14 @@ proc ::tkcon::Bindings {} {
} }
bind TkConsole <<TkCon_Previous>> { bind TkConsole <<TkCon_Previous>> {
if {[%W compare {insert linestart} != {limit linestart}]} { if {[%W compare {insert linestart} != {limit linestart}]} {
tkTextSetCursor %W [tkTextUpDownLine %W -1] ::tk::TextSetCursor %W [::tk::TextUpDownLine %W -1]
} else { } else {
::tkcon::Event -1 ::tkcon::Event -1
} }
} }
bind TkConsole <<TkCon_Next>> { bind TkConsole <<TkCon_Next>> {
if {[%W compare {insert linestart} != {end-1c linestart}]} { if {[%W compare {insert linestart} != {end-1c linestart}]} {
tkTextSetCursor %W [tkTextUpDownLine %W 1] ::tk::TextSetCursor %W [::tk::TextUpDownLine %W 1]
} else { } else {
::tkcon::Event 1 ::tkcon::Event 1
} }
@ -4390,7 +4433,7 @@ proc ::tkcon::Bindings {} {
} }
bind TkConsole <<TkCon_Transpose>> { bind TkConsole <<TkCon_Transpose>> {
## Transpose current and previous chars ## Transpose current and previous chars
if {[%W compare insert > "limit+1c"]} { tkTextTranspose %W } if {[%W compare insert > "limit+1c"]} { ::tk::TextTranspose %W }
} }
bind TkConsole <<TkCon_ClearLine>> { bind TkConsole <<TkCon_ClearLine>> {
## Clear command line (Unix shell staple) ## Clear command line (Unix shell staple)
@ -4408,10 +4451,10 @@ proc ::tkcon::Bindings {} {
::tkcon::Insert %W $::tkcon::PRIV(tmp) ::tkcon::Insert %W $::tkcon::PRIV(tmp)
%W see end %W see end
} }
catch {bind TkConsole <Key-Page_Up> { tkTextScrollPages %W -1 }} catch {bind TkConsole <Key-Page_Up> { ::tk::TextScrollPages %W -1 }}
catch {bind TkConsole <Key-Prior> { tkTextScrollPages %W -1 }} catch {bind TkConsole <Key-Prior> { ::tk::TextScrollPages %W -1 }}
catch {bind TkConsole <Key-Page_Down> { tkTextScrollPages %W 1 }} catch {bind TkConsole <Key-Page_Down> { ::tk::TextScrollPages %W 1 }}
catch {bind TkConsole <Key-Next> { tkTextScrollPages %W 1 }} catch {bind TkConsole <Key-Next> { ::tk::TextScrollPages %W 1 }}
bind TkConsole <$PRIV(meta)-d> { bind TkConsole <$PRIV(meta)-d> {
if {[%W compare insert >= limit]} { if {[%W compare insert >= limit]} {
%W delete insert {insert wordend} %W delete insert {insert wordend}
@ -4429,7 +4472,7 @@ proc ::tkcon::Bindings {} {
} }
bind TkConsole <ButtonRelease-2> { bind TkConsole <ButtonRelease-2> {
if { if {
(!$tkPriv(mouseMoved) || $tk_strictMotif) && (!$::tk::Priv(mouseMoved) || $tk_strictMotif) &&
![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)] ![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)]
} { } {
if {[%W compare @%x,%y < limit]} { if {[%W compare @%x,%y < limit]} {
@ -4600,7 +4643,7 @@ proc ::tkcon::TagProc w {
# c1 - first char of pair # c1 - first char of pair
# c2 - second char of pair # c2 - second char of pair
# Calls: ::tkcon::Blink # Calls: ::tkcon::Blink
## ##
proc ::tkcon::MatchPair {w c1 c2 {lim 1.0}} { proc ::tkcon::MatchPair {w c1 c2 {lim 1.0}} {
if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} {
while { while {
@ -4638,7 +4681,7 @@ proc ::tkcon::MatchPair {w c1 c2 {lim 1.0}} {
## The quote to match is assumed to be at the text index 'insert'. ## The quote to match is assumed to be at the text index 'insert'.
# ARGS: w - console text widget # ARGS: w - console text widget
# Calls: ::tkcon::Blink # Calls: ::tkcon::Blink
## ##
proc ::tkcon::MatchQuote {w {lim 1.0}} { proc ::tkcon::MatchQuote {w {lim 1.0}} {
set i insert-1c set i insert-1c
set j 0 set j 0
@ -4664,7 +4707,7 @@ proc ::tkcon::MatchQuote {w {lim 1.0}} {
# i2 - end index of blink region # i2 - end index of blink region
# dur - duration in usecs to blink for # dur - duration in usecs to blink for
# Outputs: blinks selected characters in $w # Outputs: blinks selected characters in $w
## ##
proc ::tkcon::Blink {w args} { proc ::tkcon::Blink {w args} {
eval [list $w tag add blink] $args eval [list $w tag add blink] $args
after $::tkcon::OPT(blinktime) [list $w] tag remove blink $args after $::tkcon::OPT(blinktime) [list $w] tag remove blink $args
@ -4679,7 +4722,7 @@ proc ::tkcon::Blink {w args} {
# ARGS: w - text window in which to insert the string # ARGS: w - text window in which to insert the string
# s - string to insert (usually just a single char) # s - string to insert (usually just a single char)
# Outputs: $s to text widget # Outputs: $s to text widget
## ##
proc ::tkcon::Insert {w s} { proc ::tkcon::Insert {w s} {
if {[string match {} $s] || [string match disabled [$w cget -state]]} { if {[string match {} $s] || [string match disabled [$w cget -state]]} {
return return
@ -4695,7 +4738,7 @@ proc ::tkcon::Insert {w s} {
$w see insert $w see insert
} }
## ::tkcon::Expand - ## ::tkcon::Expand -
# ARGS: w - text widget in which to expand str # ARGS: w - text widget in which to expand str
# type - type of expansion (path / proc / variable) # type - type of expansion (path / proc / variable)
# Calls: ::tkcon::Expand(Pathname|Procname|Variable) # Calls: ::tkcon::Expand(Pathname|Procname|Variable)
@ -4704,7 +4747,7 @@ proc ::tkcon::Insert {w s} {
# match equaled the string to expand, then all possible matches # match equaled the string to expand, then all possible matches
# are output to stdout. Triggers bell if no matches are found. # are output to stdout. Triggers bell if no matches are found.
# Returns: number of matches found # Returns: number of matches found
## ##
proc ::tkcon::Expand {w {type ""}} { proc ::tkcon::Expand {w {type ""}} {
set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"$\]" set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"$\]"
set tmp [$w search -backwards -regexp $exp insert-1c limit-1c] set tmp [$w search -backwards -regexp $exp insert-1c limit-1c]
@ -4743,7 +4786,7 @@ proc ::tkcon::Expand {w {type ""}} {
# Calls: ::tkcon::ExpandBestMatch # Calls: ::tkcon::ExpandBestMatch
# Returns: list containing longest unique match followed by all the # Returns: list containing longest unique match followed by all the
# possible further matches # possible further matches
## ##
proc ::tkcon::ExpandPathname str { proc ::tkcon::ExpandPathname str {
set pwd [EvalAttached pwd] set pwd [EvalAttached pwd]
# Cause a string like {C:/Program\ Files/} to become "C:/Program Files/" # Cause a string like {C:/Program\ Files/} to become "C:/Program Files/"
@ -4825,7 +4868,7 @@ proc ::tkcon::ExpandProcname str {
# Calls: ::tkcon::ExpandBestMatch # Calls: ::tkcon::ExpandBestMatch
# Returns: list containing longest unique match followed by all the # Returns: list containing longest unique match followed by all the
# possible further matches # possible further matches
## ##
proc ::tkcon::ExpandVariable str { proc ::tkcon::ExpandVariable str {
if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
## Looks like they're trying to expand an array. ## Looks like they're trying to expand an array.
@ -4853,7 +4896,7 @@ proc ::tkcon::ExpandVariable str {
## or $e is {}. $e is extra for compatibility with proc below. ## or $e is {}. $e is extra for compatibility with proc below.
# ARGS: l - list to find best unique match in # ARGS: l - list to find best unique match in
# Returns: longest unique match in the list # Returns: longest unique match in the list
## ##
proc ::tkcon::ExpandBestMatch2 {l {e {}}} { proc ::tkcon::ExpandBestMatch2 {l {e {}}} {
set s [lindex $l 0] set s [lindex $l 0]
if {[llength $l]>1} { if {[llength $l]>1} {
@ -4873,7 +4916,7 @@ proc ::tkcon::ExpandBestMatch2 {l {e {}}} {
# ARGS: l - list to find best unique match in # ARGS: l - list to find best unique match in
# e - currently best known unique match # e - currently best known unique match
# Returns: longest unique match in the list # Returns: longest unique match in the list
## ##
proc ::tkcon::ExpandBestMatch {l {e {}}} { proc ::tkcon::ExpandBestMatch {l {e {}}} {
set ec [lindex $l 0] set ec [lindex $l 0]
if {[llength $l]>1} { if {[llength $l]>1} {
@ -5237,7 +5280,7 @@ proc ::tkcon::Retrieve {} {
## ::tkcon::Resource - re'source's this script into current console ## ::tkcon::Resource - re'source's this script into current console
## Meant primarily for my development of this program. It follows ## Meant primarily for my development of this program. It follows
## links until the ultimate source is found. ## links until the ultimate source is found.
## ##
set ::tkcon::PRIV(SCRIPT) [info script] set ::tkcon::PRIV(SCRIPT) [info script]
if {!$::tkcon::PRIV(WWW) && [string compare $::tkcon::PRIV(SCRIPT) {}]} { if {!$::tkcon::PRIV(WWW) && [string compare $::tkcon::PRIV(SCRIPT) {}]} {
# we use a catch here because some wrap apps choke on 'file type' # we use a catch here because some wrap apps choke on 'file type'