Subversion Repositories or1k

# safetk.tcl --

#

# Support procs to use Tk in safe interpreters.

#

# SCCS: @(#) safetk.tcl 1.8 97/10/29 14:59:16

#

# Copyright (c) 1997 Sun Microsystems, Inc.

#

# See the file "license.terms" for information on usage and redistribution

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# see safetk.n for documentation

#

#

# Note: It is now ok to let untrusted code being executed

#       between the creation of the interp and the actual loading

#       of Tk in that interp because the C side Tk_Init will

#       now look up the master interp and ask its safe::TkInit

#       for the actual parameters to use for it's initialization (if allowed),

#       not relying on the slave state.

#

# We use opt (optional arguments parsing)

package require opt 0.1;

namespace eval ::safe {

    # counter for safe toplevels

    variable tkSafeId 0;

    #

    # tkInterpInit : prepare the slave interpreter for tk loading

    #                most of the real job is done by loadTk

    # returns the slave name (tkInterpInit does)

    #

    proc ::safe::tkInterpInit {slave argv} {

        global env tk_library

        # Clear Tk's access for that interp (path).

        allowTk $slave $argv

        # there seems to be an obscure case where the tk_library

        # variable value is changed to point to a sym link destination

        # dir instead of the sym link itself, and thus where the $tk_library

        # would then not be anymore one of the auto_path dir, so we use

        # the addToAccessPath which adds if it's not already in instead

        # of the more conventional findInAccessPath.

        # Might be usefull for masters without Tk really loaded too.

        ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]

        return $slave;

    }

# tkInterpLoadTk : 

# Do additional configuration as needed (calling tkInterpInit) 

# and actually load Tk into the slave.

# 

# Either contained in the specified windowId (-use) or

# creating a decorated toplevel for it.

# 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"

                }

            }

        }

        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];

        } 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]

            } 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

                }

            }

            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

        return $slave

    }

proc ::safe::TkInit {interpPath} {

    variable tkInit

    if {[info exists tkInit($interpPath)]} {

        set value $tkInit($interpPath)

        Log $interpPath "TkInit called, returning \"$value\"" NOTICE

        return $value

    } else {

        Log $interpPath "TkInit called for interp with clearance:\

                preventing Tk init" ERROR

        error "not allowed"

    }

}

proc ::safe::allowTk {interpPath argv} {

    variable tkInit

    set tkInit($interpPath) $argv

}

    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;

        }

    }

proc ::safe::tkTopLevel {slave display} {

    variable tkSafeId;

    incr tkSafeId;

    set w ".safe$tkSafeId";

    if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {

        return -code error "Unable to create toplevel for\

                safe slave \"$slave\" ($msg)";

    }

    Log $slave "New toplevel $w" NOTICE

    set msg "Untrusted Tcl applet ($slave)"

    wm title $w $msg;

    # Control frame

    set wc $w.fc

    frame $wc -bg red -borderwidth 3 -relief ridge ;

    # We will destroy the interp when the window is destroyed

    bindtags $wc [concat Safe$wc [bindtags $wc]]

    bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave];

    label $wc.l -text $msg \

            -padx 2 -pady 0 -anchor w;

    # We want the button to be the last visible item

    # (so be packed first) and at the right and not resizing horizontally

    # frame the button so it does not expand horizontally

    # but still have the default background instead of red one from the parent

    frame  $wc.fb -bd 0 ;

    button $wc.fb.b -text "Delete" \

            -bd 1  -padx 2 -pady 0 -highlightthickness 0 \

            -command [list ::safe::tkDelete $w $w $slave]

    pack $wc.fb.b -side right -fill both ;

    pack $wc.fb -side right -fill both -expand 1;

    pack $wc.l -side left  -fill both -expand 1;

    pack $wc -side bottom -fill x ;

    # Container frame

    frame $w.c -container 1;

    pack $w.c -fill both -expand 1;

    # return both the toplevel window name and the id to use for embedding

    list $w [winfo id $w.c] ;

}

}