# safe.tcl
# --------
#
# A collection of commands to provide safe versions of some commands to
# a safe interpreter.
#
# SCCS: @(#) safe.tcl 1.17 96/10/11 17:31:39

# The following code makes sure that tcl_library and tk_library are set to
# the names of the actual directories. These names may be different than the
# assigned values if the actual directories are at the end of a symbolic
# link. We need to do this to ensure that it will be possible to load files
# from the Tcl and Tk libraries even when there is a symbolic link somewhere
# in the pathname.

if {$tcl_platform(platform) == "macintosh"} {
    set tcl_library "resource"
    set tk_library "resource"
} else {
    set curdir [pwd]
    cd $tcl_library
    set tcl_library [pwd]
    if {[info exists tk_library]} {
	cd $tk_library
	set tk_library [pwd]
    }
    cd $curdir
}

# This is the default list of directories from which safe interpreters
# can source files. Add to this list with lappend.

set tcl_safe_source_dirs(___DEFAULT___) [list $tcl_library]
if {[info exists tk_library]} {
    lappend tcl_safe_source_dirs(___DEFAULT___) $tk_library
}

# This is the default list of directories from which safe interpreters
# can open files for reading. Add to this list with lappend.

set tcl_safe_read_dirs(___DEFAULT___) [list $tcl_library]
if {[info exists tk_library]} {
    lappend tcl_safe_read_dirs(___DEFAULT___) $tk_library
}

# This is the default list of directories from which safe interpreters
# can load extensions. Add to this list with lappend.

set tcl_safe_load_dirs(___DEFAULT___) [list $tcl_library]
if {[info exists tk_library]} {
    lappend tcl_safe_load_dirs(___DEFAULT___) $tk_library
}

# This is the default limit on how many files a safe interpreter can have
# open for reading or writing at any time.

set tcl_open_file_limits(___DEFAULT___) 4

# Safe interpreters can create temporary files that are open for writing,
# in this directory:

if {$tcl_platform(platform) == "windows"} {
    global env
    if {[info exists env(TMP)]} {
	set tcl_safe_tmp_file_dirs(___DEFAULT___) \
               [eval file join [file split $env(TMP)]]
    } elseif {[info exists env(TEMP)]} {
	set tcl_safe_tmp_file_dirs(___DEFAULT___) \
               [eval file join [file split $env(TEMP)]]
    } else {
        # -- may fail....use [pwd]?
        set tcl_safe_tmp_file_dirs(___DEFAULT___) "c:/tmp"
    }
    set p [lsearch [string tolower [array names env]] "comspec"]
    if {$p != -1} {
	set tcl_rm_command "exec $env([lindex [array names env] $p]) /c del"
    } else {
        if {$tcl_platform(os) == "Windows NT"} {
	    set tcl_rm_command "exec cmd.exe /c del"
         } else {
            set tcl_rm_command "exec command.com /c del"
         }
    }
    unset p
} elseif {$tcl_platform(platform) == "unix"} {
    set tcl_safe_tmp_file_dirs(___DEFAULT___) /tmp
    set tcl_rm_command "exec rm"
} else {
    set tcl_safe_tmp_file_dirs(___DEFAULT___) not_supported
    set tcl_rm_command rm
}

# By default, safe interpreters can write files whose maximum size is
# determined by the following variable:

set tcl_file_size_limits(___DEFAULT___) 1024000

# Determine if a file $f is found in a directory in the list $l
proc tcl_safe_dir {f l} {
    set pwd [pwd]
    if ![file isdir $f] {
	set path [file dirname $f]
    } else {
	set path $f
    }

    if {"$path" == ""} {
	set path "."
    }

    if {[catch {cd $path} msg]} {
	return 0
    }

    set realpath [file split [pwd]]

    # Allow the source operation if the real path is a subdirectory of
    # one of the directories in the list of safe directories.

    foreach i $l {
	set match 1
	foreach a [file split $i] b $realpath {
	    if {[string length $a] == 0} {
		break
	    } elseif {[string compare $a $b] != 0} {
		set match 0
		break
	    }
	}
	if $match {
	    cd $pwd
	    return 1
	}
    }
    cd $pwd
    return 0
}

# Source a file if it is safe to do so.

proc tcl_safe_source {i f} {
    global tcl_safe_source_dirs

    if {[catch {set l $tcl_safe_source_dirs($i)} msg]} {
	error "permission denied: source $f: $msg"
    }    
    if {[catch {tcl_safe_dir $f $l} msg] || !$msg} {
	error "permission denied: source $f: $msg"
    }
    set fd [open $f r]
    set r [read $fd]
    close $fd
    if {[catch {interp eval $i $r} msg]} {
	error $msg
    }
}

# Open a file for reading if it is safe to do so.

proc tcl_safe_open_for_reading {i f {m r}} {
    global tcl_safe_read_dirs tcl_open_file_counters tcl_open_file_limits

    if {$tcl_open_file_counters($i) == $tcl_open_file_limits($i)} {
	error "open: too many files open; close some first"
    }
    if {[catch {set l $tcl_safe_read_dirs($i)}]} {
	error "permission denied: open $f"
    }
    if {[catch {tcl_safe_dir $f $l} result] || !$result} {
	error "permission denied: open $f"
    }
    if {$m != "r"} {
	error "permission denied: open $f"
    }
    set fd [open $f r]
    interp transfer {} $fd $i

    incr tcl_open_file_counters($i)

    return $fd
}

# Load an extension if it is safe to do so.

proc tcl_safe_load {i f p {j {}}} {
    global tcl_safe_load_dirs errorInfo

    # Always allow loading of statically linked packages.

    if {$f == ""} {
        foreach k $j {
	    lappend i $k
	}
	if {[catch {load $f $p $i} msg]} {
	    error "permission denied: load $f $p: $msg"
	}
	return
    }
    if {[catch {set l $tcl_safe_load_dirs($i)} msg]} {
	error "permission denied: load $f $p: $msg"
    }
    if {[catch {tcl_safe_dir $f $l} msg] || !$msg} {
	error "permission denied: load $f $p: $msg"
    }
    foreach k $j {
	lappend i $k
    }
    load $f $p $i
}

# This procedure enables access from a safe interpreter to only a subset of
# the subcommands of a command:

proc tcl_safe_subset {command okpat args} {
    set subcommand [lindex $args 0]
    if {[regexp $okpat $subcommand]} {
	return [eval {$command $subcommand} [lrange $args 1 end]]
    }
    error "not allowed to invoke subcommand $subcommand of $command"
}

# This procedure installs an alias in a slave that invokes "safesubset"
# in the master to execute allowed subcommands. It precomputes the pattern
# of allowed subcommands; you can use wildcards in the pattern if you wish
# to allow subcommand abbreviation.
#
# Syntax is: tcl_alias_subset slave alias target subcommand1 subcommand2...

proc tcl_alias_subset {slave alias target args} {
    set pat ^(; set sep ""
    foreach sub $args {
	append pat $sep$sub
	set sep |
    }
    append pat )\$
    $slave alias $alias tcl_safe_subset $target $pat
}

# This procedure allows a safe interpreter to query options on its open
# files (but not set them) using fconfigure. If the file is not present
# in the master, we share it temporarily and discard it afterwards.

proc tcl_safe_fconfigure {i f {o {}}} {
    set tempshare 0
    if {[catch {fconfigure $f}]} {
	set tempshare 1
	interp share $i $f {}
    }
    if {$o == {}} {
	catch {set ans [fconfigure $f]}
    } else {
	catch {set ans [fconfigure $f $o]}
    }
    if {$tempshare == 1} {
	close $f
    }
    return $ans
}

# This procedure provides a safe version of "exit": it destroys the slave
# but does not cause the process to exit:

proc tcl_safe_exit {i} {
    global tcl_safe_source_dirs tcl_safe_read_dirs tcl_safe_load_dirs
    global tcl_open_file_counters tcl_open_file_limits
    global tcl_safe_tmp_file_dirs tcl_file_size_limits
    global tcl_tmp_files tcl_rm_command


    # inter delete can leave dangling pointers
    # interp delete $i

    # Destroy the main window instead.
    interp eval $i destroy .

    global tcl_platform
    foreach f $tcl_tmp_files($i) {
        if {$tcl_platform(os) != "Windows 95"} {
	    catch {eval $tcl_rm_command $f}
        }
    }
    unset tcl_safe_source_dirs($i)
    unset tcl_safe_read_dirs($i)
    unset tcl_safe_load_dirs($i)
    unset tcl_open_file_counters($i)
    unset tcl_open_file_limits($i)
    unset tcl_safe_tmp_file_dirs($i)
    unset tcl_file_size_limits($i)
    unset tcl_tmp_files($i)
}

# This procedure opens a temporary file for the slave and transfers the
# channel to the slave, if the count of open files for the slave is not
# exceeded.

proc tcl_open_tmp_file {i} {
    global tcl_open_file_counters tcl_open_file_limits
    global tcl_safe_tmp_file_dirs tcl_tmp_files tcl_tmp_fds
    global tcl_file_size_limits
    global tcl_rm_command

    if {$tcl_open_file_counters($i) == $tcl_open_file_limits($i)} {
	error "maketmp: too many files open; close some first"
    }
    set c $tcl_open_file_counters($i)
    set n $tcl_safe_tmp_file_dirs($i)/tmp$i[clock seconds]
    catch {eval $tcl_rm_command $n}
    set fd [open $n {CREAT RDWR}]
    incr tcl_open_file_counters($i)
    lappend tcl_tmp_files($i) $n
    set tcl_tmp_fds($i,$fd) $n
    interp transfer {} $fd $i
    return $fd
}

# This procedure safely closes a file for a slave. If the file is
# temporary, it is also removed.

proc tcl_safe_close {i fd} {
    global tcl_tmp_fds tcl_open_file_counters tcl_rm_command

    interp transfer $i $fd {}
    close $fd

    if {[info exists tcl_tmp_fds($i,$fd)]} {
        if {$tcl_platform(os) != "Windows 95"} {
	    catch {eval $tcl_rm_command $tcl_tmp_fds($i,$fd)}
	}
	unset tcl_tmp_fds($i,$fd)
    }
    incr tcl_open_file_counters($i) -1
    return ""
}

# This procedure implements a safe version of puts for slaves; it limits
# the size of the file if the file is temporary.

proc tcl_safe_puts {i fd {s {}} {q {}}} {
    global tcl_tmp_fds tcl_file_size_limits
    global tcl_safe_source_dirs

    set nonewline 0
    if {$fd == "-nonewline"} {
	set nonewline 1
	set fd $s
	set s $q
	set q {}
    }
    if {$s == {}} {
	set s $fd
	if {$nonewline == 1} {
	    puts -nonewline "message from unsafe interpreter $i: $s
	} else {
	    puts "message from unsafe interpreter $i: $s"
	}
	return ""
    }
    if {($fd == "stdout") || ($fd == "stderr")} {
	catch {
	    if {$nonewline == 1} {
		puts -nonewline $fd "message from unsafe interpreter $i: $s"
	    } else {
		puts $fd "message from unsafe interpreter $i: $s"
	    }
	}
	return ""
    }
    interp share $i $fd {}
    if {[info exists tcl_tmp_fds($i,$fd)]} {
	set l [string length $s]
	flush $fd
	set sz [expr [file size $tcl_tmp_fds($i,$fd)]+$l]
	set lim $tcl_file_size_limits($i)
	if {[expr $sz > $lim]} {
	    close $fd
	    error "puts: cannot write output - would exceed file size limit"
	}
    }
    if {$nonewline == 1} {
	puts -nonewline $fd $s
    } else {
	puts $fd $s
    }
    close $fd
}

# This procedure bounds the number of background errors in a slave.

proc tcl_safe_bgerror {slave max args} {
    global tcl_bgerror_count
    if ![info exist tcl_bgerror_count($slave)] {
	set tcl_bgerror_count($slave) 0
    } else {
	incr tcl_bgerror_count($slave)
    }
    if {$tcl_bgerror_count($slave) > $max} {
	puts "Too many errors from $slave"
	$slave alias bgerror tcl_donothing
	tcl_safe_exit $slave
    } else {
	puts "Tcl error: [lindex $args 0]"
    }
}
proc tcl_donothing {args} { }

# This procedure sets up a new slave with aliases so that it has access to
# the functionality provided in this file:

proc tcl_makeSafe {slave} {
    global tcl_safe_source_dirs tcl_safe_read_dirs tcl_safe_load_dirs
    global tcl_safe_tmp_file_dirs tcl_file_size_limits
    global tcl_open_file_counters tcl_open_file_limits
    global tcl_tmp_files
    global tcl_library tcl_version tcl_patchLevel tcl_platform argv0

    # Add safe version of "exit":

    $slave alias exit tcl_safe_exit $slave

    # Add safe versions of "source", "open" and "load":

    $slave alias source tcl_safe_source $slave
    $slave alias load tcl_safe_load $slave
    $slave alias open tcl_safe_open_for_reading $slave

    # Add a safe version of "close", for bookkeeping:

    $slave alias close tcl_safe_close $slave

    # Add a safe version of puts:

    $slave alias puts tcl_safe_puts $slave

    # Add safe version of "fconfigure":

    $slave alias fconfigure tcl_safe_fconfigure $slave
    
    # Add safe versions of "file":

    tcl_alias_subset $slave file file dir.* join root.* ext.* tail \
	path.* split

    # Set up default lists of directories for the new slave:

    set tcl_safe_source_dirs($slave) $tcl_safe_source_dirs(___DEFAULT___)
    set tcl_safe_read_dirs($slave) $tcl_safe_read_dirs(___DEFAULT___)
    set tcl_safe_load_dirs($slave) $tcl_safe_load_dirs(___DEFAULT___)

    # Set the default limit on how many files the slave can open:

    set tcl_open_file_counters($slave) 0
    set tcl_open_file_limits($slave) $tcl_open_file_limits(___DEFAULT___)

    # Initialize the list of temporary files opened for writing for
    # this slave to empty:

    set tcl_tmp_files($slave) {}

    # Set the default directory where temporary files will be opened for
    # this slave:

    set tcl_safe_tmp_file_dirs($slave) $tcl_safe_tmp_file_dirs(___DEFAULT___)

    # Set the default file size limit for this slave:

    set tcl_file_size_limits($slave) $tcl_file_size_limits(___DEFAULT___)

    # Force the new slave to read in init.tcl from the Tcl library, so
    # that unknown and friends will work.

    if {$tcl_platform(platform) == "macintosh"} {
	# Can we source from a resource in a safe interp?
    } else {
	$slave eval source [file join $tcl_library init.tcl]
    }
    
    # Override the default error handler

    $slave alias bgerror tcl_safe_bgerror $slave 4

    # Install some variables into the new slave:

    $slave eval [list set tcl_library $tcl_library]
    $slave eval [list set tcl_version $tcl_version]
    $slave eval [list set tcl_patchLevel $tcl_patchLevel]
    $slave eval [list set argv0 $argv0]

    if {[info globals tk_library] != ""} {
	global tk_library tk_version tk_patchLevel env
	
	$slave eval [list set tk_library $tk_library]
	$slave eval [list set tk_version $tk_version]
	$slave eval [list set tk_patchLevel $tk_patchLevel]

	if {[info exists env(DISPLAY)]} {
	    $slave eval [list set env(DISPLAY) $env(DISPLAY)]
	}
    }

    return ""
}

# The following procedure is used by the master interpreter to resolve
# relative URLs relative to the URL from which the tclet was loaded.

proc tcl_url_resolve {base ref} {
    set ref [string trim $ref]
    # See if ref is already absolute
    if {[regexp {^([^ :]+):(.+)} $ref x refproto rest]} {
	if {[regexp ^// $rest]} {
	    return $ref
	}
	# hide the protocol, for the moment
	regsub ^$refproto: $ref {} ref
    }
    # If no base, just bail
    if {[string length $base] == 0} {
	return $ref
    }
    if [regexp {([^:]+):(//[^/]*)(.*)} $base dummy protocol server ext] {
	if {[info exists refproto] && \
		[string compare $refproto $protocol] != 0} {
	    return $refproto:$ref
	}
	if {$protocol == "file"} {
	    set ext $server$ext
	    set server /
	}
	if [string match */ $ext] { 
	    set dir $ext
	} else {
	    set dir [file dirname $ext]
	    if {$dir == "."} {set dir /}
	}
	while {[regsub {^\.\./} $ref {} ref] == 1} {
	    set dir [file dirname $dir]
	}
	if {[string match /* $ref]} {
	    set ref $protocol:$server$ref
	} elseif {$dir == "/"} {
	    set ref $protocol:$server/$ref
	} else {
	    set ref $protocol:$server/[string trim $dir /]/$ref
	}
	return $ref
    }
    # Below is completely heuristic
    set ref [file dirname $base]/[string trim $ref /]
    if ![regexp {^([^:]+):} $ref x protocol] {
	if [regexp {^www\.} $ref] {
	    set protocol http
	    set ref http://$ref
	} else {
	    set protocol file
	    set ref file:$ref
	}
    }
    return $ref
}
