From d267c20fe43b1a00bb1e392f86443133855c2afe Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 23 Dec 2009 11:17:33 +0000
Subject: [Bug 2913625]: Stop information about paths from leaking through
 [info script] and [info nameofexecutable].

---
 ChangeLog        | 12 ++++++++---
 library/safe.tcl | 63 +++++++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 55 insertions(+), 20 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 6e1ef94..106f6e7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,14 @@
+2009-12-23  Donal K. Fellows  <dkf@users.sf.net>
+
+	* library/safe.tcl (AliasSource, AliasExeName): [Bug 2913625]: Stop
+	information about paths from leaking through [info script] and [info
+	nameofexecutable].
+
 2009-12-23  Jan Nijtmans  <nijtmans@users.sf.net>
 
-    * unix/tcl.m4           Install libtcl8.6.dll in bin directory 
-    * unix/Makefile.in      
-    * unix/configure        (regenerated)
+	* unix/tcl.m4:		Install libtcl8.6.dll in bin directory 
+	* unix/Makefile.in:
+	* unix/configure:	(regenerated)
 
 2009-12-22  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/library/safe.tcl b/library/safe.tcl
index 6d896ea..eaae00d 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: safe.tcl,v 1.35 2009/12/16 23:44:15 dkf Exp $
+# RCS: @(#) $Id: safe.tcl,v 1.36 2009/12/23 11:17:33 dkf Exp $
 
 #
 # The implementation is based on namespaces. These naming conventions are
@@ -462,6 +462,14 @@ proc ::safe::InterpInit {
     AliasSubset $slave file \
 	file  dir.* join root.* ext.* tail path.* split
 
+    # Subcommands of info
+    foreach {subcommand alias} {
+	nameofexecutable   AliasExeName
+    } {
+	::interp alias $slave ::tcl::info::$subcommand \
+	    {} [namespace current]::$alias $slave
+    }
+
     # The allowed slave variables already have been set by Tcl_MakeSafe(3)
 
     # Source init.tcl and tm.tcl into the slave, to get auto_load and
@@ -789,8 +797,12 @@ proc ::safe::AliasSource {slave args} {
     # filename", but "source -encoding E filename" as well.
     if {[lindex $args 0] eq "-encoding"} {
 	incr argc -2
-	set encoding [lrange $args 0 1]
+	set encoding [lindex $args 1]
 	set at 2
+	if {$encoding eq "identity"} {
+	    Log $slave "attempt to use the identity encoding"
+	    return -code error "permission denied"
+	}
     } else {
 	set at 0
 	set encoding {}
@@ -801,39 +813,51 @@ proc ::safe::AliasSource {slave args} {
 	return -code error $msg
     }
     set file [lindex $args $at]
-
+    
     # get the real path from the virtual one.
-    try {
-	set file [TranslatePath $slave $file]
-    } on error msg {
+    if {[catch {
+	set realfile [TranslatePath $slave $file]
+    } msg]} {
 	Log $slave $msg
 	return -code error "permission denied"
     }
-
+    
     # check that the path is in the access path of that slave
-    try {
-	FileInAccessPath $slave $file
-    } on error msg {
+    if {[catch {
+	FileInAccessPath $slave $realfile
+    } msg]} {
 	Log $slave $msg
 	return -code error "permission denied"
     }
 
     # do the checks on the filename :
-    try {
-	CheckFileName $slave $file
-    } on error msg {
-	Log $slave "$file:$msg"
+    if {[catch {
+	CheckFileName $slave $realfile
+    } msg]} {
+	Log $slave "$realfile:$msg"
 	return -code error $msg
     }
 
-    # passed all the tests , lets source it:
+    # Passed all the tests, lets source it. Note that we do this all manually
+    # because we want to control [info script] in the slave so information
+    # doesn't leak so much. [Bug 2913625]
+    set old [::interp eval $slave {info script}]
     if {[catch {
-	# We use catch here because we want to catch non-error/ok too
-	::interp invokehidden $slave source {*}$encoding $file
+	set f [open $realfile]
+	fconfigure $f -eofchar \032
+	if {$encoding ne ""} {
+	    fconfigure $f -encoding $encoding
+	}
+	set contents [read $f]
+	close $f
+	::interp eval $slave [list info script $file]
+	::interp eval $slave $contents
     } msg]} {
+	catch {interp eval $slave [list info script $old]}
 	Log $slave $msg
 	return -code error "script error"
     }
+    catch {interp eval $slave [list info script $old]}
     return $msg
 }
 
@@ -1004,6 +1028,11 @@ proc ::safe::AliasEncoding {slave option args} {
     return -code error -errorcode $code $msg
 }
 
+# Various minor hiding of platform features. [Bug 2913625]
+
+proc ::safe::AliasExeName {slave} {
+    return ""
+}
 
 proc ::safe::Setup {} {
     ####
-- 
cgit v0.12