summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclCmdAH.c42
-rw-r--r--library/safe.tcl73
-rw-r--r--tests/safe.test4
4 files changed, 80 insertions, 49 deletions
diff --git a/ChangeLog b/ChangeLog
index b4a6a8d..72af5c4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2012-05-16 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3445787]: Improve
+ the compatibility of safe interpreters' version of 'file' with that of
+ unsafe interpreters.
+ * library/safe.tcl (::safe::InterpInit): Teach the safe-interp scripts
+ about how to expose 'file' properly.
+
2012-05-13 Jan Nijtmans <nijtmans@users.sf.net>
* win/tclWinDde.c: Protect against receiving strings without ending \0,
@@ -21,7 +29,7 @@
event(s) into the owner thread's event queue for execution in the
correct context. Renamed the ForwardOpTo...Thread() function to
match with our terminology.
-
+
* tests/ioCmd.test [Bug 3522560]: Added a test which crashes the
core if it were not disabled as knownBug. For a reflected channel
transfered to a different thread the [chan postevent] run in the
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 70aef8d..4292224 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -61,6 +61,7 @@ static Tcl_NRPostProc ForPostNextCallback;
static Tcl_NRPostProc ForeachLoopStep;
static Tcl_NRPostProc EvalCmdErrMsg;
+static Tcl_ObjCmdProc BadFileSubcommand;
static Tcl_ObjCmdProc FileAttrAccessTimeCmd;
static Tcl_ObjCmdProc FileAttrIsDirectoryCmd;
static Tcl_ObjCmdProc FileAttrIsExecutableCmd;
@@ -581,7 +582,7 @@ Tcl_EncodingObjCmd(
break;
}
case ENC_DIRS:
- return EncodingDirsObjCmd(dummy, interp, objc-1, objv+1);
+ return EncodingDirsObjCmd(dummy, interp, objc, objv);
case ENC_NAMES:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
@@ -628,10 +629,12 @@ EncodingDirsObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- if (objc > 2) {
+ if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?dirList?");
return TCL_ERROR;
}
+ objc -= 1;
+ objv += 1;
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
return TCL_OK;
@@ -1057,6 +1060,8 @@ TclMakeFileCommandSafe(
unsafeInfo[i].cmdName,
Tcl_GetString(Tcl_GetObjResult(interp)));
}
+ Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand,
+ (ClientData) unsafeInfo[i].cmdName, NULL);
}
}
Tcl_DStringFree(&oldBuf);
@@ -1078,6 +1083,39 @@ TclMakeFileCommandSafe(
/*
*----------------------------------------------------------------------
*
+ * BadFileSubcommand --
+ *
+ * Command used to act as a backstop implementation when subcommands of
+ * "file" are unsafe (the real implementations of the subcommands are
+ * hidden). The clientData is always the full official subcommand name.
+ *
+ * Results:
+ * A standard Tcl result (always a TCL_ERROR).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BadFileSubcommand(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ const char *subcommandName = (const char *) clientData;
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "not allowed to invoke subcommand %s of file", subcommandName));
+ Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* FileAttrAccessTimeCmd --
*
* This function is invoked to process the "file atime" Tcl command. See
diff --git a/library/safe.tcl b/library/safe.tcl
index 95db3b2..b9be5a7 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -465,8 +465,18 @@ proc ::safe::InterpInit {
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
- AliasSubset $slave file \
- file dir.* join root.* ext.* tail path.* split
+ ::interp expose $slave file
+ foreach subcommand {dirname extension rootname tail} {
+ ::interp alias $slave ::tcl::file::$subcommand {} file $subcommand
+ }
+ foreach subcommand {
+ atime attributes copy delete executable exists isdirectory isfile
+ link lstat mtime mkdir nativename normalize owned readable readlink
+ rename size stat tempfile type volumes writable
+ } {
+ ::interp alias $slave ::tcl::file::$subcommand {} \
+ ::safe::BadSubcommand $slave file $subcommand
+ }
# Subcommands of info
foreach {subcommand alias} {
@@ -980,58 +990,33 @@ proc ::safe::DirInAccessPath {slave dir} {
}
}
-# This procedure enables access from a safe interpreter to only a subset
-# of the subcommands of a command:
+# This procedure is used to report an attempt to use an unsafe member of an
+# ensemble command.
-proc ::safe::Subset {slave command okpat args} {
- set subcommand [lindex $args 0]
- if {[regexp $okpat $subcommand]} {
- return [$command {*}$args]
- }
+proc ::safe::BadSubcommand {slave command subcommand args} {
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
- return -code error $msg
-}
-
-# 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: AliasSubset slave alias target subcommand1 subcommand2...
-
-proc ::safe::AliasSubset {slave alias target args} {
- set pat "^([join $args |])\$"
- ::interp alias $slave $alias {}\
- [namespace current]::Subset $slave $target $pat
+ return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
proc ::safe::AliasEncoding {slave option args} {
- # Careful; do not want empty option to get through to the [string equal]
- if {[regexp {^(name.*|convert.*|)$} $option]} {
- return [::interp invokehidden $slave encoding $option {*}$args]
- }
-
- if {[string equal -length [string length $option] $option "system"]} {
- if {![llength $args]} {
- # passed all the tests , lets source it:
- try {
- return [::interp invokehidden $slave encoding system]
- } on error msg {
- Log $slave $msg
- return -code error "script error"
- }
+ # Note that [encoding dirs] is not supported in safe slaves at all
+ set subcommands {convertfrom convertto names system}
+ try {
+ set option [tcl::prefix match -error [list -level 1 -errorcode \
+ [list TCL LOOKUP INDEX option $option]] $subcommands $option]
+ # Special case: [encoding system] ok, but [encoding system foo] not
+ if {$option eq "system" && [llength $args]} {
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be \"encoding system\""
}
- set msg "wrong # args: should be \"encoding system\""
- set code {TCL WRONGARGS}
- } else {
- set msg "bad option \"$option\": must be convertfrom, convertto, names, or system"
- set code [list TCL LOOKUP INDEX option $option]
+ } on error {msg options} {
+ Log $slave $msg
+ return -options $options $msg
}
- Log $slave $msg
- return -code error -errorcode $code $msg
+ tailcall ::interp invokehidden $slave encoding $option {*}$args
}
# Various minor hiding of platform features. [Bug 2913625]
diff --git a/tests/safe.test b/tests/safe.test
index 2d7f476..827ea11 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -94,7 +94,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
lsort [a aliases]
} -cleanup {
safe::interpDelete a
-} -result {::tcl::info::nameofexecutable clock encoding exit file glob load source}
+} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
@@ -556,7 +556,7 @@ test safe-13.1 {safe file ensemble does not surprise code} -setup {
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
} -cleanup {
interp delete $i
-} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {invalid command name "::tcl::file::isdirectory"}}
+} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
set ::auto_path $saveAutoPath
# cleanup