From e3e4b23bc593efbdcd72872578a84179805eceaf Mon Sep 17 00:00:00 2001
From: Jeff Hobbs <hobbs@users.sourceforge.net>
Date: Tue, 8 Oct 2002 18:51:00 +0000
Subject: [PATCH] * tkcon.tcl (tcl_unknown): allow ::namespace (:'s) to
be recognized. (koloska) (MainInit): add option for overriding exit
command. (InitUI): add option to control the wm protocol for
WM_DELETE_WINDOW.
---
ChangeLog | 7 +++++
tkcon.tcl | 78 ++++++++++++++++++++++++++++++-------------------------
2 files changed, 50 insertions(+), 35 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 08c490b..b777464 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2002-10-08 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tkcon.tcl (tcl_unknown): allow ::namespace (:'s) to be
+ recognized. (koloska)
+ (MainInit): add option for overriding exit command.
+ (InitUI): add option to control the wm protocol for WM_DELETE_WINDOW.
+
2002-10-01 Jeff Hobbs <jeffh@ActiveState.com>
* tkcon.tcl (InterpEval): correctly handle no args case.
diff --git a/tkcon.tcl b/tkcon.tcl
index 55c099d..82874f7 100755
--- a/tkcon.tcl
+++ b/tkcon.tcl
@@ -100,16 +100,6 @@ proc ::tkcon::Init {args} {
set tcl_interactive 1
set argc [llength $args]
- if {[info exists PRIV(name)]} {
- set title $PRIV(name)
- } else {
- MainInit
- # some main initialization occurs later in this proc,
- # to go after the UI init
- set MainInit 1
- set title Main
- }
-
##
## When setting up all the default values, we always check for
## prior existence. This allows users who embed tkcon to modify
@@ -162,6 +152,7 @@ proc ::tkcon::Init {args} {
subhistory 1
gc-delay 60000
gets {congets}
+ overrideexit 1
usehistory 1
exec slave
@@ -187,6 +178,7 @@ proc ::tkcon::Init {args} {
find,case 0
find,reg 0
errorInfo {}
+ protocol exit
showOnStartup 1
slavealias { edit more less tkcon }
slaveprocs {
@@ -203,6 +195,16 @@ proc ::tkcon::Init {args} {
}
set PRIV(version) $VERSION
+ if {[info exists PRIV(name)]} {
+ set title $PRIV(name)
+ } else {
+ MainInit
+ # some main initialization occurs later in this proc,
+ # to go after the UI init
+ set MainInit 1
+ set title Main
+ }
+
## NOTES FOR STAYING IN PRIMARY INTERPRETER:
##
## If you set ::tkcon::OPT(exec) to {}, then instead of a multiple
@@ -544,7 +546,7 @@ proc ::tkcon::InitUI {title} {
if {[string match . $root]} { set w {} } else { set w [toplevel $root] }
if {!$PRIV(WWW)} {
wm withdraw $root
- wm protocol $root WM_DELETE_WINDOW exit
+ wm protocol $root WM_DELETE_WINDOW $PRIV(protocol)
}
set PRIV(base) $w
@@ -1985,6 +1987,7 @@ proc ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } {
##
proc ::tkcon::MainInit {} {
variable PRIV
+ variable OPT
if {![info exists PRIV(slaves)]} {
array set PRIV [list slave 0 slaves Main name {} \
@@ -2088,32 +2091,35 @@ proc ::tkcon::MainInit {} {
return
}
- ## We want to do a couple things before exiting...
- if {[catch {rename ::exit ::tkcon::FinalExit} err]} {
- puts stderr "tkcon might panic:\n$err"
- }
- proc ::exit args {
- if {$::tkcon::OPT(usehistory)} {
- if {[catch {open $::tkcon::PRIV(histfile) w} fid]} {
- puts stderr "unable to save history file:\n$fid"
- # pause a moment, because we are about to die finally...
- after 1000
- } else {
- set max [::tkcon::EvalSlave history nextid]
- set id [expr {$max - $::tkcon::OPT(history)}]
- if {$id < 1} { set id 1 }
- ## FIX: This puts history in backwards!!
- while {($id < $max) && \
- ![catch {::tkcon::EvalSlave history event $id} cmd]} {
- if {[string compare {} $cmd]} {
- puts $fid "::tkcon::EvalSlave history add [list $cmd]"
+ if {$OPT(overrideexit)} {
+ ## We want to do a couple things before exiting...
+ if {[catch {rename ::exit ::tkcon::FinalExit} err]} {
+ puts stderr "tkcon might panic:\n$err"
+ }
+ proc ::exit args {
+ if {$::tkcon::OPT(usehistory)} {
+ if {[catch {open $::tkcon::PRIV(histfile) w} fid]} {
+ puts stderr "unable to save history file:\n$fid"
+ # pause a moment, because we are about to die finally...
+ after 1000
+ } else {
+ set max [::tkcon::EvalSlave history nextid]
+ set id [expr {$max - $::tkcon::OPT(history)}]
+ if {$id < 1} { set id 1 }
+ ## FIX: This puts history in backwards!!
+ while {($id < $max) && ![catch \
+ {::tkcon::EvalSlave history event $id} cmd]} {
+ if {[string compare {} $cmd]} {
+ puts $fid "::tkcon::EvalSlave\
+ history add [list $cmd]"
+ }
+ incr id
}
- incr id
+ close $fid
}
- close $fid
}
+ uplevel 1 ::tkcon::FinalExit $args
}
- uplevel 1 ::tkcon::FinalExit $args
}
## ::tkcon::InterpEval - passes evaluation to another named interpreter
@@ -3210,7 +3216,8 @@ proc dump {type args} {
set nst {}
append res "array set [list $var] \{\n"
if {[array size v]} {
- foreach i [lsort [array names v $fltr]] {
+ foreach i \
+ [lsort -dictionary [array names v $fltr]] {
upvar 0 v\($i\) __a
if {[array exists __a]} {
append nst "\#\# NESTED ARRAY ELEM: $i\n"
@@ -4019,7 +4026,8 @@ proc tcl_unknown args {
# 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} {
+ if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] \
+ && [llength $cmd] == 4} {
set arglist [lrange $args 1 end]
set ret [catch {uplevel 1 $cmd $arglist} result]
if {$ret == 0} {
--
2.23.0