summaryrefslogtreecommitdiffstats
path: root/library/safetk.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/safetk.tcl')
-rw-r--r--library/safetk.tcl194
1 files changed, 130 insertions, 64 deletions
diff --git a/library/safetk.tcl b/library/safetk.tcl
index 78aeb86..0ceaebe 100644
--- a/library/safetk.tcl
+++ b/library/safetk.tcl
@@ -2,7 +2,7 @@
#
# Support procs to use Tk in safe interpreters.
#
-# RCS: @(#) $Id: safetk.tcl,v 1.3 1998/09/14 18:23:24 stanton Exp $
+# RCS: @(#) $Id: safetk.tcl,v 1.4 1999/04/16 01:51:26 stanton Exp $
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
@@ -22,7 +22,7 @@
#
# We use opt (optional arguments parsing)
-package require opt 0.1;
+package require opt 0.4.1;
namespace eval ::safe {
@@ -62,65 +62,83 @@ namespace eval ::safe {
# empty definition for auto_mkIndex
proc ::safe::loadTk {} {}
- ::tcl::OptProc loadTk {
- {slave -interp "name of the slave interpreter"}
- {-use -windowId {} "window Id to use (new toplevel otherwise)"}
- {-display -displayName {} "display name to use (current one otherwise)"}
- } {
- set displayGiven [::tcl::OptProcArgGiven "-display"]
- if {!$displayGiven} {
- # Try to get the current display from "."
- # (which might not exist if the master is tk-less)
- if {[catch {set display [winfo screen .]}]} {
- if {[info exists ::env(DISPLAY)]} {
- set display $::env(DISPLAY)
- } else {
- Log $slave "no winfo screen . nor env(DISPLAY)" WARNING
- set display ":0.0"
- }
+::tcl::OptProc loadTk {
+ {slave -interp "name of the slave interpreter"}
+ {-use -windowId {} "window Id to use (new toplevel otherwise)"}
+ {-display -displayName {} "display name to use (current one otherwise)"}
+} {
+ set displayGiven [::tcl::OptProcArgGiven "-display"]
+ if {!$displayGiven} {
+
+ # Try to get the current display from "."
+ # (which might not exist if the master is tk-less)
+
+ if {[catch {set display [winfo screen .]}]} {
+ if {[info exists ::env(DISPLAY)]} {
+ set display $::env(DISPLAY)
+ } else {
+ Log $slave "no winfo screen . nor env(DISPLAY)" WARNING
+ set display ":0.0"
}
}
- if {![::tcl::OptProcArgGiven "-use"]} {
- # create a decorated toplevel
- ::tcl::Lassign [tkTopLevel $slave $display] w use;
- # set our delete hook (slave arg is added by interpDelete)
- Set [DeleteHookName $slave] [list tkDelete {} $w];
+ }
+ if {![::tcl::OptProcArgGiven "-use"]} {
+
+ # create a decorated toplevel
+
+ ::tcl::Lassign [tkTopLevel $slave $display] w use;
+
+ # set our delete hook (slave arg is added by interpDelete)
+ # to clean up both window related code and tkInit(slave)
+ Set [DeleteHookName $slave] [list tkDelete {} $w];
+
+ } else {
+
+ # set our delete hook (slave arg is added by interpDelete)
+ # to clean up tkInit(slave)
+
+ Set [DeleteHookName $slave] [list disallowTk]
+
+ # Let's be nice and also accept tk window names instead of ids
+
+ if {[string match ".*" $use]} {
+ set windowName $use
+ set use [winfo id $windowName]
+ set nDisplay [winfo screen $windowName]
} else {
- # Let's be nice and also accept tk window names instead of ids
- if {[string match ".*" $use]} {
- set windowName $use
- set use [winfo id $windowName]
- set nDisplay [winfo screen $windowName]
+
+ # Check for a better -display value
+ # (works only for multi screens on single host, but not
+ # cross hosts, for that a tk window name would be better
+ # but embeding is also usefull for non tk names)
+
+ if {![catch {winfo pathname $use} name]} {
+ set nDisplay [winfo screen $name]
} else {
- # Check for a better -display value
- # (works only for multi screens on single host, but not
- # cross hosts, for that a tk window name would be better
- # but embeding is also usefull for non tk names)
- if {![catch {winfo pathname $use} name]} {
- set nDisplay [winfo screen $name]
- } else {
- # Can't have a better one
- set nDisplay $display
- }
+
+ # Can't have a better one
+
+ set nDisplay $display
}
- if {[string compare $nDisplay $display]} {
- if {$displayGiven} {
- error "conflicting -display $display and -use\
- $use -> $nDisplay"
- } else {
- set display $nDisplay
- }
+ }
+ if {[string compare $nDisplay $display]} {
+ if {$displayGiven} {
+ error "conflicting -display $display and -use\
+ $use -> $nDisplay"
+ } else {
+ set display $nDisplay
}
}
+ }
- # Prepares the slave for tk with those parameters
-
- tkInterpInit $slave [list "-use" $use "-display" $display]
-
- load {} Tk $slave
+ # Prepares the slave for tk with those parameters
+
+ tkInterpInit $slave [list "-use" $use "-display" $display]
+
+ load {} Tk $slave
- return $slave
- }
+ return $slave
+}
proc ::safe::TkInit {interpPath} {
variable tkInit
@@ -135,25 +153,73 @@ proc ::safe::TkInit {interpPath} {
}
}
+# safe::allowTk --
+#
+# Set tkInit(interpPath) to allow Tk to be initialized in
+# safe::TkInit.
+#
+# Arguments:
+# interpPath slave interpreter handle
+# argv arguments passed to safe::TkInterpInit
+#
+# Results:
+# none.
+
proc ::safe::allowTk {interpPath argv} {
variable tkInit
set tkInit($interpPath) $argv
+ return
}
- proc ::safe::tkDelete {W window slave} {
- # we are going to be called for each widget... skip untill it's
- # top level
- Log $slave "Called tkDelete $W $window" NOTICE;
- if {[::interp exists $slave]} {
- if {[catch {::safe::interpDelete $slave} msg]} {
- Log $slave "Deletion error : $msg";
- }
- }
- if {[winfo exists $window]} {
- Log $slave "Destroy toplevel $window" NOTICE;
- destroy $window;
+
+# safe::disallowTk --
+#
+# Unset tkInit(interpPath) to disallow Tk from getting initialized
+# in safe::TkInit.
+#
+# Arguments:
+# interpPath slave interpreter handle
+#
+# Results:
+# none.
+
+proc ::safe::disallowTk {interpPath} {
+ variable tkInit
+ unset tkInit($interpPath)
+ none
+}
+
+
+# safe::disallowTk --
+#
+# Clean up the window associated with the interp being deleted.
+#
+# Arguments:
+# interpPath slave interpreter handle
+#
+# Results:
+# none.
+
+proc ::safe::tkDelete {W window slave} {
+
+ # we are going to be called for each widget... skip untill it's
+ # top level
+
+ Log $slave "Called tkDelete $W $window" NOTICE;
+ if {[::interp exists $slave]} {
+ if {[catch {::safe::interpDelete $slave} msg]} {
+ Log $slave "Deletion error : $msg";
}
}
+ if {[winfo exists $window]} {
+ Log $slave "Destroy toplevel $window" NOTICE;
+ destroy $window;
+ }
+
+ # clean up tkInit(slave)
+ disallowTk $slave
+ return
+}
proc ::safe::tkTopLevel {slave display} {
variable tkSafeId;