merged tcl 8.1 branch back into the main trunk

FossilOrigin-Name: f3b32fb71c9011ac220779bd9dbe5617c9dc87d9

1 files changed, 46 insertions, 2 deletions

diff --git a/library/safe.tcl b/library/safe.tcl
index 44def92..3be7739 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.4 1998/11/11 02:39:31 welch Exp $
+# RCS: @(#) $Id: safe.tcl,v 1.5 1999/04/16 00:46:57 stanton Exp $
 
 #
 # The implementation is based on namespaces. These naming conventions
@@ -22,7 +22,7 @@
 #
 
 # Needed utilities package
-package require opt 0.2;
+package require opt 0.4.1;
 
 # Create the safe namespace
 namespace eval ::safe {
@@ -440,6 +440,13 @@ proc ::safe::interpAddToAccessPath {slave path} {
 	::interp alias $slave source {} [namespace current]::AliasSource $slave
 	::interp alias $slave load {} [namespace current]::AliasLoad $slave
 
+	# This alias lets the slave use the encoding names, convertfrom,
+	# convertto, and system, but not "encoding system <name>" to set
+	# the system encoding.
+
+	::interp alias $slave encoding {} [namespace current]::AliasEncoding \
+		$slave
+
 	# This alias lets the slave have access to a subset of the 'file'
 	# command functionality.
 
@@ -884,4 +891,41 @@ proc ::safe::setLogCmd {args} {
 		[namespace current]::Subset $slave $target $pat
     }
 
+    # AliasEncoding is the target of the "encoding" alias in safe interpreters.
+
+    proc AliasEncoding {slave args} {
+
+	set argc [llength $args];
+
+	set okpat "^(name.*|convert.*)\$"
+	set subcommand [lindex $args 0]
+
+	if {[regexp $okpat $subcommand]} {
+	    return [eval ::interp invokehidden $slave encoding $subcommand \
+		    [lrange $args 1 end]]
+	}
+
+	if {[string match $subcommand system]} {
+	    if {$argc == 1} {
+		# passed all the tests , lets source it:
+		if {[catch {::interp invokehidden \
+			$slave encoding system} msg]} {
+		    Log $slave $msg;
+		    return -code error "script error";
+		}
+	    } else {
+		set msg "wrong # args: should be \"encoding system\"";
+		Log $slave $msg;
+		error $msg;
+	    }
+	} else {
+	    set msg "wrong # args: should be \"encoding option ?arg ...?\"";
+	    Log $slave $msg;
+	    error $msg;
+	}
+	
+	
+	return $msg
+    }
+
 }