From 021dfa6e8a9a75fa40de667ce2cfe4587ad277cb Mon Sep 17 00:00:00 2001 From: Tim Edwards Date: Sat, 4 Jan 2025 14:18:21 -0500 Subject: [PATCH] Made changes to tkcon.tcl to ensure compatibility with Tcl version 9. --- VERSION | 2 +- tcltk/tkcon.tcl | 203 +++++++++++++++++++++++++++++------------------- 2 files changed, 124 insertions(+), 81 deletions(-) diff --git a/VERSION b/VERSION index 9dcb9bd..fb380af 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.5.290 +1.5.291 diff --git a/tcltk/tkcon.tcl b/tcltk/tkcon.tcl index ea49ae6..62c7d1e 100755 --- a/tcltk/tkcon.tcl +++ b/tcltk/tkcon.tcl @@ -36,7 +36,7 @@ exec ${NETGEN_WISH:=wish} "$0" ${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 # @@ -44,6 +44,8 @@ exec ${NETGEN_WISH:=wish} "$0" ${1+"$@"} if {$tcl_version < 8.0} { return -code error "tkcon requires at least Tcl/Tk8" } else { + # Prevent breaking on version 8.5.2 + # package require -exact Tk $tcl_version package require Tk $tcl_version } @@ -59,18 +61,6 @@ foreach pkg [info loaded {}] { } 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 # namespace eval ::tkcon { @@ -196,7 +186,7 @@ proc ::tkcon::Init {} { tkcon_puts tkcon_gets observe observe_var unalias which what } 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} docs "http://tkcon.sourceforge.net/" email {jeff@hobbs.org} @@ -654,7 +644,7 @@ proc ::tkcon::GarbageCollect {} { ## ::tkcon::EvalCmd) in turn. Any uncompleted command will not be eval'ed. # ARGS: w - console text widget # Calls: ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd -## +## proc ::tkcon::Eval {w} { set incomplete [CmdSep [CmdGet $w] cmds last] $w mark set insert end-1c @@ -674,7 +664,7 @@ proc ::tkcon::Eval {w} { # Calls: ::tkcon::Prompt # Outputs: result of command to stdout (or stderr if error occured) # Returns: next event number -## +## proc ::tkcon::EvalCmd {w cmd} { variable OPT variable PRIV @@ -745,7 +735,7 @@ proc ::tkcon::EvalCmd {w cmd} { $w tag bind $tag \ [list $w tag configure $tag -underline 0] $w tag bind $tag \ - "if {!\[info exists tkPriv(mouseMoved)\] || !\$tkPriv(mouseMoved)} \ + "if {!\[info exists ::tk::Priv(mouseMoved)\] || !\$::tk::Priv(mouseMoved)} \ {[list edit -attach [Attach] -type error -- $PRIV(errorInfo)]}" } else { $w insert output $res\n stderr @@ -905,7 +895,7 @@ proc ::tkcon::EvalSocketClosed {} { ## ::tkcon::EvalNamespace - evaluates the args in a particular namespace ## This is an override for ::tkcon::EvalAttached for when the user wants ## to attach to a particular namespace of the attached interp -# ARGS: attached +# ARGS: attached # namespace the namespace to evaluate in # args the args to evaluate # 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 # ARGS: w - console text widget # Returns: text which compromises current command line -## +## proc ::tkcon::CmdGet w { if {![llength [$w tag nextrange prompt limit end]]} { $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). # If there is only one command, it's placed in this var. # Returns: constituent command info in varnames specified by list & rmd. -## +## proc ::tkcon::CmdSep {cmd list last} { upvar 1 $list cmds $last inc set inc {} @@ -974,7 +964,7 @@ proc ::tkcon::CmdSep {cmd list last} { ## ::tkcon::CmdSplit - splits multiple commands into a list # ARGS: cmd - (possible) multiple command to separate # Returns: constituent commands in a list -## +## proc ::tkcon::CmdSplit {cmd} { set inc {} set cmds {} @@ -998,7 +988,7 @@ proc ::tkcon::CmdSplit {cmd} { ## Called by ::tkcon::EvalCmd # ARGS: w - text widget # Outputs: tag name guaranteed unique in the widget -## +## proc ::tkcon::UniqueTag {w} { set tags [$w tag names] set idx 0 @@ -1011,7 +1001,7 @@ proc ::tkcon::UniqueTag {w} { # ARGS: w - console text widget # size - # of lines to constrain to # Outputs: may delete data in console widget -## +## proc ::tkcon::ConstrainBuffer {w size} { if {[$w index end] > $size} { $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 # ARGS: w - console text widget # Outputs: prompt (specified in ::tkcon::OPT(prompt1)) to console -## +## proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} { variable OPT variable PRIV @@ -1053,7 +1043,7 @@ proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} { } ## ::tkcon::About - gives about info for tkcon -## +## proc ::tkcon::About {} { variable OPT variable PRIV @@ -1088,7 +1078,7 @@ proc ::tkcon::About {} { ## ::tkcon::InitMenus - inits the menubar and popup for the console # ARGS: w - console text widget -## +## proc ::tkcon::InitMenus {w title} { variable OPT variable PRIV @@ -1521,7 +1511,7 @@ proc ::tkcon::NamespaceMenu m { } } -## Namepaces List +## Namepaces List ## proc ::tkcon::NamespacesList {names} { variable PRIV @@ -1894,7 +1884,7 @@ proc ::tkcon::NewSocket {} { ## The file is actually sourced in the currently attached's interp # ARGS: fn - (optional) filename to source in # Returns: selected filename ({} if nothing was selected) -## +## proc ::tkcon::Load { {fn ""} } { set types { {{Tcl Files} {.tcl .tk}} @@ -1913,7 +1903,7 @@ proc ::tkcon::Load { {fn ""} } { ## This does not eval in a slave because it's not necessary # ARGS: w - console text widget # fn - (optional) filename to save to -## +## proc ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } { variable PRIV @@ -1983,7 +1973,7 @@ proc ::tkcon::MainInit {} { ## Creates a slave interpreter and sources in this script. ## All other interpreters also get a command to eval function in the ## new interpreter. - ## + ## proc ::tkcon::New {} { variable PRIV global argv0 argc argv @@ -2020,7 +2010,7 @@ proc ::tkcon::MainInit {} { ## ::tkcon::Exit - full exit OR destroy slave console ## 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. - ## + ## proc ::tkcon::Exit {slave args} { variable PRIV variable OPT @@ -2043,7 +2033,7 @@ proc ::tkcon::MainInit {} { ## This proc should only be called by the main interpreter. If it is ## called from there, it will ask before exiting tkcon. All others ## (slaves) will just have their slave interpreter deleted, closing them. - ## + ## proc ::tkcon::Destroy {{slave {}}} { variable PRIV @@ -2474,7 +2464,7 @@ proc ::tkcon::ErrorHighlight w { $w tag configure $tag -foreground $COLOR(stdout) $w tag bind $tag [list $w tag configure $tag -underline 1] $w tag bind $tag [list $w tag configure $tag -underline 0] - $w tag bind $tag "if {!\$tkPriv(mouseMoved)} \ + $w tag bind $tag "if {!\$::tk::Priv(mouseMoved)} \ {[list edit -attach $app -type proc -find $what -- $cmd]}" } set info [string range $info $c1 end] @@ -2503,7 +2493,7 @@ proc ::tkcon::ErrorHighlight w { $w tag configure $tag -foreground $COLOR(proc) $w tag bind $tag [list $w tag configure $tag -underline 1] $w tag bind $tag [list $w tag configure $tag -underline 0] - $w tag bind $tag "if {!\$tkPriv(mouseMoved)} \ + $w tag bind $tag "if {!\$::tk::Priv(mouseMoved)} \ {[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 ## other connected interpreters # ARGS: totally variable, see internal comments -## +## proc tkcon {cmd args} { global errorInfo @@ -2552,8 +2542,8 @@ proc tkcon {cmd args} { ## 'congets' a replacement for [gets stdin] # Use the 'gets' alias of 'tkcon_gets' command instead of # calling the *get* methods directly for best compatability - if {[llength $args]} { - return -code error "wrong # args: must be \"tkcon congets\"" + if {[llength $args] > 1} { + return -code error "wrong # args: must be \"tkcon congets [pfix]\"" } tkcon show set old [bind TkConsole <>] @@ -2561,7 +2551,12 @@ proc tkcon {cmd args} { set w $::tkcon::PRIV(console) # Make sure to move the limit to get the right data $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 vwait ::tkcon::PRIV(wait) 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 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 -## +## proc tkcon_puts args { set len [llength $args] foreach {arg1 arg2 arg3} $args { break } if {$len == 1} { - tkcon console insert output "$arg1\n" stdout + set sarg $arg1 + set nl 1 + set farg stdout } elseif {$len == 2} { 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] \ || ![string compare $arg1 stderr]} { - tkcon console insert output "$arg2\n" $arg1 + set sarg $arg2 + set farg $arg1 + set nl 1 } else { set len 0 } @@ -2812,11 +2813,15 @@ proc tkcon_puts args { if {![string compare $arg1 -nonewline] \ && (![string compare $arg2 stdout] \ || ![string compare $arg2 stderr])} { - tkcon console insert output $arg3 $arg2 + set sarg $arg3 + set farg $arg2 + set nl 0 } elseif {(![string compare $arg1 stdout] \ || ![string compare $arg1 stderr]) \ && ![string compare $arg3 nonewline]} { - tkcon console insert output $arg2 $arg1 + set sarg $arg2 + set farg $arg1 + set nl 0 } else { set len 0 } @@ -2826,7 +2831,42 @@ proc tkcon_puts args { ## $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 if {[catch "tkcon_tcl_puts $args" 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 will be renamed to 'gets' at the appropriate time during init ## -# ARGS: same as gets +# ARGS: same as gets # Outputs: same as gets ## proc tkcon_gets args { @@ -2873,12 +2913,12 @@ proc tkcon_gets args { } ## edit - opens a file/proc/var for reading/editing -## +## # Arguments: # type proc/file/var # what the actual name of the item # Returns: nothing -## +## proc edit {args} { array set opts {-find {} -type {} -attach {}} 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) ## This is executed in the parent interpreter -## +## proc clear {{pcnt 100}} { if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { 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) # ARGS: newcmd - (optional) command to bind alias to # args - command and args being aliased -## +## proc alias {{newcmd {}} args} { if {[string match {} $newcmd]} { set res {} @@ -3065,7 +3105,7 @@ proc alias {{newcmd {}} args} { ## unalias - unaliases an alias'ed command # ARGS: cmd - command to unbind as an alias -## +## proc unalias {cmd} { interp alias {} $cmd {} } @@ -3085,7 +3125,7 @@ proc unalias {cmd} { # -- forcibly ends options recognition # # Returns: the values of the requested items in a 'source'able form -## +## proc dump {type args} { set whine 1 set code ok @@ -3637,13 +3677,13 @@ proc observe_var {name el op} { ## which - tells you where a command is found # ARGS: cmd - command name # Returns: where command is found (internal / external / unknown) -## +## proc which cmd { ## This tries to auto-load a command if not recognized set types [uplevel 1 [list what $cmd 1]] if {[llength $types]} { set out {} - + foreach type $types { switch -- $type { alias { set res "$cmd: aliased to [alias $cmd]" } @@ -3674,7 +3714,7 @@ proc which cmd { ## what - tells you what a string is recognized as # ARGS: str - string to id # Returns: id types of command as list -## +## proc what {str {autoload 0}} { set types {} if {[llength [info commands $str]] || ($autoload && \ @@ -3721,7 +3761,7 @@ proc what {str {autoload 0}} { # -long - list in full format "permissions size date filename" # -full - displays / after directories and link paths for links # Returns: a directory listing -## +## proc dir {args} { array set s { all 0 full 0 long 0 @@ -4106,7 +4146,7 @@ proc ::tkcon::Bindings {} { 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 # to allow moving up or down past short lines while @@ -4131,9 +4171,12 @@ proc ::tkcon::Bindings {} { } ## 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 bind TkConsole {} + + ## in 8.6b3, the virtual events <> and <> + # mess up our history feature bind TkConsole <> {} bind TkConsole <> {} @@ -4342,9 +4385,9 @@ proc ::tkcon::Bindings {} { bind TkConsole { if {[%W compare {limit linestart} == {insert linestart}]} { - tkTextSetCursor %W limit + ::tk::TextSetCursor %W limit } else { - tkTextSetCursor %W {insert linestart} + ::tk::TextSetCursor %W {insert linestart} } } bind TkConsole [bind TkConsole ] @@ -4368,14 +4411,14 @@ proc ::tkcon::Bindings {} { } bind TkConsole <> { if {[%W compare {insert linestart} != {limit linestart}]} { - tkTextSetCursor %W [tkTextUpDownLine %W -1] + ::tk::TextSetCursor %W [::tk::TextUpDownLine %W -1] } else { ::tkcon::Event -1 } } bind TkConsole <> { if {[%W compare {insert linestart} != {end-1c linestart}]} { - tkTextSetCursor %W [tkTextUpDownLine %W 1] + ::tk::TextSetCursor %W [::tk::TextUpDownLine %W 1] } else { ::tkcon::Event 1 } @@ -4390,7 +4433,7 @@ proc ::tkcon::Bindings {} { } bind TkConsole <> { ## Transpose current and previous chars - if {[%W compare insert > "limit+1c"]} { tkTextTranspose %W } + if {[%W compare insert > "limit+1c"]} { ::tk::TextTranspose %W } } bind TkConsole <> { ## Clear command line (Unix shell staple) @@ -4408,10 +4451,10 @@ proc ::tkcon::Bindings {} { ::tkcon::Insert %W $::tkcon::PRIV(tmp) %W see end } - catch {bind TkConsole { tkTextScrollPages %W -1 }} - catch {bind TkConsole { tkTextScrollPages %W -1 }} - catch {bind TkConsole { tkTextScrollPages %W 1 }} - catch {bind TkConsole { tkTextScrollPages %W 1 }} + catch {bind TkConsole { ::tk::TextScrollPages %W -1 }} + catch {bind TkConsole { ::tk::TextScrollPages %W -1 }} + catch {bind TkConsole { ::tk::TextScrollPages %W 1 }} + catch {bind TkConsole { ::tk::TextScrollPages %W 1 }} bind TkConsole <$PRIV(meta)-d> { if {[%W compare insert >= limit]} { %W delete insert {insert wordend} @@ -4429,7 +4472,7 @@ proc ::tkcon::Bindings {} { } bind TkConsole { if { - (!$tkPriv(mouseMoved) || $tk_strictMotif) && + (!$::tk::Priv(mouseMoved) || $tk_strictMotif) && ![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)] } { if {[%W compare @%x,%y < limit]} { @@ -4600,7 +4643,7 @@ proc ::tkcon::TagProc w { # c1 - first char of pair # c2 - second char of pair # Calls: ::tkcon::Blink -## +## proc ::tkcon::MatchPair {w c1 c2 {lim 1.0}} { if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { 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'. # ARGS: w - console text widget # Calls: ::tkcon::Blink -## +## proc ::tkcon::MatchQuote {w {lim 1.0}} { set i insert-1c set j 0 @@ -4664,7 +4707,7 @@ proc ::tkcon::MatchQuote {w {lim 1.0}} { # i2 - end index of blink region # dur - duration in usecs to blink for # Outputs: blinks selected characters in $w -## +## proc ::tkcon::Blink {w args} { eval [list $w tag add 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 # s - string to insert (usually just a single char) # Outputs: $s to text widget -## +## proc ::tkcon::Insert {w s} { if {[string match {} $s] || [string match disabled [$w cget -state]]} { return @@ -4695,7 +4738,7 @@ proc ::tkcon::Insert {w s} { $w see insert } -## ::tkcon::Expand - +## ::tkcon::Expand - # ARGS: w - text widget in which to expand str # type - type of expansion (path / proc / 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 # are output to stdout. Triggers bell if no matches are found. # Returns: number of matches found -## +## proc ::tkcon::Expand {w {type ""}} { set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"$\]" set tmp [$w search -backwards -regexp $exp insert-1c limit-1c] @@ -4743,7 +4786,7 @@ proc ::tkcon::Expand {w {type ""}} { # Calls: ::tkcon::ExpandBestMatch # Returns: list containing longest unique match followed by all the # possible further matches -## +## proc ::tkcon::ExpandPathname str { set pwd [EvalAttached pwd] # Cause a string like {C:/Program\ Files/} to become "C:/Program Files/" @@ -4825,7 +4868,7 @@ proc ::tkcon::ExpandProcname str { # Calls: ::tkcon::ExpandBestMatch # Returns: list containing longest unique match followed by all the # possible further matches -## +## proc ::tkcon::ExpandVariable str { if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { ## 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. # ARGS: l - list to find best unique match in # Returns: longest unique match in the list -## +## proc ::tkcon::ExpandBestMatch2 {l {e {}}} { set s [lindex $l 0] if {[llength $l]>1} { @@ -4873,7 +4916,7 @@ proc ::tkcon::ExpandBestMatch2 {l {e {}}} { # ARGS: l - list to find best unique match in # e - currently best known unique match # Returns: longest unique match in the list -## +## proc ::tkcon::ExpandBestMatch {l {e {}}} { set ec [lindex $l 0] if {[llength $l]>1} { @@ -5237,7 +5280,7 @@ proc ::tkcon::Retrieve {} { ## ::tkcon::Resource - re'source's this script into current console ## Meant primarily for my development of this program. It follows ## links until the ultimate source is found. -## +## set ::tkcon::PRIV(SCRIPT) [info script] if {!$::tkcon::PRIV(WWW) && [string compare $::tkcon::PRIV(SCRIPT) {}]} { # we use a catch here because some wrap apps choke on 'file type'