Merge branch 'master' into netgen-1.5
This commit is contained in:
Tim Edwards
commit
7bee1851fa
113
tcltk/tkcon.tcl
113
tcltk/tkcon.tcl
|
|
@ -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}
|
||||
|
|
@ -745,7 +735,7 @@ proc ::tkcon::EvalCmd {w cmd} {
|
|||
$w tag bind $tag <Leave> \
|
||||
[list $w tag configure $tag -underline 0]
|
||||
$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)]}"
|
||||
} else {
|
||||
$w insert output $res\n stderr
|
||||
|
|
@ -2474,7 +2464,7 @@ proc ::tkcon::ErrorHighlight w {
|
|||
$w tag configure $tag -foreground $COLOR(stdout)
|
||||
$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 <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \
|
||||
$w tag bind $tag <ButtonRelease-1> "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 <Enter> [list $w tag configure $tag -underline 1]
|
||||
$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]}"
|
||||
}
|
||||
}
|
||||
|
|
@ -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 <<TkCon_Eval>>]
|
||||
|
|
@ -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
|
||||
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]
|
||||
|
|
@ -2798,13 +2793,19 @@ proc tkcon_puts 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
|
||||
|
|
@ -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
|
||||
|
|
@ -4134,6 +4174,9 @@ proc ::tkcon::Bindings {} {
|
|||
foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] }
|
||||
## We really didn't want the newline insertion
|
||||
bind TkConsole <Control-Key-o> {}
|
||||
|
||||
## in 8.6b3, the virtual events <<NextLine>> and <<PrevLine>>
|
||||
# mess up our history feature
|
||||
bind TkConsole <<NextLine>> {}
|
||||
bind TkConsole <<PrevLine>> {}
|
||||
|
||||
|
|
@ -4342,9 +4385,9 @@ proc ::tkcon::Bindings {} {
|
|||
|
||||
bind TkConsole <Control-a> {
|
||||
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 <Key-Home> [bind TkConsole <Control-a>]
|
||||
|
|
@ -4368,14 +4411,14 @@ proc ::tkcon::Bindings {} {
|
|||
}
|
||||
bind TkConsole <<TkCon_Previous>> {
|
||||
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 <<TkCon_Next>> {
|
||||
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 <<TkCon_Transpose>> {
|
||||
## 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>> {
|
||||
## 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 <Key-Page_Up> { tkTextScrollPages %W -1 }}
|
||||
catch {bind TkConsole <Key-Prior> { tkTextScrollPages %W -1 }}
|
||||
catch {bind TkConsole <Key-Page_Down> { tkTextScrollPages %W 1 }}
|
||||
catch {bind TkConsole <Key-Next> { tkTextScrollPages %W 1 }}
|
||||
catch {bind TkConsole <Key-Page_Up> { ::tk::TextScrollPages %W -1 }}
|
||||
catch {bind TkConsole <Key-Prior> { ::tk::TextScrollPages %W -1 }}
|
||||
catch {bind TkConsole <Key-Page_Down> { ::tk::TextScrollPages %W 1 }}
|
||||
catch {bind TkConsole <Key-Next> { ::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 <ButtonRelease-2> {
|
||||
if {
|
||||
(!$tkPriv(mouseMoved) || $tk_strictMotif) &&
|
||||
(!$::tk::Priv(mouseMoved) || $tk_strictMotif) &&
|
||||
![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)]
|
||||
} {
|
||||
if {[%W compare @%x,%y < limit]} {
|
||||
|
|
|
|||
Loading…
Reference in New Issue