diff options
Diffstat (limited to 'library/safetk.tcl')
| -rw-r--r-- | library/safetk.tcl | 194 |
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; |