summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.fossil-settings/binary-glob1
-rw-r--r--.fossil-settings/crnl-glob19
-rw-r--r--generic/tclBasic.c158
-rw-r--r--generic/tclCmdAH.c306
-rw-r--r--generic/tclCmdIL.c2
-rw-r--r--generic/tclEncoding.c2
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclStubInit.c14
-rw-r--r--generic/tclUtf.c8
-rw-r--r--generic/tclUtil.c2
-rw-r--r--generic/tclZipfs.c461
-rw-r--r--library/safe.tcl47
-rw-r--r--tests/info.test12
-rw-r--r--tests/interp.test2
-rw-r--r--tests/safe.test12
-rw-r--r--tests/zipfs.test36
-rw-r--r--tools/empty.zipbin22 -> 0 bytes
-rw-r--r--unix/Makefile.in1
-rw-r--r--win/Makefile.in1
-rw-r--r--win/makefile.vc16
-rw-r--r--win/tclWin32Dll.c10
-rw-r--r--win/tclWinFCmd.c3
22 files changed, 566 insertions, 549 deletions
diff --git a/.fossil-settings/binary-glob b/.fossil-settings/binary-glob
index 5eebf07..ec574be 100644
--- a/.fossil-settings/binary-glob
+++ b/.fossil-settings/binary-glob
@@ -4,7 +4,6 @@ compat/zlib/win64/zdll.lib
compat/zlib/win64/zlib1.dll
compat/zlib/win64/libz.dll.a
compat/zlib/zlib.3.pdf
-tools/empty.zip
*.bmp
*.gif
*.png \ No newline at end of file
diff --git a/.fossil-settings/crnl-glob b/.fossil-settings/crnl-glob
deleted file mode 100644
index 56f3a03..0000000
--- a/.fossil-settings/crnl-glob
+++ /dev/null
@@ -1,19 +0,0 @@
-compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs
-compat/zlib/contrib/vstudio/readme.txt
-compat/zlib/contrib/vstudio/*/zlib.rc
-compat/zlib/win32/*.txt
-compat/zlib/win64/*.txt
-libtommath/*.dsp
-libtommath/*.sln
-libtommath/*.vcproj
-tools/tcl.hpj.in
-tools/tcl.wse.in
-win/buildall.vc.bat
-win/coffbase.txt
-win/makefile.vc
-win/rules.vc
-win/rules-ext.vc
-win/targets.vc
-win/tcl.dsp
-win/tcl.dsw
-win/tcl.hpj.in \ No newline at end of file
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 1ff8a33..2a2f5ee 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -93,6 +93,7 @@ TCL_DECLARE_MUTEX(commandTypeLock);
* Static functions in this file:
*/
+static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
@@ -191,6 +192,24 @@ typedef struct {
* it for it. Defined in tclInt.h. */
/*
+ * The following struct states that the command it talks about (a subcommand
+ * of one of Tcl's built-in ensembles) is unsafe and must be hidden when an
+ * interpreter is made safe. (TclHideUnsafeCommands accesses an array of these
+ * structs.) Alas, we can't sensibly just store the information directly in
+ * the commands.
+ */
+
+typedef struct {
+ const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for
+ * the end of the list of commands to hide. */
+ const char *commandName; /* The name of the command within the
+ * ensemble. If this is NULL, we want to also
+ * make the overall command be hidden, an ugly
+ * hack because it is expected by security
+ * policies in the wild. */
+} UnsafeEnsembleInfo;
+
+/*
* The built-in commands, and the functions that implement them:
*/
@@ -288,6 +307,69 @@ static const CmdInfo builtInCmds[] = {
};
/*
+ * Information about which pieces of ensembles to hide when making an
+ * interpreter safe:
+ */
+
+static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = {
+ /* [encoding] has two unsafe commands. Assumed by older security policies
+ * to be overall unsafe; it isn't but... */
+ {"encoding", NULL},
+ {"encoding", "dirs"},
+ {"encoding", "system"},
+ /* [file] has MANY unsafe commands! Assumed by older security policies to
+ * be overall unsafe; it isn't but... */
+ {"file", NULL},
+ {"file", "atime"},
+ {"file", "attributes"},
+ {"file", "copy"},
+ {"file", "delete"},
+ {"file", "dirname"},
+ {"file", "executable"},
+ {"file", "exists"},
+ {"file", "extension"},
+ {"file", "isdirectory"},
+ {"file", "isfile"},
+ {"file", "link"},
+ {"file", "lstat"},
+ {"file", "mtime"},
+ {"file", "mkdir"},
+ {"file", "nativename"},
+ {"file", "normalize"},
+ {"file", "owned"},
+ {"file", "readable"},
+ {"file", "readlink"},
+ {"file", "rename"},
+ {"file", "rootname"},
+ {"file", "size"},
+ {"file", "stat"},
+ {"file", "tail"},
+ {"file", "tempfile"},
+ {"file", "type"},
+ {"file", "volumes"},
+ {"file", "writable"},
+ /* [info] has two unsafe commands */
+ {"info", "cmdtype"},
+ {"info", "nameofexecutable"},
+ /* [tcl::process] has ONLY unsafe commands! */
+ {"process", "list"},
+ {"process", "status"},
+ {"process", "purge"},
+ {"process", "autopurge"},
+ /* [zipfs] has MANY unsafe commands! */
+ {"zipfs", "lmkimg"},
+ {"zipfs", "lmkzip"},
+ {"zipfs", "mkimg"},
+ {"zipfs", "mkkey"},
+ {"zipfs", "mkzip"},
+ {"zipfs", "mount"},
+ {"zipfs", "mount_data"},
+ {"zipfs", "tcl_library"},
+ {"zipfs", "unmount"},
+ {NULL, NULL}
+};
+
+/*
* Math functions. All are safe.
*/
@@ -1094,6 +1176,7 @@ TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
register const CmdInfo *cmdInfoPtr;
+ register const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -1103,12 +1186,83 @@ TclHideUnsafeCommands(
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
- TclMakeEncodingCommandSafe(interp); /* Ugh! */
- TclMakeFileCommandSafe(interp); /* Ugh! */
+
+ for (unsafePtr = unsafeEnsembleCommands;
+ unsafePtr->ensembleNsName; unsafePtr++) {
+ if (unsafePtr->commandName) {
+ /*
+ * Hide an ensemble subcommand.
+ */
+
+ Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName);
+ Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName);
+
+ if (TclRenameCommand(interp, TclGetString(cmdName),
+ "___tmp") != TCL_OK
+ || Tcl_HideCommand(interp, "___tmp",
+ TclGetString(hideName)) != TCL_OK) {
+ Tcl_Panic("problem making '%s %s' safe: %s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName,
+ Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ Tcl_CreateObjCommand(interp, TclGetString(cmdName),
+ BadEnsembleSubcommand, (ClientData) unsafePtr, NULL);
+ TclDecrRefCount(cmdName);
+ TclDecrRefCount(hideName);
+ } else {
+ /*
+ * Hide an ensemble main command (for compatibility).
+ */
+
+ if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName,
+ unsafePtr->ensembleNsName) != TCL_OK) {
+ Tcl_Panic("problem making '%s' safe: %s",
+ unsafePtr->ensembleNsName,
+ Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ }
+ }
+
return TCL_OK;
}
/*
+ *----------------------------------------------------------------------
+ *
+ * BadEnsembleSubcommand --
+ *
+ * Command used to act as a backstop implementation when subcommands of
+ * ensembles are unsafe (the real implementations of the subcommands are
+ * hidden). The clientData is description of what was hidden.
+ *
+ * Results:
+ * A standard Tcl result (always a TCL_ERROR).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BadEnsembleSubcommand(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ const UnsafeEnsembleInfo *infoPtr = clientData;
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "not allowed to invoke subcommand %s of %s",
+ infoPtr->commandName, infoPtr->ensembleNsName));
+ Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
+ return TCL_ERROR;
+}
+
+/*
*--------------------------------------------------------------
*
* Tcl_CallWhenDeleted --
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index c700add..ca1aa30 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -46,9 +46,6 @@ struct ForeachState {
static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int mode);
-static int BadEncodingSubcommand(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
static int EncodingConvertfromObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -84,7 +81,6 @@ 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;
@@ -399,9 +395,9 @@ TclInitEncodingCmd(
static const EnsembleImplMap encodingImplMap[] = {
{"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
- {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -409,113 +405,6 @@ TclInitEncodingCmd(
}
/*
- *-----------------------------------------------------------------------------
- *
- * TclMakeEncodingCommandSafe --
- *
- * This function hides the unsafe 'dirs' and 'system' subcommands of
- * the "encoding" Tcl command ensemble. It must be called only from
- * TclHideUnsafeCommands.
- *
- * Results:
- * A standard Tcl result
- *
- * Side effects:
- * Adds commands to the table of hidden commands.
- *
- *-----------------------------------------------------------------------------
- */
-
-int
-TclMakeEncodingCommandSafe(
- Tcl_Interp* interp) /* Tcl interpreter */
-{
- static const struct {
- const char *cmdName;
- int unsafe;
- } unsafeInfo[] = {
- {"convertfrom", 0},
- {"convertto", 0},
- {"dirs", 1},
- {"names", 0},
- {"system", 0},
- {NULL, 0}
- };
-
- int i;
- Tcl_DString oldBuf, newBuf;
-
- Tcl_DStringInit(&oldBuf);
- TclDStringAppendLiteral(&oldBuf, "::tcl::encoding::");
- Tcl_DStringInit(&newBuf);
- TclDStringAppendLiteral(&newBuf, "tcl:encoding:");
- for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) {
- if (unsafeInfo[i].unsafe) {
- const char *oldName, *newName;
-
- Tcl_DStringSetLength(&oldBuf, 17);
- oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1);
- Tcl_DStringSetLength(&newBuf, 13);
- newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1);
- if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK
- || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) {
- Tcl_Panic("problem making 'encoding %s' safe: %s",
- unsafeInfo[i].cmdName,
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
- Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand,
- (ClientData) unsafeInfo[i].cmdName, NULL);
- }
- }
- Tcl_DStringFree(&oldBuf);
- Tcl_DStringFree(&newBuf);
-
- /*
- * Ugh. The [encoding] command is now actually safe, but it is assumed by
- * scripts that it is not, which messes up security policies.
- */
-
- if (Tcl_HideCommand(interp, "encoding", "encoding") != TCL_OK) {
- Tcl_Panic("problem making 'encoding' safe: %s",
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * BadEncodingSubcommand --
- *
- * Command used to act as a backstop implementation when subcommands of
- * "encoding" 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
-BadEncodingSubcommand(
- 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 encoding", subcommandName));
- Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
- return TCL_ERROR;
-}
-
-/*
*----------------------------------------------------------------------
*
* EncodingConvertfromObjCmd --
@@ -1037,40 +926,40 @@ TclInitFileCmd(
*/
static const EnsembleImplMap initMap[] = {
- {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0},
+ {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1},
+ {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 1},
{"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0},
- {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
- {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"copy", TclFileCopyCmd, NULL, NULL, NULL, 1},
+ {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
+ {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
- {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
- {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
- {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
- {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 1},
+ {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
+ {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1},
+ {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
+ {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0},
- {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"rename", TclFileRenameCmd, NULL, NULL, NULL, 1},
+ {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
{"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
- {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
- {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1},
+ {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
+ {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "file", initMap);
@@ -1079,141 +968,6 @@ TclInitFileCmd(
/*
*----------------------------------------------------------------------
*
- * TclMakeFileCommandSafe --
- *
- * This function hides the unsafe subcommands of the "file" Tcl command
- * ensemble. It must only be called from TclHideUnsafeCommands.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Adds commands to the table of hidden commands.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclMakeFileCommandSafe(
- Tcl_Interp *interp)
-{
- static const struct {
- const char *cmdName;
- int unsafe;
- } unsafeInfo[] = {
- {"atime", 1},
- {"attributes", 1},
- {"channels", 0},
- {"copy", 1},
- {"delete", 1},
- {"dirname", 1},
- {"executable", 1},
- {"exists", 1},
- {"extension", 1},
- {"isdirectory", 1},
- {"isfile", 1},
- {"join", 0},
- {"link", 1},
- {"lstat", 1},
- {"mtime", 1},
- {"mkdir", 1},
- {"nativename", 1},
- {"normalize", 1},
- {"owned", 1},
- {"pathtype", 0},
- {"readable", 1},
- {"readlink", 1},
- {"rename", 1},
- {"rootname", 1},
- {"separator", 0},
- {"size", 1},
- {"split", 0},
- {"stat", 1},
- {"system", 0},
- {"tail", 1},
- {"tempfile", 1},
- {"type", 1},
- {"volumes", 1},
- {"writable", 1},
- {NULL, 0}
- };
- int i;
- Tcl_DString oldBuf, newBuf;
-
- Tcl_DStringInit(&oldBuf);
- TclDStringAppendLiteral(&oldBuf, "::tcl::file::");
- Tcl_DStringInit(&newBuf);
- TclDStringAppendLiteral(&newBuf, "tcl:file:");
- for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) {
- if (unsafeInfo[i].unsafe) {
- const char *oldName, *newName;
-
- Tcl_DStringSetLength(&oldBuf, 13);
- oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1);
- Tcl_DStringSetLength(&newBuf, 9);
- newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1);
- if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK
- || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) {
- Tcl_Panic("problem making 'file %s' safe: %s",
- unsafeInfo[i].cmdName,
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
- Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand,
- (ClientData) unsafeInfo[i].cmdName, NULL);
- }
- }
- Tcl_DStringFree(&oldBuf);
- Tcl_DStringFree(&newBuf);
-
- /*
- * Ugh. The [file] command is now actually safe, but it is assumed by
- * scripts that it is not, which messes up security policies. [Bug
- * 3211758]
- */
-
- if (Tcl_HideCommand(interp, "file", "file") != TCL_OK) {
- Tcl_Panic("problem making 'file' safe: %s",
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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/generic/tclCmdIL.c b/generic/tclCmdIL.c
index ffcb92c..9f265bf 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -173,7 +173,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
{"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index c1dd220..2093a29 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -1994,7 +1994,7 @@ LoadEscapeEncoding(
dataPtr->numSubTables =
Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable);
memcpy(dataPtr->subTables, Tcl_DStringValue(&escapeData),
- (size_t) Tcl_DStringLength(&escapeData));
+ Tcl_DStringLength(&escapeData));
Tcl_DStringFree(&escapeData);
memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes));
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3b7ba87..1097c34 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3288,7 +3288,6 @@ MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp);
-MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3317,7 +3316,6 @@ MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp);
-MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 8e1ea44..a03bf1a 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -105,6 +105,9 @@ Tcl_WinUtfToTChar(
Tcl_DString *dsPtr)
{
Tcl_DStringInit(dsPtr);
+ if (!string) {
+ return NULL;
+ }
return (char *)Tcl_UtfToUniCharDString(string, len, dsPtr);
}
@@ -114,12 +117,15 @@ Tcl_WinTCharToUtf(
int len,
Tcl_DString *dsPtr)
{
- if (len > 0) {
- len /= 2;
- } else if (len == -1) {
+ Tcl_DStringInit(dsPtr);
+ if (!string) {
+ return NULL;
+ }
+ if (len < 0) {
len = wcslen((wchar_t *)string);
+ } else {
+ len /= 2;
}
- Tcl_DStringInit(dsPtr);
return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr);
}
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index d62586c..ce67db7 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -451,9 +451,9 @@ Tcl_UtfToUniCharDString(
if (Tcl_UtfCharComplete(p, end-p)) {
p += TclUtfToUniChar(p, &ch);
} else if ((unsigned)((UCHAR(*p)-0x80)) < (unsigned) 0x20) {
- ch = (Tcl_UniChar) cp1252[UCHAR(*p)-0x80];
+ ch = (Tcl_UniChar) cp1252[UCHAR(*p++)-0x80];
} else {
- ch = UCHAR(*p);
+ ch = UCHAR(*p++);
}
*w++ = ch;
}
@@ -783,8 +783,8 @@ Tcl_UniCharAtIndex(
*
* Returns a pointer to the specified character (not byte) position in
* the UTF-8 string. If TCL_UTF_MAX <= 4, characters > U+FFFF count as
- * 2 positions, but then the pointer should never be placed between
- * the two positions.
+ * 2 positions, but then the pointer should never be placed between
+ * the two positions.
*
* Results:
* As above.
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 395d1bf..c5833c5 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -3998,7 +3998,7 @@ TclGetProcessGlobalValue(
ckfree(pgvPtr->value);
pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1);
memcpy(pgvPtr->value, Tcl_DStringValue(&newValue),
- (size_t) Tcl_DStringLength(&newValue) + 1);
+ Tcl_DStringLength(&newValue) + 1);
Tcl_DStringFree(&newValue);
Tcl_FreeEncoding(pgvPtr->encoding);
pgvPtr->encoding = current;
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index 5342fb1..829b5d2 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -19,17 +19,9 @@
#include "tclInt.h"
#include "tclFileSystem.h"
-#ifdef _WIN32
-#include <winbase.h>
-#else /* !_WIN32 */
+#ifndef _WIN32
#include <sys/mman.h>
#endif /* _WIN32*/
-#include <errno.h>
-#include <string.h>
-#include <sys/stat.h>
-#include <time.h>
-#include <stdlib.h>
-#include <fcntl.h>
#ifndef MAP_FILE
#define MAP_FILE 0
@@ -136,6 +128,8 @@
#define ZIP_PASSWORD_END_SIG 0x5a5a4b50
+#define DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024)
+
/*
* Macros to report errors only if an interp is present.
*/
@@ -282,7 +276,7 @@ static struct {
Tcl_HashTable fileHash; /* File name to ZipEntry mapping */
Tcl_HashTable zipHash; /* Mount to ZipFile mapping */
} ZipFS = {
- 0, 0, 0, 0, 0,
+ 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0,
};
/*
@@ -574,12 +568,8 @@ ToDosTime(
{
struct tm *tmp, tm;
-#if !defined(TCL_THREADS)
- /* Not threaded */
- tmp = localtime(&when);
- tm = *tmp;
-#elif defined(_WIN32)
- /* Win32 uses thread local storage */
+#if !defined(TCL_THREADS) || defined(_WIN32)
+ /* Not threaded, or on Win32 which uses thread local storage */
tmp = localtime(&when);
tm = *tmp;
#elif defined(HAVE_LOCALTIME_R)
@@ -602,12 +592,8 @@ ToDosDate(
{
struct tm *tmp, tm;
-#if !defined(TCL_THREADS)
- /* Not threaded */
- tmp = localtime(&when);
- tm = *tmp;
-#elif /* TCL_THREADS && */ defined(_WIN32)
- /* Win32 uses thread local storage */
+#if !defined(TCL_THREADS) || defined(_WIN32)
+ /* Not threaded, or on Win32 which uses thread local storage */
tmp = localtime(&when);
tm = *tmp;
#elif /* TCL_THREADS && !_WIN32 && */ defined(HAVE_LOCALTIME_R)
@@ -1001,6 +987,9 @@ ZipFSFindTOC(
return TCL_OK;
}
ZIPFS_ERROR(interp, "wrong end signature");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL);
+ }
goto error;
}
zf->numFiles = ZipReadShort(p + ZIP_CENTRAL_ENTS_OFFS);
@@ -1010,6 +999,9 @@ ZipFSFindTOC(
return TCL_OK;
}
ZIPFS_ERROR(interp, "empty archive");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL);
+ }
goto error;
}
q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS);
@@ -1021,6 +1013,9 @@ ZipFSFindTOC(
return TCL_OK;
}
ZIPFS_ERROR(interp, "archive directory not found");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL);
+ }
goto error;
}
zf->baseOffset = zf->passOffset = p - q;
@@ -1031,10 +1026,16 @@ ZipFSFindTOC(
if (q + ZIP_CENTRAL_HEADER_LEN > zf->data + zf->length) {
ZIPFS_ERROR(interp, "wrong header length");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL);
+ }
goto error;
}
if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) {
ZIPFS_ERROR(interp, "wrong header signature");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL);
+ }
goto error;
}
pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS);
@@ -1116,6 +1117,9 @@ ZipFSOpenArchive(
if ((zf->length - ZIP_CENTRAL_END_LEN)
> (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
ZIPFS_ERROR(interp, "illegal file size");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL);
+ }
goto error;
}
if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) {
@@ -1125,6 +1129,9 @@ ZipFSOpenArchive(
zf->ptrToFree = zf->data = attemptckalloc(zf->length);
if (!zf->ptrToFree) {
ZIPFS_ERROR(interp, "out of memory");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
goto error;
}
i = Tcl_Read(zf->chan, (char *) zf->data, zf->length);
@@ -1227,6 +1234,7 @@ ZipFSCatalogFilesystem(
if (interp) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("illegal password", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
}
return TCL_ERROR;
}
@@ -1252,6 +1260,7 @@ ZipFSCatalogFilesystem(
zf = Tcl_GetHashValue(hPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s is already mounted on %s", zf->name, mountPoint));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "MOUNTED", NULL);
}
Unlock();
ZipFSCloseArchive(interp, zf0);
@@ -1261,6 +1270,7 @@ ZipFSCatalogFilesystem(
if (!zf) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
Unlock();
ZipFSCloseArchive(interp, zf0);
@@ -1504,6 +1514,7 @@ ZipfsSetup(void)
Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS);
Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS);
ZipFS.idCount = 1;
+ ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE;
ZipFS.initialized = 1;
}
@@ -1648,6 +1659,7 @@ TclZipfs_Mount(
if (interp) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("illegal password", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
}
return TCL_ERROR;
}
@@ -1656,6 +1668,7 @@ TclZipfs_Mount(
if (!zf) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
@@ -1728,6 +1741,7 @@ TclZipfs_MountBuffer(
if (!zf) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
@@ -1738,6 +1752,7 @@ TclZipfs_MountBuffer(
if (!zf->data) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
@@ -1834,7 +1849,7 @@ TclZipfs_Unmount(
*
* ZipFSMountObjCmd --
*
- * This procedure is invoked to process the "zipfs::mount" command.
+ * This procedure is invoked to process the [zipfs mount] command.
*
* Results:
* A standard Tcl result.
@@ -1847,10 +1862,10 @@ TclZipfs_Unmount(
static int
ZipFSMountObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1868,7 +1883,7 @@ ZipFSMountObjCmd(
*
* ZipFSMountBufferObjCmd --
*
- * This procedure is invoked to process the "zipfs::mount_data" command.
+ * This procedure is invoked to process the [zipfs mount_data] command.
*
* Results:
* A standard Tcl result.
@@ -1881,10 +1896,10 @@ ZipFSMountObjCmd(
static int
ZipFSMountBufferObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *mountPoint; /* Mount point path. */
unsigned char *data;
@@ -1920,7 +1935,7 @@ ZipFSMountBufferObjCmd(
*
* ZipFSRootObjCmd --
*
- * This procedure is invoked to process the "zipfs::root" command. It
+ * This procedure is invoked to process the [zipfs root] command. It
* returns the root that all zipfs file systems are mounted under.
*
* Results:
@@ -1933,10 +1948,10 @@ ZipFSMountBufferObjCmd(
static int
ZipFSRootObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1));
return TCL_OK;
@@ -1947,7 +1962,7 @@ ZipFSRootObjCmd(
*
* ZipFSUnmountObjCmd --
*
- * This procedure is invoked to process the "zipfs::unmount" command.
+ * This procedure is invoked to process the [zipfs unmount] command.
*
* Results:
* A standard Tcl result.
@@ -1960,10 +1975,10 @@ ZipFSRootObjCmd(
static int
ZipFSUnmountObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "zipfile");
@@ -1977,7 +1992,7 @@ ZipFSUnmountObjCmd(
*
* ZipFSMkKeyObjCmd --
*
- * This procedure is invoked to process the "zipfs::mkkey" command. It
+ * This procedure is invoked to process the [zipfs mkkey] command. It
* produces a rotated password to be embedded into an image file.
*
* Results:
@@ -1991,10 +2006,10 @@ ZipFSUnmountObjCmd(
static int
ZipFSMkKeyObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int len, i = 0;
char *pw, passBuf[264];
@@ -2091,6 +2106,7 @@ ZipAddFile(
if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"path too long for \"%s\"", path));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "PATH_LEN", NULL);
return TCL_ERROR;
}
in = Tcl_OpenFileChannel(interp, path, "rb", 0);
@@ -2178,13 +2194,21 @@ ZipAddFile(
double r;
if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("PRNG error: %s",
- Tcl_GetString(Tcl_GetObjResult(interp))));
+ Tcl_Obj *eiPtr = Tcl_ObjPrintf(
+ "\n (evaluating PRNG step %d for password encoding)",
+ i);
+
+ Tcl_AppendObjToErrorInfo(interp, eiPtr);
Tcl_Close(interp, in);
return TCL_ERROR;
}
ret = Tcl_GetObjResult(interp);
if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) {
+ Tcl_Obj *eiPtr = Tcl_ObjPrintf(
+ "\n (evaluating PRNG step %d for password encoding)",
+ i);
+
+ Tcl_AppendObjToErrorInfo(interp, eiPtr);
Tcl_Close(interp, in);
return TCL_ERROR;
}
@@ -2221,6 +2245,7 @@ ZipAddFile(
Z_DEFAULT_STRATEGY) != Z_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"compression init error on \"%s\"", path));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL);
Tcl_Close(interp, in);
return TCL_ERROR;
}
@@ -2243,6 +2268,7 @@ ZipAddFile(
if (len == (size_t) Z_STREAM_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"deflate error on %s", path));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE", NULL);
deflateEnd(&stream);
Tcl_Close(interp, in);
return TCL_ERROR;
@@ -2318,7 +2344,16 @@ ZipAddFile(
}
Tcl_Close(interp, in);
+ hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew);
+ if (!isNew) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "non-unique path name \"%s\"", path));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL);
+ return TCL_ERROR;
+ }
+
z = ckalloc(sizeof(ZipEntry));
+ Tcl_SetHashValue(hPtr, z);
z->name = NULL;
z->tnext = NULL;
z->depth = 0;
@@ -2332,17 +2367,8 @@ ZipAddFile(
z->numCompressedBytes = nbytecompr;
z->compressMethod = compMeth;
z->data = NULL;
- hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew);
- if (!isNew) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "non-unique path name \"%s\"", path));
- ckfree(z);
- return TCL_ERROR;
- } else {
- Tcl_SetHashValue(hPtr, z);
- z->name = Tcl_GetHashKey(fileHash, hPtr);
- z->next = NULL;
- }
+ z->name = Tcl_GetHashKey(fileHash, hPtr);
+ z->next = NULL;
/*
* Write final local header information.
@@ -2404,12 +2430,11 @@ ZipAddFile(
static int
ZipFSMkZipOrImgObjCmd(
- ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int isImg,
int isList,
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel out;
int pwlen = 0, count, ret = TCL_ERROR, lobjc;
@@ -2433,6 +2458,7 @@ ZipFSMkZipOrImgObjCmd(
if ((pwlen > 255) || strchr(pw, 0xff)) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("illegal password", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
return TCL_ERROR;
}
}
@@ -2462,11 +2488,13 @@ ZipFSMkZipOrImgObjCmd(
Tcl_DecrRefCount(list);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("need even number of elements", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "LIST_LENGTH", NULL);
return TCL_ERROR;
}
if (lobjc == 0) {
Tcl_DecrRefCount(list);
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL);
return TCL_ERROR;
}
out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "wb", 0755);
@@ -2741,10 +2769,10 @@ ZipFSMkZipOrImgObjCmd(
/*
*-------------------------------------------------------------------------
*
- * ZipFSMkZipObjCmd --
+ * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd --
*
- * This procedure is invoked to process the "zipfs::mkzip" command. See
- * description of ZipFSMkZipOrImgCmd().
+ * These procedures are invoked to process the [zipfs mkzip] and [zipfs
+ * lmkzip] commands. See description of ZipFSMkZipOrImgCmd().
*
* Results:
* A standard Tcl result.
@@ -2757,10 +2785,10 @@ ZipFSMkZipOrImgObjCmd(
static int
ZipFSMkZipObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?");
@@ -2769,17 +2797,18 @@ ZipFSMkZipObjCmd(
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"operation not permitted in a safe interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
return TCL_ERROR;
}
- return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 0, objc, objv);
+ return ZipFSMkZipOrImgObjCmd(interp, 0, 0, objc, objv);
}
static int
ZipFSLMkZipObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?");
@@ -2788,18 +2817,19 @@ ZipFSLMkZipObjCmd(
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"operation not permitted in a safe interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
return TCL_ERROR;
}
- return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 1, objc, objv);
+ return ZipFSMkZipOrImgObjCmd(interp, 0, 1, objc, objv);
}
/*
*-------------------------------------------------------------------------
*
- * ZipFSZipFSOpenArchiveObjCmd --
+ * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd --
*
- * This procedure is invoked to process the "zipfs::mkimg" command. See
- * description of ZipFSMkZipOrImgCmd().
+ * These procedures are invoked to process the [zipfs mkimg] and [zipfs
+ * lmkimg] commands. See description of ZipFSMkZipOrImgCmd().
*
* Results:
* A standard Tcl result.
@@ -2812,10 +2842,10 @@ ZipFSLMkZipObjCmd(
static int
ZipFSMkImgObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 6) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2825,17 +2855,18 @@ ZipFSMkImgObjCmd(
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"operation not permitted in a safe interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
return TCL_ERROR;
}
- return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 0, objc, objv);
+ return ZipFSMkZipOrImgObjCmd(interp, 1, 0, objc, objv);
}
static int
ZipFSLMkImgObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?");
@@ -2844,9 +2875,10 @@ ZipFSLMkImgObjCmd(
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"operation not permitted in a safe interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
return TCL_ERROR;
}
- return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 1, objc, objv);
+ return ZipFSMkZipOrImgObjCmd(interp, 1, 1, objc, objv);
}
/*
@@ -2854,7 +2886,7 @@ ZipFSLMkImgObjCmd(
*
* ZipFSCanonicalObjCmd --
*
- * This procedure is invoked to process the "zipfs::canonical" command.
+ * This procedure is invoked to process the [zipfs canonical] command.
* It returns the canonical name for a file within zipfs
*
* Results:
@@ -2868,10 +2900,10 @@ ZipFSLMkImgObjCmd(
static int
ZipFSCanonicalObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
char *mntpoint = NULL;
char *filename = NULL;
@@ -2909,7 +2941,7 @@ ZipFSCanonicalObjCmd(
*
* ZipFSExistsObjCmd --
*
- * This procedure is invoked to process the "zipfs::exists" command. It
+ * This procedure is invoked to process the [zipfs exists] command. It
* tests for the existence of a file in the ZIP filesystem and places a
* boolean into the interp's result.
*
@@ -2924,10 +2956,10 @@ ZipFSCanonicalObjCmd(
static int
ZipFSExistsObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
char *filename;
int exists;
@@ -2961,7 +2993,7 @@ ZipFSExistsObjCmd(
*
* ZipFSInfoObjCmd --
*
- * This procedure is invoked to process the "zipfs::info" command. On
+ * This procedure is invoked to process the [zipfs info] command. On
* success, it returns a Tcl list made up of name of ZIP archive file,
* size uncompressed, size compressed, and archive offset of a file in
* the ZIP filesystem.
@@ -2977,10 +3009,10 @@ ZipFSExistsObjCmd(
static int
ZipFSInfoObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
char *filename;
ZipEntry *z;
@@ -3012,7 +3044,7 @@ ZipFSInfoObjCmd(
*
* ZipFSListObjCmd --
*
- * This procedure is invoked to process the "zipfs::list" command. On
+ * This procedure is invoked to process the [zipfs list] command. On
* success, it returns a Tcl list of files of the ZIP filesystem which
* match a search pattern (glob or regexp).
*
@@ -3027,10 +3059,10 @@ ZipFSInfoObjCmd(
static int
ZipFSListObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
char *pattern = NULL;
Tcl_RegExp regexp = NULL;
@@ -3056,6 +3088,7 @@ ZipFSListObjCmd(
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown option \"%s\"", what));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_OPT", NULL);
return TCL_ERROR;
}
} else if (objc == 2) {
@@ -3095,17 +3128,35 @@ ZipFSListObjCmd(
return TCL_OK;
}
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_TclLibrary --
+ *
+ * This procedure gets (and possibly finds) the root that Tcl's library
+ * files are mounted under.
+ *
+ * Results:
+ * A Tcl object holding the location (with zero refcount), or NULL if no
+ * Tcl library can be found.
+ *
+ * Side effects:
+ * May initialise the cache of where such library files are to be found.
+ * This cache is never cleared.
+ *
+ *-------------------------------------------------------------------------
+ */
+
#ifdef _WIN32
#define LIBRARY_SIZE 64
-static int
-ToUtf(
+static inline int
+WCharToUtf(
const WCHAR *wSrc,
char *dst)
{
- char *start;
+ char *start = dst;
- start = dst;
while (*wSrc != '\0') {
dst += Tcl_UniCharToUtf(*wSrc, dst);
wSrc++;
@@ -3118,68 +3169,83 @@ ToUtf(
Tcl_Obj *
TclZipfs_TclLibrary(void)
{
- if (zipfs_literal_tcl_library) {
- return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
- } else {
- Tcl_Obj *vfsinitscript;
- int found = 0;
+ Tcl_Obj *vfsInitScript;
+ int found;
#ifdef _WIN32
- HMODULE hModule = TclWinGetTclInstance();
- WCHAR wName[MAX_PATH + LIBRARY_SIZE];
- char dllname[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
+ HMODULE hModule;
+ WCHAR wName[MAX_PATH + LIBRARY_SIZE];
+ char dllName[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
#endif /* _WIN32 */
- /*
- * Look for the library file system within the executable.
- */
- vfsinitscript = Tcl_NewStringObj(
- ZIPFS_APP_MOUNT "/tcl_library/init.tcl", -1);
- Tcl_IncrRefCount(vfsinitscript);
- found = Tcl_FSAccess(vfsinitscript, F_OK);
- Tcl_DecrRefCount(vfsinitscript);
- if (found == TCL_OK) {
- zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
- return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
- }
+ /*
+ * Use the cached value if that has been set; we don't want to repeat the
+ * searching and mounting.
+ */
-#if defined(_WIN32)
- if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
- GetModuleFileNameA(hModule, dllname, MAX_PATH);
- } else {
- ToUtf(wName, dllname);
- }
+ if (zipfs_literal_tcl_library) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
- /*
- * Mount zip file and dll before releasing to search.
- */
+ /*
+ * Look for the library file system within the executable.
+ */
- if (ZipfsAppHookFindTclInit(dllname) == TCL_OK) {
- return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
- }
+ vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",
+ -1);
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == TCL_OK) {
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+
+ /*
+ * Look for the library file system within the DLL/shared library. Note
+ * that we must mount the zip file and dll before releasing to search.
+ */
+
+#if defined(_WIN32)
+ hModule = TclWinGetTclInstance();
+ if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
+ GetModuleFileNameA(hModule, dllName, MAX_PATH);
+ } else {
+ WCharToUtf(wName, dllName);
+ }
+
+ if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
#elif /* !_WIN32 && */ defined(CFG_RUNTIME_DLLFILE)
- /*
- * Mount zip file and dll before releasing to search.
- */
- if (ZipfsAppHookFindTclInit(
- CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
- return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
- }
+ if (ZipfsAppHookFindTclInit(
+ CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
#endif /* _WIN32 || CFG_RUNTIME_DLLFILE */
+ /*
+ * If we're configured to know about a ZIP archive we should use, do that.
+ */
+
#ifdef CFG_RUNTIME_ZIPFILE
- if (ZipfsAppHookFindTclInit(
- CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) {
- return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
- }
- if (ZipfsAppHookFindTclInit(
- CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) {
- return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
- }
- if (ZipfsAppHookFindTclInit(CFG_RUNTIME_ZIPFILE) == TCL_OK) {
- return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
- }
-#endif /* CFG_RUNTIME_ZIPFILE */
+ if (ZipfsAppHookFindTclInit(
+ CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+ if (ZipfsAppHookFindTclInit(
+ CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+ if (ZipfsAppHookFindTclInit(CFG_RUNTIME_ZIPFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
}
+#endif /* CFG_RUNTIME_ZIPFILE */
+
+ /*
+ * If anything set the cache (but subsequently failed) go with that
+ * anyway.
+ */
+
if (zipfs_literal_tcl_library) {
return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
}
@@ -3191,23 +3257,25 @@ TclZipfs_TclLibrary(void)
*
* ZipFSTclLibraryObjCmd --
*
- * This procedure is invoked to process the "zipfs::tcl_library" command.
- * It returns the root that all zipfs file systems are mounted under.
+ * This procedure is invoked to process the [zipfs tcl_library] command.
+ * It returns the root that Tcl's library files are mounted under.
*
* Results:
* A standard Tcl result.
*
* Side effects:
+ * May initialise the cache of where such library files are to be found.
+ * This cache is never cleared.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSTclLibraryObjCmd(
- ClientData clientData,
+ ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc,
- Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *pResult = TclZipfs_TclLibrary();
@@ -3552,15 +3620,18 @@ ZipChannelOpen(
if (interp) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("unsupported open mode", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_MODE", NULL);
}
return NULL;
}
WriteLock();
z = ZipFSLookup(filename);
if (!z) {
+ Tcl_SetErrno(ENOENT);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "file not found \"%s\"", filename));
+ "file not found \"%s\": %s", filename,
+ Tcl_PosixError(interp)));
}
goto error;
}
@@ -3569,19 +3640,31 @@ ZipChannelOpen(
if ((z->compressMethod != ZIP_COMPMETH_STORED)
&& (z->compressMethod != ZIP_COMPMETH_DEFLATED)) {
ZIPFS_ERROR(interp, "unsupported compression method");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "COMP_METHOD", NULL);
+ }
goto error;
}
if (wr && z->isDirectory) {
ZIPFS_ERROR(interp, "unsupported file type");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_TYPE", NULL);
+ }
goto error;
}
if (!trunc) {
flags |= TCL_READABLE;
if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) {
ZIPFS_ERROR(interp, "decryption failed");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DECRYPT", NULL);
+ }
goto error;
} else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) {
ZIPFS_ERROR(interp, "file too large");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL);
+ }
goto error;
}
} else {
@@ -3590,6 +3673,9 @@ ZipChannelOpen(
info = attemptckalloc(sizeof(ZipChannel));
if (!info) {
ZIPFS_ERROR(interp, "out of memory");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
goto error;
}
info->zipFilePtr = z->zipFilePtr;
@@ -3610,6 +3696,9 @@ ZipChannelOpen(
}
ckfree(info);
ZIPFS_ERROR(interp, "out of memory");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
goto error;
}
memset(info->ubuf, 0, info->maxWrite);
@@ -3694,6 +3783,9 @@ ZipChannelOpen(
}
ckfree(info);
ZIPFS_ERROR(interp, "decompression error");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL);
+ }
goto error;
} else if (z->isEncrypted) {
for (i = 0; i < z->numBytes - 12; i++) {
@@ -3779,6 +3871,7 @@ ZipChannelOpen(
if (interp) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("out of memory", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
goto error;
}
@@ -3808,6 +3901,9 @@ ZipChannelOpen(
}
ckfree(info);
ZIPFS_ERROR(interp, "decompression error");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL);
+ }
goto error;
}
}
@@ -4380,7 +4476,8 @@ ZipFSFileAttrsGetProc(
ReadLock();
z = ZipFSLookup(path);
if (!z) {
- ZIPFS_ERROR(interp, "file not found");
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_POSIX_ERROR(interp, "file not found");
ret = TCL_ERROR;
goto done;
}
@@ -4440,6 +4537,7 @@ ZipFSFileAttrsSetProc(
{
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL);
}
return TCL_ERROR;
}
@@ -4607,21 +4705,21 @@ TclZipfs_Init(
{
#ifdef HAVE_ZLIB
static const EnsembleImplMap initMap[] = {
- {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 0},
- {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 0},
- {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 0},
- {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 0},
+ {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 1},
+ {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 1},
+ {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 1},
+ {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 1},
/* The 4 entries above are not available in safe interpreters */
- {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 0},
- {"mount_data", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 0},
- {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 0},
- {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 0},
- {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 1},
- {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 1},
- {"list", ZipFSListObjCmd, NULL, NULL, NULL, 1},
- {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 1},
- {"root", ZipFSRootObjCmd, NULL, NULL, NULL, 1},
- {"tcl_library", ZipFSTclLibraryObjCmd, NULL, NULL, NULL, 0},
+ {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 1},
+ {"mount_data", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 1},
+ {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 1},
+ {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 1},
+ {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0},
+ {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0},
+ {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0},
+ {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 0},
+ {"root", ZipFSRootObjCmd, NULL, NULL, NULL, 0},
+ {"tcl_library", ZipFSTclLibraryObjCmd, NULL, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
static const char findproc[] =
@@ -4663,10 +4761,11 @@ TclZipfs_Init(
Tcl_PkgProvide(interp, "zipfs", "2.0");
}
return TCL_OK;
-#else
+#else /* !HAVE_ZLIB */
ZIPFS_ERROR(interp, "no zlib available");
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
return TCL_ERROR;
-#endif
+#endif /* HAVE_ZLIB */
}
static int
@@ -4770,15 +4869,14 @@ TclZipfs_AppHook(
}
#ifdef SUPPORT_BUILTIN_ZIP_INSTALL
} else if (*argcPtr > 1) {
-#ifdef _WIN32
- Tcl_DString ds;
-#endif /* _WIN32 */
/*
* If the first argument is "install", run the supplied installer
* script.
*/
#ifdef _WIN32
+ Tcl_DString ds;
+
archive = Tcl_WinTCharToUtf((*argvPtr)[1], -1, &ds);
#else /* !_WIN32 */
archive = (*argvPtr)[1];
@@ -4854,6 +4952,9 @@ TclZipfs_Mount(
* the ZIP is unprotected. */
{
ZIPFS_ERROR(interp, "no zlib available");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ }
return TCL_ERROR;
}
@@ -4866,6 +4967,9 @@ TclZipfs_MountBuffer(
int copy)
{
ZIPFS_ERROR(interp, "no zlib available");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ }
return TCL_ERROR;
}
@@ -4875,6 +4979,9 @@ TclZipfs_Unmount(
const char *mountPoint) /* Mount point path. */
{
ZIPFS_ERROR(interp, "no zlib available");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ }
return TCL_ERROR;
}
#endif /* !HAVE_ZLIB */
diff --git a/library/safe.tcl b/library/safe.tcl
index c48d002..ef370b5 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -455,37 +455,35 @@ proc ::safe::InterpInit {
foreach {command alias} {
source AliasSource
load AliasLoad
- encoding AliasEncoding
exit interpDelete
glob AliasGlob
} {
::interp alias $slave $command {} [namespace current]::$alias $slave
}
+ # UGLY POINT! These commands are safe (they're ensembles with unsafe
+ # subcommands), but is assumed to not be by existing policies so it is
+ # hidden by default. Hack it...
+ foreach command {encoding file} {
+ ::interp alias $slave $command {} interp invokehidden $slave $command
+ }
+
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
- ::interp expose $slave file
foreach subcommand {dirname extension rootname tail} {
::interp alias $slave ::tcl::file::$subcommand {} \
::safe::AliasFileSubcommand $slave $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
- }
+
+ # Subcommand of 'encoding' that has special handling; [encoding system] is
+ # OK provided it has no other arguments passed to it.
+ ::interp alias $slave ::tcl::encoding::system {} \
+ ::safe::AliasEncodingSystem $slave
# Subcommands of info
- foreach {subcommand alias} {
- nameofexecutable AliasExeName
- } {
- ::interp alias $slave ::tcl::info::$subcommand \
- {} [namespace current]::$alias $slave
- }
+ ::interp alias $slave ::tcl::info::nameofexecutable {} \
+ ::safe::AliasExeName $slave
# The allowed slave variables already have been set by Tcl_MakeSafe(3)
@@ -1027,16 +1025,13 @@ proc ::safe::BadSubcommand {slave command subcommand args} {
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} {
- # Note that [encoding dirs] is not supported in safe slaves at all
- set subcommands {convertfrom convertto names system}
+# AliasEncodingSystem is the target of the "encoding system" alias in safe
+# interpreters.
+proc ::safe::AliasEncodingSystem {slave args} {
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]} {
+ # Must not pass extra arguments; safe slaves may not set the system
+ # encoding but they may read it.
+ if {[llength $args]} {
return -code error -errorcode {TCL WRONGARGS} \
"wrong # args: should be \"encoding system\""
}
@@ -1044,7 +1039,7 @@ proc ::safe::AliasEncoding {slave option args} {
Log $slave $msg
return -options $options $msg
}
- tailcall ::interp invokehidden $slave encoding $option {*}$args
+ tailcall ::interp invokehidden $slave tcl:encoding:system
}
# Various minor hiding of platform features. [Bug 2913625]
diff --git a/tests/info.test b/tests/info.test
index 0de1510..a12d45c 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -2535,9 +2535,9 @@ test info-40.18 {info cmdtype: aliases in slave interpreters} -setup {
$safe eval {
info cmdtype foo
}
-} -cleanup {
+} -returnCodes error -cleanup {
interp delete $safe
-} -result native
+} -result {not allowed to invoke subcommand cmdtype of info}
test info-40.19 {info cmdtype: aliases in slave interpreters} -setup {
set safe [interp create -safe]
} -body {
@@ -2548,9 +2548,9 @@ test info-40.19 {info cmdtype: aliases in slave interpreters} -setup {
info cmdtype foo
}
}
-} -cleanup {
+} -returnCodes error -cleanup {
interp delete $safe
-} -result native
+} -result {not allowed to invoke subcommand cmdtype of info}
test info-40.20 {info cmdtype: aliases in slave interpreters} -setup {
set safe [interp create -safe]
} -body {
@@ -2558,9 +2558,9 @@ test info-40.20 {info cmdtype: aliases in slave interpreters} -setup {
interp alias {} foo {} gorp
info cmdtype foo
}
-} -cleanup {
+} -returnCodes error -cleanup {
interp delete $safe
-} -result alias
+} -result {not allowed to invoke subcommand cmdtype of info}
namespace delete ::testinfocmdtype
# -------------------------------------------------------------------------
diff --git a/tests/interp.test b/tests/interp.test
index 4ea04e3..e9f95d7 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -20,7 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
-set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs 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 unload}
+set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system 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:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:tcl_library tcl:zipfs:unmount unload}
foreach i [interp slaves] {
interp delete $i
diff --git a/tests/safe.test b/tests/safe.test
index 217507e..356e176 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -92,7 +92,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
lsort [a aliases]
} -cleanup {
safe::interpDelete a
-} -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}
+} -result {::tcl::encoding::system ::tcl::file::dirname ::tcl::file::extension ::tcl::file::rootname ::tcl::file::tail ::tcl::info::nameofexecutable clock encoding exit file glob load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
@@ -464,14 +464,14 @@ test safe-11.1 {testing safe encoding} -setup {
interp eval $i encoding
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -result {wrong # args: should be "encoding option ?arg ...?"}
+} -result {wrong # args: should be "encoding subcommand ?arg ...?"}
test safe-11.1a {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding foobar
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -match glob -result {bad option "foobar": must be *}
+} -match glob -result {unknown or ambiguous subcommand "foobar": must be *}
test safe-11.2 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
@@ -526,8 +526,6 @@ test safe-11.7.1 {testing safe encoding} -setup {
while executing
"encoding convertfrom"
invoked from within
-"::interp invokehidden interp* encoding convertfrom"
- invoked from within
"encoding convertfrom"
invoked from within
"interp eval $i encoding convertfrom"}
@@ -550,8 +548,6 @@ test safe-11.8.1 {testing safe encoding} -setup {
while executing
"encoding convertto"
invoked from within
-"::interp invokehidden interp* encoding convertto"
- invoked from within
"encoding convertto"
invoked from within
"interp eval $i encoding convertto"}
@@ -765,7 +761,7 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup {
unset -nocomplain msg
interp delete $i
} -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}}
-test safe-15.1.1 {safe file ensemble does not surprise code} -setup {
+test safe-15.2 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
} -body {
set result [expr {"file" in [interp hidden $i]}]
diff --git a/tests/zipfs.test b/tests/zipfs.test
index 9d60f8d..631b525 100644
--- a/tests/zipfs.test
+++ b/tests/zipfs.test
@@ -239,6 +239,42 @@ test zipfs-2.13 {zipfs unmount} -constraints {zipfs zipfsencbuf} -body {
catch {file delete -force $tmpdir}
+test zipfs-3.1 {zipfs in child interpreters} -constraints zipfs -setup {
+ set interp [interp create]
+} -body {
+ interp eval $interp {
+ zipfs ?
+ }
+} -returnCodes error -cleanup {
+ interp delete $interp
+} -result {unknown or ambiguous subcommand "?": must be canonical, exists, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, tcl_library, or unmount}
+test zipfs-3.2 {zipfs in child interpreters} -constraints zipfs -setup {
+ set interp [interp create]
+} -body {
+ interp eval $interp {
+ zipfs mkzip
+ }
+} -returnCodes error -cleanup {
+ interp delete $interp
+} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"}
+test zipfs-3.3 {zipfs in child interpreters} -constraints zipfs -setup {
+ set safe [interp create -safe]
+} -body {
+ interp eval $safe {
+ zipfs ?
+ }
+} -returnCodes error -cleanup {
+ interp delete $safe
+} -result {unknown or ambiguous subcommand "?": must be canonical, exists, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, tcl_library, or unmount}
+test zipfs-3.4 {zipfs in child interpreters} -constraints zipfs -setup {
+ set safe [interp create -safe]
+} -body {
+ interp eval $safe {
+ zipfs mkzip
+ }
+} -returnCodes error -cleanup {
+ interp delete $safe
+} -result {not allowed to invoke subcommand mkzip of zipfs}
::tcltest::cleanupTests
return
diff --git a/tools/empty.zip b/tools/empty.zip
deleted file mode 100644
index 15cb0ec..0000000
--- a/tools/empty.zip
+++ /dev/null
Binary files differ
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 37e1adb..9cf58a6 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -714,7 +714,6 @@ ${TCL_EXE}: ${TCLSH_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE}
${CC} ${CFLAGS} ${LDFLAGS} ${TCLSH_OBJS} \
@TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o ${TCL_EXE}
- cat ${TOOL_DIR}/empty.zip >> ${TCL_EXE}
# Must be empty so it doesn't conflict with rule for ${TCL_EXE} above
${NATIVE_TCLSH}:
diff --git a/win/Makefile.in b/win/Makefile.in
index abb29e3..7962bb8 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -495,7 +495,6 @@ $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
@VC_MANIFEST_EMBED_EXE@
- cat ${TOOL_DIR}/empty.zip >> ${TCLSH}
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
diff --git a/win/makefile.vc b/win/makefile.vc
index 0e009bb..824d8e3 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -123,7 +123,6 @@ TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT)
TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME)
TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe
-CAT32 = $(OUT_DIR)\cat32.exe
TCLSHOBJS = \
$(TMP_DIR)\tclAppInit.obj \
@@ -384,20 +383,20 @@ release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs
core: setup $(TCLLIB) $(TCLSTUBLIB)
shell: setup $(TCLSH)
dlls: setup $(TCLREGLIB) $(TCLDDELIB)
-all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs
-tcltest: setup $(TCLTEST) dlls $(CAT32)
+all: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs
+tcltest: setup $(TCLTEST) dlls
install: install-binaries install-libraries install-docs install-pkgs
setup: default-setup
test: test-core test-pkgs
-test-core: setup $(TCLTEST) dlls $(CAT32)
+test-core: setup $(TCLTEST) dlls
set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde]
package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry]
<<
-runtest: setup $(TCLTEST) dlls $(CAT32)
+runtest: setup $(TCLTEST) dlls
set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLTEST) $(SCRIPT)
@@ -419,11 +418,11 @@ $(TCLLIB): $(TCLOBJS)
$**
<<
$(_VC_MANIFEST_EMBED_DLL)
+
$(TCLIMPLIB): $(TCLLIB)
!endif # $(STATIC_BUILD)
-
$(TCLSTUBLIB): $(TCLSTUBOBJS)
$(LIBCMD) -nodefaultlib $(TCLSTUBOBJS)
@@ -485,11 +484,6 @@ clean-pkgs:
popd \
)
-$(CAT32): $(WINDIR)\cat.c
- $(cc32) $(cflags) $(crt) -D_CRT_NONSTDC_NO_DEPRECATE -DCONSOLE -Fo$(TMP_DIR)\ $?
- $(CONEXECMD) -stack:16384 $(TMP_DIR)\cat.obj
- $(_VC_MANIFEST_EMBED_EXE)
-
#---------------------------------------------------------------------
# Regenerate the stubs files. [Development use only]
#---------------------------------------------------------------------
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index 04d27dd..dca6875 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -473,7 +473,7 @@ Tcl_WinUtfToTChar(
{
Tcl_DStringInit(dsPtr);
if (!string) {
- return (TCHAR *)Tcl_DStringValue(dsPtr);
+ return NULL;
}
return Tcl_UtfToUniCharDString(string, len, dsPtr);
}
@@ -488,12 +488,12 @@ Tcl_WinTCharToUtf(
{
Tcl_DStringInit(dsPtr);
if (!string) {
- return Tcl_DStringValue(dsPtr);
+ return NULL;
}
- if (len > 0) {
- len /= 2;
- } else if (len < 0) {
+ if (len < 0) {
len = wcslen(string);
+ } else {
+ len /= 2;
}
return Tcl_UniCharToUtfDString(string, len, dsPtr);
}
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index a69dbe5..c3ced34 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -337,7 +337,7 @@ DoRenameFile(
* character is either end-of-string or a directory separator
*/
- if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0)
+ if ((strncmp(src, dst, Tcl_DStringLength(&srcString))==0)
&& (dst[Tcl_DStringLength(&srcString)] == '\\'
|| dst[Tcl_DStringLength(&srcString)] == '/'
|| dst[Tcl_DStringLength(&srcString)] == '\0')) {
@@ -1649,7 +1649,6 @@ ConvertFileNameFormat(
* likely to lead to infinite loops.
*/
- Tcl_DStringInit(&ds);
tempString = TclGetString(tempPath);
nativeName = Tcl_WinUtfToTChar(tempString, tempPath->length, &ds);
Tcl_DecrRefCount(tempPath);
generated by cgit v0.12 at 2025-12-09 19:56:09 (GMT)