summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2018-10-18 15:31:51 (GMT)
committerdgp <dgp@users.sourceforge.net>2018-10-18 15:31:51 (GMT)
commit90221ac971708ce2bd09ffff98b55b8198513808 (patch)
treeec9ac9fbc978032844db1abec26b437520a22af4 /generic
parent050e383cf2f4f6e67ba6030a187257e0c2c0b1e0 (diff)
parent49ebd1264d9cff42e9e5963f2a2f3c0eb732f375 (diff)
downloadtcl-90221ac971708ce2bd09ffff98b55b8198513808.zip
tcl-90221ac971708ce2bd09ffff98b55b8198513808.tar.gz
tcl-90221ac971708ce2bd09ffff98b55b8198513808.tar.bz2
merge 8.7
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls79
-rw-r--r--generic/tcl.h14
-rw-r--r--generic/tclAssembly.c2
-rw-r--r--generic/tclBasic.c358
-rw-r--r--generic/tclBinary.c51
-rw-r--r--generic/tclCmdAH.c371
-rw-r--r--generic/tclCmdIL.c80
-rw-r--r--generic/tclCmdMZ.c14
-rw-r--r--generic/tclCompCmdsGR.c61
-rw-r--r--generic/tclCompCmdsSZ.c21
-rw-r--r--generic/tclCompExpr.c2
-rw-r--r--generic/tclCompile.h2
-rw-r--r--generic/tclDate.c1896
-rw-r--r--generic/tclDecls.h183
-rw-r--r--generic/tclDisassemble.c2
-rw-r--r--generic/tclEncoding.c2
-rw-r--r--generic/tclEnsemble.c41
-rw-r--r--generic/tclEnv.c13
-rw-r--r--generic/tclExecute.c128
-rw-r--r--generic/tclFCmd.c34
-rw-r--r--generic/tclFileName.c2
-rw-r--r--generic/tclGetDate.y2
-rw-r--r--generic/tclIO.c34
-rw-r--r--generic/tclIOCmd.c6
-rw-r--r--generic/tclIOGT.c13
-rw-r--r--generic/tclIORChan.c6
-rw-r--r--generic/tclIORTrans.c17
-rw-r--r--generic/tclIOSock.c2
-rw-r--r--generic/tclIOUtil.c100
-rw-r--r--generic/tclInt.h81
-rw-r--r--generic/tclInterp.c110
-rw-r--r--generic/tclNamesp.c10
-rw-r--r--generic/tclOO.c168
-rw-r--r--generic/tclOOBasic.c32
-rw-r--r--generic/tclOODefineCmds.c152
-rw-r--r--generic/tclOOInt.h4
-rw-r--r--generic/tclOOScript.h263
-rw-r--r--generic/tclOOScript.tcl456
-rw-r--r--generic/tclObj.c172
-rw-r--r--generic/tclParse.c7
-rw-r--r--generic/tclPkg.c2
-rw-r--r--generic/tclPkgConfig.c2
-rw-r--r--generic/tclPort.h18
-rw-r--r--generic/tclProc.c138
-rw-r--r--generic/tclProcess.c70
-rw-r--r--generic/tclScan.c4
-rw-r--r--generic/tclStringObj.c66
-rw-r--r--generic/tclStubInit.c70
-rw-r--r--generic/tclTest.c26
-rw-r--r--generic/tclThreadTest.c9
-rw-r--r--generic/tclTomMath.decls3
-rw-r--r--generic/tclTomMathDecls.h6
-rw-r--r--generic/tclUtf.c56
-rw-r--r--generic/tclUtil.c471
-rw-r--r--generic/tclVar.c538
-rw-r--r--generic/tclZipfs.c5011
-rw-r--r--generic/tclZlib.c18
57 files changed, 9045 insertions, 2454 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 0200257..0bc43e8 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -104,7 +104,7 @@ declare 20 {
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
-declare 22 {
+declare 22 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line)
}
declare 23 {
@@ -119,7 +119,7 @@ declare 25 {
Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
const char *file, int line)
}
-declare 26 {
+declare 26 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line)
}
declare 27 {
@@ -152,7 +152,7 @@ declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
-declare 36 {
+declare 36 {deprecated {No longer in use, changed to macro}} {
int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
const char *const *tablePtr, const char *msg, int flags, int *indexPtr)
}
@@ -198,7 +198,7 @@ declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
int count, int objc, Tcl_Obj *const objv[])
}
-declare 49 {
+declare 49 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewBooleanObj(int boolValue)
}
declare 50 {
@@ -207,13 +207,13 @@ declare 50 {
declare 51 {
Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
}
-declare 52 {
+declare 52 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewIntObj(int intValue)
}
declare 53 {
Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[])
}
-declare 54 {
+declare 54 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewLongObj(long longValue)
}
declare 55 {
@@ -222,7 +222,7 @@ declare 55 {
declare 56 {
Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length)
}
-declare 57 {
+declare 57 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue)
}
declare 58 {
@@ -235,13 +235,13 @@ declare 59 {
declare 60 {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
-declare 61 {
+declare 61 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
}
declare 62 {
void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[])
}
-declare 63 {
+declare 63 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
}
declare 64 {
@@ -250,10 +250,10 @@ declare 64 {
declare 65 {
void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length)
}
-declare 66 {
+declare 66 {deprecated {No longer in use, changed to macro}} {
void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message)
}
-declare 67 {
+declare 67 {deprecated {No longer in use, changed to macro}} {
void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message,
int length)
}
@@ -472,7 +472,7 @@ declare 129 {
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
-declare 131 {
+declare 131 {deprecated {No longer in use, changed to macro}} {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 132 {
@@ -624,7 +624,7 @@ declare 173 {
declare 174 {
const char *Tcl_GetStringResult(Tcl_Interp *interp)
}
-declare 175 {
+declare 175 {deprecated {No longer in use, changed to macro}} {
const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags)
}
@@ -635,7 +635,7 @@ declare 176 {
declare 177 {
int Tcl_GlobalEval(Tcl_Interp *interp, const char *command)
}
-declare 178 {
+declare 178 {deprecated {No longer in use, changed to macro}} {
int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 {
@@ -834,7 +834,7 @@ declare 235 {
declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
-declare 237 {
+declare 237 {deprecated {No longer in use, changed to macro}} {
const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags)
}
@@ -869,7 +869,7 @@ declare 245 {
declare 246 {deprecated {}} {
int Tcl_TellOld(Tcl_Channel chan)
}
-declare 247 {
+declare 247 {deprecated {No longer in use, changed to macro}} {
int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
@@ -890,14 +890,14 @@ declare 251 {
declare 252 {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
-declare 253 {
+declare 253 {deprecated {No longer in use, changed to macro}} {
int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags)
}
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
-declare 255 {
+declare 255 {deprecated {No longer in use, changed to macro}} {
void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
@@ -909,7 +909,7 @@ declare 256 {
declare 257 {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
-declare 258 {
+declare 258 {deprecated {No longer in use, changed to macro}} {
int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
const char *varName, const char *localName, int flags)
}
@@ -920,7 +920,7 @@ declare 259 {
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
-declare 261 {
+declare 261 {deprecated {No longer in use, changed to macro}} {
ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
}
@@ -955,7 +955,7 @@ declare 270 {
const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
const char **termPtr)
}
-declare 271 {
+declare 271 {deprecated {No longer in use, changed to macro}} {
const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
@@ -964,12 +964,12 @@ declare 272 {
const char *name, const char *version, int exact,
void *clientDataPtr)
}
-declare 273 {
+declare 273 {deprecated {No longer in use, changed to macro}} {
int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
const char *version)
}
# TIP #268: The internally used new Require function is in slot 573.
-declare 274 {
+declare 274 {deprecated {No longer in use, changed to macro}} {
const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
@@ -1350,7 +1350,7 @@ declare 380 {
declare 381 {
int Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
}
-declare 382 {
+declare 382 {deprecated {No longer in use, changed to macro}} {
Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
}
declare 383 {
@@ -2330,25 +2330,40 @@ declare 631 {
ClientData callbackData)
}
-# TIP #445
+# TIP #430
declare 632 {
- void Tcl_FreeIntRep(Tcl_Obj *objPtr)
+ int TclZipfs_Mount(Tcl_Interp *interp, const char *mountPoint,
+ const char *zipname, const char *passwd)
}
declare 633 {
+ int TclZipfs_Unmount(Tcl_Interp *interp, const char *mountPoint)
+}
+declare 634 {
+ Tcl_Obj *TclZipfs_TclLibrary(void)
+}
+declare 635 {
+ int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint,
+ unsigned char *data, size_t datalen, int copy)
+}
+
+# TIP #445
+declare 636 {
+ void Tcl_FreeIntRep(Tcl_Obj *objPtr)
+}
+declare 637 {
char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
unsigned int numBytes)
}
-declare 634 {
+declare 638 {
Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr)
}
-declare 635 {
+declare 639 {
void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr,
const Tcl_ObjIntRep *irPtr)
}
-declare 636 {
+declare 640 {
int Tcl_HasStringRep(Tcl_Obj *objPtr)
}
-
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
@@ -2396,6 +2411,10 @@ export {
void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc)
}
export {
+ void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc,
+ Tcl_Interp *interp)
+}
+export {
const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version,
int exact)
}
diff --git a/generic/tcl.h b/generic/tcl.h
index fefd5ca..35edebb 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -224,7 +224,7 @@ extern "C" {
* to be included in a shared library, then it should have the DLLEXPORT
* storage class. If is being declared for use by a module that is going to
* link against the shared library, then it should have the DLLIMPORT storage
- * class. If the symbol is beind declared for a static build or for use from a
+ * class. If the symbol is being declared for a static build or for use from a
* stub library, then the storage class should be empty.
*
* The convention is that a macro called BUILD_xxxx, where xxxx is the name of
@@ -2337,6 +2337,13 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
#define TCL_TCPSERVER_REUSEPORT (1<<1)
/*
+ * Constants for special int-typed values, see TIP #494
+ */
+
+#define TCL_IO_FAILURE (-1)
+#define TCL_AUTO_LENGTH (-1)
+
+/*
*----------------------------------------------------------------------------
* Single public declaration for NRE.
*/
@@ -2399,12 +2406,15 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
*/
#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
- ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)()))
+ (((Tcl_SetPanicProc)(Tcl_ConsolePanic), Tcl_CreateInterp)()))
EXTERN void Tcl_MainEx(int argc, char **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
const char *version, int exact);
EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
+#ifndef _WIN32
+EXTERN int TclZipfs_AppHook(int *argc, char ***argv);
+#endif
/*
*----------------------------------------------------------------------------
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 4bc6918..5ac9a55 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -2254,7 +2254,7 @@ GetListIndexOperand(
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) {
return TCL_ERROR;
}
-
+
/* Convert to an integer, advance to the next token and return. */
/*
* NOTE: Indexing a list with an index before it yields the
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 2ef0c41..75c467b 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -71,7 +71,18 @@ typedef struct {
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
-TCL_DECLARE_MUTEX(cancelLock)
+TCL_DECLARE_MUTEX(cancelLock);
+
+/*
+ * Table used to map command implementation functions to a human-readable type
+ * name, for [info type]. The keys in the table are function addresses, and
+ * the values in the table are static char* containing strings in Tcl's
+ * internal encoding (almost UTF-8).
+ */
+
+static Tcl_HashTable commandTypeTable;
+static int commandTypeInit = 0;
+TCL_DECLARE_MUTEX(commandTypeLock);
/*
* Declarations for managing contexts for non-recursive coroutines. Contexts
@@ -94,6 +105,7 @@ TCL_DECLARE_MUTEX(cancelLock)
* Static functions in this file:
*/
+static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
@@ -114,7 +126,6 @@ static Tcl_ObjCmdProc ExprBinaryFunc;
static Tcl_ObjCmdProc ExprBoolFunc;
static Tcl_ObjCmdProc ExprCeilFunc;
static Tcl_ObjCmdProc ExprDoubleFunc;
-static Tcl_ObjCmdProc ExprEntierFunc;
static Tcl_ObjCmdProc ExprFloorFunc;
static Tcl_ObjCmdProc ExprIntFunc;
static Tcl_ObjCmdProc ExprIsqrtFunc;
@@ -196,6 +207,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:
*/
@@ -296,6 +325,68 @@ 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", "unmount"},
+ {NULL, NULL}
+};
+
+/*
* Math functions. All are safe.
*/
@@ -316,7 +407,7 @@ static const BuiltinFuncDef BuiltinFuncTable[] = {
{ "cos", ExprUnaryFunc, (ClientData) cos },
{ "cosh", ExprUnaryFunc, (ClientData) cosh },
{ "double", ExprDoubleFunc, NULL },
- { "entier", ExprEntierFunc, NULL },
+ { "entier", ExprIntFunc, NULL },
{ "exp", ExprUnaryFunc, (ClientData) exp },
{ "floor", ExprFloorFunc, NULL },
{ "fmod", ExprBinaryFunc, (ClientData) fmod },
@@ -431,6 +522,13 @@ TclFinalizeEvaluation(void)
cancelTableInitialized = 0;
}
Tcl_MutexUnlock(&cancelLock);
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_DeleteHashTable(&commandTypeTable);
+ commandTypeInit = 0;
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
}
/*
@@ -504,9 +602,23 @@ Tcl_CreateInterp(void)
Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
cancelTableInitialized = 1;
}
+
Tcl_MutexUnlock(&cancelLock);
}
+ if (commandTypeInit == 0) {
+ TclRegisterCommandTypeName(TclObjInterpProc, "proc");
+ TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
+ TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
+ TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
+ TclRegisterCommandTypeName(TclSlaveObjCmd, "slave");
+ TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
+ TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
+ TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject");
+ TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass");
+ TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine");
+ }
+
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
@@ -999,6 +1111,9 @@ Tcl_CreateInterp(void)
if (TclZlibInit(interp) != TCL_OK) {
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
+ if (TclZipfs_Init(interp) != TCL_OK) {
+ Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
#endif
TOP_CB(iPtr) = NULL;
@@ -1015,6 +1130,71 @@ DeleteOpCmdClientData(
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * TclRegisterCommandTypeName, TclGetCommandTypeName --
+ *
+ * Command type registration and lookup mechanism. Everything is keyed by
+ * the Tcl_ObjCmdProc for the command, and that is used as the *key* into
+ * the hash table that maps to constant strings that are names. (It is
+ * recommended that those names be ASCII.)
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclRegisterCommandTypeName(
+ Tcl_ObjCmdProc *implementationProc,
+ const char *nameStr)
+{
+ Tcl_HashEntry *hPtr;
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit == 0) {
+ Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS);
+ commandTypeInit = 1;
+ }
+ if (nameStr != NULL) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&commandTypeTable,
+ (void *) implementationProc, &isNew);
+ Tcl_SetHashValue(hPtr, (void *) nameStr);
+ } else {
+ hPtr = Tcl_FindHashEntry(&commandTypeTable,
+ (void *) implementationProc);
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
+}
+
+const char *
+TclGetCommandTypeName(
+ Tcl_Command command)
+{
+ Command *cmdPtr = (Command *) command;
+ void *procPtr = cmdPtr->objProc;
+ const char *name = "native";
+
+ if (procPtr == NULL) {
+ procPtr = cmdPtr->nreProc;
+ }
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr);
+
+ if (hPtr && Tcl_GetHashValue(hPtr)) {
+ name = (const char *) Tcl_GetHashValue(hPtr);
+ }
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
+
+ return name;
+}
+
+/*
*----------------------------------------------------------------------
*
* TclHideUnsafeCommands --
@@ -1035,6 +1215,7 @@ TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
register const CmdInfo *cmdInfoPtr;
+ register const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -1044,12 +1225,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 --
@@ -6525,7 +6777,7 @@ Tcl_ExprLongObj(
resultPtr = Tcl_NewBignumObj(&big);
/* FALLTHROUGH */
}
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
break;
@@ -7525,7 +7777,7 @@ ExprAbsFunc(
return TCL_ERROR;
}
- if (type == TCL_NUMBER_WIDE) {
+ if (type == TCL_NUMBER_INT) {
Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
if (l > (Tcl_WideInt)0) {
@@ -7544,7 +7796,7 @@ ExprAbsFunc(
}
}
goto unChanged;
- } else if (l == LLONG_MIN) {
+ } else if (l == WIDE_MIN) {
TclInitBignumFromWideInt(&big, l);
goto tooLarge;
}
@@ -7648,7 +7900,7 @@ ExprDoubleFunc(
}
static int
-ExprEntierFunc(
+ExprIntFunc(
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
@@ -7669,7 +7921,7 @@ ExprEntierFunc(
if (type == TCL_NUMBER_DOUBLE) {
d = *((const double *) ptr);
- if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) {
+ if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) {
mp_int big;
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
@@ -7679,9 +7931,9 @@ ExprEntierFunc(
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
} else {
- long result = (long) d;
+ Tcl_WideInt result = (Tcl_WideInt) d;
- Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
}
@@ -7704,38 +7956,6 @@ ExprEntierFunc(
}
static int
-ExprIntFunc(
- ClientData clientData, /* Ignored. */
- Tcl_Interp *interp, /* The interpreter in which to execute the
- * function. */
- int objc, /* Actual parameter count. */
- Tcl_Obj *const *objv) /* Actual parameter vector. */
-{
- long iResult;
- Tcl_Obj *objPtr;
- if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
- return TCL_ERROR;
- }
- objPtr = Tcl_GetObjResult(interp);
- if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in long range.
- */
-
- mp_int big;
-
- Tcl_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &iResult);
- Tcl_DecrRefCount(objPtr);
- }
- Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult));
- return TCL_OK;
-}
-
-static int
ExprWideFunc(
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7744,26 +7964,11 @@ ExprWideFunc(
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
Tcl_WideInt wResult;
- Tcl_Obj *objPtr;
- if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
+ if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
- objPtr = Tcl_GetObjResult(interp);
- if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in wide int range.
- */
-
- mp_int big;
-
- Tcl_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetWideIntFromObj(NULL, objPtr, &wResult);
- Tcl_DecrRefCount(objPtr);
- }
+ TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
return TCL_OK;
}
@@ -7866,7 +8071,7 @@ ExprRandFunc(
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
- iPtr->randSeed &= (unsigned long) 0x7fffffff;
+ iPtr->randSeed &= 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
@@ -8010,7 +8215,7 @@ ExprSrandFunc(
Tcl_Obj *const *objv) /* Parameter vector. */
{
Interp *iPtr = (Interp *) interp;
- long i = 0; /* Initialized to avoid compiler warning. */
+ Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */
/*
* Convert argument and use it to reset the seed.
@@ -8021,20 +8226,8 @@ ExprSrandFunc(
return TCL_ERROR;
}
- if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) {
- Tcl_Obj *objPtr;
- mp_int big;
-
- if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
- /* TODO: more ::errorInfo here? or in caller? */
- return TCL_ERROR;
- }
-
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &i);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) {
+ return TCL_ERROR;
}
/*
@@ -8043,8 +8236,7 @@ ExprSrandFunc(
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
- iPtr->randSeed = i;
- iPtr->randSeed &= (unsigned long) 0x7fffffff;
+ iPtr->randSeed = (long) w & 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
@@ -8531,18 +8723,12 @@ TclNRTailcallObjCmd(
if (objc > 1) {
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- Tcl_Namespace *ns1Ptr;
/* The tailcall data is in a Tcl list: the first element is the
* namespace, the rest the command to be tailcalled. */
- listPtr = Tcl_NewListObj(objc, objv);
-
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
- if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
- || (nsPtr != ns1Ptr)) {
- Tcl_Panic("Tailcall failed to find the proper namespace");
- }
+ listPtr = Tcl_NewListObj(objc, objv);
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
iPtr->varFramePtr->tailcallPtr = listPtr;
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 45cafdf..96adff0 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -2016,7 +2016,6 @@ FormatNumber(
Tcl_Obj *src, /* Number to format. */
unsigned char **cursorPtr) /* Pointer to index into destination buffer. */
{
- long value;
double dvalue;
Tcl_WideInt wvalue;
float fvalue;
@@ -2080,7 +2079,7 @@ FormatNumber(
case 'w':
case 'W':
case 'm':
- if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
@@ -2110,19 +2109,19 @@ FormatNumber(
case 'i':
case 'I':
case 'n':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = UCHAR(value);
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value >> 16);
- *(*cursorPtr)++ = UCHAR(value >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
} else {
- *(*cursorPtr)++ = UCHAR(value >> 24);
- *(*cursorPtr)++ = UCHAR(value >> 16);
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
@@ -2132,15 +2131,15 @@ FormatNumber(
case 's':
case 'S':
case 't':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = UCHAR(value);
- *(*cursorPtr)++ = UCHAR(value >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
} else {
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
@@ -2148,10 +2147,10 @@ FormatNumber(
* 8-bit integer values.
*/
case 'c':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue);
return TCL_OK;
default:
@@ -2539,8 +2538,8 @@ BinaryDecodeHex(
}
c = *data++;
- if (!isxdigit((int) c)) {
- if (strict || !isspace(c)) {
+ if (!isxdigit(UCHAR(c))) {
+ if (strict || !TclIsSpaceProc(c)) {
goto badChar;
}
i--;
@@ -2887,7 +2886,7 @@ BinaryDecodeUu(
if (lineLen < 0) {
c = *data++;
if (c < 32 || c > 96) {
- if (strict || !isspace(c)) {
+ if (strict || !TclIsSpaceProc(c)) {
goto badUu;
}
i--;
@@ -2905,7 +2904,7 @@ BinaryDecodeUu(
d[i] = c = *data++;
if (c < 32 || c > 96) {
if (strict) {
- if (!isspace(c)) {
+ if (!TclIsSpaceProc(c)) {
goto badUu;
} else if (c == '\n') {
goto shortUu;
@@ -2949,7 +2948,7 @@ BinaryDecodeUu(
} else if (c >= 32 && c <= 96) {
data--;
break;
- } else if (strict || !isspace(c)) {
+ } else if (strict || !TclIsSpaceProc(c)) {
goto badUu;
}
} while (data < dataend);
@@ -3074,7 +3073,7 @@ BinaryDecode64(
if (c == '=' && i > 1) {
value <<= 6;
cut++;
- } else if (!strict && isspace(c)) {
+ } else if (!strict && TclIsSpaceProc(c)) {
i--;
} else {
goto bad64;
@@ -3092,7 +3091,7 @@ BinaryDecode64(
} else if (c == '=') {
value <<= 6;
cut++;
- } else if (strict || !isspace(c)) {
+ } else if (strict || !TclIsSpaceProc(c)) {
goto bad64;
} else {
i--;
@@ -3113,7 +3112,7 @@ BinaryDecode64(
goto bad64;
}
for (; data < dataend; data++) {
- if (!isspace(*data)) {
+ if (!TclIsSpaceProc(*data)) {
goto bad64;
}
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 49c8c56..334121f 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;
@@ -514,63 +510,6 @@ Tcl_ContinueObjCmd(
}
/*
- *----------------------------------------------------------------------
- *
- * Tcl_EncodingObjCmd --
- *
- * This command manipulates encodings.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_EncodingObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- int index;
-
- static const char *const optionStrings[] = {
- "convertfrom", "convertto", "dirs", "names", "system",
- NULL
- };
- enum options {
- ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM
- };
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
-
- switch ((enum options) index) {
- case ENC_CONVERTTO:
- return EncodingConverttoObjCmd(dummy, interp, objc, objv);
- case ENC_CONVERTFROM:
- return EncodingConvertfromObjCmd(dummy, interp, objc, objv);
- case ENC_DIRS:
- return EncodingDirsObjCmd(dummy, interp, objc, objv);
- case ENC_NAMES:
- return EncodingNamesObjCmd(dummy, interp, objc, objv);
- case ENC_SYSTEM:
- return EncodingSystemObjCmd(dummy, interp, objc, objv);
- }
- return TCL_OK;
-}
-
-/*
*-----------------------------------------------------------------------------
*
* TclInitEncodingCmd --
@@ -593,9 +532,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}
};
@@ -603,113 +542,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 --
@@ -1231,40 +1063,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);
@@ -1273,141 +1105,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
@@ -1455,9 +1152,9 @@ FileAttrAccessTimeCmd(
* platforms. [Bug 698146]
*/
- long newTime;
+ Tcl_WideInt newTime;
- if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
@@ -1536,9 +1233,9 @@ FileAttrModifyTimeCmd(
* platforms. [Bug 698146]
*/
- long newTime;
+ Tcl_WideInt newTime;
- if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 3d9327d..ac2288e 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -138,6 +138,8 @@ static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+static int InfoCmdTypeCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
@@ -156,6 +158,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
@@ -170,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},
@@ -2122,6 +2125,60 @@ InfoTclVersionCmd(
/*
*----------------------------------------------------------------------
*
+ * InfoCmdTypeCmd --
+ *
+ * Called to implement the "info cmdtype" command that returns the type
+ * of a given command. Handles the following syntax:
+ *
+ * info cmdtype cmdName
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a type name. If there is an error, the result is an error
+ * message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoCmdTypeCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Command command;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "commandName");
+ return TCL_ERROR;
+ }
+ command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL,
+ TCL_LEAVE_ERR_MSG);
+ if (command == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * There's one special case: safe slave interpreters can't see aliases as
+ * aliases as they're part of the security mechanisms.
+ */
+
+ if (Tcl_IsSafe(interp)
+ && (((Command *) command)->objProc == TclAliasObjCmd)) {
+ Tcl_AppendResult(interp, "native", NULL);
+ } else {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(TclGetCommandTypeName(command), -1));
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_JoinObjCmd --
*
* This procedure is invoked to process the "join" Tcl command. See the
@@ -2720,21 +2777,10 @@ Tcl_LreplaceObjCmd(
if (first < 0) {
first = 0;
}
-
- /*
- * Complain if the user asked for a start element that is greater than the
- * list length. This won't ever trigger for the "end-*" case as that will
- * be properly constrained by TclGetIntForIndex because we use listLen-1
- * (to allow for replacing the last elem).
- */
-
- if ((first >= listLen) && (listLen > 0)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "list doesn't contain element %s", TclGetString(objv[2])));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX",
- NULL);
- return TCL_ERROR;
+ if (first > listLen) {
+ first = listLen;
}
+
if (last >= listLen) {
last = listLen - 1;
}
@@ -3323,7 +3369,7 @@ Tcl_LsearchObjCmd(
* sense in doing this when the match sense is inverted.
*/
- /*
+ /*
* With -stride, lower, upper and i are kept as multiples of groupSize.
*/
@@ -4005,7 +4051,7 @@ Tcl_LsortObjCmd(
/*
* Do not shrink the actual memory block used; that doesn't
* work with TclStackAlloc-allocated memory. [Bug 2918962]
- *
+ *
* TODO: Consider a pointer increment to replace this
* array shift.
*/
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index a7af094..e113412 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -258,7 +258,7 @@ Tcl_RegexpObjCmd(
stringLength = Tcl_GetCharLength(objPtr);
if (startIndex) {
- TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
+ TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
@@ -582,7 +582,7 @@ Tcl_RegsubObjCmd(
if (startIndex) {
int stringLength = Tcl_GetCharLength(objv[1]);
- TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
+ TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
@@ -1447,6 +1447,9 @@ StringIndexCmd(
char buf[4];
length = Tcl_UniCharToUtf(ch, buf);
+ if (!length) {
+ length = Tcl_UniCharToUtf(-1, buf);
+ }
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
}
}
@@ -1620,10 +1623,6 @@ StringIsCmd(
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT:
- if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) {
- break;
- }
- goto failedIntParse;
case STR_IS_ENTIER:
if (Tcl_FetchIntRep(objPtr, &tclIntType) ||
Tcl_FetchIntRep(objPtr, &tclBignumType)) {
@@ -1671,7 +1670,6 @@ StringIsCmd(
break;
}
- failedIntParse:
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
@@ -1846,7 +1844,7 @@ static int
UniCharIsHexDigit(
int character)
{
- return (character >= 0) && (character < 0x80) && isxdigit(character);
+ return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character));
}
/*
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 858a0c5..f9cf3d8 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -34,7 +34,7 @@ static int IndexTailVarIfKnown(Tcl_Interp *interp,
* TclGetIndexFromToken --
*
* Parse a token to determine if an index value is known at
- * compile time.
+ * compile time.
*
* Returns:
* TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
@@ -1474,7 +1474,7 @@ TclCompileLreplaceCmd(
{
Tcl_Token *tokenPtr, *listTokenPtr;
DefineLineInformation; /* TIP #280 */
- int idx1, idx2, i, offset, offset2;
+ int idx1, idx2, i;
int emptyPrefix=1, suffixStart = 0;
if (parsePtr->numWords < 4) {
@@ -1495,23 +1495,6 @@ TclCompileLreplaceCmd(
}
/*
- * idx1, idx2 are the conventional encoded forms of the tokens parsed
- * as all forms of index values. Values of idx1 that come before the
- * list are treated the same as if they were the start of the list.
- * Values of idx2 that come after the list are treated the same as if
- * they were the end of the list.
- */
-
- if (idx1 == TCL_INDEX_AFTER) {
- /*
- * [lreplace] treats idx1 value end+1 differently from end+2, etc.
- * The operand encoding cannot distinguish them, so we must bail
- * out to direct evaluation.
- */
- return TCL_ERROR;
- }
-
- /*
* General structure of the [lreplace] result is
* prefix replacement suffix
* In a few cases we can predict various parts will be empty and
@@ -1522,7 +1505,9 @@ TclCompileLreplaceCmd(
* we must defer to direct evaluation.
*/
- if (idx2 == TCL_INDEX_BEFORE) {
+ if (idx1 == TCL_INDEX_AFTER) {
+ suffixStart = idx1;
+ } else if (idx2 == TCL_INDEX_BEFORE) {
suffixStart = idx1;
} else if (idx2 == TCL_INDEX_END) {
suffixStart = TCL_INDEX_AFTER;
@@ -1553,42 +1538,6 @@ TclCompileLreplaceCmd(
emptyPrefix = 0;
}
-
- /*
- * [lreplace] raises an error when idx1 points after the list, but
- * only when the list is not empty. This is maximum stupidity.
- *
- * TODO: TIP this nonsense away!
- */
- if (idx1 >= TCL_INDEX_START) {
- if (emptyPrefix) {
- TclEmitOpcode( INST_DUP, envPtr);
- } else {
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- }
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- TclEmitOpcode( INST_DUP, envPtr);
- offset = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
-
- /* List is not empty */
- TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewIntObj(idx1),
- NULL), envPtr);
- TclEmitOpcode( INST_GT, envPtr);
- offset2 = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr);
-
- /* Idx1 >= list length ===> raise an error */
- TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf(
- "list doesn't contain element %d", idx1), NULL), envPtr);
- CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0,
- Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}"));
- TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset,
- envPtr->codeStart + offset + 1);
- TclEmitOpcode( INST_POP, envPtr);
- TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2,
- envPtr->codeStart + offset2 + 1);
- }
if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {
/*
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index cf088bb..b16b8b3 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -691,14 +691,11 @@ TclCompileStringIsCmd(
}
switch (t) {
- case STR_IS_INT:
- PUSH( "1");
- OP( EQ);
- break;
case STR_IS_WIDE:
PUSH( "2");
OP( LE);
break;
+ case STR_IS_INT:
case STR_IS_ENTIER:
PUSH( "3");
OP( LE);
@@ -1002,13 +999,13 @@ TclCompileStringReplaceCmd(
if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
return TCL_ERROR;
}
-
+
/* Bytecode to compute/push string argument being replaced */
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, valueTokenPtr, interp, 1);
/*
- * Check for first index known and useful at compile time.
+ * Check for first index known and useful at compile time.
*/
tokenPtr = TokenAfter(valueTokenPtr);
if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
@@ -1017,7 +1014,7 @@ TclCompileStringReplaceCmd(
}
/*
- * Check for last index known and useful at compile time.
+ * Check for last index known and useful at compile time.
*/
tokenPtr = TokenAfter(tokenPtr);
if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
@@ -1025,7 +1022,7 @@ TclCompileStringReplaceCmd(
goto genericReplace;
}
- /*
+ /*
* [string replace] is an odd bird. For many arguments it is
* a conventional substring replacer. However it also goes out
* of its way to become a no-op for many cases where it would be
@@ -1108,12 +1105,12 @@ TclCompileStringReplaceCmd(
* Finally we need, third:
*
* (first <= last)
- *
+ *
* Considered in combination with the constraints we already have,
* we see that we can proceed when (first == TCL_INDEX_BEFORE)
* or (last == TCL_INDEX_AFTER). These also permit simplification
* of the prefix|replace|suffix construction. The other constraints,
- * though, interfere with getting a guarantee that first <= last.
+ * though, interfere with getting a guarantee that first <= last.
*/
if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) {
@@ -1141,7 +1138,7 @@ TclCompileStringReplaceCmd(
/* FLOW THROUGH TO genericReplace */
} else {
- /*
+ /*
* When we have no replacement string to worry about, we may
* have more luck, because the forbidden empty string replacements
* are harmless when they are replaced by another empty string.
@@ -1353,7 +1350,7 @@ static int
UniCharIsHexDigit(
int character)
{
- return (character >= 0) && (character < 0x80) && isxdigit(character);
+ return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character));
}
StringClassDesc const tclStringClassTable[] = {
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 159e2ea..e96e264 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -1759,7 +1759,7 @@ ConvertTreeToTokens(
/*
* All the Tcl_Tokens allocated and filled belong to
- * this subexpresion. The first token is the leading
+ * this subexpression. The first token is the leading
* TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer)
* are its components.
*/
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index a1fc151..3e349b2 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1490,7 +1490,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#endif
#define TclGetInt4AtPtr(p) \
- (((int) TclGetInt1AtPtr(p) << 24) | \
+ (((int) (TclGetUInt1AtPtr(p) << 24)) | \
(*((p)+1) << 16) | \
(*((p)+2) << 8) | \
(*((p)+3)))
diff --git a/generic/tclDate.c b/generic/tclDate.c
index e4dd000..f720325 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -1,14 +1,13 @@
-/* A Bison parser, made by GNU Bison 2.3. */
+/* A Bison parser, made by GNU Bison 3.1. */
-/* Skeleton implementation for Bison's Yacc-like parsers in C
+/* Bison implementation for Yacc-like parsers in C
- Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006
- Free Software Foundation, Inc.
+ Copyright (C) 1984, 1989-1990, 2000-2015, 2018 Free Software Foundation, Inc.
- This program is free software; you can redistribute it and/or modify
+ This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2, or (at your option)
- any later version.
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -16,9 +15,7 @@
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor,
- Boston, MA 02110-1301, USA. */
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
/* As a special exception, you may create a larger work that contains
part or all of the Bison parser skeleton and distribute that work
@@ -47,7 +44,7 @@
#define YYBISON 1
/* Bison version. */
-#define YYBISON_VERSION "2.3"
+#define YYBISON_VERSION "3.1"
/* Skeleton name. */
#define YYSKELETON_NAME "yacc.c"
@@ -55,64 +52,19 @@
/* Pure parsers. */
#define YYPURE 1
-/* Using locations. */
-#define YYLSP_NEEDED 1
+/* Push parsers. */
+#define YYPUSH 0
-/* Substitute the variable and function names. */
-#define yyparse TclDateparse
-#define yylex TclDatelex
-#define yyerror TclDateerror
-#define yylval TclDatelval
-#define yychar TclDatechar
-#define yydebug TclDatedebug
-#define yynerrs TclDatenerrs
-#define yylloc TclDatelloc
-
-/* Tokens. */
-#ifndef YYTOKENTYPE
-# define YYTOKENTYPE
- /* Put the tokens into the symbol table, so that GDB and other debuggers
- know about them. */
- enum yytokentype {
- tAGO = 258,
- tDAY = 259,
- tDAYZONE = 260,
- tID = 261,
- tMERIDIAN = 262,
- tMONTH = 263,
- tMONTH_UNIT = 264,
- tSTARDATE = 265,
- tSEC_UNIT = 266,
- tSNUMBER = 267,
- tUNUMBER = 268,
- tZONE = 269,
- tEPOCH = 270,
- tDST = 271,
- tISOBASE = 272,
- tDAY_UNIT = 273,
- tNEXT = 274
- };
-#endif
-/* Tokens. */
-#define tAGO 258
-#define tDAY 259
-#define tDAYZONE 260
-#define tID 261
-#define tMERIDIAN 262
-#define tMONTH 263
-#define tMONTH_UNIT 264
-#define tSTARDATE 265
-#define tSEC_UNIT 266
-#define tSNUMBER 267
-#define tUNUMBER 268
-#define tZONE 269
-#define tEPOCH 270
-#define tDST 271
-#define tISOBASE 272
-#define tDAY_UNIT 273
-#define tNEXT 274
+/* Pull parsers. */
+#define YYPULL 1
+/* Substitute the variable and function names. */
+#define yyparse TclDateparse
+#define yylex TclDatelex
+#define yyerror TclDateerror
+#define yydebug TclDatedebug
+#define yynerrs TclDatenerrs
/* Copy the first part of user declarations. */
@@ -129,6 +81,7 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
*/
#include "tclInt.h"
@@ -256,10 +209,14 @@ typedef enum _MERIDIAN {
-/* Enabling traces. */
-#ifndef YYDEBUG
-# define YYDEBUG 0
-#endif
+
+# ifndef YY_NULLPTR
+# if defined __cplusplus && 201103L <= __cplusplus
+# define YY_NULLPTR nullptr
+# else
+# define YY_NULLPTR 0
+# endif
+# endif
/* Enabling verbose error messages. */
#ifdef YYERROR_VERBOSE
@@ -269,40 +226,78 @@ typedef enum _MERIDIAN {
# define YYERROR_VERBOSE 0
#endif
-/* Enabling the token table. */
-#ifndef YYTOKEN_TABLE
-# define YYTOKEN_TABLE 0
+
+/* Debug traces. */
+#ifndef YYDEBUG
+# define YYDEBUG 0
+#endif
+#if YYDEBUG
+extern int TclDatedebug;
#endif
+/* Token type. */
+#ifndef YYTOKENTYPE
+# define YYTOKENTYPE
+ enum yytokentype
+ {
+ tAGO = 258,
+ tDAY = 259,
+ tDAYZONE = 260,
+ tID = 261,
+ tMERIDIAN = 262,
+ tMONTH = 263,
+ tMONTH_UNIT = 264,
+ tSTARDATE = 265,
+ tSEC_UNIT = 266,
+ tSNUMBER = 267,
+ tUNUMBER = 268,
+ tZONE = 269,
+ tEPOCH = 270,
+ tDST = 271,
+ tISOBASE = 272,
+ tDAY_UNIT = 273,
+ tNEXT = 274
+ };
+#endif
+
+/* Value type. */
#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
-typedef union YYSTYPE
+union YYSTYPE
{
+
+
time_t Number;
enum _MERIDIAN Meridian;
-}
-/* Line 187 of yacc.c. */
- YYSTYPE;
-# define yystype YYSTYPE /* obsolescent; will be withdrawn */
-# define YYSTYPE_IS_DECLARED 1
+
+};
+
+typedef union YYSTYPE YYSTYPE;
# define YYSTYPE_IS_TRIVIAL 1
+# define YYSTYPE_IS_DECLARED 1
#endif
+/* Location type. */
#if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED
-typedef struct YYLTYPE
+typedef struct YYLTYPE YYLTYPE;
+struct YYLTYPE
{
int first_line;
int first_column;
int last_line;
int last_column;
-} YYLTYPE;
-# define yyltype YYLTYPE /* obsolescent; will be withdrawn */
+};
# define YYLTYPE_IS_DECLARED 1
# define YYLTYPE_IS_TRIVIAL 1
#endif
+
+int TclDateparse (DateInfo* info);
+
+
+
/* Copy the second part of user declarations. */
@@ -322,8 +317,6 @@ MODULE_SCOPE int yyparse(DateInfo*);
-/* Line 216 of yacc.c. */
-
#ifdef short
# undef short
@@ -337,72 +330,103 @@ typedef unsigned char yytype_uint8;
#ifdef YYTYPE_INT8
typedef YYTYPE_INT8 yytype_int8;
-#elif (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
-typedef signed char yytype_int8;
#else
-typedef short int yytype_int8;
+typedef signed char yytype_int8;
#endif
#ifdef YYTYPE_UINT16
typedef YYTYPE_UINT16 yytype_uint16;
#else
-typedef unsigned short int yytype_uint16;
+typedef unsigned short yytype_uint16;
#endif
#ifdef YYTYPE_INT16
typedef YYTYPE_INT16 yytype_int16;
#else
-typedef short int yytype_int16;
+typedef short yytype_int16;
#endif
#ifndef YYSIZE_T
# ifdef __SIZE_TYPE__
# define YYSIZE_T __SIZE_TYPE__
-# else
+# elif defined size_t
# define YYSIZE_T size_t
+# elif ! defined YYSIZE_T
+# include <stddef.h> /* INFRINGES ON USER NAME SPACE */
+# define YYSIZE_T size_t
+# else
+# define YYSIZE_T unsigned
# endif
#endif
#define YYSIZE_MAXIMUM ((YYSIZE_T) -1)
#ifndef YY_
-# if YYENABLE_NLS
+# if defined YYENABLE_NLS && YYENABLE_NLS
# if ENABLE_NLS
# include <libintl.h> /* INFRINGES ON USER NAME SPACE */
-# define YY_(msgid) dgettext ("bison-runtime", msgid)
+# define YY_(Msgid) dgettext ("bison-runtime", Msgid)
# endif
# endif
# ifndef YY_
-# define YY_(msgid) msgid
+# define YY_(Msgid) Msgid
+# endif
+#endif
+
+#ifndef YY_ATTRIBUTE
+# if (defined __GNUC__ \
+ && (2 < __GNUC__ || (__GNUC__ == 2 && 96 <= __GNUC_MINOR__))) \
+ || defined __SUNPRO_C && 0x5110 <= __SUNPRO_C
+# define YY_ATTRIBUTE(Spec) __attribute__(Spec)
+# else
+# define YY_ATTRIBUTE(Spec) /* empty */
+# endif
+#endif
+
+#ifndef YY_ATTRIBUTE_PURE
+# define YY_ATTRIBUTE_PURE YY_ATTRIBUTE ((__pure__))
+#endif
+
+#ifndef YY_ATTRIBUTE_UNUSED
+# define YY_ATTRIBUTE_UNUSED YY_ATTRIBUTE ((__unused__))
+#endif
+
+#if !defined _Noreturn \
+ && (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112)
+# if defined _MSC_VER && 1200 <= _MSC_VER
+# define _Noreturn __declspec (noreturn)
+# else
+# define _Noreturn YY_ATTRIBUTE ((__noreturn__))
# endif
#endif
/* Suppress unused-variable warnings by "using" E. */
#if ! defined lint || defined __GNUC__
-# define YYUSE(e) ((void) (e))
+# define YYUSE(E) ((void) (E))
#else
-# define YYUSE(e) /* empty */
+# define YYUSE(E) /* empty */
#endif
-/* Identity function, used to suppress warnings about constant conditions. */
-#ifndef lint
-# define YYID(n) (n)
-#else
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
-static int
-YYID (int i)
+#if defined __GNUC__ && ! defined __ICC && 407 <= __GNUC__ * 100 + __GNUC_MINOR__
+/* Suppress an incorrect diagnostic about yylval being uninitialized. */
+# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN \
+ _Pragma ("GCC diagnostic push") \
+ _Pragma ("GCC diagnostic ignored \"-Wuninitialized\"")\
+ _Pragma ("GCC diagnostic ignored \"-Wmaybe-uninitialized\"")
+# define YY_IGNORE_MAYBE_UNINITIALIZED_END \
+ _Pragma ("GCC diagnostic pop")
#else
-static int
-YYID (i)
- int i;
+# define YY_INITIAL_VALUE(Value) Value
#endif
-{
- return i;
-}
+#ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
+# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
+# define YY_IGNORE_MAYBE_UNINITIALIZED_END
+#endif
+#ifndef YY_INITIAL_VALUE
+# define YY_INITIAL_VALUE(Value) /* Nothing. */
#endif
+
#if ! defined yyoverflow || YYERROR_VERBOSE
/* The parser invokes alloca or malloc; define the necessary symbols. */
@@ -420,11 +444,11 @@ YYID (i)
# define alloca _alloca
# else
# define YYSTACK_ALLOC alloca
-# if ! defined _ALLOCA_H && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
+# if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS
# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
-# ifndef _STDLIB_H
-# define _STDLIB_H 1
+ /* Use EXIT_SUCCESS as a witness for stdlib.h. */
+# ifndef EXIT_SUCCESS
+# define EXIT_SUCCESS 0
# endif
# endif
# endif
@@ -432,8 +456,8 @@ YYID (i)
# endif
# ifdef YYSTACK_ALLOC
- /* Pacify GCC's `empty if-body' warning. */
-# define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0))
+ /* Pacify GCC's 'empty if-body' warning. */
+# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0)
# ifndef YYSTACK_ALLOC_MAXIMUM
/* The OS might guarantee only one guard page at the bottom of the stack,
and a page size can be as small as 4096 bytes. So we cannot safely
@@ -447,25 +471,23 @@ YYID (i)
# ifndef YYSTACK_ALLOC_MAXIMUM
# define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM
# endif
-# if (defined __cplusplus && ! defined _STDLIB_H \
+# if (defined __cplusplus && ! defined EXIT_SUCCESS \
&& ! ((defined YYMALLOC || defined malloc) \
- && (defined YYFREE || defined free)))
+ && (defined YYFREE || defined free)))
# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
-# ifndef _STDLIB_H
-# define _STDLIB_H 1
+# ifndef EXIT_SUCCESS
+# define EXIT_SUCCESS 0
# endif
# endif
# ifndef YYMALLOC
# define YYMALLOC malloc
-# if ! defined malloc && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
+# if ! defined malloc && ! defined EXIT_SUCCESS
void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */
# endif
# endif
# ifndef YYFREE
# define YYFREE free
-# if ! defined free && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
+# if ! defined free && ! defined EXIT_SUCCESS
void free (void *); /* INFRINGES ON USER NAME SPACE */
# endif
# endif
@@ -475,15 +497,15 @@ void free (void *); /* INFRINGES ON USER NAME SPACE */
#if (! defined yyoverflow \
&& (! defined __cplusplus \
- || (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \
- && defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL)))
+ || (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \
+ && defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL)))
/* A type that is properly aligned for any stack member. */
union yyalloc
{
- yytype_int16 yyss;
- YYSTYPE yyvs;
- YYLTYPE yyls;
+ yytype_int16 yyss_alloc;
+ YYSTYPE yyvs_alloc;
+ YYLTYPE yyls_alloc;
};
/* The size of the maximum gap between one aligned stack and the next. */
@@ -495,42 +517,46 @@ union yyalloc
((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE) + sizeof (YYLTYPE)) \
+ 2 * YYSTACK_GAP_MAXIMUM)
-/* Copy COUNT objects from FROM to TO. The source and destination do
- not overlap. */
-# ifndef YYCOPY
-# if defined __GNUC__ && 1 < __GNUC__
-# define YYCOPY(To, From, Count) \
- __builtin_memcpy (To, From, (Count) * sizeof (*(From)))
-# else
-# define YYCOPY(To, From, Count) \
- do \
- { \
- YYSIZE_T yyi; \
- for (yyi = 0; yyi < (Count); yyi++) \
- (To)[yyi] = (From)[yyi]; \
- } \
- while (YYID (0))
-# endif
-# endif
+# define YYCOPY_NEEDED 1
/* Relocate STACK from its old location to the new one. The
local variables YYSIZE and YYSTACKSIZE give the old and new number of
elements in the stack, and YYPTR gives the new location of the
stack. Advance YYPTR to a properly aligned location for the next
stack. */
-# define YYSTACK_RELOCATE(Stack) \
- do \
- { \
- YYSIZE_T yynewbytes; \
- YYCOPY (&yyptr->Stack, Stack, yysize); \
- Stack = &yyptr->Stack; \
- yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \
- yyptr += yynewbytes / sizeof (*yyptr); \
- } \
- while (YYID (0))
+# define YYSTACK_RELOCATE(Stack_alloc, Stack) \
+ do \
+ { \
+ YYSIZE_T yynewbytes; \
+ YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \
+ Stack = &yyptr->Stack_alloc; \
+ yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \
+ yyptr += yynewbytes / sizeof (*yyptr); \
+ } \
+ while (0)
#endif
+#if defined YYCOPY_NEEDED && YYCOPY_NEEDED
+/* Copy COUNT objects from SRC to DST. The source and destination do
+ not overlap. */
+# ifndef YYCOPY
+# if defined __GNUC__ && 1 < __GNUC__
+# define YYCOPY(Dst, Src, Count) \
+ __builtin_memcpy (Dst, Src, (Count) * sizeof (*(Src)))
+# else
+# define YYCOPY(Dst, Src, Count) \
+ do \
+ { \
+ YYSIZE_T yyi; \
+ for (yyi = 0; yyi < (Count); yyi++) \
+ (Dst)[yyi] = (Src)[yyi]; \
+ } \
+ while (0)
+# endif
+# endif
+#endif /* !YYCOPY_NEEDED */
+
/* YYFINAL -- State number of the termination state. */
#define YYFINAL 2
/* YYLAST -- Last index in YYTABLE. */
@@ -542,17 +568,19 @@ union yyalloc
#define YYNNTS 16
/* YYNRULES -- Number of rules. */
#define YYNRULES 56
-/* YYNRULES -- Number of states. */
+/* YYNSTATES -- Number of states. */
#define YYNSTATES 83
-/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */
+/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned
+ by yylex, with out-of-bounds checking. */
#define YYUNDEFTOK 2
#define YYMAXUTOK 274
-#define YYTRANSLATE(YYX) \
- ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
+#define YYTRANSLATE(YYX) \
+ ((unsigned) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
-/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */
+/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM
+ as returned by yylex, without out-of-bounds checking. */
static const yytype_uint8 yytranslate[] =
{
0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
@@ -586,54 +614,19 @@ static const yytype_uint8 yytranslate[] =
};
#if YYDEBUG
-/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in
- YYRHS. */
-static const yytype_uint8 yyprhs[] =
-{
- 0, 0, 3, 4, 7, 9, 11, 13, 15, 17,
- 19, 21, 23, 25, 28, 33, 39, 46, 54, 57,
- 59, 61, 63, 66, 69, 73, 76, 80, 86, 88,
- 94, 100, 103, 108, 111, 113, 117, 120, 124, 128,
- 136, 139, 144, 147, 149, 153, 156, 159, 163, 165,
- 167, 169, 171, 173, 175, 177, 178
-};
-
-/* YYRHS -- A `-1'-separated list of the rules' RHS. */
-static const yytype_int8 yyrhs[] =
-{
- 27, 0, -1, -1, 27, 28, -1, 29, -1, 30,
- -1, 32, -1, 33, -1, 31, -1, 36, -1, 34,
- -1, 35, -1, 40, -1, 13, 7, -1, 13, 20,
- 13, 41, -1, 13, 20, 13, 21, 13, -1, 13,
- 20, 13, 20, 13, 41, -1, 13, 20, 13, 20,
- 13, 21, 13, -1, 14, 16, -1, 14, -1, 5,
- -1, 4, -1, 4, 22, -1, 13, 4, -1, 38,
- 13, 4, -1, 19, 4, -1, 13, 23, 13, -1,
- 13, 23, 13, 23, 13, -1, 17, -1, 13, 21,
- 8, 21, 13, -1, 13, 21, 13, 21, 13, -1,
- 8, 13, -1, 8, 13, 22, 13, -1, 13, 8,
- -1, 15, -1, 13, 8, 13, -1, 19, 8, -1,
- 19, 13, 8, -1, 17, 14, 17, -1, 17, 14,
- 13, 20, 13, 20, 13, -1, 17, 17, -1, 10,
- 13, 24, 13, -1, 37, 3, -1, 37, -1, 38,
- 13, 39, -1, 13, 39, -1, 19, 39, -1, 19,
- 13, 39, -1, 39, -1, 21, -1, 25, -1, 11,
- -1, 18, -1, 9, -1, 13, -1, -1, 7, -1
-};
-
-/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
+ /* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
- 0, 225, 225, 226, 229, 232, 235, 238, 241, 244,
- 247, 251, 256, 259, 265, 271, 279, 285, 296, 300,
- 304, 310, 314, 318, 322, 326, 332, 336, 341, 346,
- 351, 356, 360, 365, 369, 374, 381, 385, 391, 400,
- 409, 419, 433, 438, 441, 444, 447, 450, 453, 458,
- 461, 466, 470, 474, 480, 498, 501
+ 0, 223, 223, 224, 227, 230, 233, 236, 239, 242,
+ 245, 249, 254, 257, 263, 269, 277, 283, 294, 298,
+ 302, 308, 312, 316, 320, 324, 330, 334, 339, 344,
+ 349, 354, 358, 363, 367, 372, 379, 383, 389, 398,
+ 407, 417, 431, 436, 439, 442, 445, 448, 451, 456,
+ 459, 464, 468, 472, 478, 496, 499
};
#endif
-#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE
+#if YYDEBUG || YYERROR_VERBOSE || 0
/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
@@ -644,13 +637,13 @@ static const char *const yytname[] =
"tDAY_UNIT", "tNEXT", "':'", "'-'", "','", "'/'", "'.'", "'+'",
"$accept", "spec", "item", "time", "zone", "day", "date", "ordMonth",
"iso", "trek", "relspec", "relunits", "sign", "unit", "number",
- "o_merid", 0
+ "o_merid", YY_NULLPTR
};
#endif
# ifdef YYPRINT
-/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to
- token YYLEX-NUM. */
+/* YYTOKNUM[NUM] -- (External) token number corresponding to the
+ (internal) symbol number NUM (which must be that of a token). */
static const yytype_uint16 yytoknum[] =
{
0, 256, 257, 258, 259, 260, 261, 262, 263, 264,
@@ -659,54 +652,18 @@ static const yytype_uint16 yytoknum[] =
};
# endif
-/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
-static const yytype_uint8 yyr1[] =
-{
- 0, 26, 27, 27, 28, 28, 28, 28, 28, 28,
- 28, 28, 28, 29, 29, 29, 29, 29, 30, 30,
- 30, 31, 31, 31, 31, 31, 32, 32, 32, 32,
- 32, 32, 32, 32, 32, 32, 33, 33, 34, 34,
- 34, 35, 36, 36, 37, 37, 37, 37, 37, 38,
- 38, 39, 39, 39, 40, 41, 41
-};
+#define YYPACT_NINF -22
-/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */
-static const yytype_uint8 yyr2[] =
-{
- 0, 2, 0, 2, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 2, 4, 5, 6, 7, 2, 1,
- 1, 1, 2, 2, 3, 2, 3, 5, 1, 5,
- 5, 2, 4, 2, 1, 3, 2, 3, 3, 7,
- 2, 4, 2, 1, 3, 2, 2, 3, 1, 1,
- 1, 1, 1, 1, 1, 0, 1
-};
+#define yypact_value_is_default(Yystate) \
+ (!!((Yystate) == (-22)))
-/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state
- STATE-NUM when YYTABLE doesn't specify something else to do. Zero
- means the default is an error. */
-static const yytype_uint8 yydefact[] =
-{
- 2, 0, 1, 21, 20, 0, 53, 0, 51, 54,
- 19, 34, 28, 52, 0, 49, 50, 3, 4, 5,
- 8, 6, 7, 10, 11, 9, 43, 0, 48, 12,
- 22, 31, 0, 23, 13, 33, 0, 0, 0, 45,
- 18, 0, 40, 25, 36, 0, 46, 42, 0, 0,
- 0, 35, 55, 0, 0, 26, 0, 38, 37, 47,
- 24, 44, 32, 41, 56, 0, 0, 14, 0, 0,
- 0, 0, 55, 15, 29, 30, 27, 0, 0, 16,
- 0, 17, 39
-};
+#define YYTABLE_NINF -1
-/* YYDEFGOTO[NTERM-NUM]. */
-static const yytype_int8 yydefgoto[] =
-{
- -1, 1, 17, 18, 19, 20, 21, 22, 23, 24,
- 25, 26, 27, 28, 29, 67
-};
+#define yytable_value_is_error(Yytable_value) \
+ 0
-/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
- STATE-NUM. */
-#define YYPACT_NINF -22
+ /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
+ STATE-NUM. */
static const yytype_int8 yypact[] =
{
-22, 2, -22, -21, -22, -4, -22, 1, -22, 22,
@@ -720,18 +677,39 @@ static const yytype_int8 yypact[] =
64, -22, -22
};
-/* YYPGOTO[NTERM-NUM]. */
+ /* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM.
+ Performed when YYTABLE does not specify something else to do. Zero
+ means the default is an error. */
+static const yytype_uint8 yydefact[] =
+{
+ 2, 0, 1, 21, 20, 0, 53, 0, 51, 54,
+ 19, 34, 28, 52, 0, 49, 50, 3, 4, 5,
+ 8, 6, 7, 10, 11, 9, 43, 0, 48, 12,
+ 22, 31, 0, 23, 13, 33, 0, 0, 0, 45,
+ 18, 0, 40, 25, 36, 0, 46, 42, 0, 0,
+ 0, 35, 55, 0, 0, 26, 0, 38, 37, 47,
+ 24, 44, 32, 41, 56, 0, 0, 14, 0, 0,
+ 0, 0, 55, 15, 29, 30, 27, 0, 0, 16,
+ 0, 17, 39
+};
+
+ /* YYPGOTO[NTERM-NUM]. */
static const yytype_int8 yypgoto[] =
{
-22, -22, -22, -22, -22, -22, -22, -22, -22, -22,
-22, -22, -22, -9, -22, 6
};
-/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If
- positive, shift that token. If negative, reduce the rule which
- number is the opposite. If zero, do what YYDEFACT says.
- If YYTABLE_NINF, syntax error. */
-#define YYTABLE_NINF -1
+ /* YYDEFGOTO[NTERM-NUM]. */
+static const yytype_int8 yydefgoto[] =
+{
+ -1, 1, 17, 18, 19, 20, 21, 22, 23, 24,
+ 25, 26, 27, 28, 29, 67
+};
+
+ /* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If
+ positive, shift that token. If negative, reduce the rule whose
+ number is the opposite. If YYTABLE_NINF, syntax error. */
static const yytype_uint8 yytable[] =
{
39, 30, 2, 53, 64, 46, 3, 4, 54, 31,
@@ -756,8 +734,8 @@ static const yytype_uint8 yycheck[] =
13, 13, 20, 13, 13, 13, 13, 13, 72, 20
};
-/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
- symbol of state STATE-NUM. */
+ /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
+ symbol of state STATE-NUM. */
static const yytype_uint8 yystos[] =
{
0, 27, 0, 4, 5, 8, 9, 10, 11, 13,
@@ -771,156 +749,179 @@ static const yytype_uint8 yystos[] =
20, 13, 13
};
-#define yyerrok (yyerrstatus = 0)
-#define yyclearin (yychar = YYEMPTY)
-#define YYEMPTY (-2)
-#define YYEOF 0
+ /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
+static const yytype_uint8 yyr1[] =
+{
+ 0, 26, 27, 27, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 29, 29, 29, 29, 29, 30, 30,
+ 30, 31, 31, 31, 31, 31, 32, 32, 32, 32,
+ 32, 32, 32, 32, 32, 32, 33, 33, 34, 34,
+ 34, 35, 36, 36, 37, 37, 37, 37, 37, 38,
+ 38, 39, 39, 39, 40, 41, 41
+};
+
+ /* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */
+static const yytype_uint8 yyr2[] =
+{
+ 0, 2, 0, 2, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 2, 4, 5, 6, 7, 2, 1,
+ 1, 1, 2, 2, 3, 2, 3, 5, 1, 5,
+ 5, 2, 4, 2, 1, 3, 2, 3, 3, 7,
+ 2, 4, 2, 1, 3, 2, 2, 3, 1, 1,
+ 1, 1, 1, 1, 1, 0, 1
+};
-#define YYACCEPT goto yyacceptlab
-#define YYABORT goto yyabortlab
-#define YYERROR goto yyerrorlab
+#define yyerrok (yyerrstatus = 0)
+#define yyclearin (yychar = YYEMPTY)
+#define YYEMPTY (-2)
+#define YYEOF 0
-/* Like YYERROR except do call yyerror. This remains here temporarily
- to ease the transition to the new meaning of YYERROR, for GCC.
- Once GCC version 2 has supplanted version 1, this can go. */
+#define YYACCEPT goto yyacceptlab
+#define YYABORT goto yyabortlab
+#define YYERROR goto yyerrorlab
-#define YYFAIL goto yyerrlab
#define YYRECOVERING() (!!yyerrstatus)
-#define YYBACKUP(Token, Value) \
-do \
- if (yychar == YYEMPTY && yylen == 1) \
- { \
- yychar = (Token); \
- yylval = (Value); \
- yytoken = YYTRANSLATE (yychar); \
- YYPOPSTACK (1); \
- goto yybackup; \
- } \
- else \
- { \
+#define YYBACKUP(Token, Value) \
+do \
+ if (yychar == YYEMPTY) \
+ { \
+ yychar = (Token); \
+ yylval = (Value); \
+ YYPOPSTACK (yylen); \
+ yystate = *yyssp; \
+ goto yybackup; \
+ } \
+ else \
+ { \
yyerror (&yylloc, info, YY_("syntax error: cannot back up")); \
- YYERROR; \
- } \
-while (YYID (0))
+ YYERROR; \
+ } \
+while (0)
-
-#define YYTERROR 1
-#define YYERRCODE 256
+/* Error token number */
+#define YYTERROR 1
+#define YYERRCODE 256
/* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N].
If N is 0, then set CURRENT to the empty location which ends
the previous symbol: RHS[0] (always defined). */
-#define YYRHSLOC(Rhs, K) ((Rhs)[K])
#ifndef YYLLOC_DEFAULT
-# define YYLLOC_DEFAULT(Current, Rhs, N) \
- do \
- if (YYID (N)) \
- { \
- (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
- (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
- (Current).last_line = YYRHSLOC (Rhs, N).last_line; \
- (Current).last_column = YYRHSLOC (Rhs, N).last_column; \
- } \
- else \
- { \
- (Current).first_line = (Current).last_line = \
- YYRHSLOC (Rhs, 0).last_line; \
- (Current).first_column = (Current).last_column = \
- YYRHSLOC (Rhs, 0).last_column; \
- } \
- while (YYID (0))
+# define YYLLOC_DEFAULT(Current, Rhs, N) \
+ do \
+ if (N) \
+ { \
+ (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
+ (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
+ (Current).last_line = YYRHSLOC (Rhs, N).last_line; \
+ (Current).last_column = YYRHSLOC (Rhs, N).last_column; \
+ } \
+ else \
+ { \
+ (Current).first_line = (Current).last_line = \
+ YYRHSLOC (Rhs, 0).last_line; \
+ (Current).first_column = (Current).last_column = \
+ YYRHSLOC (Rhs, 0).last_column; \
+ } \
+ while (0)
#endif
+#define YYRHSLOC(Rhs, K) ((Rhs)[K])
+
+
+/* Enable debugging if requested. */
+#if YYDEBUG
+
+# ifndef YYFPRINTF
+# include <stdio.h> /* INFRINGES ON USER NAME SPACE */
+# define YYFPRINTF fprintf
+# endif
+
+# define YYDPRINTF(Args) \
+do { \
+ if (yydebug) \
+ YYFPRINTF Args; \
+} while (0)
+
/* YY_LOCATION_PRINT -- Print the location on the stream.
This macro was not mandated originally: define only if we know
we won't break user code: when these are the locations we know. */
#ifndef YY_LOCATION_PRINT
-# if YYLTYPE_IS_TRIVIAL
-# define YY_LOCATION_PRINT(File, Loc) \
- fprintf (File, "%d.%d-%d.%d", \
- (Loc).first_line, (Loc).first_column, \
- (Loc).last_line, (Loc).last_column)
-# else
-# define YY_LOCATION_PRINT(File, Loc) ((void) 0)
-# endif
-#endif
-
+# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL
-/* YYLEX -- calling `yylex' with the right arguments. */
+/* Print *YYLOCP on YYO. Private, do not rely on its existence. */
-#ifdef YYLEX_PARAM
-# define YYLEX yylex (&yylval, &yylloc, YYLEX_PARAM)
-#else
-# define YYLEX yylex (&yylval, &yylloc, info)
-#endif
+YY_ATTRIBUTE_UNUSED
+static unsigned
+yy_location_print_ (FILE *yyo, YYLTYPE const * const yylocp)
+{
+ unsigned res = 0;
+ int end_col = 0 != yylocp->last_column ? yylocp->last_column - 1 : 0;
+ if (0 <= yylocp->first_line)
+ {
+ res += YYFPRINTF (yyo, "%d", yylocp->first_line);
+ if (0 <= yylocp->first_column)
+ res += YYFPRINTF (yyo, ".%d", yylocp->first_column);
+ }
+ if (0 <= yylocp->last_line)
+ {
+ if (yylocp->first_line < yylocp->last_line)
+ {
+ res += YYFPRINTF (yyo, "-%d", yylocp->last_line);
+ if (0 <= end_col)
+ res += YYFPRINTF (yyo, ".%d", end_col);
+ }
+ else if (0 <= end_col && yylocp->first_column < end_col)
+ res += YYFPRINTF (yyo, "-%d", end_col);
+ }
+ return res;
+ }
-/* Enable debugging if requested. */
-#if YYDEBUG
+# define YY_LOCATION_PRINT(File, Loc) \
+ yy_location_print_ (File, &(Loc))
-# ifndef YYFPRINTF
-# include <stdio.h> /* INFRINGES ON USER NAME SPACE */
-# define YYFPRINTF fprintf
+# else
+# define YY_LOCATION_PRINT(File, Loc) ((void) 0)
# endif
+#endif
-# define YYDPRINTF(Args) \
-do { \
- if (yydebug) \
- YYFPRINTF Args; \
-} while (YYID (0))
-# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \
-do { \
- if (yydebug) \
- { \
- YYFPRINTF (stderr, "%s ", Title); \
- yy_symbol_print (stderr, \
- Type, Value, Location, info); \
- YYFPRINTF (stderr, "\n"); \
- } \
-} while (YYID (0))
+# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \
+do { \
+ if (yydebug) \
+ { \
+ YYFPRINTF (stderr, "%s ", Title); \
+ yy_symbol_print (stderr, \
+ Type, Value, Location, info); \
+ YYFPRINTF (stderr, "\n"); \
+ } \
+} while (0)
-/*--------------------------------.
-| Print this symbol on YYOUTPUT. |
-`--------------------------------*/
+/*----------------------------------------.
+| Print this symbol's value on YYOUTPUT. |
+`----------------------------------------*/
-/*ARGSUSED*/
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
static void
yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info)
-#else
-static void
-yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info)
- FILE *yyoutput;
- int yytype;
- YYSTYPE const * const yyvaluep;
- YYLTYPE const * const yylocationp;
- DateInfo* info;
-#endif
{
- if (!yyvaluep)
- return;
+ FILE *yyo = yyoutput;
+ YYUSE (yyo);
YYUSE (yylocationp);
YYUSE (info);
+ if (!yyvaluep)
+ return;
# ifdef YYPRINT
if (yytype < YYNTOKENS)
YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
-# else
- YYUSE (yyoutput);
# endif
- switch (yytype)
- {
- default:
- break;
- }
+ YYUSE (yytype);
}
@@ -928,24 +929,11 @@ yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info)
| Print this symbol on YYOUTPUT. |
`--------------------------------*/
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
static void
yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info)
-#else
-static void
-yy_symbol_print (yyoutput, yytype, yyvaluep, yylocationp, info)
- FILE *yyoutput;
- int yytype;
- YYSTYPE const * const yyvaluep;
- YYLTYPE const * const yylocationp;
- DateInfo* info;
-#endif
{
- if (yytype < YYNTOKENS)
- YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
- else
- YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
+ YYFPRINTF (yyoutput, "%s %s (",
+ yytype < YYNTOKENS ? "token" : "nterm", yytname[yytype]);
YY_LOCATION_PRINT (yyoutput, *yylocationp);
YYFPRINTF (yyoutput, ": ");
@@ -958,68 +946,54 @@ yy_symbol_print (yyoutput, yytype, yyvaluep, yylocationp, info)
| TOP (included). |
`------------------------------------------------------------------*/
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
-static void
-yy_stack_print (yytype_int16 *bottom, yytype_int16 *top)
-#else
static void
-yy_stack_print (bottom, top)
- yytype_int16 *bottom;
- yytype_int16 *top;
-#endif
+yy_stack_print (yytype_int16 *yybottom, yytype_int16 *yytop)
{
YYFPRINTF (stderr, "Stack now");
- for (; bottom <= top; ++bottom)
- YYFPRINTF (stderr, " %d", *bottom);
+ for (; yybottom <= yytop; yybottom++)
+ {
+ int yybot = *yybottom;
+ YYFPRINTF (stderr, " %d", yybot);
+ }
YYFPRINTF (stderr, "\n");
}
-# define YY_STACK_PRINT(Bottom, Top) \
-do { \
- if (yydebug) \
- yy_stack_print ((Bottom), (Top)); \
-} while (YYID (0))
+# define YY_STACK_PRINT(Bottom, Top) \
+do { \
+ if (yydebug) \
+ yy_stack_print ((Bottom), (Top)); \
+} while (0)
/*------------------------------------------------.
| Report that the YYRULE is going to be reduced. |
`------------------------------------------------*/
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
static void
-yy_reduce_print (YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule, DateInfo* info)
-#else
-static void
-yy_reduce_print (yyvsp, yylsp, yyrule, info)
- YYSTYPE *yyvsp;
- YYLTYPE *yylsp;
- int yyrule;
- DateInfo* info;
-#endif
+yy_reduce_print (yytype_int16 *yyssp, YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule, DateInfo* info)
{
+ unsigned long yylno = yyrline[yyrule];
int yynrhs = yyr2[yyrule];
int yyi;
- unsigned long int yylno = yyrline[yyrule];
YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n",
- yyrule - 1, yylno);
+ yyrule - 1, yylno);
/* The symbols being reduced. */
for (yyi = 0; yyi < yynrhs; yyi++)
{
- fprintf (stderr, " $%d = ", yyi + 1);
- yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi],
- &(yyvsp[(yyi + 1) - (yynrhs)])
- , &(yylsp[(yyi + 1) - (yynrhs)]) , info);
- fprintf (stderr, "\n");
+ YYFPRINTF (stderr, " $%d = ", yyi + 1);
+ yy_symbol_print (stderr,
+ yystos[yyssp[yyi + 1 - yynrhs]],
+ &(yyvsp[(yyi + 1) - (yynrhs)])
+ , &(yylsp[(yyi + 1) - (yynrhs)]) , info);
+ YYFPRINTF (stderr, "\n");
}
}
-# define YY_REDUCE_PRINT(Rule) \
-do { \
- if (yydebug) \
- yy_reduce_print (yyvsp, yylsp, Rule, info); \
-} while (YYID (0))
+# define YY_REDUCE_PRINT(Rule) \
+do { \
+ if (yydebug) \
+ yy_reduce_print (yyssp, yyvsp, yylsp, Rule, info); \
+} while (0)
/* Nonzero means print parse trace. It is left uninitialized so that
multiple parsers can coexist. */
@@ -1033,7 +1007,7 @@ int yydebug;
/* YYINITDEPTH -- initial size of the parser's stacks. */
-#ifndef YYINITDEPTH
+#ifndef YYINITDEPTH
# define YYINITDEPTH 200
#endif
@@ -1048,7 +1022,6 @@ int yydebug;
# define YYMAXDEPTH 10000
#endif
-
#if YYERROR_VERBOSE
@@ -1057,15 +1030,8 @@ int yydebug;
# define yystrlen strlen
# else
/* Return the length of YYSTR. */
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
static YYSIZE_T
yystrlen (const char *yystr)
-#else
-static YYSIZE_T
-yystrlen (yystr)
- const char *yystr;
-#endif
{
YYSIZE_T yylen;
for (yylen = 0; yystr[yylen]; yylen++)
@@ -1081,16 +1047,8 @@ yystrlen (yystr)
# else
/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in
YYDEST. */
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
static char *
yystpcpy (char *yydest, const char *yysrc)
-#else
-static char *
-yystpcpy (yydest, yysrc)
- char *yydest;
- const char *yysrc;
-#endif
{
char *yyd = yydest;
const char *yys = yysrc;
@@ -1120,27 +1078,27 @@ yytnamerr (char *yyres, const char *yystr)
char const *yyp = yystr;
for (;;)
- switch (*++yyp)
- {
- case '\'':
- case ',':
- goto do_not_strip_quotes;
-
- case '\\':
- if (*++yyp != '\\')
- goto do_not_strip_quotes;
- /* Fall through. */
- default:
- if (yyres)
- yyres[yyn] = *yyp;
- yyn++;
- break;
-
- case '"':
- if (yyres)
- yyres[yyn] = '\0';
- return yyn;
- }
+ switch (*++yyp)
+ {
+ case '\'':
+ case ',':
+ goto do_not_strip_quotes;
+
+ case '\\':
+ if (*++yyp != '\\')
+ goto do_not_strip_quotes;
+ /* Fall through. */
+ default:
+ if (yyres)
+ yyres[yyn] = *yyp;
+ yyn++;
+ break;
+
+ case '"':
+ if (yyres)
+ yyres[yyn] = '\0';
+ return yyn;
+ }
do_not_strip_quotes: ;
}
@@ -1151,169 +1109,161 @@ yytnamerr (char *yyres, const char *yystr)
}
# endif
-/* Copy into YYRESULT an error message about the unexpected token
- YYCHAR while in state YYSTATE. Return the number of bytes copied,
- including the terminating null byte. If YYRESULT is null, do not
- copy anything; just return the number of bytes that would be
- copied. As a special case, return 0 if an ordinary "syntax error"
- message will do. Return YYSIZE_MAXIMUM if overflow occurs during
- size calculation. */
-static YYSIZE_T
-yysyntax_error (char *yyresult, int yystate, int yychar)
+/* Copy into *YYMSG, which is of size *YYMSG_ALLOC, an error message
+ about the unexpected token YYTOKEN for the state stack whose top is
+ YYSSP.
+
+ Return 0 if *YYMSG was successfully written. Return 1 if *YYMSG is
+ not large enough to hold the message. In that case, also set
+ *YYMSG_ALLOC to the required number of bytes. Return 2 if the
+ required number of bytes is too large to store. */
+static int
+yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg,
+ yytype_int16 *yyssp, int yytoken)
{
- int yyn = yypact[yystate];
+ YYSIZE_T yysize0 = yytnamerr (YY_NULLPTR, yytname[yytoken]);
+ YYSIZE_T yysize = yysize0;
+ enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 };
+ /* Internationalized format string. */
+ const char *yyformat = YY_NULLPTR;
+ /* Arguments of yyformat. */
+ char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM];
+ /* Number of reported tokens (one for the "unexpected", one per
+ "expected"). */
+ int yycount = 0;
+
+ /* There are many possibilities here to consider:
+ - If this state is a consistent state with a default action, then
+ the only way this function was invoked is if the default action
+ is an error action. In that case, don't check for expected
+ tokens because there are none.
+ - The only way there can be no lookahead present (in yychar) is if
+ this state is a consistent state with a default action. Thus,
+ detecting the absence of a lookahead is sufficient to determine
+ that there is no unexpected or expected token to report. In that
+ case, just report a simple "syntax error".
+ - Don't assume there isn't a lookahead just because this state is a
+ consistent state with a default action. There might have been a
+ previous inconsistent state, consistent state with a non-default
+ action, or user semantic action that manipulated yychar.
+ - Of course, the expected token list depends on states to have
+ correct lookahead information, and it depends on the parser not
+ to perform extra reductions after fetching a lookahead from the
+ scanner and before detecting a syntax error. Thus, state merging
+ (from LALR or IELR) and default reductions corrupt the expected
+ token list. However, the list is correct for canonical LR with
+ one exception: it will still contain any token that will not be
+ accepted due to an error action in a later state.
+ */
+ if (yytoken != YYEMPTY)
+ {
+ int yyn = yypact[*yyssp];
+ yyarg[yycount++] = yytname[yytoken];
+ if (!yypact_value_is_default (yyn))
+ {
+ /* Start YYX at -YYN if negative to avoid negative indexes in
+ YYCHECK. In other words, skip the first -YYN actions for
+ this state because they are default actions. */
+ int yyxbegin = yyn < 0 ? -yyn : 0;
+ /* Stay within bounds of both yycheck and yytname. */
+ int yychecklim = YYLAST - yyn + 1;
+ int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS;
+ int yyx;
+
+ for (yyx = yyxbegin; yyx < yyxend; ++yyx)
+ if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR
+ && !yytable_value_is_error (yytable[yyx + yyn]))
+ {
+ if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM)
+ {
+ yycount = 1;
+ yysize = yysize0;
+ break;
+ }
+ yyarg[yycount++] = yytname[yyx];
+ {
+ YYSIZE_T yysize1 = yysize + yytnamerr (YY_NULLPTR, yytname[yyx]);
+ if (! (yysize <= yysize1
+ && yysize1 <= YYSTACK_ALLOC_MAXIMUM))
+ return 2;
+ yysize = yysize1;
+ }
+ }
+ }
+ }
- if (! (YYPACT_NINF < yyn && yyn <= YYLAST))
- return 0;
- else
+ switch (yycount)
+ {
+# define YYCASE_(N, S) \
+ case N: \
+ yyformat = S; \
+ break
+ default: /* Avoid compiler warnings. */
+ YYCASE_(0, YY_("syntax error"));
+ YYCASE_(1, YY_("syntax error, unexpected %s"));
+ YYCASE_(2, YY_("syntax error, unexpected %s, expecting %s"));
+ YYCASE_(3, YY_("syntax error, unexpected %s, expecting %s or %s"));
+ YYCASE_(4, YY_("syntax error, unexpected %s, expecting %s or %s or %s"));
+ YYCASE_(5, YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"));
+# undef YYCASE_
+ }
+
+ {
+ YYSIZE_T yysize1 = yysize + yystrlen (yyformat);
+ if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM))
+ return 2;
+ yysize = yysize1;
+ }
+
+ if (*yymsg_alloc < yysize)
{
- int yytype = YYTRANSLATE (yychar);
- YYSIZE_T yysize0 = yytnamerr (0, yytname[yytype]);
- YYSIZE_T yysize = yysize0;
- YYSIZE_T yysize1;
- int yysize_overflow = 0;
- enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 };
- char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM];
- int yyx;
-
-# if 0
- /* This is so xgettext sees the translatable formats that are
- constructed on the fly. */
- YY_("syntax error, unexpected %s");
- YY_("syntax error, unexpected %s, expecting %s");
- YY_("syntax error, unexpected %s, expecting %s or %s");
- YY_("syntax error, unexpected %s, expecting %s or %s or %s");
- YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s");
-# endif
- char *yyfmt;
- char const *yyf;
- static char const yyunexpected[] = "syntax error, unexpected %s";
- static char const yyexpecting[] = ", expecting %s";
- static char const yyor[] = " or %s";
- char yyformat[sizeof yyunexpected
- + sizeof yyexpecting - 1
- + ((YYERROR_VERBOSE_ARGS_MAXIMUM - 2)
- * (sizeof yyor - 1))];
- char const *yyprefix = yyexpecting;
-
- /* Start YYX at -YYN if negative to avoid negative indexes in
- YYCHECK. */
- int yyxbegin = yyn < 0 ? -yyn : 0;
-
- /* Stay within bounds of both yycheck and yytname. */
- int yychecklim = YYLAST - yyn + 1;
- int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS;
- int yycount = 1;
-
- yyarg[0] = yytname[yytype];
- yyfmt = yystpcpy (yyformat, yyunexpected);
-
- for (yyx = yyxbegin; yyx < yyxend; ++yyx)
- if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR)
- {
- if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM)
- {
- yycount = 1;
- yysize = yysize0;
- yyformat[sizeof yyunexpected - 1] = '\0';
- break;
- }
- yyarg[yycount++] = yytname[yyx];
- yysize1 = yysize + yytnamerr (0, yytname[yyx]);
- yysize_overflow |= (yysize1 < yysize);
- yysize = yysize1;
- yyfmt = yystpcpy (yyfmt, yyprefix);
- yyprefix = yyor;
- }
-
- yyf = YY_(yyformat);
- yysize1 = yysize + yystrlen (yyf);
- yysize_overflow |= (yysize1 < yysize);
- yysize = yysize1;
-
- if (yysize_overflow)
- return YYSIZE_MAXIMUM;
-
- if (yyresult)
- {
- /* Avoid sprintf, as that infringes on the user's name space.
- Don't have undefined behavior even if the translation
- produced a string with the wrong number of "%s"s. */
- char *yyp = yyresult;
- int yyi = 0;
- while ((*yyp = *yyf) != '\0')
- {
- if (*yyp == '%' && yyf[1] == 's' && yyi < yycount)
- {
- yyp += yytnamerr (yyp, yyarg[yyi++]);
- yyf += 2;
- }
- else
- {
- yyp++;
- yyf++;
- }
- }
- }
- return yysize;
+ *yymsg_alloc = 2 * yysize;
+ if (! (yysize <= *yymsg_alloc
+ && *yymsg_alloc <= YYSTACK_ALLOC_MAXIMUM))
+ *yymsg_alloc = YYSTACK_ALLOC_MAXIMUM;
+ return 1;
}
+
+ /* Avoid sprintf, as that infringes on the user's name space.
+ Don't have undefined behavior even if the translation
+ produced a string with the wrong number of "%s"s. */
+ {
+ char *yyp = *yymsg;
+ int yyi = 0;
+ while ((*yyp = *yyformat) != '\0')
+ if (*yyp == '%' && yyformat[1] == 's' && yyi < yycount)
+ {
+ yyp += yytnamerr (yyp, yyarg[yyi++]);
+ yyformat += 2;
+ }
+ else
+ {
+ yyp++;
+ yyformat++;
+ }
+ }
+ return 0;
}
#endif /* YYERROR_VERBOSE */
-
/*-----------------------------------------------.
| Release the memory associated to this symbol. |
`-----------------------------------------------*/
-/*ARGSUSED*/
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
static void
yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep, YYLTYPE *yylocationp, DateInfo* info)
-#else
-static void
-yydestruct (yymsg, yytype, yyvaluep, yylocationp, info)
- const char *yymsg;
- int yytype;
- YYSTYPE *yyvaluep;
- YYLTYPE *yylocationp;
- DateInfo* info;
-#endif
{
YYUSE (yyvaluep);
YYUSE (yylocationp);
YYUSE (info);
-
if (!yymsg)
yymsg = "Deleting";
YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp);
- switch (yytype)
- {
-
- default:
- break;
- }
+ YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
+ YYUSE (yytype);
+ YY_IGNORE_MAYBE_UNINITIALIZED_END
}
-
-
-/* Prevent warnings from -Wmissing-prototypes. */
-
-#ifdef YYPARSE_PARAM
-#if defined __STDC__ || defined __cplusplus
-int yyparse (void *YYPARSE_PARAM);
-#else
-int yyparse ();
-#endif
-#else /* ! YYPARSE_PARAM */
-#if defined __STDC__ || defined __cplusplus
-int yyparse (DateInfo* info);
-#else
-int yyparse ();
-#endif
-#endif /* ! YYPARSE_PARAM */
-
-
@@ -1322,112 +1272,96 @@ int yyparse ();
| yyparse. |
`----------*/
-#ifdef YYPARSE_PARAM
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
-int
-yyparse (void *YYPARSE_PARAM)
-#else
-int
-yyparse (YYPARSE_PARAM)
- void *YYPARSE_PARAM;
-#endif
-#else /* ! YYPARSE_PARAM */
-#if (defined __STDC__ || defined __C99__FUNC__ \
- || defined __cplusplus || defined _MSC_VER)
int
yyparse (DateInfo* info)
-#else
-int
-yyparse (info)
- DateInfo* info;
-#endif
-#endif
{
- /* The look-ahead symbol. */
+/* The lookahead symbol. */
int yychar;
-/* The semantic value of the look-ahead symbol. */
-YYSTYPE yylval;
-/* Number of syntax errors so far. */
-int yynerrs;
-/* Location data for the look-ahead symbol. */
-YYLTYPE yylloc;
+/* The semantic value of the lookahead symbol. */
+/* Default value used for initialization, for pacifying older GCCs
+ or non-GCC compilers. */
+YY_INITIAL_VALUE (static YYSTYPE yyval_default;)
+YYSTYPE yylval YY_INITIAL_VALUE (= yyval_default);
- int yystate;
- int yyn;
- int yyresult;
- /* Number of tokens to shift before error messages enabled. */
- int yyerrstatus;
- /* Look-ahead token as an internal (translated) token number. */
- int yytoken = 0;
-#if YYERROR_VERBOSE
- /* Buffer for error messages, and its allocated size. */
- char yymsgbuf[128];
- char *yymsg = yymsgbuf;
- YYSIZE_T yymsg_alloc = sizeof yymsgbuf;
-#endif
+/* Location data for the lookahead symbol. */
+static YYLTYPE yyloc_default
+# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL
+ = { 1, 1, 1, 1 }
+# endif
+;
+YYLTYPE yylloc = yyloc_default;
- /* Three stacks and their tools:
- `yyss': related to states,
- `yyvs': related to semantic values,
- `yyls': related to locations.
+ /* Number of syntax errors so far. */
+ int yynerrs;
- Refer to the stacks thru separate pointers, to allow yyoverflow
- to reallocate them elsewhere. */
+ int yystate;
+ /* Number of tokens to shift before error messages enabled. */
+ int yyerrstatus;
- /* The state stack. */
- yytype_int16 yyssa[YYINITDEPTH];
- yytype_int16 *yyss = yyssa;
- yytype_int16 *yyssp;
+ /* The stacks and their tools:
+ 'yyss': related to states.
+ 'yyvs': related to semantic values.
+ 'yyls': related to locations.
- /* The semantic value stack. */
- YYSTYPE yyvsa[YYINITDEPTH];
- YYSTYPE *yyvs = yyvsa;
- YYSTYPE *yyvsp;
+ Refer to the stacks through separate pointers, to allow yyoverflow
+ to reallocate them elsewhere. */
- /* The location stack. */
- YYLTYPE yylsa[YYINITDEPTH];
- YYLTYPE *yyls = yylsa;
- YYLTYPE *yylsp;
- /* The locations where the error started and ended. */
- YYLTYPE yyerror_range[2];
+ /* The state stack. */
+ yytype_int16 yyssa[YYINITDEPTH];
+ yytype_int16 *yyss;
+ yytype_int16 *yyssp;
-#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N))
+ /* The semantic value stack. */
+ YYSTYPE yyvsa[YYINITDEPTH];
+ YYSTYPE *yyvs;
+ YYSTYPE *yyvsp;
- YYSIZE_T yystacksize = YYINITDEPTH;
+ /* The location stack. */
+ YYLTYPE yylsa[YYINITDEPTH];
+ YYLTYPE *yyls;
+ YYLTYPE *yylsp;
+ /* The locations where the error started and ended. */
+ YYLTYPE yyerror_range[3];
+
+ YYSIZE_T yystacksize;
+
+ int yyn;
+ int yyresult;
+ /* Lookahead token as an internal (translated) token number. */
+ int yytoken = 0;
/* The variables used to return semantic value and location from the
action routines. */
YYSTYPE yyval;
YYLTYPE yyloc;
+#if YYERROR_VERBOSE
+ /* Buffer for error messages, and its allocated size. */
+ char yymsgbuf[128];
+ char *yymsg = yymsgbuf;
+ YYSIZE_T yymsg_alloc = sizeof yymsgbuf;
+#endif
+
+#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N))
+
/* The number of symbols on the RHS of the reduced rule.
Keep to zero when no symbol should be popped. */
int yylen = 0;
+ yyssp = yyss = yyssa;
+ yyvsp = yyvs = yyvsa;
+ yylsp = yyls = yylsa;
+ yystacksize = YYINITDEPTH;
+
YYDPRINTF ((stderr, "Starting parse\n"));
yystate = 0;
yyerrstatus = 0;
yynerrs = 0;
- yychar = YYEMPTY; /* Cause a token to be read. */
-
- /* Initialize stack pointers.
- Waste one element of value and location stack
- so that they stay on the same level as the state stack.
- The wasted elements are never initialized. */
-
- yyssp = yyss;
- yyvsp = yyvs;
- yylsp = yyls;
-#if YYLTYPE_IS_TRIVIAL
- /* Initialize the default location before parsing starts. */
- yylloc.first_line = yylloc.last_line = 1;
- yylloc.first_column = yylloc.last_column = 0;
-#endif
-
+ yychar = YYEMPTY; /* Cause a token to be read. */
+ yylsp[0] = yylloc;
goto yysetstate;
/*------------------------------------------------------------.
@@ -1448,25 +1382,26 @@ YYLTYPE yylloc;
#ifdef yyoverflow
{
- /* Give user a chance to reallocate the stack. Use copies of
- these so that the &'s don't force the real ones into
- memory. */
- YYSTYPE *yyvs1 = yyvs;
- yytype_int16 *yyss1 = yyss;
- YYLTYPE *yyls1 = yyls;
-
- /* Each stack pointer address is followed by the size of the
- data in use in that stack, in bytes. This used to be a
- conditional around just the two extra args, but that might
- be undefined if yyoverflow is a macro. */
- yyoverflow (YY_("memory exhausted"),
- &yyss1, yysize * sizeof (*yyssp),
- &yyvs1, yysize * sizeof (*yyvsp),
- &yyls1, yysize * sizeof (*yylsp),
- &yystacksize);
- yyls = yyls1;
- yyss = yyss1;
- yyvs = yyvs1;
+ /* Give user a chance to reallocate the stack. Use copies of
+ these so that the &'s don't force the real ones into
+ memory. */
+ YYSTYPE *yyvs1 = yyvs;
+ yytype_int16 *yyss1 = yyss;
+ YYLTYPE *yyls1 = yyls;
+
+ /* Each stack pointer address is followed by the size of the
+ data in use in that stack, in bytes. This used to be a
+ conditional around just the two extra args, but that might
+ be undefined if yyoverflow is a macro. */
+ yyoverflow (YY_("memory exhausted"),
+ &yyss1, yysize * sizeof (*yyssp),
+ &yyvs1, yysize * sizeof (*yyvsp),
+ &yyls1, yysize * sizeof (*yylsp),
+ &yystacksize);
+
+ yyls = yyls1;
+ yyss = yyss1;
+ yyvs = yyvs1;
}
#else /* no yyoverflow */
# ifndef YYSTACK_RELOCATE
@@ -1474,23 +1409,23 @@ YYLTYPE yylloc;
# else
/* Extend the stack our own way. */
if (YYMAXDEPTH <= yystacksize)
- goto yyexhaustedlab;
+ goto yyexhaustedlab;
yystacksize *= 2;
if (YYMAXDEPTH < yystacksize)
- yystacksize = YYMAXDEPTH;
+ yystacksize = YYMAXDEPTH;
{
- yytype_int16 *yyss1 = yyss;
- union yyalloc *yyptr =
- (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize));
- if (! yyptr)
- goto yyexhaustedlab;
- YYSTACK_RELOCATE (yyss);
- YYSTACK_RELOCATE (yyvs);
- YYSTACK_RELOCATE (yyls);
+ yytype_int16 *yyss1 = yyss;
+ union yyalloc *yyptr =
+ (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize));
+ if (! yyptr)
+ goto yyexhaustedlab;
+ YYSTACK_RELOCATE (yyss_alloc, yyss);
+ YYSTACK_RELOCATE (yyvs_alloc, yyvs);
+ YYSTACK_RELOCATE (yyls_alloc, yyls);
# undef YYSTACK_RELOCATE
- if (yyss1 != yyssa)
- YYSTACK_FREE (yyss1);
+ if (yyss1 != yyssa)
+ YYSTACK_FREE (yyss1);
}
# endif
#endif /* no yyoverflow */
@@ -1500,14 +1435,17 @@ YYLTYPE yylloc;
yylsp = yyls + yysize - 1;
YYDPRINTF ((stderr, "Stack size increased to %lu\n",
- (unsigned long int) yystacksize));
+ (unsigned long) yystacksize));
if (yyss + yystacksize - 1 <= yyssp)
- YYABORT;
+ YYABORT;
}
YYDPRINTF ((stderr, "Entering state %d\n", yystate));
+ if (yystate == YYFINAL)
+ YYACCEPT;
+
goto yybackup;
/*-----------.
@@ -1516,20 +1454,20 @@ YYLTYPE yylloc;
yybackup:
/* Do appropriate processing given the current state. Read a
- look-ahead token if we need one and don't already have one. */
+ lookahead token if we need one and don't already have one. */
- /* First try to decide what to do without reference to look-ahead token. */
+ /* First try to decide what to do without reference to lookahead token. */
yyn = yypact[yystate];
- if (yyn == YYPACT_NINF)
+ if (yypact_value_is_default (yyn))
goto yydefault;
- /* Not known => get a look-ahead token if don't already have one. */
+ /* Not known => get a lookahead token if don't already have one. */
- /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */
+ /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */
if (yychar == YYEMPTY)
{
YYDPRINTF ((stderr, "Reading a token: "));
- yychar = YYLEX;
+ yychar = yylex (&yylval, &yylloc, info);
}
if (yychar <= YYEOF)
@@ -1551,29 +1489,27 @@ yybackup:
yyn = yytable[yyn];
if (yyn <= 0)
{
- if (yyn == 0 || yyn == YYTABLE_NINF)
- goto yyerrlab;
+ if (yytable_value_is_error (yyn))
+ goto yyerrlab;
yyn = -yyn;
goto yyreduce;
}
- if (yyn == YYFINAL)
- YYACCEPT;
-
/* Count tokens shifted since error; after three, turn off error
status. */
if (yyerrstatus)
yyerrstatus--;
- /* Shift the look-ahead token. */
+ /* Shift the lookahead token. */
YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc);
- /* Discard the shifted token unless it is eof. */
- if (yychar != YYEOF)
- yychar = YYEMPTY;
+ /* Discard the shifted token. */
+ yychar = YYEMPTY;
yystate = yyn;
+ YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
*++yyvsp = yylval;
+ YY_IGNORE_MAYBE_UNINITIALIZED_END
*++yylsp = yylloc;
goto yynewstate;
@@ -1596,7 +1532,7 @@ yyreduce:
yylen = yyr2[yyn];
/* If YYLEN is nonzero, implement the default value of the action:
- `$$ = $1'.
+ '$$ = $1'.
Otherwise, the following line sets YYVAL to garbage.
This behavior is undocumented and Bison
@@ -1605,8 +1541,9 @@ yyreduce:
GCC warning that YYVAL may be used uninitialized. */
yyval = yyvsp[1-yylen];
- /* Default location. */
+ /* Default location. */
YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen);
+ yyerror_range[1] = yyloc;
YY_REDUCE_PRINT (yyn);
switch (yyn)
{
@@ -1614,42 +1551,48 @@ yyreduce:
{
yyHaveTime++;
- ;}
+ }
+
break;
case 5:
{
yyHaveZone++;
- ;}
+ }
+
break;
case 6:
{
yyHaveDate++;
- ;}
+ }
+
break;
case 7:
{
yyHaveOrdinalMonth++;
- ;}
+ }
+
break;
case 8:
{
yyHaveDay++;
- ;}
+ }
+
break;
case 9:
{
yyHaveRel++;
- ;}
+ }
+
break;
case 10:
@@ -1657,7 +1600,8 @@ yyreduce:
{
yyHaveTime++;
yyHaveDate++;
- ;}
+ }
+
break;
case 11:
@@ -1666,195 +1610,217 @@ yyreduce:
yyHaveTime++;
yyHaveDate++;
yyHaveRel++;
- ;}
+ }
+
break;
case 13:
{
- yyHour = (yyvsp[(1) - (2)].Number);
+ yyHour = (yyvsp[-1].Number);
yyMinutes = 0;
yySeconds = 0;
- yyMeridian = (yyvsp[(2) - (2)].Meridian);
- ;}
+ yyMeridian = (yyvsp[0].Meridian);
+ }
+
break;
case 14:
{
- yyHour = (yyvsp[(1) - (4)].Number);
- yyMinutes = (yyvsp[(3) - (4)].Number);
+ yyHour = (yyvsp[-3].Number);
+ yyMinutes = (yyvsp[-1].Number);
yySeconds = 0;
- yyMeridian = (yyvsp[(4) - (4)].Meridian);
- ;}
+ yyMeridian = (yyvsp[0].Meridian);
+ }
+
break;
case 15:
{
- yyHour = (yyvsp[(1) - (5)].Number);
- yyMinutes = (yyvsp[(3) - (5)].Number);
+ yyHour = (yyvsp[-4].Number);
+ yyMinutes = (yyvsp[-2].Number);
yyMeridian = MER24;
yyDSTmode = DSToff;
- yyTimezone = ((yyvsp[(5) - (5)].Number) % 100 + ((yyvsp[(5) - (5)].Number) / 100) * 60);
+ yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
++yyHaveZone;
- ;}
+ }
+
break;
case 16:
{
- yyHour = (yyvsp[(1) - (6)].Number);
- yyMinutes = (yyvsp[(3) - (6)].Number);
- yySeconds = (yyvsp[(5) - (6)].Number);
- yyMeridian = (yyvsp[(6) - (6)].Meridian);
- ;}
+ yyHour = (yyvsp[-5].Number);
+ yyMinutes = (yyvsp[-3].Number);
+ yySeconds = (yyvsp[-1].Number);
+ yyMeridian = (yyvsp[0].Meridian);
+ }
+
break;
case 17:
{
- yyHour = (yyvsp[(1) - (7)].Number);
- yyMinutes = (yyvsp[(3) - (7)].Number);
- yySeconds = (yyvsp[(5) - (7)].Number);
+ yyHour = (yyvsp[-6].Number);
+ yyMinutes = (yyvsp[-4].Number);
+ yySeconds = (yyvsp[-2].Number);
yyMeridian = MER24;
yyDSTmode = DSToff;
- yyTimezone = ((yyvsp[(7) - (7)].Number) % 100 + ((yyvsp[(7) - (7)].Number) / 100) * 60);
+ yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
++yyHaveZone;
- ;}
+ }
+
break;
case 18:
{
- yyTimezone = (yyvsp[(1) - (2)].Number);
+ yyTimezone = (yyvsp[-1].Number);
yyDSTmode = DSTon;
- ;}
+ }
+
break;
case 19:
{
- yyTimezone = (yyvsp[(1) - (1)].Number);
+ yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSToff;
- ;}
+ }
+
break;
case 20:
{
- yyTimezone = (yyvsp[(1) - (1)].Number);
+ yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSTon;
- ;}
+ }
+
break;
case 21:
{
yyDayOrdinal = 1;
- yyDayNumber = (yyvsp[(1) - (1)].Number);
- ;}
+ yyDayNumber = (yyvsp[0].Number);
+ }
+
break;
case 22:
{
yyDayOrdinal = 1;
- yyDayNumber = (yyvsp[(1) - (2)].Number);
- ;}
+ yyDayNumber = (yyvsp[-1].Number);
+ }
+
break;
case 23:
{
- yyDayOrdinal = (yyvsp[(1) - (2)].Number);
- yyDayNumber = (yyvsp[(2) - (2)].Number);
- ;}
+ yyDayOrdinal = (yyvsp[-1].Number);
+ yyDayNumber = (yyvsp[0].Number);
+ }
+
break;
case 24:
{
- yyDayOrdinal = (yyvsp[(1) - (3)].Number) * (yyvsp[(2) - (3)].Number);
- yyDayNumber = (yyvsp[(3) - (3)].Number);
- ;}
+ yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number);
+ yyDayNumber = (yyvsp[0].Number);
+ }
+
break;
case 25:
{
yyDayOrdinal = 2;
- yyDayNumber = (yyvsp[(2) - (2)].Number);
- ;}
+ yyDayNumber = (yyvsp[0].Number);
+ }
+
break;
case 26:
{
- yyMonth = (yyvsp[(1) - (3)].Number);
- yyDay = (yyvsp[(3) - (3)].Number);
- ;}
+ yyMonth = (yyvsp[-2].Number);
+ yyDay = (yyvsp[0].Number);
+ }
+
break;
case 27:
{
- yyMonth = (yyvsp[(1) - (5)].Number);
- yyDay = (yyvsp[(3) - (5)].Number);
- yyYear = (yyvsp[(5) - (5)].Number);
- ;}
+ yyMonth = (yyvsp[-4].Number);
+ yyDay = (yyvsp[-2].Number);
+ yyYear = (yyvsp[0].Number);
+ }
+
break;
case 28:
{
- yyYear = (yyvsp[(1) - (1)].Number) / 10000;
- yyMonth = ((yyvsp[(1) - (1)].Number) % 10000)/100;
- yyDay = (yyvsp[(1) - (1)].Number) % 100;
- ;}
+ yyYear = (yyvsp[0].Number) / 10000;
+ yyMonth = ((yyvsp[0].Number) % 10000)/100;
+ yyDay = (yyvsp[0].Number) % 100;
+ }
+
break;
case 29:
{
- yyDay = (yyvsp[(1) - (5)].Number);
- yyMonth = (yyvsp[(3) - (5)].Number);
- yyYear = (yyvsp[(5) - (5)].Number);
- ;}
+ yyDay = (yyvsp[-4].Number);
+ yyMonth = (yyvsp[-2].Number);
+ yyYear = (yyvsp[0].Number);
+ }
+
break;
case 30:
{
- yyMonth = (yyvsp[(3) - (5)].Number);
- yyDay = (yyvsp[(5) - (5)].Number);
- yyYear = (yyvsp[(1) - (5)].Number);
- ;}
+ yyMonth = (yyvsp[-2].Number);
+ yyDay = (yyvsp[0].Number);
+ yyYear = (yyvsp[-4].Number);
+ }
+
break;
case 31:
{
- yyMonth = (yyvsp[(1) - (2)].Number);
- yyDay = (yyvsp[(2) - (2)].Number);
- ;}
+ yyMonth = (yyvsp[-1].Number);
+ yyDay = (yyvsp[0].Number);
+ }
+
break;
case 32:
{
- yyMonth = (yyvsp[(1) - (4)].Number);
- yyDay = (yyvsp[(2) - (4)].Number);
- yyYear = (yyvsp[(4) - (4)].Number);
- ;}
+ yyMonth = (yyvsp[-3].Number);
+ yyDay = (yyvsp[-2].Number);
+ yyYear = (yyvsp[0].Number);
+ }
+
break;
case 33:
{
- yyMonth = (yyvsp[(2) - (2)].Number);
- yyDay = (yyvsp[(1) - (2)].Number);
- ;}
+ yyMonth = (yyvsp[0].Number);
+ yyDay = (yyvsp[-1].Number);
+ }
+
break;
case 34:
@@ -1863,70 +1829,77 @@ yyreduce:
yyMonth = 1;
yyDay = 1;
yyYear = EPOCH;
- ;}
+ }
+
break;
case 35:
{
- yyMonth = (yyvsp[(2) - (3)].Number);
- yyDay = (yyvsp[(1) - (3)].Number);
- yyYear = (yyvsp[(3) - (3)].Number);
- ;}
+ yyMonth = (yyvsp[-1].Number);
+ yyDay = (yyvsp[-2].Number);
+ yyYear = (yyvsp[0].Number);
+ }
+
break;
case 36:
{
yyMonthOrdinal = 1;
- yyMonth = (yyvsp[(2) - (2)].Number);
- ;}
+ yyMonth = (yyvsp[0].Number);
+ }
+
break;
case 37:
{
- yyMonthOrdinal = (yyvsp[(2) - (3)].Number);
- yyMonth = (yyvsp[(3) - (3)].Number);
- ;}
+ yyMonthOrdinal = (yyvsp[-1].Number);
+ yyMonth = (yyvsp[0].Number);
+ }
+
break;
case 38:
{
- if ((yyvsp[(2) - (3)].Number) != HOUR( 7)) YYABORT;
- yyYear = (yyvsp[(1) - (3)].Number) / 10000;
- yyMonth = ((yyvsp[(1) - (3)].Number) % 10000)/100;
- yyDay = (yyvsp[(1) - (3)].Number) % 100;
- yyHour = (yyvsp[(3) - (3)].Number) / 10000;
- yyMinutes = ((yyvsp[(3) - (3)].Number) % 10000)/100;
- yySeconds = (yyvsp[(3) - (3)].Number) % 100;
- ;}
+ if ((yyvsp[-1].Number) != HOUR( 7)) YYABORT;
+ yyYear = (yyvsp[-2].Number) / 10000;
+ yyMonth = ((yyvsp[-2].Number) % 10000)/100;
+ yyDay = (yyvsp[-2].Number) % 100;
+ yyHour = (yyvsp[0].Number) / 10000;
+ yyMinutes = ((yyvsp[0].Number) % 10000)/100;
+ yySeconds = (yyvsp[0].Number) % 100;
+ }
+
break;
case 39:
{
- if ((yyvsp[(2) - (7)].Number) != HOUR( 7)) YYABORT;
- yyYear = (yyvsp[(1) - (7)].Number) / 10000;
- yyMonth = ((yyvsp[(1) - (7)].Number) % 10000)/100;
- yyDay = (yyvsp[(1) - (7)].Number) % 100;
- yyHour = (yyvsp[(3) - (7)].Number);
- yyMinutes = (yyvsp[(5) - (7)].Number);
- yySeconds = (yyvsp[(7) - (7)].Number);
- ;}
+ if ((yyvsp[-5].Number) != HOUR( 7)) YYABORT;
+ yyYear = (yyvsp[-6].Number) / 10000;
+ yyMonth = ((yyvsp[-6].Number) % 10000)/100;
+ yyDay = (yyvsp[-6].Number) % 100;
+ yyHour = (yyvsp[-4].Number);
+ yyMinutes = (yyvsp[-2].Number);
+ yySeconds = (yyvsp[0].Number);
+ }
+
break;
case 40:
{
- yyYear = (yyvsp[(1) - (2)].Number) / 10000;
- yyMonth = ((yyvsp[(1) - (2)].Number) % 10000)/100;
- yyDay = (yyvsp[(1) - (2)].Number) % 100;
- yyHour = (yyvsp[(2) - (2)].Number) / 10000;
- yyMinutes = ((yyvsp[(2) - (2)].Number) % 10000)/100;
- yySeconds = (yyvsp[(2) - (2)].Number) % 100;
- ;}
+ yyYear = (yyvsp[-1].Number) / 10000;
+ yyMonth = ((yyvsp[-1].Number) % 10000)/100;
+ yyDay = (yyvsp[-1].Number) % 100;
+ yyHour = (yyvsp[0].Number) / 10000;
+ yyMinutes = ((yyvsp[0].Number) % 10000)/100;
+ yySeconds = (yyvsp[0].Number) % 100;
+ }
+
break;
case 41:
@@ -1937,12 +1910,13 @@ yyreduce:
* in a range accessible with a 32 bit clock seconds value.
*/
- yyYear = (yyvsp[(2) - (4)].Number)/1000 + 2323 - 377;
+ yyYear = (yyvsp[-2].Number)/1000 + 2323 - 377;
yyDay = 1;
yyMonth = 1;
- yyRelDay += (((yyvsp[(2) - (4)].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000;
- yyRelSeconds += (yyvsp[(4) - (4)].Number) * 144 * 60;
- ;}
+ yyRelDay += (((yyvsp[-2].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000;
+ yyRelSeconds += (yyvsp[0].Number) * 144 * 60;
+ }
+
break;
case 42:
@@ -1951,121 +1925,145 @@ yyreduce:
yyRelSeconds *= -1;
yyRelMonth *= -1;
yyRelDay *= -1;
- ;}
+ }
+
break;
case 44:
{
- *yyRelPointer += (yyvsp[(1) - (3)].Number) * (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number);
- ;}
+ *yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number);
+ }
+
break;
case 45:
{
- *yyRelPointer += (yyvsp[(1) - (2)].Number) * (yyvsp[(2) - (2)].Number);
- ;}
+ *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
+ }
+
break;
case 46:
{
- *yyRelPointer += (yyvsp[(2) - (2)].Number);
- ;}
+ *yyRelPointer += (yyvsp[0].Number);
+ }
+
break;
case 47:
{
- *yyRelPointer += (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number);
- ;}
+ *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
+ }
+
break;
case 48:
{
- *yyRelPointer += (yyvsp[(1) - (1)].Number);
- ;}
+ *yyRelPointer += (yyvsp[0].Number);
+ }
+
break;
case 49:
{
(yyval.Number) = -1;
- ;}
+ }
+
break;
case 50:
{
(yyval.Number) = 1;
- ;}
+ }
+
break;
case 51:
{
- (yyval.Number) = (yyvsp[(1) - (1)].Number);
+ (yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelSeconds;
- ;}
+ }
+
break;
case 52:
{
- (yyval.Number) = (yyvsp[(1) - (1)].Number);
+ (yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelDay;
- ;}
+ }
+
break;
case 53:
{
- (yyval.Number) = (yyvsp[(1) - (1)].Number);
+ (yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelMonth;
- ;}
+ }
+
break;
case 54:
{
if (yyHaveTime && yyHaveDate && !yyHaveRel) {
- yyYear = (yyvsp[(1) - (1)].Number);
+ yyYear = (yyvsp[0].Number);
} else {
yyHaveTime++;
if (yyDigitCount <= 2) {
- yyHour = (yyvsp[(1) - (1)].Number);
+ yyHour = (yyvsp[0].Number);
yyMinutes = 0;
} else {
- yyHour = (yyvsp[(1) - (1)].Number) / 100;
- yyMinutes = (yyvsp[(1) - (1)].Number) % 100;
+ yyHour = (yyvsp[0].Number) / 100;
+ yyMinutes = (yyvsp[0].Number) % 100;
}
yySeconds = 0;
yyMeridian = MER24;
}
- ;}
+ }
+
break;
case 55:
{
(yyval.Meridian) = MER24;
- ;}
+ }
+
break;
case 56:
{
- (yyval.Meridian) = (yyvsp[(1) - (1)].Meridian);
- ;}
+ (yyval.Meridian) = (yyvsp[0].Meridian);
+ }
+
break;
-/* Line 1267 of yacc.c. */
default: break;
}
+ /* User semantic actions sometimes alter yychar, and that requires
+ that yytoken be updated with the new translation. We take the
+ approach of translating immediately before every use of yytoken.
+ One alternative is translating here after every semantic action,
+ but that translation would be missed if the semantic action invokes
+ YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or
+ if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an
+ incorrect destructor might then be invoked immediately. In the
+ case of YYERROR or YYBACKUP, subsequent parser actions might lead
+ to an incorrect destructor call or verbose syntax error message
+ before the lookahead is translated. */
YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc);
YYPOPSTACK (yylen);
@@ -2075,7 +2073,7 @@ yyreduce:
*++yyvsp = yyval;
*++yylsp = yyloc;
- /* Now `shift' the result of the reduction. Determine what state
+ /* Now 'shift' the result of the reduction. Determine what state
that goes to, based on the state we popped back to and the rule
number reduced by. */
@@ -2090,10 +2088,14 @@ yyreduce:
goto yynewstate;
-/*------------------------------------.
-| yyerrlab -- here on detecting error |
-`------------------------------------*/
+/*--------------------------------------.
+| yyerrlab -- here on detecting error. |
+`--------------------------------------*/
yyerrlab:
+ /* Make sure we have latest lookahead translation. See comments at
+ user semantic actions for why this is necessary. */
+ yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar);
+
/* If not already recovering from an error, report this error. */
if (!yyerrstatus)
{
@@ -2101,62 +2103,61 @@ yyerrlab:
#if ! YYERROR_VERBOSE
yyerror (&yylloc, info, YY_("syntax error"));
#else
+# define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \
+ yyssp, yytoken)
{
- YYSIZE_T yysize = yysyntax_error (0, yystate, yychar);
- if (yymsg_alloc < yysize && yymsg_alloc < YYSTACK_ALLOC_MAXIMUM)
- {
- YYSIZE_T yyalloc = 2 * yysize;
- if (! (yysize <= yyalloc && yyalloc <= YYSTACK_ALLOC_MAXIMUM))
- yyalloc = YYSTACK_ALLOC_MAXIMUM;
- if (yymsg != yymsgbuf)
- YYSTACK_FREE (yymsg);
- yymsg = (char *) YYSTACK_ALLOC (yyalloc);
- if (yymsg)
- yymsg_alloc = yyalloc;
- else
- {
- yymsg = yymsgbuf;
- yymsg_alloc = sizeof yymsgbuf;
- }
- }
-
- if (0 < yysize && yysize <= yymsg_alloc)
- {
- (void) yysyntax_error (yymsg, yystate, yychar);
- yyerror (&yylloc, info, yymsg);
- }
- else
- {
- yyerror (&yylloc, info, YY_("syntax error"));
- if (yysize != 0)
- goto yyexhaustedlab;
- }
+ char const *yymsgp = YY_("syntax error");
+ int yysyntax_error_status;
+ yysyntax_error_status = YYSYNTAX_ERROR;
+ if (yysyntax_error_status == 0)
+ yymsgp = yymsg;
+ else if (yysyntax_error_status == 1)
+ {
+ if (yymsg != yymsgbuf)
+ YYSTACK_FREE (yymsg);
+ yymsg = (char *) YYSTACK_ALLOC (yymsg_alloc);
+ if (!yymsg)
+ {
+ yymsg = yymsgbuf;
+ yymsg_alloc = sizeof yymsgbuf;
+ yysyntax_error_status = 2;
+ }
+ else
+ {
+ yysyntax_error_status = YYSYNTAX_ERROR;
+ yymsgp = yymsg;
+ }
+ }
+ yyerror (&yylloc, info, yymsgp);
+ if (yysyntax_error_status == 2)
+ goto yyexhaustedlab;
}
+# undef YYSYNTAX_ERROR
#endif
}
- yyerror_range[0] = yylloc;
+ yyerror_range[1] = yylloc;
if (yyerrstatus == 3)
{
- /* If just tried and failed to reuse look-ahead token after an
- error, discard it. */
+ /* If just tried and failed to reuse lookahead token after an
+ error, discard it. */
if (yychar <= YYEOF)
- {
- /* Return failure if at end of input. */
- if (yychar == YYEOF)
- YYABORT;
- }
+ {
+ /* Return failure if at end of input. */
+ if (yychar == YYEOF)
+ YYABORT;
+ }
else
- {
- yydestruct ("Error: discarding",
- yytoken, &yylval, &yylloc, info);
- yychar = YYEMPTY;
- }
+ {
+ yydestruct ("Error: discarding",
+ yytoken, &yylval, &yylloc, info);
+ yychar = YYEMPTY;
+ }
}
- /* Else will try to reuse look-ahead token after shifting the error
+ /* Else will try to reuse lookahead token after shifting the error
token. */
goto yyerrlab1;
@@ -2172,8 +2173,7 @@ yyerrorlab:
if (/*CONSTCOND*/ 0)
goto yyerrorlab;
- yyerror_range[0] = yylsp[1-yylen];
- /* Do not reclaim the symbols of the rule which action triggered
+ /* Do not reclaim the symbols of the rule whose action triggered
this YYERROR. */
YYPOPSTACK (yylen);
yylen = 0;
@@ -2186,43 +2186,42 @@ yyerrorlab:
| yyerrlab1 -- common code for both syntax error and YYERROR. |
`-------------------------------------------------------------*/
yyerrlab1:
- yyerrstatus = 3; /* Each real token shifted decrements this. */
+ yyerrstatus = 3; /* Each real token shifted decrements this. */
for (;;)
{
yyn = yypact[yystate];
- if (yyn != YYPACT_NINF)
- {
- yyn += YYTERROR;
- if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR)
- {
- yyn = yytable[yyn];
- if (0 < yyn)
- break;
- }
- }
+ if (!yypact_value_is_default (yyn))
+ {
+ yyn += YYTERROR;
+ if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR)
+ {
+ yyn = yytable[yyn];
+ if (0 < yyn)
+ break;
+ }
+ }
/* Pop the current state because it cannot handle the error token. */
if (yyssp == yyss)
- YYABORT;
+ YYABORT;
- yyerror_range[0] = *yylsp;
+ yyerror_range[1] = *yylsp;
yydestruct ("Error: popping",
- yystos[yystate], yyvsp, yylsp, info);
+ yystos[yystate], yyvsp, yylsp, info);
YYPOPSTACK (1);
yystate = *yyssp;
YY_STACK_PRINT (yyss, yyssp);
}
- if (yyn == YYFINAL)
- YYACCEPT;
-
+ YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
*++yyvsp = yylval;
+ YY_IGNORE_MAYBE_UNINITIALIZED_END
- yyerror_range[1] = yylloc;
+ yyerror_range[2] = yylloc;
/* Using YYLLOC is tempting, but would change the location of
- the look-ahead. YYLOC is available though. */
- YYLLOC_DEFAULT (yyloc, (yyerror_range - 1), 2);
+ the lookahead. YYLOC is available though. */
+ YYLLOC_DEFAULT (yyloc, yyerror_range, 2);
*++yylsp = yyloc;
/* Shift the error token. */
@@ -2246,7 +2245,7 @@ yyabortlab:
yyresult = 1;
goto yyreturn;
-#ifndef yyoverflow
+#if !defined yyoverflow || YYERROR_VERBOSE
/*-------------------------------------------------.
| yyexhaustedlab -- memory exhaustion comes here. |
`-------------------------------------------------*/
@@ -2257,17 +2256,22 @@ yyexhaustedlab:
#endif
yyreturn:
- if (yychar != YYEOF && yychar != YYEMPTY)
- yydestruct ("Cleanup: discarding lookahead",
- yytoken, &yylval, &yylloc, info);
- /* Do not reclaim the symbols of the rule which action triggered
+ if (yychar != YYEMPTY)
+ {
+ /* Make sure we have latest lookahead translation. See comments at
+ user semantic actions for why this is necessary. */
+ yytoken = YYTRANSLATE (yychar);
+ yydestruct ("Cleanup: discarding lookahead",
+ yytoken, &yylval, &yylloc, info);
+ }
+ /* Do not reclaim the symbols of the rule whose action triggered
this YYABORT or YYACCEPT. */
YYPOPSTACK (yylen);
YY_STACK_PRINT (yyss, yyssp);
while (yyssp != yyss)
{
yydestruct ("Cleanup: popping",
- yystos[*yyssp], yyvsp, yylsp, info);
+ yystos[*yyssp], yyvsp, yylsp, info);
YYPOPSTACK (1);
}
#ifndef yyoverflow
@@ -2278,13 +2282,10 @@ yyreturn:
if (yymsg != yymsgbuf)
YYSTACK_FREE (yymsg);
#endif
- /* Make sure YYID is used. */
- return YYID (yyresult);
+ return yyresult;
}
-
-
/*
* Month and day table.
*/
@@ -2680,7 +2681,7 @@ TclDatelex(
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
- while (TclIsSpaceProc(*yyInput)) {
+ while (TclIsSpaceProc(UCHAR(*yyInput))) {
yyInput++;
}
@@ -2911,4 +2912,3 @@ TclClockOldscanObjCmd(
* fill-column: 78
* End:
*/
-
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 252b46e..c79a408 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -119,7 +119,8 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file,
EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file,
int line);
/* 22 */
-EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file,
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file,
int line);
/* 23 */
EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes,
@@ -131,7 +132,8 @@ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue,
EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
const char *file, int line);
/* 26 */
-EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file,
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file,
int line);
/* 27 */
EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line);
@@ -158,7 +160,8 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src,
EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, double *doublePtr);
/* 36 */
-EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_GetIndexFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, const char *const *tablePtr,
const char *msg, int flags, int *indexPtr);
/* 37 */
@@ -198,24 +201,28 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp,
Tcl_Obj *listPtr, int first, int count,
int objc, Tcl_Obj *const objv[]);
/* 49 */
-EXTERN Tcl_Obj * Tcl_NewBooleanObj(int boolValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewBooleanObj(int boolValue);
/* 50 */
EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes,
int length);
/* 51 */
EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue);
/* 52 */
-EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewIntObj(int intValue);
/* 53 */
EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]);
/* 54 */
-EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewLongObj(long longValue);
/* 55 */
EXTERN Tcl_Obj * Tcl_NewObj(void);
/* 56 */
EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length);
/* 57 */
-EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue);
/* 58 */
EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length);
/* 59 */
@@ -224,22 +231,26 @@ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr,
/* 60 */
EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue);
/* 61 */
-EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
/* 62 */
EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc,
Tcl_Obj *const objv[]);
/* 63 */
-EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
/* 64 */
EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length);
/* 65 */
EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes,
int length);
/* 66 */
-EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_AddErrorInfo(Tcl_Interp *interp,
const char *message);
/* 67 */
-EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_AddObjErrorInfo(Tcl_Interp *interp,
const char *message, int length);
/* 68 */
EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp);
@@ -422,7 +433,8 @@ EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script);
EXTERN int Tcl_EvalFile(Tcl_Interp *interp,
const char *fileName);
/* 131 */
-EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
/* 132 */
EXTERN void Tcl_EventuallyFree(ClientData clientData,
Tcl_FreeProc *freeProc);
@@ -549,7 +561,8 @@ EXTERN Tcl_Channel Tcl_GetStdChannel(int type);
/* 174 */
EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp);
/* 175 */
-EXTERN const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags);
/* 176 */
EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
@@ -558,7 +571,8 @@ EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
EXTERN int Tcl_GlobalEval(Tcl_Interp *interp,
const char *command);
/* 178 */
-EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_GlobalEvalObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 179 */
EXTERN int Tcl_HideCommand(Tcl_Interp *interp,
@@ -713,7 +727,8 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp,
/* 236 */
EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type);
/* 237 */
-EXTERN const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags);
/* 238 */
EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
@@ -743,7 +758,8 @@ EXTERN int Tcl_StringMatch(const char *str, const char *pattern);
TCL_DEPRECATED("")
int Tcl_TellOld(Tcl_Channel chan);
/* 247 */
-EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *proc,
ClientData clientData);
/* 248 */
@@ -764,13 +780,15 @@ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp,
EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp,
Tcl_Channel chan);
/* 253 */
-EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
int flags);
/* 254 */
EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags);
/* 255 */
-EXTERN void Tcl_UntraceVar(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_UntraceVar(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_VarTraceProc *proc,
ClientData clientData);
@@ -783,7 +801,8 @@ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp,
EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp,
const char *varName);
/* 258 */
-EXTERN int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
const char *varName, const char *localName,
int flags);
/* 259 */
@@ -793,7 +812,8 @@ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName,
/* 260 */
EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...);
/* 261 */
-EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+ClientData Tcl_VarTraceInfo(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_VarTraceProc *procPtr,
ClientData prevClientData);
@@ -825,17 +845,20 @@ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr);
EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start,
const char **termPtr);
/* 271 */
-EXTERN const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
const char *version, int exact);
/* 272 */
EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version,
int exact, void *clientDataPtr);
/* 273 */
-EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
const char *version);
/* 274 */
-EXTERN const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact);
/* 275 */
TCL_DEPRECATED("see TIP #422")
@@ -1125,7 +1148,8 @@ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr);
/* 381 */
EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
/* 382 */
-EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr);
/* 383 */
EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last);
/* 384 */
@@ -1839,18 +1863,31 @@ EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp,
Tcl_TcpAcceptProc *acceptProc,
ClientData callbackData);
/* 632 */
-EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr);
+EXTERN int TclZipfs_Mount(Tcl_Interp *interp,
+ const char *mountPoint, const char *zipname,
+ const char *passwd);
/* 633 */
+EXTERN int TclZipfs_Unmount(Tcl_Interp *interp,
+ const char *mountPoint);
+/* 634 */
+EXTERN Tcl_Obj * TclZipfs_TclLibrary(void);
+/* 635 */
+EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp,
+ const char *mountPoint, unsigned char *data,
+ size_t datalen, int copy);
+/* 636 */
+EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr);
+/* 637 */
EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
unsigned int numBytes);
-/* 634 */
+/* 638 */
EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr);
-/* 635 */
+/* 639 */
EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr,
const Tcl_ObjIntRep *irPtr);
-/* 636 */
+/* 640 */
EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr);
typedef struct {
@@ -1901,11 +1938,11 @@ typedef struct TclStubs {
void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */
void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */
int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */
- Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */
Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */
Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */
Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */
- Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */
Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */
Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */
Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */
@@ -1915,7 +1952,7 @@ typedef struct TclStubs {
unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */
int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
- int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */
int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */
int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */
@@ -1928,25 +1965,25 @@ typedef struct TclStubs {
int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */
int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */
int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */
- Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */
Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */
Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */
- Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */
- Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */
Tcl_Obj * (*tcl_NewObj) (void); /* 55 */
Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */
- void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */
unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */
void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */
void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */
- void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */
- void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */
void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */
- void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */
- void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */
void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */
void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */
void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */
@@ -2010,7 +2047,7 @@ typedef struct TclStubs {
const char * (*tcl_ErrnoMsg) (int err); /* 128 */
int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */
int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */
- int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */
TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */
int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */
@@ -2062,10 +2099,10 @@ typedef struct TclStubs {
Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
- const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */
- int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
int (*tcl_Init) (Tcl_Interp *interp); /* 180 */
void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */
@@ -2124,7 +2161,7 @@ typedef struct TclStubs {
void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */
void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */
void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */
- const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
const char * (*tcl_SignalId) (int sig); /* 239 */
const char * (*tcl_SignalMsg) (int sig); /* 240 */
@@ -2134,21 +2171,21 @@ typedef struct TclStubs {
void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
- int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */
char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */
int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */
void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */
int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */
- int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */
int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */
- void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */
void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */
void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */
- int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */
int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */
int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */
- ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */
ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */
int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */
void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */
@@ -2158,10 +2195,10 @@ typedef struct TclStubs {
TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */
const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */
- const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
- int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
- const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
@@ -2269,7 +2306,7 @@ typedef struct TclStubs {
void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */
int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
- Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */
void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */
int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
@@ -2519,11 +2556,15 @@ typedef struct TclStubs {
int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */
- void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 632 */
- char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 633 */
- Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 634 */
- void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 635 */
- int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 636 */
+ int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *mountPoint, const char *zipname, const char *passwd); /* 632 */
+ int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */
+ Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */
+ int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */
+ void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 636 */
+ char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */
+ Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
+ void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
+ int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -3818,16 +3859,24 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */
#define Tcl_OpenTcpServerEx \
(tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */
+#define TclZipfs_Mount \
+ (tclStubsPtr->tclZipfs_Mount) /* 632 */
+#define TclZipfs_Unmount \
+ (tclStubsPtr->tclZipfs_Unmount) /* 633 */
+#define TclZipfs_TclLibrary \
+ (tclStubsPtr->tclZipfs_TclLibrary) /* 634 */
+#define TclZipfs_MountBuffer \
+ (tclStubsPtr->tclZipfs_MountBuffer) /* 635 */
#define Tcl_FreeIntRep \
- (tclStubsPtr->tcl_FreeIntRep) /* 632 */
+ (tclStubsPtr->tcl_FreeIntRep) /* 636 */
#define Tcl_InitStringRep \
- (tclStubsPtr->tcl_InitStringRep) /* 633 */
+ (tclStubsPtr->tcl_InitStringRep) /* 637 */
#define Tcl_FetchIntRep \
- (tclStubsPtr->tcl_FetchIntRep) /* 634 */
+ (tclStubsPtr->tcl_FetchIntRep) /* 638 */
#define Tcl_StoreIntRep \
- (tclStubsPtr->tcl_StoreIntRep) /* 635 */
+ (tclStubsPtr->tcl_StoreIntRep) /* 639 */
#define Tcl_HasStringRep \
- (tclStubsPtr->tcl_HasStringRep) /* 636 */
+ (tclStubsPtr->tcl_HasStringRep) /* 640 */
#endif /* defined(USE_TCL_STUBS) */
@@ -3839,15 +3888,12 @@ extern const TclStubs *tclStubsPtr;
# undef Tcl_GetStringResult
# undef Tcl_Init
# undef Tcl_SetPanicProc
-# undef Tcl_SetVar
# undef Tcl_ObjSetVar2
# undef Tcl_StaticPackage
# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp())
# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp))
# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp))
# define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc))
-# define Tcl_SetVar(interp, varName, newValue, flags) \
- (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags))
# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \
(tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags))
#endif
@@ -3857,6 +3903,7 @@ extern const TclStubs *tclStubsPtr;
# define Tcl_MainEx Tcl_MainExW
EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
+ EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv);
#endif
#undef TCL_STORAGE_CLASS
@@ -4003,9 +4050,11 @@ extern const TclStubs *tclStubsPtr;
#undef Tcl_DbNewLongObj
#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line)
#undef Tcl_SetIntObj
-#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (int)(value))
+#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value))
#undef Tcl_SetLongObj
-#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (long)(value))
+#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value))
+#undef Tcl_GetUnicode
+#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL)
/*
* Deprecated Tcl procedures:
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index e63b9d6..46012c5 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -908,7 +908,7 @@ PrintSourceToObj(
Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch);
i += 10;
} else
-#elif TCL_UTF_MAX > 3
+#else
/* If len == 0, this means we have a char > 0xffff, resulting in
* TclUtfToUniChar producing a surrogate pair. We want to output
* this pair as a single Unicode character.
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index e233e57..6d32676 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -2074,7 +2074,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/tclEnsemble.c b/generic/tclEnsemble.c
index 93d85bc..b710399 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -21,8 +21,6 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
EnsembleConfig *ensemblePtr, int objc,
Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
-static int NsEnsembleImplementationCmd(ClientData clientData,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NsEnsembleImplementationCmdNR(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
@@ -679,7 +677,7 @@ TclCreateEnsembleInNs(
ensemblePtr = ckalloc(sizeof(EnsembleConfig));
token = TclNRCreateCommandInNs(interp, name,
- (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
+ (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd,
NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
if (token == NULL) {
ckfree(ensemblePtr);
@@ -783,7 +781,7 @@ Tcl_SetEnsembleSubcommandList(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -859,7 +857,7 @@ Tcl_SetEnsembleParameterList(
Tcl_Obj *oldList;
int length;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -935,7 +933,7 @@ Tcl_SetEnsembleMappingDict(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldDict;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -1034,7 +1032,7 @@ Tcl_SetEnsembleUnknownHandler(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -1100,7 +1098,7 @@ Tcl_SetEnsembleFlags(
EnsembleConfig *ensemblePtr;
int wasCompiled;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -1176,7 +1174,7 @@ Tcl_GetEnsembleSubcommandList(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1218,7 +1216,7 @@ Tcl_GetEnsembleParameterList(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1260,7 +1258,7 @@ Tcl_GetEnsembleMappingDict(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1301,7 +1299,7 @@ Tcl_GetEnsembleUnknownHandler(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1342,7 +1340,7 @@ Tcl_GetEnsembleFlags(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1383,7 +1381,7 @@ Tcl_GetEnsembleNamespace(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1433,7 +1431,7 @@ Tcl_FindEnsemble(
return NULL;
}
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
/*
* Reuse existing infrastructure for following import link chains
* rather than duplicating it.
@@ -1441,7 +1439,8 @@ Tcl_FindEnsemble(
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
+ if (cmdPtr == NULL
+ || cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not an ensemble command",
@@ -1479,11 +1478,11 @@ Tcl_IsEnsemble(
{
Command *cmdPtr = (Command *) token;
- if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc == TclEnsembleImplementationCmd) {
return 1;
}
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) {
return 0;
}
return 1;
@@ -1654,7 +1653,7 @@ TclMakeEnsemble(
/*
*----------------------------------------------------------------------
*
- * NsEnsembleImplementationCmd --
+ * TclEnsembleImplementationCmd --
*
* Implements an ensemble of commands (being those exported by a
* namespace other than the global namespace) as a command with the same
@@ -1673,8 +1672,8 @@ TclMakeEnsemble(
*----------------------------------------------------------------------
*/
-static int
-NsEnsembleImplementationCmd(
+int
+TclEnsembleImplementationCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 8cc4b74..40ced17 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -723,14 +723,25 @@ TclFinalizeEnvironment(void)
* strings. This may leak more memory that strictly necessary, since some
* of the strings may no longer be in the environment. However,
* determining which ones are ok to delete is n-squared, and is pretty
- * unlikely, so we don't bother.
+ * unlikely, so we don't bother. However, in the case of DPURIFY, just
+ * free all strings in the cache.
*/
if (env.cache) {
+#ifdef PURIFY
+ int i;
+ for (i = 0; i < env.cacheSize; i++) {
+ ckfree(env.cache[i]);
+ }
+#endif
ckfree(env.cache);
env.cache = NULL;
env.cacheSize = 0;
#ifndef USE_PUTENV
+ if ((env.ourEnviron != NULL)) {
+ ckfree(env.ourEnviron);
+ env.ourEnviron = NULL;
+ }
env.ourEnvironSize = 0;
#endif
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index d5687dd..f38f7cd 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -500,7 +500,7 @@ VarHashCreateVar(
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
- ? (*(tPtr) = TCL_NUMBER_WIDE, \
+ ? (*(tPtr) = TCL_NUMBER_INT, \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
((objPtr)->typePtr == &tclDoubleType) \
@@ -3628,7 +3628,7 @@ TEBCresume(
objPtr = varPtr->value.objPtr;
if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
- if (type == TCL_NUMBER_WIDE) {
+ if (type == TCL_NUMBER_INT) {
Tcl_WideInt augend = *((const Tcl_WideInt *)ptr);
Tcl_WideInt sum = augend + increment;
@@ -3670,7 +3670,7 @@ TEBCresume(
TclSetIntObj(objPtr, w+increment);
}
goto doneIncr;
- } /* end if (type == TCL_NUMBER_WIDE) */
+ } /* end if (type == TCL_NUMBER_INT) */
}
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
@@ -4078,10 +4078,7 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr,
- TclGetVarNsPtr(varPtr));
+ TclInitArrayVar(varPtr);
#ifdef TCL_COMPILE_DEBUG
TRACE_APPEND(("done\n"));
} else {
@@ -4772,7 +4769,7 @@ TEBCresume(
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
&& (NULL == Tcl_FetchIntRep(value2Ptr, &tclListType))
- && (TclGetIntForIndexM(NULL , value2Ptr, objc-1,
+ && (TclGetIntForIndexM(NULL, value2Ptr, objc-1,
&index) == TCL_OK)) {
TclDecrRefCount(value2Ptr);
tosPtr--;
@@ -4972,7 +4969,7 @@ TEBCresume(
/* Decode index value operands. */
- /*
+ /*
assert ( toIdx != TCL_INDEX_AFTER);
*
* Extra safety for legacy bytecodes:
@@ -5231,9 +5228,15 @@ TEBCresume(
* but creating the object as a string seems to be faster in
* practical use.
*/
-
- length = (ch != -1) ? Tcl_UniCharToUtf(ch, buf) : 0;
- objResultPtr = Tcl_NewStringObj(buf, length);
+ if (ch == -1) {
+ objResultPtr = Tcl_NewObj();
+ } else {
+ length = Tcl_UniCharToUtf(ch, buf);
+ if (!length) {
+ length = Tcl_UniCharToUtf(-1, buf);
+ }
+ objResultPtr = Tcl_NewStringObj(buf, length);
+ }
}
TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
@@ -5636,22 +5639,13 @@ TEBCresume(
case INST_NUM_TYPE:
if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
type1 = 0;
- } else if (type1 == TCL_NUMBER_WIDE) {
- /* value is between LLONG_MIN and LLONG_MAX */
- /* [string is integer] is -UINT_MAX to UINT_MAX range */
- /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */
- int i;
-
- if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) {
- type1 = TCL_NUMBER_LONG;
- }
} else if (type1 == TCL_NUMBER_BIG) {
- /* value is an integer outside the LLONG_MIN to LLONG_MAX range */
- /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */
+ /* value is an integer outside the WIDE_MIN to WIDE_MAX range */
+ /* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */
Tcl_WideInt w;
if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
- type1 = TCL_NUMBER_WIDE;
+ type1 = TCL_NUMBER_INT;
}
}
TclNewIntObj(objResultPtr, type1);
@@ -5697,7 +5691,7 @@ TEBCresume(
compare = MP_EQ;
goto convertComparison;
}
- if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) {
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
w1 = *((const Tcl_WideInt *)ptr1);
w2 = *((const Tcl_WideInt *)ptr2);
compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
@@ -5776,7 +5770,7 @@ TEBCresume(
* Check for common, simple case.
*/
- if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) {
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
w1 = *((const Tcl_WideInt *)ptr1);
w2 = *((const Tcl_WideInt *)ptr2);
@@ -6016,7 +6010,7 @@ TEBCresume(
* an external function.
*/
- if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) {
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
w1 = *((const Tcl_WideInt *)ptr1);
w2 = *((const Tcl_WideInt *)ptr2);
@@ -6063,9 +6057,9 @@ TEBCresume(
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
- } else if ((w1 == LLONG_MIN) && (w2 == -1)) {
+ } else if ((w1 == WIDE_MIN) && (w2 == -1)) {
/*
- * Can't represent (-LLONG_MIN) as a Tcl_WideInt.
+ * Can't represent (-WIDE_MIN) as a Tcl_WideInt.
*/
goto overflow;
@@ -6159,7 +6153,7 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
w1 = *((const Tcl_WideInt *) ptr1);
if (Tcl_IsShared(valuePtr)) {
TclNewIntObj(objResultPtr, ~w1);
@@ -6196,9 +6190,9 @@ TEBCresume(
/* -NaN => NaN */
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w1 = *((const Tcl_WideInt *) ptr1);
- if (w1 != LLONG_MIN) {
+ if (w1 != WIDE_MIN) {
if (Tcl_IsShared(valuePtr)) {
TclNewIntObj(objResultPtr, -w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
@@ -7884,7 +7878,7 @@ ExecuteExtendedBinaryMathOp(
/* TODO: Attempts to re-use unshared operands on stack */
w2 = 0; /* silence gcc warning */
- if (type2 == TCL_NUMBER_WIDE) {
+ if (type2 == TCL_NUMBER_INT) {
w2 = *((const Tcl_WideInt *)ptr2);
if (w2 == 0) {
return DIVIDED_BY_ZERO;
@@ -7897,7 +7891,7 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
}
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
w1 = *((const Tcl_WideInt *)ptr1);
if (w1 == 0) {
@@ -7975,7 +7969,7 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type2) {
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
break;
case TCL_NUMBER_BIG:
@@ -7997,7 +7991,7 @@ ExecuteExtendedBinaryMathOp(
* Zero shifted any number of bits is still zero.
*/
- if ((type1==TCL_NUMBER_WIDE) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) {
+ if ((type1==TCL_NUMBER_INT) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) {
return constants[0];
}
@@ -8010,7 +8004,7 @@ ExecuteExtendedBinaryMathOp(
* counterparts, leading to incorrect results.
*/
- if ((type2 != TCL_NUMBER_WIDE)
+ if ((type2 != TCL_NUMBER_INT)
|| (*((const Tcl_WideInt *)ptr2) > INT_MAX)) {
/*
* Technically, we could hold the value (1 << (INT_MAX+1)) in
@@ -8043,7 +8037,7 @@ ExecuteExtendedBinaryMathOp(
* Quickly force large right shifts to 0 or -1.
*/
- if ((type2 != TCL_NUMBER_WIDE)
+ if ((type2 != TCL_NUMBER_INT)
|| (*(const Tcl_WideInt *)ptr2 > INT_MAX)) {
/*
* Again, technically, the value to be shifted could be an
@@ -8054,7 +8048,7 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type1) {
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
break;
case TCL_NUMBER_BIG:
@@ -8077,7 +8071,7 @@ ExecuteExtendedBinaryMathOp(
* Handle shifts within the native wide range.
*/
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
w1 = *(const Tcl_WideInt *)ptr1;
if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
if (w1 >= (Tcl_WideInt)0) {
@@ -8254,7 +8248,7 @@ ExecuteExtendedBinaryMathOp(
BIG_RESULT(&bigResult);
}
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
+ if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) {
TclGetWideIntFromObj(NULL, valuePtr, &w1);
TclGetWideIntFromObj(NULL, value2Ptr, &w2);
@@ -8308,7 +8302,7 @@ ExecuteExtendedBinaryMathOp(
goto doubleResult;
}
w2 = 0;
- if (type2 == TCL_NUMBER_WIDE) {
+ if (type2 == TCL_NUMBER_INT) {
w2 = *((const Tcl_WideInt *) ptr2);
if (w2 == 0) {
/*
@@ -8326,7 +8320,7 @@ ExecuteExtendedBinaryMathOp(
}
switch (type2) {
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w2 = *((const Tcl_WideInt *)ptr2);
negativeExponent = (w2 < 0);
oddExponent = (int) (w2 & (Tcl_WideInt)1);
@@ -8340,11 +8334,11 @@ ExecuteExtendedBinaryMathOp(
break;
}
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
w1 = *((const Tcl_WideInt *)ptr1);
}
if (negativeExponent) {
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
switch (w1) {
case 0:
/*
@@ -8374,7 +8368,7 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
switch (w1) {
case 0:
/*
@@ -8401,17 +8395,17 @@ ExecuteExtendedBinaryMathOp(
* which means the max exponent value is 2**28-1 = 0x0fffffff =
* 268435455, which fits into a signed 32 bit int which is within the
* range of the long int type. This means any numeric Tcl_Obj value
- * not using TCL_NUMBER_WIDE type must hold a value larger than we
+ * not using TCL_NUMBER_INT type must hold a value larger than we
* accept.
*/
- if (type2 != TCL_NUMBER_WIDE) {
+ if (type2 != TCL_NUMBER_INT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
if (w1 == 2) {
/*
* Reduce small powers of 2 to shifts.
@@ -8435,7 +8429,7 @@ ExecuteExtendedBinaryMathOp(
goto overflowExpon;
}
}
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
w1 = *((const Tcl_WideInt *) ptr1);
} else {
goto overflowExpon;
@@ -8635,7 +8629,7 @@ ExecuteExtendedBinaryMathOp(
switch (opcode) {
case INST_ADD:
wResult = w1 + w2;
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
+ if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT))
{
/*
* Check for overflow.
@@ -8649,7 +8643,7 @@ ExecuteExtendedBinaryMathOp(
case INST_SUB:
wResult = w1 - w2;
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
+ if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT))
{
/*
* Must check for overflow. The macro tests for overflows
@@ -8681,10 +8675,10 @@ ExecuteExtendedBinaryMathOp(
}
/*
- * Need a bignum to represent (LLONG_MIN / -1)
+ * Need a bignum to represent (WIDE_MIN / -1)
*/
- if ((w1 == LLONG_MIN) && (w2 == -1)) {
+ if ((w1 == WIDE_MIN) && (w2 == -1)) {
goto overflowBasic;
}
wResult = w1 / w2;
@@ -8772,7 +8766,7 @@ ExecuteExtendedUnaryMathOp(
switch (opcode) {
case INST_BITNOT:
- if (type == TCL_NUMBER_WIDE) {
+ if (type == TCL_NUMBER_INT) {
w = *((const Tcl_WideInt *) ptr);
WIDE_RESULT(~w);
}
@@ -8785,9 +8779,9 @@ ExecuteExtendedUnaryMathOp(
switch (type) {
case TCL_NUMBER_DOUBLE:
DOUBLE_RESULT(-(*((const double *) ptr)));
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w = *((const Tcl_WideInt *) ptr);
- if (w != LLONG_MIN) {
+ if (w != WIDE_MIN) {
WIDE_RESULT(-w);
}
TclInitBignumFromWideInt(&big, w);
@@ -8839,10 +8833,10 @@ TclCompareTwoNumbers(
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
switch (type1) {
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w1 = *((const Tcl_WideInt *)ptr1);
switch (type2) {
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w2 = *((const Tcl_WideInt *)ptr2);
wideCompare:
return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
@@ -8873,10 +8867,10 @@ TclCompareTwoNumbers(
* integer comparison can tell the difference.
*/
- if (d2 < (double)LLONG_MIN) {
+ if (d2 < (double)WIDE_MIN) {
return MP_GT;
}
- if (d2 > (double)LLONG_MAX) {
+ if (d2 > (double)WIDE_MAX) {
return MP_LT;
}
w2 = (Tcl_WideInt) d2;
@@ -8899,17 +8893,17 @@ TclCompareTwoNumbers(
d2 = *((const double *)ptr2);
doubleCompare:
return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w2 = *((const Tcl_WideInt *)ptr2);
d2 = (double) w2;
if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
|| w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) {
goto doubleCompare;
}
- if (d1 < (double)LLONG_MIN) {
+ if (d1 < (double)WIDE_MIN) {
return MP_LT;
}
- if (d1 > (double)LLONG_MAX) {
+ if (d1 > (double)WIDE_MAX) {
return MP_GT;
}
w1 = (Tcl_WideInt) d1;
@@ -8919,7 +8913,7 @@ TclCompareTwoNumbers(
return (d1 > 0.0) ? MP_GT : MP_LT;
}
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if ((d1 < (double)LLONG_MAX) && (d1 > (double)LLONG_MIN)) {
+ if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) {
if (mp_isneg(&big2)) {
compare = MP_GT;
} else {
@@ -8941,7 +8935,7 @@ TclCompareTwoNumbers(
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
switch (type2) {
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
return compare;
@@ -8952,7 +8946,7 @@ TclCompareTwoNumbers(
mp_clear(&big1);
return compare;
}
- if ((d2 < (double)LLONG_MAX) && (d2 > (double)LLONG_MIN)) {
+ if ((d2 < (double)WIDE_MAX) && (d2 > (double)WIDE_MIN)) {
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
return compare;
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index ddfe3bf..ea2a1c5 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -240,9 +240,13 @@ TclFileMakeDirsCmd(
break;
}
for (j = 0; j < pobjc; j++) {
+ int errCount = 2;
+
target = Tcl_FSJoinPath(split, j + 1);
Tcl_IncrRefCount(target);
+ createDir:
+
/*
* Call Tcl_FSStat() so that if target is a symlink that points to
* a directory we will create subdirectories in that directory.
@@ -269,23 +273,25 @@ TclFileMakeDirsCmd(
* subdirectory.
*/
- if (errno != EEXIST) {
- errfile = target;
- goto done;
- } else if ((Tcl_FSStat(target, &statBuf) == 0)
- && S_ISDIR(statBuf.st_mode)) {
- /*
- * It is a directory that wasn't there before, so keep
- * going without error.
- */
-
- Tcl_ResetResult(interp);
- } else {
- errfile = target;
- goto done;
+ if (errno == EEXIST) {
+ /* Be aware other workers could delete it immediately after
+ * creation, so give this worker still one chance (repeat once),
+ * see [270f78ca95] for description of the race-condition.
+ * Don't repeat the create always (to avoid endless loop). */
+ if (--errCount > 0) {
+ goto createDir;
+ }
+ /* Already tried, with delete in-between directly after
+ * creation, so just continue (assume created successful). */
+ goto nextPart;
}
+
+ /* return with error */
+ errfile = target;
+ goto done;
}
+ nextPart:
/*
* Forget about this sub-path.
*/
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 15fcde7..015cfc3 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -1881,7 +1881,7 @@ TclGlob(
separators = "/\\";
} else if (tclPlatform == TCL_PLATFORM_UNIX) {
- if (pathPrefix == NULL && tail[0] == '/') {
+ if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') {
pathPrefix = Tcl_NewStringObj(tail, 1);
tail++;
Tcl_IncrRefCount(pathPrefix);
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index da4c3fd..9c67227 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -897,7 +897,7 @@ TclDatelex(
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
- while (isspace(UCHAR(*yyInput))) {
+ while (TclIsSpaceProc(UCHAR(*yyInput))) {
yyInput++;
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index f1da67b..d144cbc 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -498,13 +498,13 @@ ChanSeek(
offset, mode, errnoPtr);
}
- if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
+ if (offset<LONG_MIN || offset>LONG_MAX) {
*errnoPtr = EOVERFLOW;
- return Tcl_LongAsWide(-1);
+ return -1;
}
- return Tcl_LongAsWide(chanPtr->typePtr->seekProc(chanPtr->instanceData,
- Tcl_WideAsLong(offset), mode, errnoPtr));
+ return chanPtr->typePtr->seekProc(chanPtr->instanceData,
+ offset, mode, errnoPtr);
}
static inline void
@@ -6965,7 +6965,7 @@ Tcl_Seek(
* non-blocking mode after the seek. */
if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
- return Tcl_LongAsWide(-1);
+ return -1;
}
/*
@@ -6976,7 +6976,7 @@ Tcl_Seek(
*/
if (CheckForDeadChannel(NULL, statePtr)) {
- return Tcl_LongAsWide(-1);
+ return -1;
}
/*
@@ -6992,7 +6992,7 @@ Tcl_Seek(
if (chanPtr->typePtr->seekProc == NULL) {
Tcl_SetErrno(EINVAL);
- return Tcl_LongAsWide(-1);
+ return -1;
}
/*
@@ -7005,7 +7005,7 @@ Tcl_Seek(
if ((inputBuffered != 0) && (outputBuffered != 0)) {
Tcl_SetErrno(EFAULT);
- return Tcl_LongAsWide(-1);
+ return -1;
}
/*
@@ -7048,7 +7048,7 @@ Tcl_Seek(
wasAsync = 1;
result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
if (result != 0) {
- return Tcl_LongAsWide(-1);
+ return -1;
}
ResetFlag(statePtr, CHANNEL_NONBLOCKING);
if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
@@ -7073,7 +7073,7 @@ Tcl_Seek(
*/
curPos = ChanSeek(chanPtr, offset, mode, &result);
- if (curPos == Tcl_LongAsWide(-1)) {
+ if (curPos == -1) {
Tcl_SetErrno(result);
}
}
@@ -7089,7 +7089,7 @@ Tcl_Seek(
SetFlag(statePtr, CHANNEL_NONBLOCKING);
result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING);
if (result != 0) {
- return Tcl_LongAsWide(-1);
+ return -1;
}
}
@@ -7129,7 +7129,7 @@ Tcl_Tell(
Tcl_WideInt curPos; /* Position on device. */
if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
- return Tcl_LongAsWide(-1);
+ return -1;
}
/*
@@ -7140,7 +7140,7 @@ Tcl_Tell(
*/
if (CheckForDeadChannel(NULL, statePtr)) {
- return Tcl_LongAsWide(-1);
+ return -1;
}
/*
@@ -7156,7 +7156,7 @@ Tcl_Tell(
if (chanPtr->typePtr->seekProc == NULL) {
Tcl_SetErrno(EINVAL);
- return Tcl_LongAsWide(-1);
+ return -1;
}
/*
@@ -7173,10 +7173,10 @@ Tcl_Tell(
* wideSeekProc if that is available and non-NULL...
*/
- curPos = ChanSeek(chanPtr, Tcl_LongAsWide(0), SEEK_CUR, &result);
- if (curPos == Tcl_LongAsWide(-1)) {
+ curPos = ChanSeek(chanPtr, 0, SEEK_CUR, &result);
+ if (curPos == -1) {
Tcl_SetErrno(result);
- return Tcl_LongAsWide(-1);
+ return -1;
}
if (inputBuffered != 0) {
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 87bf415..1dd8666 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -559,7 +559,7 @@ Tcl_SeekObjCmd(
TclChannelPreserve(chan);
result = Tcl_Seek(chan, offset, mode);
- if (result == Tcl_LongAsWide(-1)) {
+ if (result == -1) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
@@ -991,7 +991,7 @@ Tcl_ExecObjCmd(
resultPtr = Tcl_NewObj();
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
- if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
+ if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
@@ -1913,7 +1913,7 @@ ChanTruncateObjCmd(
*/
length = Tcl_Tell(chan);
- if (length == Tcl_WideAsLong(-1)) {
+ if (length == -1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not determine current location in \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index c1e8c44..9949a0e 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -910,7 +910,7 @@ TransformWideSeekProc(
Tcl_ChannelWideSeekProc(parentType);
ClientData parentData = Tcl_GetChannelInstanceData(parent);
- if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) {
+ if ((offset == 0) && (mode == SEEK_CUR)) {
/*
* This is no seek but a request to tell the caller the current
* location. Simply pass the request down.
@@ -920,8 +920,7 @@ TransformWideSeekProc(
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}
- return Tcl_LongAsWide(parentSeekProc(parentData, 0, mode,
- errorCodePtr));
+ return parentSeekProc(parentData, 0, mode, errorCodePtr);
}
/*
@@ -961,13 +960,13 @@ TransformWideSeekProc(
* to go out of the representable range.
*/
- if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
+ if (offset<LONG_MIN || offset>LONG_MAX) {
*errorCodePtr = EOVERFLOW;
- return Tcl_LongAsWide(-1);
+ return -1;
}
- return Tcl_LongAsWide(parentSeekProc(parentData, Tcl_WideAsLong(offset),
- mode, errorCodePtr));
+ return parentSeekProc(parentData, offset,
+ mode, errorCodePtr);
}
/*
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 354f1fb..611ee3f 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -1544,7 +1544,7 @@ ReflectSeekWide(
goto invalid;
}
- if (newLoc < Tcl_LongAsWide(0)) {
+ if (newLoc < 0) {
SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart);
goto invalid;
}
@@ -1576,7 +1576,7 @@ ReflectSeek(
* routine.
*/
- return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
+ return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
@@ -3079,7 +3079,7 @@ ForwardProc(
Tcl_WideInt newLoc;
if (Tcl_GetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) {
- if (newLoc < Tcl_LongAsWide(0)) {
+ if (newLoc < 0) {
ForwardSetStaticError(paramPtr, msg_seek_beforestart);
paramPtr->seek.offset = -1;
} else {
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 1a7b940..4841e39 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -1340,7 +1340,7 @@ ReflectSeekWide(
if (seekProc == NULL) {
Tcl_SetErrno(EINVAL);
- return Tcl_LongAsWide(-1);
+ return -1;
}
/*
@@ -1390,16 +1390,15 @@ ReflectSeekWide(
parent->typePtr->wideSeekProc != NULL) {
curPos = parent->typePtr->wideSeekProc(parent->instanceData, offset,
seekMode, errorCodePtr);
- } else if (offset < Tcl_LongAsWide(LONG_MIN) ||
- offset > Tcl_LongAsWide(LONG_MAX)) {
+ } else if (offset < LONG_MIN || offset > LONG_MAX) {
*errorCodePtr = EOVERFLOW;
- curPos = Tcl_LongAsWide(-1);
+ curPos = -1;
} else {
- curPos = Tcl_LongAsWide(parent->typePtr->seekProc(
- parent->instanceData, Tcl_WideAsLong(offset), seekMode,
- errorCodePtr));
+ curPos = parent->typePtr->seekProc(
+ parent->instanceData, offset, seekMode,
+ errorCodePtr);
}
- if (curPos == Tcl_LongAsWide(-1)) {
+ if (curPos == -1) {
Tcl_SetErrno(*errorCodePtr);
}
@@ -1422,7 +1421,7 @@ ReflectSeek(
* routine.
*/
- return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
+ return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 6abfa60..12e2900 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -11,7 +11,7 @@
#include "tclInt.h"
-#if defined(_WIN32) && defined(UNICODE)
+#if defined(_WIN32)
/*
* On Windows, we need to do proper Unicode->UTF-8 conversion.
*/
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 3382825..63d16be 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -139,7 +139,6 @@ Tcl_FSRenameFileProc TclpObjRenameFile;
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
-Tcl_FSUnloadFileProc TclpUnloadFile;
Tcl_FSLinkProc TclpObjLink;
Tcl_FSListVolumesProc TclpObjListVolumes;
@@ -276,8 +275,8 @@ Tcl_Stat(
Tcl_WideInt tmp1, tmp2, tmp3 = 0;
# define OUT_OF_RANGE(x) \
- (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
- ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
+ (((Tcl_WideInt)(x)) < LONG_MIN || \
+ ((Tcl_WideInt)(x)) > LONG_MAX)
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX))
@@ -1391,31 +1390,62 @@ TclFSNormalizeToUniquePath(
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
+ int i;
+ int isVfsPath = 0;
+ char *path;
+
/*
- * Call each of the "normalise path" functions in succession. This is a
- * special case, in which if we have a native filesystem handler, we call
- * it first. This is because the root of Tcl's filesystem is always a
- * native filesystem (i.e., '/' on unix is native).
+ * Paths starting with a UNC prefix whose final character is a colon
+ * are reserved for VFS use. These names can not conflict with real
+ * UNC paths per https://msdn.microsoft.com/en-us/library/gg465305.aspx
+ * and rfc3986's definition of reg-name.
+ *
+ * We check these first to avoid useless calls to the native filesystem's
+ * normalizePathProc.
*/
+ path = Tcl_GetStringFromObj(pathPtr, &i);
+
+ if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/')
+ || (path[0] == '\\' && path[1] == '\\') ) ) {
+ for ( i = 2; ; i++) {
+ if (path[i] == '\0') break;
+ if (path[i] == path[0]) break;
+ }
+ --i;
+ if (path[i] == ':') isVfsPath = 1;
+ }
+ /*
+ * Call each of the "normalise path" functions in succession.
+ */
firstFsRecPtr = FsGetFirstFilesystem();
Claim();
- for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
- if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
- continue;
- }
+
+ if (!isVfsPath) {
/*
- * TODO: Assume that we always find the native file system; it should
- * always be there...
+ * If we have a native filesystem handler, we call it first. This is
+ * because the root of Tcl's filesystem is always a native filesystem
+ * (i.e., '/' on unix is native).
*/
- if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
- startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
- startAt);
+ for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
+ if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
+ continue;
+ }
+
+ /*
+ * TODO: Assume that we always find the native file system; it should
+ * always be there...
+ */
+
+ if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
+ startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
+ startAt);
+ }
+ break;
}
- break;
}
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
@@ -1777,7 +1807,7 @@ Tcl_FSEvalFileEx(
* be handled especially.
*/
- if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
+ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1792,7 +1822,7 @@ Tcl_FSEvalFileEx(
*/
if (Tcl_ReadChars(chan, objPtr, -1,
- memcmp(string, "\xef\xbb\xbf", 3)) < 0) {
+ memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1912,7 +1942,7 @@ TclNREvalFile(
* be handled especially.
*/
- if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
+ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1928,7 +1958,7 @@ TclNREvalFile(
*/
if (Tcl_ReadChars(chan, objPtr, -1,
- memcmp(string, "\xef\xbb\xbf", 3)) < 0) {
+ memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -3154,8 +3184,8 @@ Tcl_FSLoadFile(
* present and set to true (any integer > 0) then the unlink is skipped.
*/
-int
-TclSkipUnlink(
+static int
+skipUnlink(
Tcl_Obj *shlibFile)
{
/*
@@ -3413,7 +3443,7 @@ Tcl_LoadFile(
* avoids any worries about leaving the copy laying around on exit.
*/
- if (!TclSkipUnlink(copyToPtr) &&
+ if (!skipUnlink(copyToPtr) &&
(Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
Tcl_DecrRefCount(copyToPtr);
@@ -3682,30 +3712,10 @@ Tcl_FSUnloadFile(
}
return TCL_ERROR;
}
- TclpUnloadFile(handle);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpUnloadFile --
- *
- * Unloads a library given its handle
- *
- * This function was once filesystem-specific, but has been made portable by
- * having TclpDlopen return a structure that includes procedure pointers.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpUnloadFile(
- Tcl_LoadHandle handle)
-{
if (handle->unloadFileProcPtr != NULL) {
handle->unloadFileProcPtr(handle);
}
+ return TCL_OK;
}
/*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6f40169..334ae20 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -38,6 +38,23 @@
#define AVOID_HACKS_FOR_ITCL 1
+
+/*
+ * Used to tag functions that are only to be visible within the module being
+ * built and not outside it (where this is supported by the linker).
+ * Also used in the platform-specific *Port.h files.
+ */
+
+#ifndef MODULE_SCOPE
+# ifdef __cplusplus
+# define MODULE_SCOPE extern "C"
+# else
+# define MODULE_SCOPE extern
+# endif
+#endif
+
+
+
/*
* Common include files needed by most of the Tcl source files are included
* here, so that system-dependent personalizations for the include files only
@@ -95,19 +112,6 @@ typedef int ptrdiff_t;
#endif
/*
- * Used to tag functions that are only to be visible within the module being
- * built and not outside it (where this is supported by the linker).
- */
-
-#ifndef MODULE_SCOPE
-# ifdef __cplusplus
-# define MODULE_SCOPE extern "C"
-# else
-# define MODULE_SCOPE extern
-# endif
-#endif
-
-/*
* Macros used to cast between pointers and integers (e.g. when storing an int
* in ClientData), on 64-bit architectures they avoid gcc warning about "cast
* to/from pointer from/to integer of different size".
@@ -2494,16 +2498,16 @@ typedef struct List {
#else
#define TclGetLongFromObj(interp, objPtr, longPtr) \
(((objPtr)->typePtr == &tclIntType \
- && (objPtr)->internalRep.wideValue >= -(Tcl_WideInt)(ULONG_MAX) \
- && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(ULONG_MAX)) \
+ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
+ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \
? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#endif
#define TclGetIntFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType \
- && (objPtr)->internalRep.wideValue >= -(Tcl_WideInt)(UINT_MAX) \
- && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(UINT_MAX)) \
+ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
+ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
@@ -2706,8 +2710,11 @@ typedef struct ProcessGlobalValue {
*----------------------------------------------------------------------
*/
-#define TCL_NUMBER_LONG 1
-#define TCL_NUMBER_WIDE 2
+#define TCL_NUMBER_INT 2
+#if (TCL_MAJOR_VERSION < 9) && !defined(TCL_NO_DEPRECATED)
+# define TCL_NUMBER_LONG 1 /* deprecated, not used any more */
+# define TCL_NUMBER_WIDE TCL_NUMBER_INT /* deprecated */
+#endif
#define TCL_NUMBER_BIG 3
#define TCL_NUMBER_DOUBLE 4
#define TCL_NUMBER_NAN 5
@@ -3039,6 +3046,8 @@ MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr,
MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp,
const char *targetName,
const char *packageName);
+MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *,
+ Tcl_WideInt *);
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
Tcl_Obj *unquotedPrefix, int globFlags,
Tcl_GlobTypeData *types);
@@ -3234,6 +3243,10 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
const char *trim, int numTrim);
+MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command);
+MODULE_SCOPE void TclRegisterCommandTypeName(
+ Tcl_ObjCmdProc *implementationProc,
+ const char *nameStr);
MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCount(int ch);
@@ -3257,12 +3270,20 @@ MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
#endif
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
+MODULE_SCOPE int TclZipfsInit(Tcl_Interp *interp);
+MODULE_SCOPE int TclZipfsMount(Tcl_Interp *interp, const char *zipname,
+ const char *mntpt, const char *passwd);
+MODULE_SCOPE int TclZipfsUnmount(Tcl_Interp *interp, const char *zipname);
MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr);
MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp,
const char *msg, int length);
+/* Tip 430 */
+MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp);
+MODULE_SCOPE int TclZipfs_SafeInit(Tcl_Interp *interp);
+
/*
*----------------------------------------------------------------
@@ -3344,7 +3365,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[]);
@@ -3373,7 +3393,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[]);
@@ -4102,6 +4121,19 @@ MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int TclFullFinalizationRequested(void);
/*
+ * Just for the purposes of command-type registration.
+ */
+
+MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd;
+
+/*
* TIP #462.
*/
@@ -4126,6 +4158,13 @@ MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options,
Tcl_Obj **errorObjPtr);
/*
+ * TIP #508: [array default]
+ */
+
+MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr);
+MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr);
+
+/*
* Utility routines for encoding index values as integers. Used by both
* some of the command compilers and by [lsort] and [lsearch].
*/
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 8ed001d..b1cc0c8 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -222,9 +222,6 @@ static int AliasDelete(Tcl_Interp *interp,
static int AliasDescribe(Tcl_Interp *interp,
Tcl_Interp *slaveInterp, Tcl_Obj *objPtr);
static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp);
-static int AliasObjCmd(ClientData dummy,
- Tcl_Interp *currentInterp, int objc,
- Tcl_Obj *const objv[]);
static int AliasNRCmd(ClientData dummy,
Tcl_Interp *currentInterp, int objc,
Tcl_Obj *const objv[]);
@@ -257,8 +254,6 @@ static int SlaveInvokeHidden(Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int SlaveMarkTrusted(Tcl_Interp *interp,
Tcl_Interp *slaveInterp);
-static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
static void SlaveObjCmdDeleteProc(ClientData clientData);
static int SlaveRecursionLimit(Tcl_Interp *interp,
Tcl_Interp *slaveInterp, int objc,
@@ -414,6 +409,7 @@ Tcl_Init(
" } else {\n"
" lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n"
" }\n"
+" lappend scripts {::tcl::zipfs::tcl_library_init}\n"
" lappend scripts {\n"
"set parentDir [file dirname [file dirname [info nameofexecutable]]]\n"
"set grandParentDir [file dirname $parentDir]\n"
@@ -1418,7 +1414,8 @@ TclPreventAliasLoop(
* create or rename the command.
*/
- if (cmdPtr->objProc != AliasObjCmd) {
+ if (cmdPtr->objProc != TclAliasObjCmd
+ && cmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
@@ -1473,7 +1470,8 @@ TclPreventAliasLoop(
* Otherwise we do not have a loop.
*/
- if (aliasCmdPtr->objProc != AliasObjCmd) {
+ if (aliasCmdPtr->objProc != TclAliasObjCmd
+ && aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
nextAliasPtr = aliasCmdPtr->objClientData;
@@ -1539,12 +1537,12 @@ AliasCreate(
if (slaveInterp == masterInterp) {
aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp,
- TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
- AliasObjCmdDeleteProc);
+ TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd,
+ aliasPtr, AliasObjCmdDeleteProc);
} else {
- aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
- TclGetString(namePtr), AliasObjCmd, aliasPtr,
- AliasObjCmdDeleteProc);
+ aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
+ TclGetString(namePtr), TclAliasObjCmd, aliasPtr,
+ AliasObjCmdDeleteProc);
}
if (TclPreventAliasLoop(interp, slaveInterp,
@@ -1780,7 +1778,7 @@ AliasList(
/*
*----------------------------------------------------------------------
*
- * AliasObjCmd --
+ * TclAliasObjCmd, TclLocalAliasObjCmd --
*
* This is the function that services invocations of aliases in a slave
* interpreter. One such command exists for each alias. When invoked,
@@ -1788,6 +1786,11 @@ AliasList(
* master interpreter as designated by the Alias record associated with
* this command.
*
+ * TclLocalAliasObjCmd is a stripped down version used when the source
+ * and target interpreters of the alias are the same. That lets a number
+ * of safety precautions be avoided: the state is much more precisely
+ * known.
+ *
* Results:
* A standard Tcl result.
*
@@ -1847,8 +1850,8 @@ AliasNRCmd(
return Tcl_NREvalObj(interp, listPtr, flags);
}
-static int
-AliasObjCmd(
+int
+TclAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -1937,6 +1940,73 @@ AliasObjCmd(
return result;
#undef ALIAS_CMDV_PREALLOC
}
+
+int
+TclLocalAliasObjCmd(
+ ClientData clientData, /* Alias record. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument vector. */
+{
+#define ALIAS_CMDV_PREALLOC 10
+ Alias *aliasPtr = clientData;
+ int result, prefc, cmdc, i;
+ Tcl_Obj **prefv, **cmdv;
+ Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
+ Interp *iPtr = (Interp *) interp;
+ int isRootEnsemble;
+
+ /*
+ * Append the arguments to the command prefix and invoke the command in
+ * the global namespace.
+ */
+
+ prefc = aliasPtr->objc;
+ prefv = &aliasPtr->objPtr;
+ cmdc = prefc + objc - 1;
+ if (cmdc <= ALIAS_CMDV_PREALLOC) {
+ cmdv = cmdArr;
+ } else {
+ cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
+ }
+
+ memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *)));
+ memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
+
+ for (i=0; i<cmdc; i++) {
+ Tcl_IncrRefCount(cmdv[i]);
+ }
+
+ /*
+ * Use the ensemble rewriting machinery to ensure correct error messages:
+ * only the source command should show, not the full target prefix.
+ */
+
+ isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)iPtr, 1, prefc, objv);
+
+ /*
+ * Execute the target command in the target interpreter.
+ */
+
+ result = Tcl_EvalObjv(interp, cmdc, cmdv, TCL_EVAL_INVOKE);
+
+ /*
+ * Clean up the ensemble rewrite info if we set it in the first place.
+ */
+
+ if (isRootEnsemble) {
+ TclResetRewriteEnsemble((Tcl_Interp *)iPtr, 1);
+ }
+
+ for (i=0; i<cmdc; i++) {
+ Tcl_DecrRefCount(cmdv[i]);
+ }
+ if (cmdv != cmdArr) {
+ TclStackFree(interp, cmdv);
+ }
+ return result;
+#undef ALIAS_CMDV_PREALLOC
+}
/*
*----------------------------------------------------------------------
@@ -2376,7 +2446,7 @@ SlaveCreate(
slavePtr->slaveEntryPtr = hPtr;
slavePtr->slaveInterp = slaveInterp;
slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
- SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
+ TclSlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, slavePtr);
Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY);
@@ -2444,7 +2514,7 @@ SlaveCreate(
/*
*----------------------------------------------------------------------
*
- * SlaveObjCmd --
+ * TclSlaveObjCmd --
*
* Command to manipulate an interpreter, e.g. to send commands to it to
* be evaluated. One such command exists for each slave interpreter.
@@ -2458,8 +2528,8 @@ SlaveCreate(
*----------------------------------------------------------------------
*/
-static int
-SlaveObjCmd(
+int
+TclSlaveObjCmd(
ClientData clientData, /* Slave interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -2491,7 +2561,7 @@ NRSlaveCmd(
};
if (slaveInterp == NULL) {
- Tcl_Panic("SlaveObjCmd: interpreter has been deleted");
+ Tcl_Panic("TclSlaveObjCmd: interpreter has been deleted");
}
if (objc < 2) {
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index a961ab4..27aafc3 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -90,8 +90,6 @@ static char * EstablishErrorInfoTraces(ClientData clientData,
static void FreeNsNameInternalRep(Tcl_Obj *objPtr);
static int GetNamespaceFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
-static int InvokeImportedCmd(ClientData clientData,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int InvokeImportedNRCmd(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceChildrenCmd(ClientData dummy,
@@ -1783,7 +1781,7 @@ DoImport(
dataPtr = ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
- InvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
+ TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
@@ -2004,7 +2002,7 @@ TclGetOriginalCommand(
/*
*----------------------------------------------------------------------
*
- * InvokeImportedCmd --
+ * TclInvokeImportedCmd --
*
* Invoked by Tcl whenever the user calls an imported command that was
* created by Tcl_Import. Finds the "real" command (in another
@@ -2035,8 +2033,8 @@ InvokeImportedNRCmd(
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}
-static int
-InvokeImportedCmd(
+int
+TclInvokeImportedCmd(
ClientData clientData, /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp, /* Current interpreter. */
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 6aa03fa..c8471d5 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -90,18 +90,16 @@ static inline void RemoveClass(Class **list, int num, int idx);
static inline void RemoveObject(Object **list, int num, int idx);
static inline void SquelchCachedName(Object *oPtr);
-static int PublicObjectCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
static int PublicNRObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static int PrivateObjectCmd(ClientData clientData,
+static int PrivateNRObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static int PrivateNRObjectCmd(ClientData clientData,
+static int MyClassNRObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
+static void MyClassDeleted(ClientData clientData);
/*
* Methods in the oo::object and oo::class classes. First, we define a helper
@@ -152,65 +150,10 @@ static const char *initScript =
/* " tcloo.tcl OO_LIBRARY oo::library;"; */
/*
- * The scripted part of the definitions of slots.
- */
-
-static const char *slotScript =
-"::oo::define ::oo::Slot {\n"
-" method Get {} {error unimplemented}\n"
-" method Set list {error unimplemented}\n"
-" method -set args {\n"
-" uplevel 1 [list [namespace which my] Set $args]\n"
-" }\n"
-" method -append args {\n"
-" uplevel 1 [list [namespace which my] Set [list"
-" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
-" }\n"
-" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
-" forward --default-operation my -append\n"
-" method unknown {args} {\n"
-" set def --default-operation\n"
-" if {[llength $args] == 0} {\n"
-" return [uplevel 1 [list [namespace which my] $def]]\n"
-" } elseif {![string match -* [lindex $args 0]]} {\n"
-" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
-" }\n"
-" next {*}$args\n"
-" }\n"
-" export -set -append -clear\n"
-" unexport unknown destroy\n"
-"}\n"
-"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
-"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
-"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
-
-/*
- * The body of the <cloned> method of oo::object.
+ * The scripted part of the definitions of TclOO.
*/
-static const char *clonedBody =
-"foreach p [info procs [info object namespace $originObject]::*] {"
-" set args [info args $p];"
-" set idx -1;"
-" foreach a $args {"
-" lset args [incr idx] "
-" [if {[info default $p $a d]} {list $a $d} {list $a}]"
-" };"
-" set b [info body $p];"
-" set p [namespace tail $p];"
-" proc $p $args $b;"
-"};"
-"foreach v [info vars [info object namespace $originObject]::*] {"
-" upvar 0 $v vOrigin;"
-" namespace upvar [namespace current] [namespace tail $v] vNew;"
-" if {[info exists vOrigin]} {"
-" if {[array exists vOrigin]} {"
-" array set vNew [array get vOrigin];"
-" } else {"
-" set vNew $vOrigin;"
-" }"
-" }"
-"}";
+#include "tclOOScript.h"
/*
* The actual definition of the variable holding the TclOO stub table.
@@ -360,7 +303,7 @@ InitFoundation(
ThreadLocalData *tsdPtr =
Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = ckalloc(sizeof(Foundation));
- Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
+ Tcl_Obj *namePtr;
Tcl_DString buffer;
Command *cmdPtr;
int i;
@@ -440,18 +383,6 @@ InitFoundation(
}
/*
- * Create the default <cloned> method implementation, used when 'oo::copy'
- * is called to finish the copying of one object to another.
- */
-
- TclNewLiteralStringObj(argsPtr, "originObject");
- Tcl_IncrRefCount(argsPtr);
- bodyPtr = Tcl_NewStringObj(clonedBody, -1);
- TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
- bodyPtr, NULL);
- TclDecrRefCount(argsPtr);
-
- /*
* Finish setting up the class of classes by marking the 'new' method as
* private; classes, unlike general objects, must have explicit names. We
* also need to create the constructor for classes.
@@ -491,7 +422,12 @@ InitFoundation(
if (TclOODefineSlots(fPtr) != TCL_OK) {
return TCL_ERROR;
}
- return Tcl_EvalEx(interp, slotScript, -1, 0);
+
+ /*
+ * Evaluate the remaining definitions, which are a compiled-in Tcl script.
+ */
+
+ return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0);
}
/*
@@ -776,10 +712,9 @@ AllocObject(
if (nsPtr->parentPtr != NULL) {
nsPtr = nsPtr->parentPtr;
}
-
}
oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
- (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
+ (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL);
/*
* Add the NRE command and trace directly. While this breaks a number of
@@ -796,7 +731,10 @@ AllocObject(
tracePtr->refCount = 1;
oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
- PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
+ TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
+ oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
+ oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
+ MyClassDeleted);
return oPtr;
}
@@ -824,12 +762,12 @@ SquelchCachedName(
/*
* ----------------------------------------------------------------------
*
- * MyDeleted --
+ * MyDeleted, MyClassDeleted --
*
- * This callback is triggered when the object's [my] command is deleted
- * by any mechanism. It just marks the object as not having a [my]
- * command, and so prevents cleanup of that when the object itself is
- * deleted.
+ * These callbacks are triggered when the object's [my] or [myclass]
+ * commands are deleted by any mechanism. They just mark the object as
+ * not having a [my] command or [myclass] command, and so prevent cleanup
+ * of those commands when the object itself is deleted.
*
* ----------------------------------------------------------------------
*/
@@ -843,6 +781,14 @@ MyDeleted(
oPtr->myCommand = NULL;
}
+
+static void
+MyClassDeleted(
+ ClientData clientData)
+{
+ Object *oPtr = clientData;
+ oPtr->myclassCommand = NULL;
+}
/*
* ----------------------------------------------------------------------
@@ -1215,6 +1161,9 @@ ObjectNamespaceDeleted(
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
}
+ if (oPtr->myclassCommand) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand);
+ }
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
}
@@ -2453,7 +2402,7 @@ Tcl_ObjectSetMetadata(
/*
* ----------------------------------------------------------------------
*
- * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
+ * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject --
*
* Main entry point for object invocations. The Public* and Private*
* wrapper functions (implementations of both object instance commands
@@ -2463,8 +2412,8 @@ Tcl_ObjectSetMetadata(
* ----------------------------------------------------------------------
*/
-static int
-PublicObjectCmd(
+int
+TclOOPublicObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -2484,8 +2433,8 @@ PublicNRObjectCmd(
NULL);
}
-static int
-PrivateObjectCmd(
+int
+TclOOPrivateObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -2538,6 +2487,43 @@ TclOOInvokeObject(
/*
* ----------------------------------------------------------------------
*
+ * TclOOMyClassObjCmd, MyClassNRObjCmd --
+ *
+ * Special trap door to allow an object to delegate simply to its class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOMyClassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv);
+}
+
+static int
+MyClassNRObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = clientData;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
+ return TCL_ERROR;
+ }
+ return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0,
+ NULL);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOOObjectCmdCore, FinalizeObjectCall --
*
* Main function for object invocations. Does call chain creation,
@@ -2892,9 +2878,9 @@ Tcl_GetObjectFromObj(
if (cmdPtr == NULL) {
goto notAnObject;
}
- if (cmdPtr->objProc != PublicObjectCmd) {
+ if (cmdPtr->objProc != TclOOPublicObjectCmd) {
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
+ if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
goto notAnObject;
}
}
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 763f0ad..13c98f4 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -83,7 +83,7 @@ TclOO_Class_Constructor(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Obj **invoke;
+ Tcl_Obj **invoke, *nameObj;
if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -94,6 +94,17 @@ TclOO_Class_Constructor(
}
/*
+ * Make the class definition delegate. This is special; it doesn't reenter
+ * here (and the class definition delegate doesn't run any constructors).
+ */
+
+ nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
+ Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+ Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
+ TclGetString(nameObj), NULL, -1, NULL, -1);
+ Tcl_DecrRefCount(nameObj);
+
+ /*
* Delegate to [oo::define] to do the work.
*/
@@ -111,7 +122,7 @@ TclOO_Class_Constructor(
Tcl_IncrRefCount(invoke[1]);
Tcl_IncrRefCount(invoke[2]);
TclNRAddCallback(interp, DecrRefsPostClassConstructor,
- invoke, NULL, NULL, NULL);
+ invoke, oPtr, NULL, NULL);
/*
* Tricky point: do not want the extra reported level in the Tcl stack
@@ -128,12 +139,27 @@ DecrRefsPostClassConstructor(
int result)
{
Tcl_Obj **invoke = data[0];
+ Object *oPtr = data[1];
+ Tcl_InterpState saved;
+ int code;
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
TclDecrRefCount(invoke[2]);
+ invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
+ invoke[1] = TclOOObjectName(interp, oPtr);
+ Tcl_IncrRefCount(invoke[0]);
+ Tcl_IncrRefCount(invoke[1]);
+ saved = Tcl_SaveInterpState(interp, result);
+ code = Tcl_EvalObjv(interp, 2, invoke, 0);
+ TclDecrRefCount(invoke[0]);
+ TclDecrRefCount(invoke[1]);
ckfree(invoke);
- return result;
+ if (code != TCL_OK) {
+ Tcl_DiscardInterpState(saved);
+ return code;
+ }
+ return Tcl_RestoreInterpState(interp, saved);
}
/*
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 19cd42b..17680a0 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -37,14 +37,17 @@ struct DeclaredSlot {
const char *name;
const Tcl_MethodType getterType;
const Tcl_MethodType setterType;
+ const Tcl_MethodType resolverType;
};
-#define SLOT(name,getter,setter) \
+#define SLOT(name,getter,setter,resolver) \
{"::oo::" name, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
getter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
- setter, NULL, NULL}}
+ setter, NULL, NULL}, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
+ resolver, NULL, NULL}}
/*
* Forward declarations.
@@ -109,20 +112,23 @@ static int ObjVarsGet(ClientData clientData,
static int ObjVarsSet(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
+static int ResolveClass(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
/*
* Now define the slots used in declarations.
*/
static const struct DeclaredSlot slots[] = {
- SLOT("define::filter", ClassFilterGet, ClassFilterSet),
- SLOT("define::mixin", ClassMixinGet, ClassMixinSet),
- SLOT("define::superclass", ClassSuperGet, ClassSuperSet),
- SLOT("define::variable", ClassVarsGet, ClassVarsSet),
- SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet),
- SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet),
- SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet),
- {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
+ SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL),
+ SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass),
+ SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass),
+ SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL),
+ SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL),
+ SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass),
+ SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL),
+ {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};
/*
@@ -1841,70 +1847,6 @@ TclOODefineMethodObjCmd(
/*
* ----------------------------------------------------------------------
*
- * TclOODefineMixinObjCmd --
- *
- * Implementation of the "mixin" subcommand of the "oo::define" and
- * "oo::objdefine" commands.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOODefineMixinObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- const int objc,
- Tcl_Obj *const *objv)
-{
- int isInstanceMixin = (clientData != NULL);
- Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Class **mixins;
- int i;
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (!isInstanceMixin && !oPtr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
- return TCL_ERROR;
- }
- mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
-
- for (i=1 ; i<objc ; i++) {
- Class *clsPtr = GetClassInOuterContext(interp, objv[i],
- "may only mix in classes");
-
- if (clsPtr == NULL) {
- goto freeAndError;
- }
- if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "may not mix a class into itself", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
- goto freeAndError;
- }
- mixins[i-1] = clsPtr;
- }
-
- if (isInstanceMixin) {
- TclOOObjectSetMixins(oPtr, objc-1, mixins);
- } else {
- TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
- }
-
- TclStackFree(interp, mixins);
- return TCL_OK;
-
- freeAndError:
- TclStackFree(interp, mixins);
- return TCL_ERROR;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
* TclOODefineRenameMethodObjCmd --
*
* Implementation of the "renamemethod" subcommand of the "oo::define"
@@ -2127,6 +2069,7 @@ TclOODefineSlots(
const struct DeclaredSlot *slotInfoPtr;
Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
+ Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1);
Class *slotCls;
slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
@@ -2136,9 +2079,10 @@ TclOODefineSlots(
}
Tcl_IncrRefCount(getName);
Tcl_IncrRefCount(setName);
+ Tcl_IncrRefCount(resolveName);
for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
- (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0);
+ (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0);
if (slotObject == NULL) {
continue;
@@ -2147,9 +2091,14 @@ TclOODefineSlots(
&slotInfoPtr->getterType, NULL);
Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
+ if (slotInfoPtr->resolverType.callProc) {
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
+ &slotInfoPtr->resolverType, NULL);
+ }
}
Tcl_DecrRefCount(getName);
Tcl_DecrRefCount(setName);
+ Tcl_DecrRefCount(resolveName);
return TCL_OK;
}
@@ -2879,6 +2828,59 @@ ObjVarsSet(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * ResolveClass --
+ *
+ * Implementation of the "Resolve" support method for some slots (those
+ * that are slots around a list of classes). This resolves possible class
+ * names to their fully-qualified names if possible.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ResolveClass(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int idx = Tcl_ObjectContextSkippedArgs(context);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr;
+
+ /*
+ * Check if were called wrongly. The definition context isn't used...
+ * except that GetClassInOuterContext() assumes that it is there.
+ */
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (objc != idx + 1) {
+ Tcl_WrongNumArgs(interp, idx, objv, "slotElement");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Resolve the class if possible. If not, remove any resolution error and
+ * return what we've got anyway as the failure might not be fatal overall.
+ */
+
+ clsPtr = GetClassInOuterContext(interp, objv[idx],
+ "USER SHOULD NOT SEE THIS MESSAGE");
+ if (clsPtr == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, objv[idx]);
+ } else {
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
+ }
+
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index a43ab76..1f30fed 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -209,6 +209,8 @@ typedef struct Object {
PrivateVariableList privateVariables;
/* Configurations for the variable resolver
* used inside methods. */
+ Tcl_Command myclassCommand; /* Reference to this object's class dispatcher
+ * command. */
} Object;
#define OBJECT_DELETED 1 /* Flag to say that an object has been
@@ -597,7 +599,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
#define FOREACH(var,ary) \
for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \
continue; \
- } else if (var = (ary).list[i], 1)
+ } else if (var = (ary).list[i], 1)
/*
* A variation where the array is an array of structs. There's no issue with
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
new file mode 100644
index 0000000..2213ce3
--- /dev/null
+++ b/generic/tclOOScript.h
@@ -0,0 +1,263 @@
+/*
+ * tclOOScript.h --
+ *
+ * This file contains support scripts for TclOO. They are defined here so
+ * that the code can be definitely run even in safe interpreters; TclOO's
+ * core setup is safe.
+ *
+ * Copyright (c) 2012-2018 Donal K. Fellows
+ * Copyright (c) 2013 Andreas Kupries
+ * Copyright (c) 2017 Gerald Lester
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef TCL_OO_SCRIPT_H
+#define TCL_OO_SCRIPT_H
+
+/*
+ * The scripted part of the definitions of TclOO.
+ *
+ * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which
+ * contains the commented version of everything; *this* file is automatically
+ * generated.
+ */
+
+static const char *tclOOSetupScript =
+/* !BEGIN!: Do not edit below this line. */
+"::namespace eval ::oo {\n"
+"\t::namespace path {}\n"
+"\tnamespace eval Helpers {\n"
+"\t\t::namespace path {}\n"
+"\t\tproc callback {method args} {\n"
+"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
+"\t\t}\n"
+"\t\tnamespace export callback\n"
+"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
+"\t\tnamespace export -clear\n"
+"\t\trename tmp::callback mymethod\n"
+"\t\tnamespace delete tmp\n"
+"\t\tproc classvariable {name args} {\n"
+"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
+"\t\t\tforeach v [list $name {*}$args] {\n"
+"\t\t\t\tif {[string match *(*) $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string match *::* $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tlappend vs $v $v\n"
+"\t\t\t}\n"
+"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
+"\t\t}\n"
+"\t\tproc link {args} {\n"
+"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
+"\t\t\tforeach link $args {\n"
+"\t\t\t\tif {[llength $link] == 2} {\n"
+"\t\t\t\t\tlassign $link src dst\n"
+"\t\t\t\t} elseif {[llength $link] == 1} {\n"
+"\t\t\t\t\tlassign $link src\n"
+"\t\t\t\t\tset dst $src\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {![string match ::* $src]} {\n"
+"\t\t\t\t\tset src [string cat $ns :: $src]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
+"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
+"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
+"\t\t\t}\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc UnlinkLinkedCommand {cmd args} {\n"
+"\t\tif {[namespace which $cmd] ne {}} {\n"
+"\t\t\trename $cmd {}\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc DelegateName {class} {\n"
+"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
+"\t}\n"
+"\tproc MixinClassDelegates {class} {\n"
+"\t\tif {![info object isa class $class]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tset delegate [DelegateName $class]\n"
+"\t\tif {![info object isa class $delegate]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tforeach c [info class superclass $class] {\n"
+"\t\t\tset d [DelegateName $c]\n"
+"\t\t\tif {![info object isa class $d]} {\n"
+"\t\t\t\tcontinue\n"
+"\t\t\t}\n"
+"\t\t\tdefine $delegate superclass -append $d\n"
+"\t\t}\n"
+"\t\tobjdefine $class mixin -append $delegate\n"
+"\t}\n"
+"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
+"\t\tset originDelegate [DelegateName $originObject]\n"
+"\t\tset targetDelegate [DelegateName $targetObject]\n"
+"\t\tif {\n"
+"\t\t\t[info object isa class $originDelegate]\n"
+"\t\t\t&& ![info object isa class $targetDelegate]\n"
+"\t\t} then {\n"
+"\t\t\tcopy $originDelegate $targetDelegate\n"
+"\t\t\tobjdefine $targetObject mixin -set \\\n"
+"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
+"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"\t\t\t\t}]\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc define::classmethod {name {args {}} {body {}}} {\n"
+"\t\t::set argc [::llength [::info level 0]]\n"
+"\t\t::if {$argc == 3} {\n"
+"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
+"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
+"\t\t\t\t[::lindex [::info level 0] 0]]\n"
+"\t\t}\n"
+"\t\t::set cls [::uplevel 1 self]\n"
+"\t\t::if {$argc == 4} {\n"
+"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
+"\t\t}\n"
+"\t\t::tailcall forward $name myclass $name\n"
+"\t}\n"
+"\tproc define::initialise {body} {\n"
+"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
+"\t\t::tailcall apply [::list {} $body $clsns]\n"
+"\t}\n"
+"\tnamespace eval define {\n"
+"\t\t::namespace export initialise\n"
+"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
+"\t\t::namespace export -clear\n"
+"\t\t::rename tmp::initialise initialize\n"
+"\t\t::namespace delete tmp\n"
+"\t}\n"
+"\tdefine Slot {\n"
+"\t\tmethod Get {} {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Set list {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Resolve list {\n"
+"\t\t\treturn $list\n"
+"\t\t}\n"
+"\t\tmethod -set args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\ttailcall my Set $args\n"
+"\t\t}\n"
+"\t\tmethod -append args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
+"\t\t}\n"
+"\t\tmethod -clear {} {tailcall my Set {}}\n"
+"\t\tmethod -prepend args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
+"\t\t}\n"
+"\t\tmethod -remove args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\ttailcall my Set [lmap val $current {\n"
+"\t\t\t\tif {$val in $args} continue else {set val}\n"
+"\t\t\t}]\n"
+"\t\t}\n"
+"\t\tforward --default-operation my -append\n"
+"\t\tmethod unknown {args} {\n"
+"\t\t\tset def --default-operation\n"
+"\t\t\tif {[llength $args] == 0} {\n"
+"\t\t\t\ttailcall my $def\n"
+"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
+"\t\t\t\ttailcall my $def {*}$args\n"
+"\t\t\t}\n"
+"\t\t\tnext {*}$args\n"
+"\t\t}\n"
+"\t\texport -set -append -clear -prepend -remove\n"
+"\t\tunexport unknown destroy\n"
+"\t}\n"
+"\tobjdefine define::superclass forward --default-operation my -set\n"
+"\tobjdefine define::mixin forward --default-operation my -set\n"
+"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
+"\tdefine object method <cloned> {originObject} {\n"
+"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
+"\t\t\tset args [info args $p]\n"
+"\t\t\tset idx -1\n"
+"\t\t\tforeach a $args {\n"
+"\t\t\t\tif {[info default $p $a d]} {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a]\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\tset b [info body $p]\n"
+"\t\t\tset p [namespace tail $p]\n"
+"\t\t\tproc $p $args $b\n"
+"\t\t}\n"
+"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
+"\t\t\tupvar 0 $v vOrigin\n"
+"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
+"\t\t\tif {[info exists vOrigin]} {\n"
+"\t\t\t\tif {[array exists vOrigin]} {\n"
+"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tset vNew $vOrigin\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t}\n"
+"\tdefine class method <cloned> {originObject} {\n"
+"\t\tnext $originObject\n"
+"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t}\n"
+"\tclass create singleton {\n"
+"\t\tsuperclass class\n"
+"\t\tvariable object\n"
+"\t\tunexport create createWithNamespace\n"
+"\t\tmethod new args {\n"
+"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
+"\t\t\t\tset object [next {*}$args]\n"
+"\t\t\t\t::oo::objdefine $object {\n"
+"\t\t\t\t\tmethod destroy {} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\tmethod <cloned> {originObject} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn $object\n"
+"\t\t}\n"
+"\t}\n"
+"\tclass create abstract {\n"
+"\t\tsuperclass class\n"
+"\t\tunexport create createWithNamespace new\n"
+"\t}\n"
+"}\n"
+/* !END!: Do not edit above this line. */
+;
+
+#endif /* TCL_OO_SCRIPT_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl
new file mode 100644
index 0000000..a48eab5
--- /dev/null
+++ b/generic/tclOOScript.tcl
@@ -0,0 +1,456 @@
+# tclOOScript.h --
+#
+# This file contains support scripts for TclOO. They are defined here so
+# that the code can be definitely run even in safe interpreters; TclOO's
+# core setup is safe.
+#
+# Copyright (c) 2012-2018 Donal K. Fellows
+# Copyright (c) 2013 Andreas Kupries
+# Copyright (c) 2017 Gerald Lester
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+::namespace eval ::oo {
+ ::namespace path {}
+
+ #
+ # Commands that are made available to objects by default.
+ #
+ namespace eval Helpers {
+ ::namespace path {}
+
+ # ------------------------------------------------------------------
+ #
+ # callback, mymethod --
+ #
+ # Create a script prefix that calls a method on the current
+ # object. Same operation, two names.
+ #
+ # ------------------------------------------------------------------
+
+ proc callback {method args} {
+ list [uplevel 1 {::namespace which my}] $method {*}$args
+ }
+
+ # Make the [callback] command appear as [mymethod] too.
+ namespace export callback
+ namespace eval tmp {namespace import ::oo::Helpers::callback}
+ namespace export -clear
+ rename tmp::callback mymethod
+ namespace delete tmp
+
+ # ------------------------------------------------------------------
+ #
+ # classvariable --
+ #
+ # Link to a variable in the class of the current object.
+ #
+ # ------------------------------------------------------------------
+
+ proc classvariable {name args} {
+ # Get a reference to the class's namespace
+ set ns [info object namespace [uplevel 1 {self class}]]
+ # Double up the list of variable names
+ foreach v [list $name {*}$args] {
+ if {[string match *(*) $v]} {
+ set reason "can't create a scalar variable that looks like an array element"
+ return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
+ [format {bad variable name "%s": %s} $v $reason]
+ }
+ if {[string match *::* $v]} {
+ set reason "can't create a local variable with a namespace separator in it"
+ return -code error -errorcode {TCL UPVAR INVERTED} \
+ [format {bad variable name "%s": %s} $v $reason]
+ }
+ lappend vs $v $v
+ }
+ # Lastly, link the caller's local variables to the class's variables
+ tailcall namespace upvar $ns {*}$vs
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # link --
+ #
+ # Make a command that invokes a method on the current object.
+ # The name of the command and the name of the method match by
+ # default.
+ #
+ # ------------------------------------------------------------------
+
+ proc link {args} {
+ set ns [uplevel 1 {::namespace current}]
+ foreach link $args {
+ if {[llength $link] == 2} {
+ lassign $link src dst
+ } elseif {[llength $link] == 1} {
+ lassign $link src
+ set dst $src
+ } else {
+ return -code error -errorcode {TCLOO CMDLINK FORMAT} \
+ "bad link description; must only have one or two elements"
+ }
+ if {![string match ::* $src]} {
+ set src [string cat $ns :: $src]
+ }
+ interp alias {} $src {} ${ns}::my $dst
+ trace add command ${ns}::my delete [list \
+ ::oo::UnlinkLinkedCommand $src]
+ }
+ return
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # UnlinkLinkedCommand --
+ #
+ # Callback used to remove linked command when the underlying mechanism
+ # that supports it is deleted.
+ #
+ # ----------------------------------------------------------------------
+
+ proc UnlinkLinkedCommand {cmd args} {
+ if {[namespace which $cmd] ne {}} {
+ rename $cmd {}
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # DelegateName --
+ #
+ # Utility that gets the name of the class delegate for a class. It's
+ # trivial, but makes working with them much easier as delegate names are
+ # intentionally hard to create by accident.
+ #
+ # ----------------------------------------------------------------------
+
+ proc DelegateName {class} {
+ string cat [info object namespace $class] {:: oo ::delegate}
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # MixinClassDelegates --
+ #
+ # Support code called *after* [oo::define] inside the constructor of a
+ # class that patches in the appropriate class delegates.
+ #
+ # ----------------------------------------------------------------------
+
+ proc MixinClassDelegates {class} {
+ if {![info object isa class $class]} {
+ return
+ }
+ set delegate [DelegateName $class]
+ if {![info object isa class $delegate]} {
+ return
+ }
+ foreach c [info class superclass $class] {
+ set d [DelegateName $c]
+ if {![info object isa class $d]} {
+ continue
+ }
+ define $delegate superclass -append $d
+ }
+ objdefine $class mixin -append $delegate
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # UpdateClassDelegatesAfterClone --
+ #
+ # Support code that is like [MixinClassDelegates] except for when a
+ # class is cloned.
+ #
+ # ----------------------------------------------------------------------
+
+ proc UpdateClassDelegatesAfterClone {originObject targetObject} {
+ # Rebuild the class inheritance delegation class
+ set originDelegate [DelegateName $originObject]
+ set targetDelegate [DelegateName $targetObject]
+ if {
+ [info object isa class $originDelegate]
+ && ![info object isa class $targetDelegate]
+ } then {
+ copy $originDelegate $targetDelegate
+ objdefine $targetObject mixin -set \
+ {*}[lmap c [info object mixin $targetObject] {
+ if {$c eq $originDelegate} {set targetDelegate} {set c}
+ }]
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::define::classmethod --
+ #
+ # Defines a class method. See define(n) for details.
+ #
+ # Note that the ::oo::define namespace is semi-public and a bit weird
+ # anyway, so we don't regard the namespace path as being under control:
+ # fully qualified names are used for everything.
+ #
+ # ----------------------------------------------------------------------
+
+ proc define::classmethod {name {args {}} {body {}}} {
+ # Create the method on the class if the caller gave arguments and body
+ ::set argc [::llength [::info level 0]]
+ ::if {$argc == 3} {
+ ::return -code error -errorcode {TCL WRONGARGS} [::format \
+ {wrong # args: should be "%s name ?args body?"} \
+ [::lindex [::info level 0] 0]]
+ }
+ ::set cls [::uplevel 1 self]
+ ::if {$argc == 4} {
+ ::oo::define [::oo::DelegateName $cls] method $name $args $body
+ }
+ # Make the connection by forwarding
+ ::tailcall forward $name myclass $name
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::define::initialise, oo::define::initialize --
+ #
+ # Do specific initialisation for a class. See define(n) for details.
+ #
+ # Note that the ::oo::define namespace is semi-public and a bit weird
+ # anyway, so we don't regard the namespace path as being under control:
+ # fully qualified names are used for everything.
+ #
+ # ----------------------------------------------------------------------
+
+ proc define::initialise {body} {
+ ::set clsns [::info object namespace [::uplevel 1 self]]
+ ::tailcall apply [::list {} $body $clsns]
+ }
+
+ # Make the [initialise] definition appear as [initialize] too
+ namespace eval define {
+ ::namespace export initialise
+ ::namespace eval tmp {::namespace import ::oo::define::initialise}
+ ::namespace export -clear
+ ::rename tmp::initialise initialize
+ ::namespace delete tmp
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # Slot --
+ #
+ # The class of slot operations, which are basically lists at the low
+ # level of TclOO; this provides a more consistent interface to them.
+ #
+ # ----------------------------------------------------------------------
+
+ define Slot {
+ # ------------------------------------------------------------------
+ #
+ # Slot Get --
+ #
+ # Basic slot getter. Retrieves the contents of the slot.
+ # Particular slots must provide concrete non-erroring
+ # implementation.
+ #
+ # ------------------------------------------------------------------
+
+ method Get {} {
+ return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # Slot Set --
+ #
+ # Basic slot setter. Sets the contents of the slot. Particular
+ # slots must provide concrete non-erroring implementation.
+ #
+ # ------------------------------------------------------------------
+
+ method Set list {
+ return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # Slot Resolve --
+ #
+ # Helper that lets a slot convert a list of arguments of a
+ # particular type to their canonical forms. Defaults to doing
+ # nothing (suitable for simple strings).
+ #
+ # ------------------------------------------------------------------
+
+ method Resolve list {
+ return $list
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # Slot -set, -append, -clear, --default-operation --
+ #
+ # Standard public slot operations. If a slot can't figure out
+ # what method to call directly, it uses --default-operation.
+ #
+ # ------------------------------------------------------------------
+
+ method -set args {
+ set my [namespace which my]
+ set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
+ tailcall my Set $args
+ }
+ method -append args {
+ set my [namespace which my]
+ set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
+ set current [uplevel 1 [list $my Get]]
+ tailcall my Set [list {*}$current {*}$args]
+ }
+ method -clear {} {tailcall my Set {}}
+ method -prepend args {
+ set my [namespace which my]
+ set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
+ set current [uplevel 1 [list $my Get]]
+ tailcall my Set [list {*}$args {*}$current]
+ }
+ method -remove args {
+ set my [namespace which my]
+ set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
+ set current [uplevel 1 [list $my Get]]
+ tailcall my Set [lmap val $current {
+ if {$val in $args} continue else {set val}
+ }]
+ }
+
+ # Default handling
+ forward --default-operation my -append
+ method unknown {args} {
+ set def --default-operation
+ if {[llength $args] == 0} {
+ tailcall my $def
+ } elseif {![string match -* [lindex $args 0]]} {
+ tailcall my $def {*}$args
+ }
+ next {*}$args
+ }
+
+ # Set up what is exported and what isn't
+ export -set -append -clear -prepend -remove
+ unexport unknown destroy
+ }
+
+ # Set the default operation differently for these slots
+ objdefine define::superclass forward --default-operation my -set
+ objdefine define::mixin forward --default-operation my -set
+ objdefine objdefine::mixin forward --default-operation my -set
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::object <cloned> --
+ #
+ # Handler for cloning objects that clones basic bits (only!) of the
+ # object's namespace. Non-procedures, traces, sub-namespaces, etc. need
+ # more complex (and class-specific) handling.
+ #
+ # ----------------------------------------------------------------------
+
+ define object method <cloned> {originObject} {
+ # Copy over the procedures from the original namespace
+ foreach p [info procs [info object namespace $originObject]::*] {
+ set args [info args $p]
+ set idx -1
+ foreach a $args {
+ if {[info default $p $a d]} {
+ lset args [incr idx] [list $a $d]
+ } else {
+ lset args [incr idx] [list $a]
+ }
+ }
+ set b [info body $p]
+ set p [namespace tail $p]
+ proc $p $args $b
+ }
+ # Copy over the variables from the original namespace
+ foreach v [info vars [info object namespace $originObject]::*] {
+ upvar 0 $v vOrigin
+ namespace upvar [namespace current] [namespace tail $v] vNew
+ if {[info exists vOrigin]} {
+ if {[array exists vOrigin]} {
+ array set vNew [array get vOrigin]
+ } else {
+ set vNew $vOrigin
+ }
+ }
+ }
+ # General commands, sub-namespaces and advancd variable config (traces,
+ # etc) are *not* copied over. Classes that want that should do it
+ # themselves.
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::class <cloned> --
+ #
+ # Handler for cloning classes, which fixes up the delegates.
+ #
+ # ----------------------------------------------------------------------
+
+ define class method <cloned> {originObject} {
+ next $originObject
+ # Rebuild the class inheritance delegation class
+ ::oo::UpdateClassDelegatesAfterClone $originObject [self]
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::singleton --
+ #
+ # A metaclass that is used to make classes that only permit one instance
+ # of them to exist. See singleton(n).
+ #
+ # ----------------------------------------------------------------------
+
+ class create singleton {
+ superclass class
+ variable object
+ unexport create createWithNamespace
+ method new args {
+ if {![info exists object] || ![info object isa object $object]} {
+ set object [next {*}$args]
+ ::oo::objdefine $object {
+ method destroy {} {
+ ::return -code error -errorcode {TCLOO SINGLETON} \
+ "may not destroy a singleton object"
+ }
+ method <cloned> {originObject} {
+ ::return -code error -errorcode {TCLOO SINGLETON} \
+ "may not clone a singleton object"
+ }
+ }
+ }
+ return $object
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::abstract --
+ #
+ # A metaclass that is used to make classes that can't be directly
+ # instantiated. See abstract(n).
+ #
+ # ----------------------------------------------------------------------
+
+ class create abstract {
+ superclass class
+ unexport create createWithNamespace new
+ }
+}
+
+# Local Variables:
+# mode: tcl
+# c-basic-offset: 4
+# fill-column: 78
+# End:
diff --git a/generic/tclObj.c b/generic/tclObj.c
index cd09e61..6a4d161 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -1632,32 +1632,30 @@ Tcl_GetString(
register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be returned. */
{
- if (objPtr->bytes != NULL) {
- return objPtr->bytes;
- }
-
- /*
- * Note we do not check for objPtr->typePtr == NULL. An invariant of
- * a properly maintained Tcl_Obj is that at least one of objPtr->bytes
- * and objPtr->typePtr must not be NULL. If broken extensions fail to
- * maintain that invariant, we can crash here.
- */
-
- if (objPtr->typePtr->updateStringProc == NULL) {
+ if (objPtr->bytes == NULL) {
/*
- * Those Tcl_ObjTypes which choose not to define an updateStringProc
- * must be written in such a way that (objPtr->bytes) never becomes
- * NULL. This panic was added in Tcl 8.1.
+ * Note we do not check for objPtr->typePtr == NULL. An invariant
+ * of a properly maintained Tcl_Obj is that at least one of
+ * objPtr->bytes and objPtr->typePtr must not be NULL. If broken
+ * extensions fail to maintain that invariant, we can crash here.
*/
- Tcl_Panic("UpdateStringProc should not be invoked for type %s",
- objPtr->typePtr->name);
- }
- objPtr->typePtr->updateStringProc(objPtr);
- if (objPtr->bytes == NULL || objPtr->length < 0
- || objPtr->bytes[objPtr->length] != '\0') {
- Tcl_Panic("UpdateStringProc for type '%s' "
- "failed to create a valid string rep", objPtr->typePtr->name);
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ /*
+ * Those Tcl_ObjTypes which choose not to define an
+ * updateStringProc must be written in such a way that
+ * (objPtr->bytes) never becomes NULL.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->bytes == NULL || objPtr->length < 0
+ || objPtr->bytes[objPtr->length] != '\0') {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to create a valid string rep",
+ objPtr->typePtr->name);
+ }
}
return objPtr->bytes;
}
@@ -1693,8 +1691,31 @@ Tcl_GetStringFromObj(
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
- (void) TclGetString(objPtr);
+ if (objPtr->bytes == NULL) {
+ /*
+ * Note we do not check for objPtr->typePtr == NULL. An invariant
+ * of a properly maintained Tcl_Obj is that at least one of
+ * objPtr->bytes and objPtr->typePtr must not be NULL. If broken
+ * extensions fail to maintain that invariant, we can crash here.
+ */
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ /*
+ * Those Tcl_ObjTypes which choose not to define an
+ * updateStringProc must be written in such a way that
+ * (objPtr->bytes) never becomes NULL.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->bytes == NULL || objPtr->length < 0
+ || objPtr->bytes[objPtr->length] != '\0') {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to create a valid string rep",
+ objPtr->typePtr->name);
+ }
+ }
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
}
@@ -2696,7 +2717,7 @@ Tcl_GetIntFromObj(
if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
return TCL_ERROR;
}
- if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) {
+ if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) {
if (interp != NULL) {
const char *s =
"integer value too large to represent as non-long integer";
@@ -2971,7 +2992,7 @@ Tcl_GetLongFromObj(
#else
if (objPtr->typePtr == &tclIntType) {
/*
- * We return any integer in the range -ULONG_MAX to ULONG_MAX
+ * We return any integer in the range LONG_MIN to ULONG_MAX
* converted to a long, ignoring overflow. The rule preserves
* existing semantics for conversion of integers on input, but
* avoids inadvertent demotion of wide integers to 32-bit ones in
@@ -2980,9 +3001,9 @@ Tcl_GetLongFromObj(
Tcl_WideInt w = objPtr->internalRep.wideValue;
- if (w >= -(Tcl_WideInt)(ULONG_MAX)
+ if (w >= (Tcl_WideInt)(LONG_MIN)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
- *longPtr = Tcl_WideAsLong(w);
+ *longPtr = (long) w;
return TCL_OK;
}
goto tooLarge;
@@ -3008,10 +3029,9 @@ Tcl_GetLongFromObj(
mp_int big;
UNPACK_BIGNUM(objPtr, big);
- if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)
+ if ((size_t) big.used <= (CHAR_BIT * sizeof(unsigned long) + DIGIT_BIT - 1)
/ DIGIT_BIT) {
- unsigned long value = 0, numBytes = sizeof(long);
- long scratch;
+ unsigned long scratch, value = 0, numBytes = sizeof(unsigned long);
unsigned char *bytes = (unsigned char *) &scratch;
if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
@@ -3019,11 +3039,16 @@ Tcl_GetLongFromObj(
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
- *longPtr = - (long) value;
+ if (value <= 1 + (unsigned long)LONG_MAX) {
+ *longPtr = - (long) value;
+ return TCL_OK;
+ }
} else {
- *longPtr = (long) value;
+ if (value <= (unsigned long)ULONG_MAX) {
+ *longPtr = (long) value;
+ return TCL_OK;
+ }
}
- return TCL_OK;
}
}
#ifndef TCL_WIDE_INT_IS_LONG
@@ -3258,11 +3283,16 @@ Tcl_GetWideIntFromObj(
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
- *wideIntPtr = - (Tcl_WideInt) value;
+ if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) {
+ *wideIntPtr = - (Tcl_WideInt) value;
+ return TCL_OK;
+ }
} else {
- *wideIntPtr = (Tcl_WideInt) value;
+ if (value <= (Tcl_WideUInt)WIDE_MAX) {
+ *wideIntPtr = (Tcl_WideInt) value;
+ return TCL_OK;
+ }
}
- return TCL_OK;
}
}
if (interp != NULL) {
@@ -3282,6 +3312,70 @@ Tcl_GetWideIntFromObj(
/*
*----------------------------------------------------------------------
*
+ * TclGetWideBitsFromObj --
+ *
+ * Attempt to return a wide integer from the Tcl object "objPtr". If the
+ * object is not already a int, double or bignum, an attempt will be made
+ * to convert it to one of these. Out-of-range values don't result in an
+ * error, but only the least significant 64 bits will be returned.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already an int, double or bignum object, the
+ * conversion will free any old internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetWideBitsFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* Object from which to get a wide int. */
+ Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */
+{
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ *wideIntPtr = objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected integer but got \"%s\"",
+ TclGetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ mp_int big;
+
+ Tcl_WideUInt value = 0, scratch;
+ unsigned long numBytes = sizeof(Tcl_WideInt);
+ unsigned char *bytes = (unsigned char *) &scratch;
+
+ Tcl_GetBignumFromObj(NULL, objPtr, &big);
+ mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big);
+ mp_to_unsigned_bin_n(&big, bytes, &numBytes);
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value;
+ mp_clear(&big);
+ return TCL_OK;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* FreeBignum --
*
* This function frees the internal rep of a bignum.
@@ -3650,7 +3744,7 @@ Tcl_SetBignumObj(
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
- if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) {
+ if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) {
goto tooLargeForWide;
}
if (bignumValue->sign) {
@@ -3743,7 +3837,7 @@ TclGetNumberFromObj(
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- *typePtr = TCL_NUMBER_WIDE;
+ *typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
diff --git a/generic/tclParse.c b/generic/tclParse.c
index a2227f7..00b83a1 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -979,7 +979,12 @@ TclParseBackslash(
if (readPtr != NULL) {
*readPtr = count;
}
- return Tcl_UniCharToUtf(result, dst);
+ count = Tcl_UniCharToUtf(result, dst);
+ if (!count) {
+ /* Special case for handling upper surrogates. */
+ count = Tcl_UniCharToUtf(-1, dst);
+ }
+ return count;
}
/*
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 223ef93..2c16458 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -577,7 +577,7 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
- int availStable, satisfies;
+ int availStable, satisfies;
Require *reqPtr = data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = data[2];
diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c
index 9e194c8..96b6962 100644
--- a/generic/tclPkgConfig.c
+++ b/generic/tclPkgConfig.c
@@ -105,6 +105,8 @@ static Tcl_Config const cfg[] = {
{"scriptdir,runtime", CFG_RUNTIME_SCRDIR},
{"includedir,runtime", CFG_RUNTIME_INCDIR},
{"docdir,runtime", CFG_RUNTIME_DOCDIR},
+ {"dllfile,runtime", CFG_RUNTIME_DLLFILE},
+ {"zipfile,runtime", CFG_RUNTIME_ZIPFILE},
/* Installation paths to various stuff */
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 12a60db..d3f6233 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -24,20 +24,8 @@
#endif
#include "tcl.h"
-#if !defined(LLONG_MIN)
-# ifdef TCL_WIDE_INT_IS_LONG
-# define LLONG_MIN LONG_MIN
-# else
-# ifdef LLONG_BIT
-# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1)))
-# else
-/* Assume we're on a system with a 64-bit 'long long' type */
-# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63))
-# endif
-# endif
-/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */
-# define LLONG_MAX (~LLONG_MIN)
-#endif
-
+#define UWIDE_MAX ((Tcl_WideUInt)-1)
+#define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1))
+#define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1))
#endif /* _TCLPORT */
diff --git a/generic/tclProc.c b/generic/tclProc.c
index b0a3ee1..f1822a2 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -540,10 +540,11 @@ TclCreateProc(
goto procError;
}
- nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length);
+ argname = Tcl_GetStringFromObj(fieldValues[0], &plen);
+ nameLength = Tcl_NumUtfChars(argname, plen);
if (fieldCount == 2) {
- valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]),
- fieldValues[1]->length);
+ const char * value = TclGetString(fieldValues[1]);
+ valueLength = Tcl_NumUtfChars(value, fieldValues[1]->length);
} else {
valueLength = 0;
}
@@ -552,7 +553,6 @@ TclCreateProc(
* Check that the formal parameter name is a scalar.
*/
- argname = Tcl_GetStringFromObj(fieldValues[0], &plen);
argnamei = argname;
argnamelast = argname[plen-1];
while (plen--) {
@@ -646,7 +646,7 @@ TclCreateProc(
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
- localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length);
+ localPtr->nameLength = nameLength;
localPtr->frameIndex = i;
localPtr->flags = VAR_ARGUMENT;
localPtr->resolveInfo = NULL;
@@ -723,51 +723,15 @@ TclGetFrame(
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
- register Interp *iPtr = (Interp *) interp;
- int curLevel, level, result;
- CallFrame *framePtr;
-
- /*
- * Parse string to figure out which level number to go to.
- */
-
- result = 1;
- curLevel = iPtr->varFramePtr->level;
- if (*name== '#') {
- if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
- goto levelError;
- }
- } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
- if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
- goto levelError;
- }
- level = curLevel - level;
- } else {
- level = curLevel - 1;
- result = 0;
- }
-
- /*
- * Figure out which frame to use, and return it to the caller.
- */
-
- for (framePtr = iPtr->varFramePtr; framePtr != NULL;
- framePtr = framePtr->callerVarPtr) {
- if (framePtr->level == level) {
- break;
- }
- }
- if (framePtr == NULL) {
- goto levelError;
- }
-
- *framePtrPtr = framePtr;
- return result;
-
- levelError:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
- return -1;
+ int result;
+ Tcl_Obj obj;
+
+ obj.bytes = (char *) name;
+ obj.length = strlen(name);
+ obj.typePtr = NULL;
+ result = TclObjGetFrame(interp, &obj, framePtrPtr);
+ TclFreeIntRep(&obj);
+ return result;
}
/*
@@ -806,6 +770,7 @@ TclObjGetFrame(
int curLevel, level, result;
const Tcl_ObjIntRep *irPtr;
const char *name = NULL;
+ Tcl_WideInt w;
/*
* Parse object to figure out which level number to go to.
@@ -821,26 +786,34 @@ TclObjGetFrame(
if (objPtr == NULL) {
/* Do nothing */
- } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)
- && (level >= 0)) {
- level = curLevel - level;
- result = 1;
+ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) {
+ Tcl_GetWideIntFromObj(NULL, objPtr, &w);
+ if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) {
+ result = -1;
+ } else {
+ level = curLevel - level;
+ result = 1;
+ }
} else if ((irPtr = Tcl_FetchIntRep(objPtr, &levelReferenceType))) {
level = irPtr->wideValue;
result = 1;
} else {
name = TclGetString(objPtr);
if (name[0] == '#') {
- if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) {
- Tcl_ObjIntRep ir;
-
- ir.wideValue = level;
- Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir);
- result = 1;
+ if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) {
+ if (level < 0 || (level > 0 && name[1] == '-')) {
+ result = -1;
+ } else {
+ Tcl_ObjIntRep ir;
+
+ ir.wideValue = level;
+ Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir);
+ result = 1;
+ }
} else {
result = -1;
}
- } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */
+ } else if (TclGetWideBitsFromObj(interp, objPtr, &w) == TCL_OK) {
/*
* If this were an integer, we'd have succeeded already.
* Docs say we have to treat this as a 'bad level' error.
@@ -851,7 +824,6 @@ TclObjGetFrame(
if (result == 0) {
level = curLevel - 1;
- name = "1";
}
if (result != -1) {
if (level >= 0) {
@@ -864,11 +836,11 @@ TclObjGetFrame(
}
}
}
- if (name == NULL) {
- name = TclGetString(objPtr);
- }
}
+ if (name == NULL) {
+ name = TclGetString(objPtr);
+ }
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL);
return -1;
@@ -1072,7 +1044,6 @@ ProcWrongNumArgs(
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
- register Var *defPtr;
int localCt = procPtr->numCompiledLocals, numArgs, i;
Tcl_Obj **desiredObjs;
const char *final = NULL;
@@ -1096,23 +1067,26 @@ ProcWrongNumArgs(
}
Tcl_IncrRefCount(desiredObjs[0]);
- defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
- for (i=1 ; i<=numArgs ; i++, defPtr++) {
- Tcl_Obj *argObj;
- Tcl_Obj *namePtr = localName(framePtr, i-1);
-
- if (defPtr->value.objPtr != NULL) {
- TclNewObj(argObj);
- Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
- } else if (defPtr->flags & VAR_IS_ARGS) {
- numArgs--;
- final = "?arg ...?";
- break;
- } else {
- argObj = namePtr;
- Tcl_IncrRefCount(namePtr);
+ if (localCt > 0) {
+ register Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
+
+ for (i=1 ; i<=numArgs ; i++, defPtr++) {
+ Tcl_Obj *argObj;
+ Tcl_Obj *namePtr = localName(framePtr, i-1);
+
+ if (defPtr->value.objPtr != NULL) {
+ TclNewObj(argObj);
+ Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
+ } else if (defPtr->flags & VAR_IS_ARGS) {
+ numArgs--;
+ final = "?arg ...?";
+ break;
+ } else {
+ argObj = namePtr;
+ Tcl_IncrRefCount(namePtr);
+ }
+ desiredObjs[i] = argObj;
}
- desiredObjs[i] = argObj;
}
Tcl_ResetResult(interp);
diff --git a/generic/tclProcess.c b/generic/tclProcess.c
index 604b7ce..a781386 100644
--- a/generic/tclProcess.c
+++ b/generic/tclProcess.c
@@ -1,7 +1,7 @@
/*
* tclProcess.c --
*
- * This file implements the "tcl::process" ensemble for subprocess
+ * This file implements the "tcl::process" ensemble for subprocess
* management as defined by TIP #462.
*
* Copyright (c) 2017 Frederic Bonnet.
@@ -13,14 +13,14 @@
#include "tclInt.h"
/*
- * Autopurge flag. Process-global because of the way Tcl manages child
+ * Autopurge flag. Process-global because of the way Tcl manages child
* processes (see tclPipe.c).
*/
static int autopurge = 1; /* Autopurge flag. */
/*
- * Hash tables that keeps track of all child process statuses. Keys are the
+ * Hash tables that keeps track of all child process statuses. Keys are the
* child process ids and resolved pids, values are (ProcessInfo *).
*/
@@ -29,7 +29,7 @@ typedef struct ProcessInfo {
int resolvedPid; /* Resolved process id. */
int purge; /* Purge eventualy. */
TclProcessWaitStatus status;/* Process status. */
- int code; /* Error code, exit status or signal
+ int code; /* Error code, exit status or signal
number. */
Tcl_Obj *msg; /* Error message. */
Tcl_Obj *error; /* Error code. */
@@ -47,7 +47,7 @@ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
int resolvedPid);
static void FreeProcessInfo(ProcessInfo *info);
static int RefreshProcessInfo(ProcessInfo *info, int options);
-static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid,
+static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid,
int options, int *codePtr, Tcl_Obj **msgPtr,
Tcl_Obj **errorObjPtr);
static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info);
@@ -160,7 +160,7 @@ RefreshProcessInfo(
* Refresh & store status.
*/
- info->status = WaitProcessStatus(info->pid, info->resolvedPid,
+ info->status = WaitProcessStatus(info->pid, info->resolvedPid,
options, &info->code, &info->msg, &info->error);
if (info->msg) Tcl_IncrRefCount(info->msg);
if (info->error) Tcl_IncrRefCount(info->error);
@@ -214,7 +214,7 @@ WaitProcessStatus(
/*
* No change.
*/
-
+
return TCL_PROCESS_UNCHANGED;
}
@@ -370,7 +370,7 @@ BuildProcessStatusObj(
/*
* Normal exit, return TCL_OK.
*/
-
+
return Tcl_NewIntObj(TCL_OK);
}
@@ -388,7 +388,7 @@ BuildProcessStatusObj(
*
* ProcessListObjCmd --
*
- * This function implements the 'tcl::process list' Tcl command.
+ * This function implements the 'tcl::process list' Tcl command.
* Refer to the user documentation for details on what it does.
*
* Results:
@@ -423,10 +423,10 @@ ProcessListObjCmd(
list = Tcl_NewListObj(0, NULL);
Tcl_MutexLock(&infoTablesMutex);
- for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
info = (ProcessInfo *) Tcl_GetHashValue(entry);
- Tcl_ListObjAppendElement(interp, list,
+ Tcl_ListObjAppendElement(interp, list,
Tcl_NewIntObj(info->resolvedPid));
}
Tcl_MutexUnlock(&infoTablesMutex);
@@ -438,7 +438,7 @@ ProcessListObjCmd(
*
* ProcessStatusObjCmd --
*
- * This function implements the 'tcl::process status' Tcl command.
+ * This function implements the 'tcl::process status' Tcl command.
* Refer to the user documentation for details on what it does.
*
* Results:
@@ -504,7 +504,7 @@ ProcessStatusObjCmd(
dict = Tcl_NewDictObj();
Tcl_MutexLock(&infoTablesMutex);
- for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
info = (ProcessInfo *) Tcl_GetHashValue(entry);
RefreshProcessInfo(info, options);
@@ -513,7 +513,7 @@ ProcessStatusObjCmd(
/*
* Purge entry.
*/
-
+
Tcl_DeleteHashEntry(entry);
entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
Tcl_DeleteHashEntry(entry);
@@ -523,7 +523,7 @@ ProcessStatusObjCmd(
* Add to result.
*/
- Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid),
+ Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid),
BuildProcessStatusObj(info));
}
}
@@ -532,7 +532,7 @@ ProcessStatusObjCmd(
/*
* Only return statuses of provided processes.
*/
-
+
result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
if (result != TCL_OK) {
return result;
@@ -552,10 +552,10 @@ ProcessStatusObjCmd(
/*
* Skip unknown process.
*/
-
+
continue;
}
-
+
info = (ProcessInfo *) Tcl_GetHashValue(entry);
RefreshProcessInfo(info, options);
@@ -563,7 +563,7 @@ ProcessStatusObjCmd(
/*
* Purge entry.
*/
-
+
Tcl_DeleteHashEntry(entry);
entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
Tcl_DeleteHashEntry(entry);
@@ -573,7 +573,7 @@ ProcessStatusObjCmd(
* Add to result.
*/
- Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid),
+ Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid),
BuildProcessStatusObj(info));
}
}
@@ -587,7 +587,7 @@ ProcessStatusObjCmd(
*
* ProcessPurgeObjCmd --
*
- * This function implements the 'tcl::process purge' Tcl command.
+ * This function implements the 'tcl::process purge' Tcl command.
* Refer to the user documentation for details on what it does.
*
* Results:
@@ -632,7 +632,7 @@ ProcessPurgeObjCmd(
*/
Tcl_MutexLock(&infoTablesMutex);
- for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
info = (ProcessInfo *) Tcl_GetHashValue(entry);
if (info->purge) {
@@ -647,7 +647,7 @@ ProcessPurgeObjCmd(
/*
* Purge only provided processes.
*/
-
+
result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
if (result != TCL_OK) {
return result;
@@ -665,7 +665,7 @@ ProcessPurgeObjCmd(
/*
* Skip unknown process.
*/
-
+
continue;
}
@@ -687,7 +687,7 @@ ProcessPurgeObjCmd(
*
* ProcessAutopurgeObjCmd --
*
- * This function implements the 'tcl::process autopurge' Tcl command.
+ * This function implements the 'tcl::process autopurge' Tcl command.
* Refer to the user documentation for details on what it does.
*
* Results:
@@ -715,7 +715,7 @@ ProcessAutopurgeObjCmd(
/*
* Set given value.
*/
-
+
int flag;
int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag);
if (result != TCL_OK) {
@@ -725,8 +725,8 @@ ProcessAutopurgeObjCmd(
autopurge = !!flag;
}
- /*
- * Return current value.
+ /*
+ * Return current value.
*/
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
@@ -821,9 +821,9 @@ TclProcessCreated(
/*
* Pid was reused, free old info and reuse structure.
*/
-
+
info = (ProcessInfo *) Tcl_GetHashValue(entry);
- entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid,
+ entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid,
INT2PTR(resolvedPid));
if (entry2) Tcl_DeleteHashEntry(entry2);
FreeProcessInfo(info);
@@ -893,8 +893,8 @@ TclProcessWait(
/*
* Unknown process, just call WaitProcessStatus and return.
*/
-
- result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr,
+
+ result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr,
msgObjPtr, errorObjPtr);
if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
@@ -909,7 +909,7 @@ TclProcessWait(
* so report no change.
*/
Tcl_MutexUnlock(&infoTablesMutex);
-
+
return TCL_PROCESS_UNCHANGED;
}
@@ -919,7 +919,7 @@ TclProcessWait(
* No change, stop there.
*/
Tcl_MutexUnlock(&infoTablesMutex);
-
+
return TCL_PROCESS_UNCHANGED;
}
@@ -940,7 +940,7 @@ TclProcessWait(
*/
Tcl_DeleteHashEntry(entry);
- entry = Tcl_FindHashEntry(&infoTablePerResolvedPid,
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid,
INT2PTR(info->resolvedPid));
Tcl_DeleteHashEntry(entry);
FreeProcessInfo(info);
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 3ab3ce6..da6a52f 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -926,9 +926,9 @@ Tcl_ScanObjCmd(
}
if (flags & SCAN_LONGER) {
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
- wideValue = LLONG_MAX;
+ wideValue = WIDE_MAX;
if (TclGetString(objPtr)[0] == '-') {
- wideValue = LLONG_MIN;
+ wideValue = WIDE_MIN;
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index fdbc157..7be74ca 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -490,7 +490,7 @@ TclCheckEmptyString(
Tcl_DictObjSize(NULL, objPtr, &length);
return length == 0;
}
-
+
if (objPtr->bytes == NULL) {
return TCL_EMPTYSTRING_UNKNOWN;
}
@@ -606,6 +606,8 @@ Tcl_GetUniChar(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_GetUnicode
Tcl_UniChar *
Tcl_GetUnicode(
Tcl_Obj *objPtr) /* The object to find the unicode string
@@ -613,6 +615,7 @@ Tcl_GetUnicode(
{
return Tcl_GetUnicodeFromObj(objPtr, NULL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1901,6 +1904,11 @@ Tcl_AppendFormatToObj(
width = 0;
if (isdigit(UCHAR(ch))) {
width = strtoul(format, &end, 10);
+ if (width < 0) {
+ msg = overflow;
+ errCode = "OVERFLOW";
+ goto errorMsg;
+ }
format = end;
step = TclUtfToUniChar(format, &ch);
} else if (ch == '*') {
@@ -2040,6 +2048,10 @@ Tcl_AppendFormatToObj(
goto error;
}
length = Tcl_UniCharToUtf(code, buf);
+ if (!length) {
+ /* Special case for handling upper surrogates. */
+ length = Tcl_UniCharToUtf(-1, buf);
+ }
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
@@ -2085,35 +2097,17 @@ Tcl_AppendFormatToObj(
}
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
- if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
- Tcl_Obj *objPtr;
-
- if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
- goto error;
- }
- mp_mod_2d(&big, (int) CHAR_BIT*sizeof(Tcl_WideInt), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetWideIntFromObj(NULL, objPtr, &w);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
+ goto error;
}
isNegative = (w < (Tcl_WideInt) 0);
if (w == (Tcl_WideInt) 0) gotHash = 0;
#endif
} else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
- if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
- Tcl_Obj *objPtr;
-
- if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
- goto error;
- }
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &l);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
+ goto error;
} else {
- l = Tcl_WideAsLong(w);
+ l = (long) w;
}
if (useShort) {
s = (short) l;
@@ -3058,15 +3052,21 @@ TclStringCat(
* Result will be pure byte array. Pre-size it
*/
+ int numBytes;
ov = objv;
oc = objc;
do {
Tcl_Obj *objPtr = *ov++;
- if (objPtr->bytes == NULL) {
- int numBytes;
+ /*
+ * Every argument is either a bytearray with a ("pure")
+ * value we know we can safely use, or it is an empty string.
+ * We don't need to count bytes for the empty strings.
+ */
+ if (TclIsPureByteArray(objPtr)) {
Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */
+
if (numBytes) {
last = objc - oc;
if (length == 0) {
@@ -3218,7 +3218,13 @@ TclStringCat(
while (objc--) {
Tcl_Obj *objPtr = *objv++;
- if (objPtr->bytes == NULL) {
+ /*
+ * Every argument is either a bytearray with a ("pure")
+ * value we know we can safely use, or it is an empty string.
+ * We don't need to copy bytes from the empty strings.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
int more;
unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
memcpy(dst, src, (size_t) more);
@@ -3549,7 +3555,7 @@ TclStringFirst(
start = 0;
}
if (ln == 0) {
- /* We don't find empty substrings. Bizarre!
+ /* We don't find empty substrings. Bizarre!
* Whenever this routine is turned into a proper substring
* finder, change to `return start` after limits imposed. */
return -1;
@@ -3946,7 +3952,7 @@ TclStringReplace(
result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes);
/* PANIC? */
Tcl_SetByteArrayLength(result, 0);
- TclAppendBytesToByteArray(result, bytes, first);
+ TclAppendBytesToByteArray(result, bytes, first);
TclAppendBytesToByteArray(result, iBytes, newBytes);
TclAppendBytesToByteArray(result, bytes + first + count,
numBytes - count - first);
@@ -3968,7 +3974,7 @@ TclStringReplace(
Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars);
/* TODO: Is there an in-place option worth pursuing here? */
-
+
result = Tcl_NewUnicodeObj(ustring, first);
if (insertPtr) {
Tcl_AppendObjToObj(result, insertPtr);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index c6e9dc5..4c9d3e8 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -12,6 +12,10 @@
#include "tclInt.h"
#include "tommath.h"
+#ifdef __CYGWIN__
+# include <wchar.h>
+#endif
+
#ifdef __GNUC__
#pragma GCC dependency "tcl.decls"
#pragma GCC dependency "tclInt.decls"
@@ -34,6 +38,7 @@
#undef Tcl_DbNewLongObj
#undef Tcl_NewObj
#undef Tcl_NewStringObj
+#undef Tcl_GetUnicode
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
@@ -224,17 +229,11 @@ Tcl_WinUtfToTChar(
int len,
Tcl_DString *dsPtr)
{
- WCHAR *wp;
- int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0);
-
Tcl_DStringInit(dsPtr);
- Tcl_DStringSetLength(dsPtr, 2*size+2);
- wp = (WCHAR *)Tcl_DStringValue(dsPtr);
- MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1);
- if (len == -1) --size; /* account for 0-byte at string end */
- Tcl_DStringSetLength(dsPtr, 2*size);
- wp[size] = 0;
- return (char *)wp;
+ if (!string) {
+ return NULL;
+ }
+ return (char *)Tcl_UtfToUniCharDString(string, len, dsPtr);
}
char *
@@ -243,21 +242,16 @@ Tcl_WinTCharToUtf(
int len,
Tcl_DString *dsPtr)
{
- char *p;
- int size;
-
- if (len > 0) {
+ Tcl_DStringInit(dsPtr);
+ if (!string) {
+ return NULL;
+ }
+ if (len < 0) {
+ len = wcslen((wchar_t *)string);
+ } else {
len /= 2;
}
- size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL);
- Tcl_DStringInit(dsPtr);
- Tcl_DStringSetLength(dsPtr, size+1);
- p = (char *)Tcl_DStringValue(dsPtr);
- WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL);
- if (len == -1) --size; /* account for 0-byte at string end */
- Tcl_DStringSetLength(dsPtr, size);
- p[size] = 0;
- return p;
+ return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr);
}
#if defined(TCL_WIDE_INT_IS_LONG)
@@ -270,7 +264,7 @@ static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
long longValue;
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
- if ((longValue >= -(long)(UINT_MAX))
+ if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
@@ -286,7 +280,7 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
long longValue;
int result = Tcl_ExprLongObj(interp, expr, &longValue);
if (result == TCL_OK) {
- if ((longValue >= -(long)(UINT_MAX))
+ if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
@@ -402,6 +396,7 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig
# define TclpGmtime 0
# define TclpLocaltime_unix 0
# define TclpGmtime_unix 0
+# define Tcl_GetUnicode 0
#else /* TCL_NO_DEPRECATED */
# define Tcl_SeekOld seekOld
# define Tcl_TellOld tellOld
@@ -429,20 +424,14 @@ seekOld(
int offset, /* Offset to seek to. */
int mode) /* Relative to which location to seek? */
{
- Tcl_WideInt wOffset, wResult;
-
- wOffset = Tcl_LongAsWide((long) offset);
- wResult = Tcl_Seek(chan, wOffset, mode);
- return (int) Tcl_WideAsLong(wResult);
+ return Tcl_Seek(chan, offset, mode);
}
static int
tellOld(
Tcl_Channel chan) /* The channel to return pos for. */
{
- Tcl_WideInt wResult = Tcl_Tell(chan);
-
- return (int) Tcl_WideAsLong(wResult);
+ return Tcl_Tell(chan);
}
#endif /* !TCL_NO_DEPRECATED */
@@ -920,6 +909,7 @@ const TclTomMathStubs tclTomMathStubs = {
TclBN_mp_get_long_long, /* 69 */
TclBN_mp_set_long, /* 70 */
TclBN_mp_get_long, /* 71 */
+ TclBN_mp_get_int, /* 72 */
};
static const TclStubHooks tclStubHooks = {
@@ -1587,11 +1577,15 @@ const TclStubs tclStubs = {
Tcl_FSUnloadFile, /* 629 */
Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
Tcl_OpenTcpServerEx, /* 631 */
- Tcl_FreeIntRep, /* 632 */
- Tcl_InitStringRep, /* 633 */
- Tcl_FetchIntRep, /* 634 */
- Tcl_StoreIntRep, /* 635 */
- Tcl_HasStringRep, /* 636 */
+ TclZipfs_Mount, /* 632 */
+ TclZipfs_Unmount, /* 633 */
+ TclZipfs_TclLibrary, /* 634 */
+ TclZipfs_MountBuffer, /* 635 */
+ Tcl_FreeIntRep, /* 636 */
+ Tcl_InitStringRep, /* 637 */
+ Tcl_FetchIntRep, /* 638 */
+ Tcl_StoreIntRep, /* 639 */
+ Tcl_HasStringRep, /* 640 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 57056ab..f680ff5 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -293,6 +293,8 @@ static int TestgetassocdataCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestgetintCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
+static int TestlongsizeCmd(ClientData dummy,
+ Tcl_Interp *interp, int argc, const char **argv);
static int TestgetplatformCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestgetvarfullnameCmd(
@@ -645,6 +647,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateCommand(interp, "testgetint", TestgetintCmd,
NULL, NULL);
+ Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd,
+ NULL, NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
@@ -2828,7 +2832,7 @@ TestlinkCmd(
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
- static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
+ static Tcl_WideInt wideVar = 79;
static char *stringVar = NULL;
static char charVar = '@';
static unsigned char ucharVar = 130;
@@ -2838,7 +2842,7 @@ TestlinkCmd(
static long longVar = 123456789L;
static unsigned long ulongVar = 3456789012UL;
static float floatVar = 4.5;
- static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123);
+ static Tcl_WideUInt uwideVar = 123;
static int created = 0;
char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
@@ -6936,6 +6940,24 @@ TestgetintCmd(
}
}
+/*
+ * Used for determining sizeof(long) at script level.
+ */
+static int
+TestlongsizeCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int argc,
+ const char **argv)
+{
+ if (argc != 1) {
+ Tcl_AppendResult(interp, "wrong # args", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj((int)sizeof(long)));
+ return TCL_OK;
+}
+
static int
NREUnwind_callback(
ClientData data[],
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 3a6fc43..1742eb7 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -174,7 +174,6 @@ TclThread_Init(
Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL);
return TCL_OK;
}
-
/*
*----------------------------------------------------------------------
@@ -1158,6 +1157,14 @@ ThreadExitProc(
Tcl_MutexLock(&threadMutex);
+ if (self == errorThreadId) {
+ if (errorProcString) { /* Extra safety */
+ ckfree(errorProcString);
+ errorProcString = NULL;
+ }
+ errorThreadId = 0;
+ }
+
if (threadEvalScript) {
ckfree(threadEvalScript);
threadEvalScript = NULL;
diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls
index 10df919..56ab55f 100644
--- a/generic/tclTomMath.decls
+++ b/generic/tclTomMath.decls
@@ -250,6 +250,9 @@ declare 70 {
declare 71 {
unsigned long TclBN_mp_get_long(const mp_int *a)
}
+declare 72 {
+ unsigned long TclBN_mp_get_int(const mp_int *a)
+}
# Local Variables:
# mode: tcl
diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h
index f3145d7..9fc034f 100644
--- a/generic/tclTomMathDecls.h
+++ b/generic/tclTomMathDecls.h
@@ -98,7 +98,6 @@
#define mp_radix_size TclBN_mp_radix_size
#define mp_read_radix TclBN_mp_read_radix
#define mp_rshd TclBN_mp_rshd
-#define mp_s_rmap TclBNMpSRmap
#define mp_set TclBN_mp_set
#define mp_set_int TclBN_mp_set_int
#define mp_set_long TclBN_mp_set_long
@@ -324,6 +323,8 @@ EXTERN Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a);
EXTERN int TclBN_mp_set_long(mp_int *a, unsigned long i);
/* 71 */
EXTERN unsigned long TclBN_mp_get_long(const mp_int *a);
+/* 72 */
+EXTERN unsigned long TclBN_mp_get_int(const mp_int *a);
typedef struct TclTomMathStubs {
int magic;
@@ -401,6 +402,7 @@ typedef struct TclTomMathStubs {
Tcl_WideUInt (*tclBN_mp_get_long_long) (const mp_int *a); /* 69 */
int (*tclBN_mp_set_long) (mp_int *a, unsigned long i); /* 70 */
unsigned long (*tclBN_mp_get_long) (const mp_int *a); /* 71 */
+ unsigned long (*tclBN_mp_get_int) (const mp_int *a); /* 72 */
} TclTomMathStubs;
extern const TclTomMathStubs *tclTomMathStubsPtr;
@@ -559,6 +561,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
(tclTomMathStubsPtr->tclBN_mp_set_long) /* 70 */
#define TclBN_mp_get_long \
(tclTomMathStubsPtr->tclBN_mp_get_long) /* 71 */
+#define TclBN_mp_get_int \
+ (tclTomMathStubsPtr->tclBN_mp_get_int) /* 72 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 693e210..ce67db7 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -173,6 +173,13 @@ Tcl_UniCharToUtf(
buf[0] = (char) ((ch >> 18) | 0xF0);
return 4;
}
+ } else if (ch == -1) {
+ if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80)
+ && ((buf[2] & 0xCF) == 0)) {
+ ch = 0xD7C0 + ((buf[0] & 0x07) << 8) + ((buf[1] & 0x3F) << 2)
+ + ((buf[2] & 0x30) >> 4);
+ goto three;
+ }
}
ch = 0xFFFD;
@@ -211,22 +218,31 @@ Tcl_UniCharToUtfDString(
{
const Tcl_UniChar *w, *wEnd;
char *p, *string;
- int oldLength;
+ int oldLength, len = 1;
/*
* UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
oldLength = Tcl_DStringLength(dsPtr);
- Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * 4);
+ Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
wEnd = uniStr + uniLength;
for (w = uniStr; w < wEnd; ) {
- p += Tcl_UniCharToUtf(*w, p);
+ if (!len && ((*w & 0xFC00) != 0xDC00)) {
+ /* Special case for handling upper surrogates. */
+ p += Tcl_UniCharToUtf(-1, p);
+ }
+ len = Tcl_UniCharToUtf(*w, p);
+ p += len;
w++;
}
+ if (!len) {
+ /* Special case for handling upper surrogates. */
+ p += Tcl_UniCharToUtf(-1, p);
+ }
Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
return string;
@@ -418,20 +434,32 @@ Tcl_UtfToUniCharDString(
*/
oldLength = Tcl_DStringLength(dsPtr);
-/* TODO: fix overreach! */
+
Tcl_DStringSetLength(dsPtr,
- (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar)));
+ oldLength + (int) ((length + 1) * sizeof(Tcl_UniChar)));
wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
- end = src + length;
- for (p = src; p < end; ) {
+ p = src;
+ end = src + length - 4;
+ while (p < end) {
p += TclUtfToUniChar(p, &ch);
*w++ = ch;
}
+ end += 4;
+ while (p < end) {
+ 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];
+ } else {
+ ch = UCHAR(*p++);
+ }
+ *w++ = ch;
+ }
*w = '\0';
Tcl_DStringSetLength(dsPtr,
- (oldLength + ((char *) w - (char *) wString)));
+ oldLength + ((char *) w - (char *) wString));
return wString;
}
@@ -755,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.
@@ -892,7 +920,7 @@ Tcl_UtfToUpper(
* char to dst if its size is <= the original char.
*/
- if (bytes < TclUtfCount(upChar)) {
+ if ((bytes < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
@@ -955,7 +983,7 @@ Tcl_UtfToLower(
* char to dst if its size is <= the original char.
*/
- if (bytes < TclUtfCount(lowChar)) {
+ if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
@@ -1015,7 +1043,7 @@ Tcl_UtfToTitle(
#endif
titleChar = Tcl_UniCharToTitle(titleChar);
- if (bytes < TclUtfCount(titleChar)) {
+ if ((bytes < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
@@ -1039,7 +1067,7 @@ Tcl_UtfToTitle(
lowChar = Tcl_UniCharToLower(lowChar);
}
- if (bytes < TclUtfCount(lowChar)) {
+ if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 9136c21..97ddea7 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclParse.h"
#include "tclStringTrim.h"
+#include "tommath.h"
#include <math.h>
/*
@@ -107,9 +108,13 @@ static Tcl_ThreadDataKey precisionKey;
static void ClearHash(Tcl_HashTable *tablePtr);
static void FreeProcessGlobalValue(ClientData clientData);
static void FreeThreadHash(ClientData clientData);
+static int GetEndOffsetFromObj(Tcl_Obj *objPtr,
+ Tcl_WideInt endValue, Tcl_WideInt *indexPtr);
static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr);
-static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue,
- int *indexPtr);
+static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_WideInt endValue, Tcl_WideInt *widePtr);
+static int SetEndOffsetFromAny(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
static int FindElement(Tcl_Interp *interp, const char *string,
int stringLength, const char *typeStr,
const char *typeCode, const char **elementPtr,
@@ -118,7 +123,7 @@ static int FindElement(Tcl_Interp *interp, const char *string,
/*
* The following is the Tcl object type definition for an object that
* represents a list index in the form, "end-offset". It is used as a
- * performance optimization in TclGetIntForIndex. The internal rep is
+ * performance optimization in TclGetIntForIndex. The internal rep is
* stored directly in the wideValue, so no memory management is required
* for it. This is a caching intrep, keeping the result of a parse
* around. This type is only created from a pre-existing string, so an
@@ -1671,7 +1676,7 @@ UtfWellFormedEnd(
if (Tcl_UtfCharComplete(p, l - p)) {
return bytes;
}
- /*
+ /*
* Malformed utf-8 end, be sure we've NTS to safe compare of end-character,
* avoid segfault by access violation out of range.
*/
@@ -3652,6 +3657,204 @@ TclFormatInt(
/*
*----------------------------------------------------------------------
*
+ * GetWideForIndex --
+ *
+ * This function produces a wide integer value corresponding to the
+ * list index held in *objPtr. The parsing supports all values
+ * recognized as any size of integer, and the syntaxes end[-+]$integer
+ * and $integer[-+]$integer. The argument endValue is used to give
+ * the meaning of the literal index value "end".
+ *
+ * Results:
+ * When parsing of *objPtr successfully recognizes an index value,
+ * TCL_OK is returned, and the wide integer value corresponding to
+ * the recognized index value is written to *widePtr. When parsing
+ * fails, TCL_ERROR is returned and error information is written to
+ * interp, if non-NULL.
+ *
+ * Side effects:
+ * The type of *objPtr may change.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetWideForIndex(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. If
+ * NULL, then no error message is left after
+ * errors. */
+ Tcl_Obj *objPtr, /* Points to the value to be parsed */
+ Tcl_WideInt endValue, /* The value to be stored at *widePtr if
+ * objPtr holds "end".
+ * NOTE: this value may be negative. */
+ Tcl_WideInt *widePtr) /* Location filled in with a wide integer
+ * representing an index. */
+{
+ ClientData cd;
+ const char *opPtr;
+ int numType, length, t1 = 0, t2 = 0;
+ int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType);
+
+ if (code == TCL_OK) {
+ if (numType == TCL_NUMBER_INT) {
+ /* objPtr holds an integer in the signed wide range */
+ *widePtr = (Tcl_WideInt)(*(Tcl_WideInt *)cd);
+ return TCL_OK;
+ }
+ if (numType == TCL_NUMBER_BIG) {
+ /* objPtr holds an integer outside the signed wide range */
+ /* Truncate to the signed wide range. */
+ if (mp_isneg((mp_int *)cd)) {
+ *widePtr = LLONG_MIN;
+ } else {
+ *widePtr = LLONG_MAX;
+ }
+ return TCL_OK;
+ }
+ /* Must be a double -> not a valid index */
+ goto parseError;
+ }
+
+ /* objPtr does not hold a number, check the end+/- format... */
+ if (GetEndOffsetFromObj(objPtr, endValue, widePtr) == TCL_OK) {
+ return TCL_OK;
+ }
+
+ /* If we reach here, the string rep of objPtr exists. */
+
+ /*
+ * The valid index syntax does not include any value that is
+ * a list of more than one element. This is necessary so that
+ * lists of index values can be reliably distinguished from any
+ * single index value.
+ */
+
+ /*
+ * Quick scan to see if multi-value list is even possible.
+ * This relies on TclGetString() returning a NUL-terminated string.
+ */
+ if ((TclMaxListLength(TclGetString(objPtr), -1, NULL) > 1)
+
+ /* If it's possible, do the full list parse. */
+ && (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length))
+ && (length > 1)) {
+ goto parseError;
+ }
+
+ /* Passed the list screen, so parse for index arithmetic expression */
+ if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr,
+ TCL_PARSE_INTEGER_ONLY)) {
+ Tcl_WideInt w1=0, w2=0;
+
+ /* value starts with valid integer... */
+
+ if ((*opPtr == '-') || (*opPtr == '+')) {
+ /* ... value continues with [-+] ... */
+
+ /* Save first integer as wide if possible */
+ TclGetNumberFromObj(NULL, objPtr, &cd, &t1);
+ if (t1 == TCL_NUMBER_INT) {
+ w1 = (*(Tcl_WideInt *)cd);
+ }
+
+ if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1,
+ -1, NULL, TCL_PARSE_INTEGER_ONLY)) {
+ /* ... value concludes with second valid integer */
+
+ /* Save second integer as wide if possible */
+ TclGetNumberFromObj(NULL, objPtr, &cd, &t2);
+ if (t2 == TCL_NUMBER_INT) {
+ w2 = (*(Tcl_WideInt *)cd);
+ }
+ }
+ }
+ /* Clear invalid intreps left by TclParseNumber */
+ TclFreeIntRep(objPtr);
+
+ if (t1 && t2) {
+ /* We have both integer values */
+ if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
+ /* Both are wide, do wide-integer math */
+ if (*opPtr == '-') {
+ if ((w2 == LLONG_MIN) && (interp != NULL)) {
+ goto extreme;
+ }
+ w2 = -w2;
+ }
+
+ if ((w1 ^ w2) < 0) {
+ /* Different signs, sum cannot overflow */
+ *widePtr = w1 + w2;
+ } else if (w1 >= 0) {
+ if (w1 < LLONG_MAX - w2) {
+ *widePtr = w1 + w2;
+ } else {
+ *widePtr = LLONG_MAX;
+ }
+ } else {
+ if (w1 > LLONG_MIN - w2) {
+ *widePtr = w1 + w2;
+ } else {
+ *widePtr = LLONG_MIN;
+ }
+ }
+ } else if (interp == NULL) {
+ /*
+ * We use an interp to do bignum index calculations.
+ * If we don't get one, call all indices with bignums errors,
+ * and rely on callers to handle it.
+ */
+ return TCL_ERROR;
+ } else {
+ /*
+ * At least one is big, do bignum math. Little reason to
+ * value performance here. Re-use code. Parse has verified
+ * objPtr is an expression. Compute it.
+ */
+
+ Tcl_Obj *sum;
+
+ extreme:
+ Tcl_ExprObj(interp, objPtr, &sum);
+ TclGetNumberFromObj(NULL, sum, &cd, &numType);
+
+ if (numType == TCL_NUMBER_INT) {
+ /* sum holds an integer in the signed wide range */
+ *widePtr = (Tcl_WideInt)(*(Tcl_WideInt *)cd);
+ } else {
+ /* sum holds an integer outside the signed wide range */
+ /* Truncate to the signed wide range. */
+ if (mp_isneg((mp_int *)cd)) {
+ *widePtr = LLONG_MIN;
+ } else {
+ *widePtr = LLONG_MAX;
+ }
+ }
+ Tcl_DecrRefCount(sum);
+ }
+ return TCL_OK;
+ }
+ }
+
+ /* Report a parse error. */
+ parseError:
+ if (interp != NULL) {
+ char * bytes = TclGetString(objPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be integer?[+-]integer? or"
+ " end?[+-]integer?", bytes));
+ if (!strncmp(bytes, "end-", 4)) {
+ bytes += 4;
+ }
+ TclCheckBadOctal(interp, bytes);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclGetIntForIndex --
*
* This function returns an integer corresponding to the list index held
@@ -3685,129 +3888,170 @@ TclGetIntForIndex(
int *indexPtr) /* Location filled in with an integer
* representing an index. */
{
- size_t length;
- char *opPtr;
- const char *bytes;
+ Tcl_WideInt wide;
- if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
- return TCL_OK;
- }
-
- if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) {
- return TCL_OK;
+ if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) {
+ return TCL_ERROR;
}
-
- bytes = TclGetString(objPtr);
- length = objPtr->length;
-
- /*
- * Leading whitespace is acceptable in an index.
- */
-
- while (length && TclIsSpaceProc(*bytes)) {
- bytes++;
- length--;
+ if (wide < INT_MIN) {
+ *indexPtr = INT_MIN;
+ } else if (wide > INT_MAX) {
+ *indexPtr = INT_MAX;
+ } else {
+ *indexPtr = (int) wide;
}
+ return TCL_OK;
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetEndOffsetFromObj --
+ *
+ * Look for a string of the form "end[+-]offset" and convert it to an
+ * internal representation holding the offset.
+ *
+ * Results:
+ * Tcl return code.
+ *
+ * Side effects:
+ * May store a Tcl_ObjType.
+ *
+ *----------------------------------------------------------------------
+ */
- if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr,
- TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
- int code, first, second;
- char savedOp = *opPtr;
-
- if ((savedOp != '+') && (savedOp != '-')) {
- goto parseError;
- }
- if (TclIsSpaceProc(opPtr[1])) {
- goto parseError;
- }
- *opPtr = '\0';
- code = Tcl_GetInt(interp, bytes, &first);
- *opPtr = savedOp;
- if (code == TCL_ERROR) {
- goto parseError;
- }
- if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) {
- goto parseError;
- }
- if (savedOp == '+') {
- *indexPtr = first + second;
+static int
+GetEndOffsetFromObj(
+ Tcl_Obj *objPtr, /* Pointer to the object to parse */
+ Tcl_WideInt endValue, /* The value to be stored at "indexPtr" if
+ * "objPtr" holds "end". */
+ Tcl_WideInt *widePtr) /* Location filled in with an integer
+ * representing an index. */
+{
+ if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
+ Tcl_WideInt offset = objPtr->internalRep.wideValue;
+
+ if ((endValue ^ offset) < 0) {
+ /* Different signs, sum cannot overflow */
+ *widePtr = endValue + offset;
+ } else if (endValue >= 0) {
+ if (endValue < LLONG_MAX - offset) {
+ *widePtr = endValue + offset;
+ } else {
+ *widePtr = LLONG_MAX;
+ }
} else {
- *indexPtr = first - second;
+ if (endValue > LLONG_MIN - offset) {
+ *widePtr = endValue + offset;
+ } else {
+ *widePtr = LLONG_MIN;
+ }
}
return TCL_OK;
}
-
- /*
- * Report a parse error.
- */
-
- parseError:
- if (interp != NULL) {
- bytes = TclGetString(objPtr);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be integer?[+-]integer? or"
- " end?[+-]integer?", bytes));
- if (!strncmp(bytes, "end-", 4)) {
- bytes += 4;
- }
- TclCheckBadOctal(interp, bytes);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
- }
-
return TCL_ERROR;
}
+
/*
*----------------------------------------------------------------------
*
- * GetEndOffsetFromObj --
+ * SetEndOffsetFromAny --
*
* Look for a string of the form "end[+-]offset" and convert it to an
* internal representation holding the offset.
*
* Results:
- * Tcl return code.
+ * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
*
* Side effects:
- * May store a Tcl_ObjType.
+ * If interp is not NULL, stores an error message in the interpreter
+ * result.
*
*----------------------------------------------------------------------
*/
static int
-GetEndOffsetFromObj(
- Tcl_Obj *objPtr, /* Pointer to the object to parse */
- int endValue, /* The value to be stored at "indexPtr" if
- * "objPtr" holds "end". */
- int *indexPtr) /* Location filled in with an integer
- * representing an index. */
+SetEndOffsetFromAny(
+ Tcl_Interp *interp, /* Tcl interpreter or NULL */
+ Tcl_Obj *objPtr) /* Pointer to the object to parse */
{
- const Tcl_ObjIntRep *irPtr;
+ Tcl_WideInt offset; /* Offset in the "end-offset" expression */
+ register const char *bytes; /* String rep of the object */
+ int length; /* Length of the object's string rep */
- while (NULL == (irPtr = Tcl_FetchIntRep(objPtr, &endOffsetType))) {
- Tcl_ObjIntRep ir;
- int length, offset = 0;
- const char *bytes = TclGetStringFromObj(objPtr, &length);
+ /*
+ * If it's already the right type, we're fine.
+ */
- if ((length == 4) || (*bytes != 'e') || (strncmp(bytes, "end",
- (size_t)((length > 3) ? 3 : length)) != 0)) {
- return TCL_ERROR;
+ if (objPtr->typePtr == &endOffsetType) {
+ return TCL_OK;
+ }
+
+ /*
+ * Check for a string rep of the right form.
+ */
+
+ bytes = TclGetStringFromObj(objPtr, &length);
+ if ((*bytes != 'e') || (strncmp(bytes, "end",
+ (size_t)((length > 3) ? 3 : length)) != 0)) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be end?[+-]integer?", bytes));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
- if (length > 4) {
- if (((bytes[3] != '-') && (bytes[3] != '+'))
- || (TclIsSpaceProc(bytes[4]))
- || (TCL_OK != Tcl_GetInt(NULL, bytes+4, &offset))) {
- return TCL_ERROR;
- }
- if (bytes[3] == '-') {
- /* TODO: Handle overflow cases sensibly */
- offset = -offset;
- }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Convert the string rep.
+ */
+
+ if (length <= 3) {
+ offset = 0;
+ } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) {
+ /*
+ * This is our limited string expression evaluator. Pass everything
+ * after "end-" to TclParseNumber.
+ */
+
+ if (TclIsSpaceProc(bytes[4])) {
+ goto badIndexFormat;
+ }
+ if (TclParseNumber(NULL, objPtr, NULL, bytes+4, length-4, NULL,
+ TCL_PARSE_INTEGER_ONLY) != TCL_OK) {
+ return TCL_ERROR;
}
- ir.wideValue = offset;
- Tcl_StoreIntRep(objPtr, &endOffsetType, &ir);
+ if (objPtr->typePtr != &tclIntType) {
+ goto badIndexFormat;
+ }
+ offset = objPtr->internalRep.wideValue;
+ if (bytes[3] == '-') {
+
+ /* TODO: Review overflow concerns here! */
+ offset = -offset;
+ }
+ } else {
+ /*
+ * Conversion failed. Report the error.
+ */
+
+ badIndexFormat:
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be end?[+-]integer?", bytes));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
+ }
+ return TCL_ERROR;
}
- *indexPtr = endValue + (int)irPtr->wideValue;
+ /*
+ * The conversion succeeded. Free the old internal rep and set the new
+ * one.
+ */
+
+ TclFreeIntRep(objPtr);
+ objPtr->internalRep.wideValue = offset;
+ objPtr->typePtr = &endOffsetType;
+
return TCL_OK;
}
@@ -3874,43 +4118,48 @@ TclIndexEncode(
int after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
- int idx;
+ ClientData cd;
+ Tcl_WideInt wide;
+ int idx, numType, code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType);
- if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) {
- /* We parsed a value in the range INT_MIN...INT_MAX */
+ if ((code == TCL_OK) && (numType == TCL_NUMBER_INT)) {
+ /* We parsed a value in the range LLONG_MIN...LLONG_MAX */
+ wide = (*(Tcl_WideInt *)cd);
integerEncode:
- if (idx < TCL_INDEX_START) {
+ if (wide < TCL_INDEX_START) {
/* All negative absolute indices are "before the beginning" */
idx = before;
- } else if (idx == INT_MAX) {
+ } else if (wide >= INT_MAX) {
/* This index value is always "after the end" */
idx = after;
- }
+ } else {
+ idx = (int) wide;
+ }
/* usual case, the absolute index value encodes itself */
- } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) {
+ } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &wide)) {
/*
- * We parsed an end+offset index value.
- * idx holds the offset value in the range INT_MIN...INT_MAX.
+ * We parsed an end+offset index value.
+ * wide holds the offset value in the range LLONG_MIN...LLONG_MAX.
*/
- if (idx > 0) {
+ if (wide > 0) {
/*
- * All end+postive or end-negative expressions
+ * All end+postive or end-negative expressions
* always indicate "after the end".
*/
idx = after;
- } else if (idx < INT_MIN - TCL_INDEX_END) {
+ } else if (wide < INT_MIN - TCL_INDEX_END) {
/* These indices always indicate "before the beginning */
idx = before;
} else {
/* Encoded end-positive (or end+negative) are offset */
- idx += TCL_INDEX_END;
+ idx = (int)wide + TCL_INDEX_END;
}
/* TODO: Consider flag to suppress repeated end-offset parse. */
- } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) {
+ } else if (TCL_OK == GetWideForIndex(interp, objPtr, 0, &wide)) {
/*
* Only reach this case when the index value is a
- * constant index arithmetic expression, and idx
+ * constant index arithmetic expression, and wide
* holds the result. Treat it the same as if it were
* parsed as an absolute integer value.
*/
@@ -4229,7 +4478,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/tclVar.c b/generic/tclVar.c
index eb0ef99..dfe883f 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -165,6 +165,18 @@ typedef struct ArraySearch {
} ArraySearch;
/*
+ * TIP #508: [array default]
+ *
+ * The following structure extends the regular TclVarHashTable used by array
+ * variables to store their optional default value.
+ */
+
+typedef struct ArrayVarHashTable {
+ TclVarHashTable table;
+ Tcl_Obj *defaultObj;
+} ArrayVarHashTable;
+
+/*
* Forward references to functions defined later in this file:
*/
@@ -198,6 +210,16 @@ static void UnsetVarStruct(Var *varPtr, Var *arrayPtr,
Tcl_Obj *part2Ptr, int flags, int index);
/*
+ * TIP #508: [array default]
+ */
+
+static int ArrayDefaultCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static void DeleteArrayVar(Var *arrayPtr);
+static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj);
+
+/*
* Functions defined in this file that may be exported in the future for use
* by the bytecode compiler and engine or to the public interface.
*/
@@ -275,7 +297,6 @@ static const Tcl_ObjType parsedVarNameType = {
(array) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
(elem) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \
} while (0)
-
Var *
TclVarHashCreateVar(
@@ -948,20 +969,24 @@ TclLookupSimpleVar(
}
}
} else { /* Local var: look in frame varFramePtr. */
- int localLen, localCt = varFramePtr->numCompiledLocals;
- Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0;
- const char *localNameStr;
+ int localCt = varFramePtr->numCompiledLocals;
+
+ if (localCt > 0) {
+ Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0;
+ const char *localNameStr;
+ int localLen;
- for (i=0 ; i<localCt ; i++, objPtrPtr++) {
- register Tcl_Obj *objPtr = *objPtrPtr;
+ for (i=0 ; i<localCt ; i++, objPtrPtr++) {
+ register Tcl_Obj *objPtr = *objPtrPtr;
- if (objPtr) {
- localNameStr = TclGetStringFromObj(objPtr, &localLen);
+ if (objPtr) {
+ localNameStr = TclGetStringFromObj(objPtr, &localLen);
- if ((varLen == localLen) && (varName[0] == localNameStr[0])
+ if ((varLen == localLen) && (varName[0] == localNameStr[0])
&& !memcmp(varName, localNameStr, varLen)) {
- *indexPtr = i;
- return (Var *) &varFramePtr->compiledLocals[i];
+ *indexPtr = i;
+ return (Var *) &varFramePtr->compiledLocals[i];
+ }
}
}
}
@@ -1047,8 +1072,6 @@ TclLookupArrayElement(
{
int isNew;
Var *varPtr;
- TclVarHashTable *tablePtr;
- Namespace *nsPtr;
/*
* We're dealing with an array element. Make sure the variable is an array
@@ -1081,16 +1104,7 @@ TclLookupArrayElement(
return NULL;
}
- TclSetVarArray(arrayPtr);
- tablePtr = ckalloc(sizeof(TclVarHashTable));
- arrayPtr->value.tablePtr = tablePtr;
-
- if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) {
- nsPtr = TclGetVarNsPtr(arrayPtr);
- } else {
- nsPtr = NULL;
- }
- TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr);
+ TclInitArrayVar(arrayPtr);
} else if (!TclIsVarArray(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray,
@@ -1440,6 +1454,28 @@ TclPtrGetVarIdx(
return varPtr->value.objPtr;
}
+ /*
+ * Return the array default value if any.
+ */
+
+ if (arrayPtr && TclIsVarArray(arrayPtr) && TclGetArrayDefault(arrayPtr)) {
+ return TclGetArrayDefault(arrayPtr);
+ }
+ if (TclIsVarArrayElement(varPtr) && !arrayPtr) {
+ /*
+ * UGLY! Peek inside the implementation of things. This lets us get
+ * the default of an array even when we've been [upvar]ed to just an
+ * element of the array.
+ */
+
+ ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *)
+ ((VarInHash *) varPtr)->entry.tablePtr;
+
+ if (avhtPtr->defaultObj) {
+ return avhtPtr->defaultObj;
+ }
+ }
+
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarUndefined(varPtr) && arrayPtr
&& !TclIsVarUndefined(arrayPtr)) {
@@ -1800,6 +1836,130 @@ TclPtrSetVar(
/*
*----------------------------------------------------------------------
*
+ * ListAppendInVar, StringAppendInVar --
+ *
+ * Support functions for TclPtrSetVarIdx that implement various types of
+ * appending operations.
+ *
+ * Results:
+ * ListAppendInVar returns a Tcl result code (from the core list append
+ * operation). StringAppendInVar has no return value.
+ *
+ * Side effects:
+ * The variable or element of the array is updated. This may make the
+ * variable/element exist. Reference counts of values may be updated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+ListAppendInVar(
+ Tcl_Interp *interp,
+ Var *varPtr,
+ Var *arrayPtr,
+ Tcl_Obj *oldValuePtr,
+ Tcl_Obj *newValuePtr)
+{
+ if (oldValuePtr == NULL) {
+ /*
+ * No previous value. Check for defaults if there's an array we can
+ * ask this of.
+ */
+
+ if (arrayPtr) {
+ Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr);
+
+ if (defValuePtr) {
+ oldValuePtr = Tcl_DuplicateObj(defValuePtr);
+ }
+ }
+
+ if (oldValuePtr == NULL) {
+ /*
+ * No default. [lappend] semantics say this is like being an empty
+ * string.
+ */
+
+ TclNewObj(oldValuePtr);
+ }
+ varPtr->value.objPtr = oldValuePtr;
+ Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
+ } else if (Tcl_IsShared(oldValuePtr)) {
+ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+ TclDecrRefCount(oldValuePtr);
+ oldValuePtr = varPtr->value.objPtr;
+ Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
+ }
+
+ return Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr);
+}
+
+static inline void
+StringAppendInVar(
+ Var *varPtr,
+ Var *arrayPtr,
+ Tcl_Obj *oldValuePtr,
+ Tcl_Obj *newValuePtr)
+{
+ /*
+ * If there was no previous value, either we use the array's default (if
+ * this is an array with a default at all) or we treat this as a simple
+ * set.
+ */
+
+ if (oldValuePtr == NULL) {
+ if (arrayPtr) {
+ Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr);
+
+ if (defValuePtr) {
+ /*
+ * This is *almost* the same as the shared path below, except
+ * that the original value reference in defValuePtr is not
+ * decremented.
+ */
+
+ Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr);
+
+ varPtr->value.objPtr = valuePtr;
+ TclContinuationsCopy(valuePtr, defValuePtr);
+ Tcl_IncrRefCount(valuePtr);
+ Tcl_AppendObjToObj(valuePtr, newValuePtr);
+ if (newValuePtr->refCount == 0) {
+ Tcl_DecrRefCount(newValuePtr);
+ }
+ return;
+ }
+ }
+ varPtr->value.objPtr = newValuePtr;
+ Tcl_IncrRefCount(newValuePtr);
+ return;
+ }
+
+ /*
+ * We append newValuePtr's bytes but don't change its ref count. Unless
+ * the reference is shared, when we have to duplicate in order to be safe
+ * to modify at all.
+ */
+
+ if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */
+ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+
+ TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr);
+
+ TclDecrRefCount(oldValuePtr);
+ oldValuePtr = varPtr->value.objPtr;
+ Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
+ }
+
+ Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
+ if (newValuePtr->refCount == 0) {
+ Tcl_DecrRefCount(newValuePtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclPtrSetVarIdx --
*
* This function is the same as Tcl_SetVar2Ex above, except that it
@@ -1912,44 +2072,13 @@ TclPtrSetVarIdx(
}
if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
if (flags & TCL_LIST_ELEMENT) { /* Append list element. */
- if (oldValuePtr == NULL) {
- TclNewObj(oldValuePtr);
- varPtr->value.objPtr = oldValuePtr;
- Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
- } else if (Tcl_IsShared(oldValuePtr)) {
- varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
- TclDecrRefCount(oldValuePtr);
- oldValuePtr = varPtr->value.objPtr;
- Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
- }
- result = Tcl_ListObjAppendElement(interp, oldValuePtr,
+ result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr,
newValuePtr);
if (result != TCL_OK) {
goto earlyError;
}
} else { /* Append string. */
- /*
- * We append newValuePtr's bytes but don't change its ref count.
- */
-
- if (oldValuePtr == NULL) {
- varPtr->value.objPtr = newValuePtr;
- Tcl_IncrRefCount(newValuePtr);
- } else {
- if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */
- varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
-
- TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr);
-
- TclDecrRefCount(oldValuePtr);
- oldValuePtr = varPtr->value.objPtr;
- Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
- }
- Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
- if (newValuePtr->refCount == 0) {
- Tcl_DecrRefCount(newValuePtr);
- }
- }
+ StringAppendInVar(varPtr, arrayPtr, oldValuePtr, newValuePtr);
}
} else if (newValuePtr != oldValuePtr) {
/*
@@ -3025,7 +3154,7 @@ ArrayObjNext(
return donerc;
}
-int
+static int
ArrayForObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
@@ -4106,9 +4235,7 @@ ArraySetCmd(
return TCL_ERROR;
}
}
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
+ TclInitArrayVar(varPtr);
return TCL_OK;
}
@@ -4388,6 +4515,7 @@ TclInitArrayCmd(
{
static const EnsembleImplMap arrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
{"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0},
@@ -5578,8 +5706,7 @@ DeleteArray(
TclClearVarNamespaceVar(elPtr);
}
- VarHashDeleteTable(varPtr->value.tablePtr);
- ckfree(varPtr->value.tablePtr);
+ DeleteArrayVar(varPtr);
}
/*
@@ -6266,7 +6393,7 @@ AppendLocals(
Interp *iPtr = (Interp *) interp;
Var *varPtr;
int i, localVarCt, added;
- Tcl_Obj **varNamePtr, *objNamePtr;
+ Tcl_Obj *objNamePtr;
const char *varName;
TclVarHashTable *localVarTablePtr;
Tcl_HashSearch search;
@@ -6276,27 +6403,30 @@ AppendLocals(
localVarCt = iPtr->varFramePtr->numCompiledLocals;
varPtr = iPtr->varFramePtr->compiledLocals;
localVarTablePtr = iPtr->varFramePtr->varTablePtr;
- varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0;
if (includeLinks) {
Tcl_InitObjHashTable(&addedTable);
}
- for (i = 0; i < localVarCt; i++, varNamePtr++) {
- /*
- * Skip nameless (temporary) variables and undefined variables.
- */
+ if (localVarCt > 0) {
+ Tcl_Obj **varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0;
+
+ for (i = 0; i < localVarCt; i++, varNamePtr++) {
+ /*
+ * Skip nameless (temporary) variables and undefined variables.
+ */
- if (*varNamePtr && !TclIsVarUndefined(varPtr)
+ if (*varNamePtr && !TclIsVarUndefined(varPtr)
&& (includeLinks || !TclIsVarLink(varPtr))) {
- varName = TclGetString(*varNamePtr);
- if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
- Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr);
- if (includeLinks) {
- Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added);
+ varName = TclGetString(*varNamePtr);
+ if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr);
+ if (includeLinks) {
+ Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added);
+ }
}
}
+ varPtr++;
}
- varPtr++;
}
/*
@@ -6490,6 +6620,264 @@ CompareVarKeys(
return ((l1 == l2) && !memcmp(p1, p2, l1));
}
+/*----------------------------------------------------------------------
+ *
+ * ArrayDefaultCmd --
+ *
+ * This function implements the 'array default' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+ArrayDefaultCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ static const char *const options[] = {
+ "get", "set", "exists", "unset", NULL
+ };
+ enum options { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET };
+ Tcl_Obj *arrayNameObj, *defaultValueObj;
+ Var *varPtr, *arrayPtr;
+ int isArray, option;
+
+ /*
+ * Parse arguments.
+ */
+
+ if (objc != 3 && objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?value?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option",
+ 0, &option) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ arrayNameObj = objv[2];
+
+ if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
+ return TCL_ERROR;
+ }
+
+ switch (option) {
+ case OPT_GET:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+ if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ }
+
+ defaultValueObj = TclGetArrayDefault(varPtr);
+ if (!defaultValueObj) {
+ /* Array default must exist. */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "array has no default value", -1));
+ Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, defaultValueObj);
+ return TCL_OK;
+
+ case OPT_SET:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName value");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Attempt to create array if needed.
+ */
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
+ /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set",
+ /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (arrayPtr) {
+ /*
+ * Not a valid array name.
+ */
+
+ CleanupVar(varPtr, arrayPtr);
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set",
+ needArray, -1);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ TclGetString(arrayNameObj), NULL);
+ return TCL_ERROR;
+ }
+ if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+ /*
+ * Not an array.
+ */
+
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set",
+ needArray, -1);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+ return TCL_ERROR;
+ }
+
+ if (!TclIsVarArray(varPtr)) {
+ TclInitArrayVar(varPtr);
+ }
+ defaultValueObj = objv[3];
+ SetArrayDefault(varPtr, defaultValueObj);
+ return TCL_OK;
+
+ case OPT_EXISTS:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Undefined variables (whether or not they have storage allocated) do
+ * not have defaults, and this is not an error case.
+ */
+
+ if (!varPtr || TclIsVarUndefined(varPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
+ } else if (!isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ } else {
+ defaultValueObj = TclGetArrayDefault(varPtr);
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj));
+ }
+ return TCL_OK;
+
+ case OPT_UNSET:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+
+ if (varPtr && !TclIsVarUndefined(varPtr)) {
+ if (!isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ }
+ SetArrayDefault(varPtr, NULL);
+ }
+ return TCL_OK;
+ }
+
+ /* Unreached */
+ return TCL_ERROR;
+}
+
+/*
+ * Initialize array variable.
+ */
+
+void
+TclInitArrayVar(
+ Var *arrayPtr)
+{
+ ArrayVarHashTable *tablePtr = ckalloc(sizeof(ArrayVarHashTable));
+
+ /*
+ * Mark the variable as an array.
+ */
+
+ TclSetVarArray(arrayPtr);
+
+ /*
+ * Regular TclVarHashTable initialization.
+ */
+
+ arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr;
+ TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr));
+
+ /*
+ * Default value initialization.
+ */
+
+ tablePtr->defaultObj = NULL;
+}
+
+/*
+ * Cleanup array variable.
+ */
+
+static void
+DeleteArrayVar(
+ Var *arrayPtr)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
+ arrayPtr->value.tablePtr;
+
+ /*
+ * Default value cleanup.
+ */
+
+ SetArrayDefault(arrayPtr, NULL);
+
+ /*
+ * Regular TclVarHashTable cleanup.
+ */
+
+ VarHashDeleteTable(arrayPtr->value.tablePtr);
+ ckfree(tablePtr);
+}
+
+/*
+ * Get array default value if any.
+ */
+
+Tcl_Obj *
+TclGetArrayDefault(
+ Var *arrayPtr)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
+ arrayPtr->value.tablePtr;
+
+ return tablePtr->defaultObj;
+}
+
+/*
+ * Set/replace/unset array default value.
+ */
+
+static void
+SetArrayDefault(
+ Var *arrayPtr,
+ Tcl_Obj *defaultObj)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
+ arrayPtr->value.tablePtr;
+
+ /*
+ * Increment/decrement refcount twice to ensure that the object is shared,
+ * so that it doesn't get modified accidentally by the folling code:
+ *
+ * array default set v 1
+ * lappend v(a) 2; # returns a new object {1 2}
+ * set v(b); # returns the original default object "1"
+ */
+
+ if (tablePtr->defaultObj) {
+ Tcl_DecrRefCount(tablePtr->defaultObj);
+ Tcl_DecrRefCount(tablePtr->defaultObj);
+ }
+ tablePtr->defaultObj = defaultObj;
+ if (tablePtr->defaultObj) {
+ Tcl_IncrRefCount(tablePtr->defaultObj);
+ Tcl_IncrRefCount(tablePtr->defaultObj);
+ }
+}
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
new file mode 100644
index 0000000..428be15
--- /dev/null
+++ b/generic/tclZipfs.c
@@ -0,0 +1,5011 @@
+/*
+ * tclZipfs.c --
+ *
+ * Implementation of the ZIP filesystem used in TIP 430
+ * Adapted from the implentation for AndroWish.
+ *
+ * Copyright (c) 2016-2017 Sean Woods <yoda@etoyoc.com>
+ * Copyright (c) 2013-2015 Christian Werner <chw@ch-werner.de>
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * This file is distributed in two ways:
+ * generic/tclZipfs.c file in the TIP430-enabled Tcl cores.
+ * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430
+ * projects.
+ */
+
+#include "tclInt.h"
+#include "tclFileSystem.h"
+
+#ifndef _WIN32
+#include <sys/mman.h>
+#endif /* _WIN32*/
+
+#ifndef MAP_FILE
+#define MAP_FILE 0
+#endif /* !MAP_FILE */
+
+#ifdef HAVE_ZLIB
+#include "zlib.h"
+#include "crypt.h"
+
+#ifdef CFG_RUNTIME_DLLFILE
+
+/*
+** We are compiling as part of the core.
+** TIP430 style zipfs prefix
+*/
+
+#define ZIPFS_VOLUME "//zipfs:/"
+#define ZIPFS_VOLUME_LEN 9
+#define ZIPFS_APP_MOUNT "//zipfs:/app"
+#define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl"
+
+#else /* !CFG_RUNTIME_DLLFILE */
+
+/*
+** We are compiling from the /compat folder of tclconfig
+** Pre TIP430 style zipfs prefix
+** //zipfs:/ doesn't work straight out of the box on either windows or Unix
+** without other changes made to tip 430
+*/
+
+#define ZIPFS_VOLUME "zipfs:/"
+#define ZIPFS_VOLUME_LEN 7
+#define ZIPFS_APP_MOUNT "zipfs:/app"
+#define ZIPFS_ZIP_MOUNT "zipfs:/lib/tcl"
+
+#endif /* CFG_RUNTIME_DLLFILE */
+
+/*
+ * Various constants and offsets found in ZIP archive files
+ */
+
+#define ZIP_SIG_LEN 4
+
+/*
+ * Local header of ZIP archive member (at very beginning of each member).
+ */
+
+#define ZIP_LOCAL_HEADER_SIG 0x04034b50
+#define ZIP_LOCAL_HEADER_LEN 30
+#define ZIP_LOCAL_SIG_OFFS 0
+#define ZIP_LOCAL_VERSION_OFFS 4
+#define ZIP_LOCAL_FLAGS_OFFS 6
+#define ZIP_LOCAL_COMPMETH_OFFS 8
+#define ZIP_LOCAL_MTIME_OFFS 10
+#define ZIP_LOCAL_MDATE_OFFS 12
+#define ZIP_LOCAL_CRC32_OFFS 14
+#define ZIP_LOCAL_COMPLEN_OFFS 18
+#define ZIP_LOCAL_UNCOMPLEN_OFFS 22
+#define ZIP_LOCAL_PATHLEN_OFFS 26
+#define ZIP_LOCAL_EXTRALEN_OFFS 28
+
+/*
+ * Central header of ZIP archive member at end of ZIP file.
+ */
+
+#define ZIP_CENTRAL_HEADER_SIG 0x02014b50
+#define ZIP_CENTRAL_HEADER_LEN 46
+#define ZIP_CENTRAL_SIG_OFFS 0
+#define ZIP_CENTRAL_VERSIONMADE_OFFS 4
+#define ZIP_CENTRAL_VERSION_OFFS 6
+#define ZIP_CENTRAL_FLAGS_OFFS 8
+#define ZIP_CENTRAL_COMPMETH_OFFS 10
+#define ZIP_CENTRAL_MTIME_OFFS 12
+#define ZIP_CENTRAL_MDATE_OFFS 14
+#define ZIP_CENTRAL_CRC32_OFFS 16
+#define ZIP_CENTRAL_COMPLEN_OFFS 20
+#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24
+#define ZIP_CENTRAL_PATHLEN_OFFS 28
+#define ZIP_CENTRAL_EXTRALEN_OFFS 30
+#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32
+#define ZIP_CENTRAL_DISKFILE_OFFS 34
+#define ZIP_CENTRAL_IATTR_OFFS 36
+#define ZIP_CENTRAL_EATTR_OFFS 38
+#define ZIP_CENTRAL_LOCALHDR_OFFS 42
+
+/*
+ * Central end signature at very end of ZIP file.
+ */
+
+#define ZIP_CENTRAL_END_SIG 0x06054b50
+#define ZIP_CENTRAL_END_LEN 22
+#define ZIP_CENTRAL_END_SIG_OFFS 0
+#define ZIP_CENTRAL_DISKNO_OFFS 4
+#define ZIP_CENTRAL_DISKDIR_OFFS 6
+#define ZIP_CENTRAL_ENTS_OFFS 8
+#define ZIP_CENTRAL_TOTALENTS_OFFS 10
+#define ZIP_CENTRAL_DIRSIZE_OFFS 12
+#define ZIP_CENTRAL_DIRSTART_OFFS 16
+#define ZIP_CENTRAL_COMMENTLEN_OFFS 20
+
+#define ZIP_MIN_VERSION 20
+#define ZIP_COMPMETH_STORED 0
+#define ZIP_COMPMETH_DEFLATED 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.
+ */
+
+#define ZIPFS_ERROR(interp,errstr) \
+ do { \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \
+ } \
+ } while (0)
+#define ZIPFS_POSIX_ERROR(interp,errstr) \
+ do { \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
+ "%s: %s", errstr, Tcl_PosixError(interp))); \
+ } \
+ } while (0)
+
+/*
+ * Macros to read and write 16 and 32 bit integers from/to ZIP archives.
+ */
+
+#define ZipReadInt(p) \
+ ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24))
+#define ZipReadShort(p) \
+ ((p)[0] | ((p)[1] << 8))
+
+#define ZipWriteInt(p, v) \
+ do { \
+ (p)[0] = (v) & 0xff; \
+ (p)[1] = ((v) >> 8) & 0xff; \
+ (p)[2] = ((v) >> 16) & 0xff; \
+ (p)[3] = ((v) >> 24) & 0xff; \
+ } while (0)
+#define ZipWriteShort(p, v) \
+ do { \
+ (p)[0] = (v) & 0xff; \
+ (p)[1] = ((v) >> 8) & 0xff; \
+ } while (0)
+
+/*
+ * Windows drive letters.
+ */
+
+#ifdef _WIN32
+static const char drvletters[] =
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
+#endif /* _WIN32 */
+
+/*
+ * Mutex to protect localtime(3) when no reentrant version available.
+ */
+
+#if !defined(_WIN32) && !defined(HAVE_LOCALTIME_R) && TCL_THREADS
+TCL_DECLARE_MUTEX(localtimeMutex)
+#endif /* !_WIN32 && !HAVE_LOCALTIME_R && TCL_THREADS */
+
+/*
+ * In-core description of mounted ZIP archive file.
+ */
+
+typedef struct ZipFile {
+ char *name; /* Archive name */
+ size_t nameLength; /* Length of archive name */
+ char isMemBuffer; /* When true, not a file but a memory buffer */
+ Tcl_Channel chan; /* Channel handle or NULL */
+ unsigned char *data; /* Memory mapped or malloc'ed file */
+ size_t length; /* Length of memory mapped file */
+ void *ptrToFree; /* Non-NULL if malloc'ed file */
+ size_t numFiles; /* Number of files in archive */
+ size_t baseOffset; /* Archive start */
+ size_t passOffset; /* Password start */
+ size_t directoryOffset; /* Archive directory start */
+ unsigned char passBuf[264]; /* Password buffer */
+ size_t numOpen; /* Number of open files on archive */
+ struct ZipEntry *entries; /* List of files in archive */
+ struct ZipEntry *topEnts; /* List of top-level dirs in archive */
+ char *mountPoint; /* Mount point name */
+ size_t mountPointLen; /* Length of mount point name */
+#ifdef _WIN32
+ HANDLE mountHandle; /* Handle used for direct file access. */
+#endif /* _WIN32 */
+} ZipFile;
+
+/*
+ * In-core description of file contained in mounted ZIP archive.
+ */
+
+typedef struct ZipEntry {
+ char *name; /* The full pathname of the virtual file */
+ ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */
+ Tcl_WideInt offset; /* Data offset into memory mapped ZIP file */
+ int numBytes; /* Uncompressed size of the virtual file */
+ int numCompressedBytes; /* Compressed size of the virtual file */
+ int compressMethod; /* Compress method */
+ int isDirectory; /* Set to 1 if directory, or -1 if root */
+ int depth; /* Number of slashes in path. */
+ int crc32; /* CRC-32 */
+ int timestamp; /* Modification time */
+ int isEncrypted; /* True if data is encrypted */
+ unsigned char *data; /* File data if written */
+ struct ZipEntry *next; /* Next file in the same archive */
+ struct ZipEntry *tnext; /* Next top-level dir in archive */
+} ZipEntry;
+
+/*
+ * File channel for file contained in mounted ZIP archive.
+ */
+
+typedef struct ZipChannel {
+ ZipFile *zipFilePtr; /* The ZIP file holding this channel */
+ ZipEntry *zipEntryPtr; /* Pointer back to virtual file */
+ size_t maxWrite; /* Maximum size for write */
+ size_t numBytes; /* Number of bytes of uncompressed data */
+ size_t numRead; /* Position of next byte to be read from the
+ * channel */
+ unsigned char *ubuf; /* Pointer to the uncompressed data */
+ int iscompr; /* True if data is compressed */
+ int isDirectory; /* Set to 1 if directory, or -1 if root */
+ int isEncrypted; /* True if data is encrypted */
+ int isWriting; /* True if open for writing */
+ unsigned long keys[3]; /* Key for decryption */
+} ZipChannel;
+
+/*
+ * Global variables.
+ *
+ * Most are kept in single ZipFS struct. When build with threading support
+ * this struct is protected by the ZipFSMutex (see below).
+ *
+ * The "fileHash" component is the process wide global table of all known ZIP
+ * archive members in all mounted ZIP archives.
+ *
+ * The "zipHash" components is the process wide global table of all mounted
+ * ZIP archive files.
+ */
+
+static struct {
+ int initialized; /* True when initialized */
+ int lock; /* RW lock, see below */
+ int waiters; /* RW lock, see below */
+ int wrmax; /* Maximum write size of a file */
+ int idCount; /* Counter for channel names */
+ Tcl_HashTable fileHash; /* File name to ZipEntry mapping */
+ Tcl_HashTable zipHash; /* Mount to ZipFile mapping */
+} ZipFS = {
+ 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0,
+};
+
+/*
+ * For password rotation.
+ */
+
+static const char pwrot[16] = {
+ 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0,
+ 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0
+};
+
+/*
+ * Table to compute CRC32.
+ */
+
+static const z_crc_t crc32tab[256] = {
+ 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419,
+ 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4,
+ 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07,
+ 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de,
+ 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856,
+ 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
+ 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4,
+ 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b,
+ 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3,
+ 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a,
+ 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599,
+ 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
+ 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190,
+ 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f,
+ 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e,
+ 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01,
+ 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed,
+ 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
+ 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3,
+ 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2,
+ 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a,
+ 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5,
+ 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010,
+ 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
+ 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17,
+ 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6,
+ 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615,
+ 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8,
+ 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344,
+ 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
+ 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a,
+ 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5,
+ 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1,
+ 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c,
+ 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef,
+ 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
+ 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe,
+ 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31,
+ 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c,
+ 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713,
+ 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b,
+ 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
+ 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1,
+ 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c,
+ 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278,
+ 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7,
+ 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66,
+ 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
+ 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605,
+ 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8,
+ 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b,
+ 0x2d02ef8d,
+};
+
+static const char *zipfs_literal_tcl_library = NULL;
+
+/* Function prototypes */
+
+static inline int DescribeMounted(Tcl_Interp *interp,
+ const char *mountPoint);
+static inline int ListMountPoints(Tcl_Interp *interp);
+static int ZipfsAppHookFindTclInit(const char *archive);
+static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr);
+static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr);
+static Tcl_Obj * ZipFSFilesystemSeparatorProc(Tcl_Obj *pathPtr);
+static int ZipFSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
+static int ZipFSAccessProc(Tcl_Obj *pathPtr, int mode);
+static Tcl_Channel ZipFSOpenFileChannelProc(Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int mode, int permissions);
+static int ZipFSMatchInDirectoryProc(Tcl_Interp *interp,
+ Tcl_Obj *result, Tcl_Obj *pathPtr,
+ const char *pattern, Tcl_GlobTypeData *types);
+static Tcl_Obj * ZipFSListVolumesProc(void);
+static const char *const *ZipFSFileAttrStringsProc(Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef);
+static int ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index,
+ Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef);
+static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index,
+ Tcl_Obj *pathPtr, Tcl_Obj *objPtr);
+static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
+ Tcl_LoadHandle *loadHandle,
+ Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
+static void ZipfsSetup(void);
+static int ZipChannelClose(ClientData instanceData,
+ Tcl_Interp *interp);
+static int ZipChannelGetFile(ClientData instanceData,
+ int direction, ClientData *handlePtr);
+static int ZipChannelRead(ClientData instanceData, char *buf,
+ int toRead, int *errloc);
+static int ZipChannelSeek(ClientData instanceData, long offset,
+ int mode, int *errloc);
+static void ZipChannelWatchChannel(ClientData instanceData,
+ int mask);
+static int ZipChannelWrite(ClientData instanceData,
+ const char *buf, int toWrite, int *errloc);
+
+/*
+ * Define the ZIP filesystem dispatch table.
+ */
+
+MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem;
+
+const Tcl_Filesystem zipfsFilesystem = {
+ "zipfs",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_2,
+ ZipFSPathInFilesystemProc,
+ NULL, /* dupInternalRepProc */
+ NULL, /* freeInternalRepProc */
+ NULL, /* internalToNormalizedProc */
+ NULL, /* createInternalRepProc */
+ NULL, /* normalizePathProc */
+ ZipFSFilesystemPathTypeProc,
+ ZipFSFilesystemSeparatorProc,
+ ZipFSStatProc,
+ ZipFSAccessProc,
+ ZipFSOpenFileChannelProc,
+ ZipFSMatchInDirectoryProc,
+ NULL, /* utimeProc */
+ NULL, /* linkProc */
+ ZipFSListVolumesProc,
+ ZipFSFileAttrStringsProc,
+ ZipFSFileAttrsGetProc,
+ ZipFSFileAttrsSetProc,
+ NULL, /* createDirectoryProc */
+ NULL, /* removeDirectoryProc */
+ NULL, /* deleteFileProc */
+ NULL, /* copyFileProc */
+ NULL, /* renameFileProc */
+ NULL, /* copyDirectoryProc */
+ NULL, /* lstatProc */
+ (Tcl_FSLoadFileProc *) ZipFSLoadFile,
+ NULL, /* getCwdProc */
+ NULL, /* chdirProc */
+};
+
+/*
+ * The channel type/driver definition used for ZIP archive members.
+ */
+
+static Tcl_ChannelType ZipChannelType = {
+ "zip", /* Type name. */
+ TCL_CHANNEL_VERSION_5,
+ ZipChannelClose, /* Close channel, clean instance data */
+ ZipChannelRead, /* Handle read request */
+ ZipChannelWrite, /* Handle write request */
+ ZipChannelSeek, /* Move location of access point, NULL'able */
+ NULL, /* Set options, NULL'able */
+ NULL, /* Get options, NULL'able */
+ ZipChannelWatchChannel, /* Initialize notifier */
+ ZipChannelGetFile, /* Get OS handle from the channel */
+ NULL, /* 2nd version of close channel, NULL'able */
+ NULL, /* Set blocking mode for raw channel, NULL'able */
+ NULL, /* Function to flush channel, NULL'able */
+ NULL, /* Function to handle event, NULL'able */
+ NULL, /* Wide seek function, NULL'able */
+ NULL, /* Thread action function, NULL'able */
+ NULL, /* Truncate function, NULL'able */
+};
+
+/*
+ * Miscellaneous constants.
+ */
+
+#define ERROR_LENGTH ((size_t) -1)
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ReadLock, WriteLock, Unlock --
+ *
+ * POSIX like rwlock functions to support multiple readers and single
+ * writer on internal structs.
+ *
+ * Limitations:
+ * - a read lock cannot be promoted to a write lock
+ * - a write lock may not be nested
+ *
+ *-------------------------------------------------------------------------
+ */
+
+TCL_DECLARE_MUTEX(ZipFSMutex)
+
+#if TCL_THREADS
+
+static Tcl_Condition ZipFSCond;
+
+static void
+ReadLock(void)
+{
+ Tcl_MutexLock(&ZipFSMutex);
+ while (ZipFS.lock < 0) {
+ ZipFS.waiters++;
+ Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL);
+ ZipFS.waiters--;
+ }
+ ZipFS.lock++;
+ Tcl_MutexUnlock(&ZipFSMutex);
+}
+
+static void
+WriteLock(void)
+{
+ Tcl_MutexLock(&ZipFSMutex);
+ while (ZipFS.lock != 0) {
+ ZipFS.waiters++;
+ Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL);
+ ZipFS.waiters--;
+ }
+ ZipFS.lock = -1;
+ Tcl_MutexUnlock(&ZipFSMutex);
+}
+
+static void
+Unlock(void)
+{
+ Tcl_MutexLock(&ZipFSMutex);
+ if (ZipFS.lock > 0) {
+ --ZipFS.lock;
+ } else if (ZipFS.lock < 0) {
+ ZipFS.lock = 0;
+ }
+ if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) {
+ Tcl_ConditionNotify(&ZipFSCond);
+ }
+ Tcl_MutexUnlock(&ZipFSMutex);
+}
+
+#else /* !TCL_THREADS */
+#define ReadLock() do {} while (0)
+#define WriteLock() do {} while (0)
+#define Unlock() do {} while (0)
+#endif /* TCL_THREADS */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * DosTimeDate, ToDosTime, ToDosDate --
+ *
+ * Functions to perform conversions between DOS time stamps and POSIX
+ * time_t.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static time_t
+DosTimeDate(
+ int dosDate,
+ int dosTime)
+{
+ struct tm tm;
+ time_t ret;
+
+ memset(&tm, 0, sizeof(struct tm));
+ tm.tm_year = ((dosDate & 0xfe00) >> 9) + 80;
+ tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1;
+ tm.tm_mday = dosDate & 0x1f;
+ tm.tm_hour = (dosTime & 0xf800) >> 11;
+ tm.tm_min = (dosTime & 0x7e) >> 5;
+ tm.tm_sec = (dosTime & 0x1f) << 1;
+ ret = mktime(&tm);
+ if (ret == (time_t) -1) {
+ /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */
+ ret = (time_t) 315532800;
+ }
+ return ret;
+}
+
+static int
+ToDosTime(
+ time_t when)
+{
+ struct tm *tmp, tm;
+
+#if !TCL_THREADS || defined(_WIN32)
+ /* Not threaded, or on Win32 which uses thread local storage */
+ tmp = localtime(&when);
+ tm = *tmp;
+#elif defined(HAVE_LOCALTIME_R)
+ /* Threaded, have reentrant API */
+ tmp = &tm;
+ localtime_r(&when, tmp);
+#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */
+ /* Only using a mutex is safe. */
+ Tcl_MutexLock(&localtimeMutex);
+ tmp = localtime(&when);
+ tm = *tmp;
+ Tcl_MutexUnlock(&localtimeMutex);
+#endif
+ return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1);
+}
+
+static int
+ToDosDate(
+ time_t when)
+{
+ struct tm *tmp, tm;
+
+#if !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)
+ /* Threaded, have reentrant API */
+ tmp = &tm;
+ localtime_r(&when, tmp);
+#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */
+ /* Only using a mutex is safe. */
+ Tcl_MutexLock(&localtimeMutex);
+ tmp = localtime(&when);
+ tm = *tmp;
+ Tcl_MutexUnlock(&localtimeMutex);
+#endif
+ return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * CountSlashes --
+ *
+ * This function counts the number of slashes in a pathname string.
+ *
+ * Results:
+ * Number of slashes found in string.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+CountSlashes(
+ const char *string)
+{
+ int count = 0;
+ const char *p = string;
+
+ while (*p != '\0') {
+ if (*p == '/') {
+ count++;
+ }
+ p++;
+ }
+ return count;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * CanonicalPath --
+ *
+ * This function computes the canonical path from a directory and file
+ * name components into the specified Tcl_DString.
+ *
+ * Results:
+ * Returns the pointer to the canonical path contained in the specified
+ * Tcl_DString.
+ *
+ * Side effects:
+ * Modifies the specified Tcl_DString.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static char *
+CanonicalPath(
+ const char *root,
+ const char *tail,
+ Tcl_DString *dsPtr,
+ int inZipfs)
+{
+ char *path;
+ int i, j, c, isUNC = 0, isVfs = 0, n = 0;
+ int haveZipfsPath = 1;
+
+#ifdef _WIN32
+ if (tail[0] != '\0' && strchr(drvletters, tail[0]) && tail[1] == ':') {
+ tail += 2;
+ haveZipfsPath = 0;
+ }
+ /* UNC style path */
+ if (tail[0] == '\\') {
+ root = "";
+ ++tail;
+ haveZipfsPath = 0;
+ }
+ if (tail[0] == '\\') {
+ root = "/";
+ ++tail;
+ haveZipfsPath = 0;
+ }
+#endif /* _WIN32 */
+
+ if (haveZipfsPath) {
+ /* UNC style path */
+ if (root && strncmp(root, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) {
+ isVfs = 1;
+ } else if (tail &&
+ strncmp(tail, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) {
+ isVfs = 2;
+ }
+ if (isVfs != 1 && (root[0] == '/') && (root[1] == '/')) {
+ isUNC = 1;
+ }
+ }
+
+ if (isVfs != 2) {
+ if (tail[0] == '/') {
+ if (isVfs != 1) {
+ root = "";
+ }
+ ++tail;
+ isUNC = 0;
+ }
+ if (tail[0] == '/') {
+ if (isVfs != 1) {
+ root = "/";
+ }
+ ++tail;
+ isUNC = 1;
+ }
+ }
+ i = strlen(root);
+ j = strlen(tail);
+
+ switch (isVfs) {
+ case 1:
+ if (i > ZIPFS_VOLUME_LEN) {
+ Tcl_DStringSetLength(dsPtr, i + j + 1);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, root, i);
+ path[i++] = '/';
+ memcpy(path + i, tail, j);
+ } else {
+ Tcl_DStringSetLength(dsPtr, i + j);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, root, i);
+ memcpy(path + i, tail, j);
+ }
+ break;
+ case 2:
+ Tcl_DStringSetLength(dsPtr, j);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, tail, j);
+ break;
+ default:
+ if (inZipfs) {
+ Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN);
+ memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j);
+ } else {
+ Tcl_DStringSetLength(dsPtr, i + j + 1);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, root, i);
+ path[i++] = '/';
+ memcpy(path + i, tail, j);
+ }
+ break;
+ }
+
+#ifdef _WIN32
+ for (i = 0; path[i] != '\0'; i++) {
+ if (path[i] == '\\') {
+ path[i] = '/';
+ }
+ }
+#endif /* _WIN32 */
+
+ if (inZipfs) {
+ n = ZIPFS_VOLUME_LEN;
+ } else {
+ n = 0;
+ }
+
+ for (i = j = n; (c = path[i]) != '\0'; i++) {
+ if (c == '/') {
+ int c2 = path[i + 1];
+
+ if (c2 == '\0' || c2 == '/') {
+ continue;
+ }
+ if (c2 == '.') {
+ int c3 = path[i + 2];
+
+ if ((c3 == '/') || (c3 == '\0')) {
+ i++;
+ continue;
+ }
+ if ((c3 == '.')
+ && ((path[i + 3] == '/') || (path[i + 3] == '\0'))) {
+ i += 2;
+ while ((j > 0) && (path[j - 1] != '/')) {
+ j--;
+ }
+ if (j > isUNC) {
+ --j;
+ while ((j > 1 + isUNC) && (path[j - 2] == '/')) {
+ j--;
+ }
+ }
+ continue;
+ }
+ }
+ }
+ path[j++] = c;
+ }
+ if (j == 0) {
+ path[j++] = '/';
+ }
+ path[j] = 0;
+ Tcl_DStringSetLength(dsPtr, j);
+ return Tcl_DStringValue(dsPtr);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLookup --
+ *
+ * This function returns the ZIP entry struct corresponding to the ZIP
+ * archive member of the given file name. Caller must hold the right
+ * lock.
+ *
+ * Results:
+ * Returns the pointer to ZIP entry struct or NULL if the the given file
+ * name could not be found in the global list of ZIP archive members.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static ZipEntry *
+ZipFSLookup(
+ char *filename)
+{
+ Tcl_HashEntry *hPtr;
+ ZipEntry *z = NULL;
+
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename);
+ if (hPtr) {
+ z = Tcl_GetHashValue(hPtr);
+ }
+ return z;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLookupMount --
+ *
+ * This function returns an indication if the given file name corresponds
+ * to a mounted ZIP archive file.
+ *
+ * Results:
+ * Returns true, if the given file name is a mounted ZIP archive file.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+#ifdef NEVER_USED
+static int
+ZipFSLookupMount(
+ char *filename)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = Tcl_GetHashValue(hPtr);
+
+ if (strcmp(zf->mountPoint, filename) == 0) {
+ return 1;
+ }
+ }
+ return 0;
+}
+#endif /* NEVER_USED */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSCloseArchive --
+ *
+ * This function closes a mounted ZIP archive file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * A memory mapped ZIP archive is unmapped, allocated memory is released.
+ * The ZipFile pointer is *NOT* deallocated by this function.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipFSCloseArchive(
+ Tcl_Interp *interp, /* Current interpreter. */
+ ZipFile *zf)
+{
+ if (zf->nameLength) {
+ ckfree(zf->name);
+ }
+ if (zf->isMemBuffer) {
+ /* Pointer to memory */
+ if (zf->ptrToFree) {
+ ckfree(zf->ptrToFree);
+ zf->ptrToFree = NULL;
+ }
+ zf->data = NULL;
+ return;
+ }
+
+#ifdef _WIN32
+ if (zf->data && !zf->ptrToFree) {
+ UnmapViewOfFile(zf->data);
+ zf->data = NULL;
+ }
+ if (zf->mountHandle != INVALID_HANDLE_VALUE) {
+ CloseHandle(zf->mountHandle);
+ }
+#else /* !_WIN32 */
+ if ((zf->data != MAP_FAILED) && !zf->ptrToFree) {
+ munmap(zf->data, zf->length);
+ zf->data = MAP_FAILED;
+ }
+#endif /* _WIN32 */
+
+ if (zf->ptrToFree) {
+ ckfree(zf->ptrToFree);
+ zf->ptrToFree = NULL;
+ }
+ if (zf->chan) {
+ Tcl_Close(interp, zf->chan);
+ zf->chan = NULL;
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFindTOC --
+ *
+ * This function takes a memory mapped zip file and indexes the contents.
+ * When "needZip" is zero an embedded ZIP archive in an executable file
+ * is accepted.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL.
+ *
+ * Side effects:
+ * The given ZipFile struct is filled with information about the ZIP
+ * archive file.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFindTOC(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ int needZip,
+ ZipFile *zf)
+{
+ size_t i;
+ unsigned char *p, *q;
+
+ p = zf->data + zf->length - ZIP_CENTRAL_END_LEN;
+ while (p >= zf->data) {
+ if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) {
+ if (ZipReadInt(p) == ZIP_CENTRAL_END_SIG) {
+ break;
+ }
+ p -= ZIP_SIG_LEN;
+ } else {
+ --p;
+ }
+ }
+ if (p < zf->data) {
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ 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);
+ if (zf->numFiles == 0) {
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ 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);
+ p -= ZipReadInt(p + ZIP_CENTRAL_DIRSIZE_OFFS);
+ if ((p < zf->data) || (p > zf->data + zf->length)
+ || (q < zf->data) || (q > zf->data + zf->length)) {
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ 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;
+ zf->directoryOffset = p - zf->data;
+ q = p;
+ for (i = 0; i < zf->numFiles; i++) {
+ int pathlen, comlen, extra;
+
+ 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);
+ comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
+ extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS);
+ q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
+ }
+ q = zf->data + zf->baseOffset;
+ if ((zf->baseOffset >= 6) && (ZipReadInt(q - 4) == ZIP_PASSWORD_END_SIG)) {
+ i = q[-5];
+ if (q - 5 - i > zf->data) {
+ zf->passBuf[0] = i;
+ memcpy(zf->passBuf + 1, q - 5 - i, i);
+ zf->passOffset -= i ? (5 + i) : 0;
+ }
+ }
+ return TCL_OK;
+
+ error:
+ ZipFSCloseArchive(interp, zf);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSOpenArchive --
+ *
+ * This function opens a ZIP archive file for reading. An attempt is made
+ * to memory map that file. Otherwise it is read into an allocated memory
+ * buffer. The ZIP archive header is verified and must be valid for the
+ * function to succeed. When "needZip" is zero an embedded ZIP archive in
+ * an executable file is accepted.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL.
+ *
+ * Side effects:
+ * ZIP archive is memory mapped or read into allocated memory, the given
+ * ZipFile struct is filled with information about the ZIP archive file.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSOpenArchive(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *zipname, /* Path to ZIP file to open. */
+ int needZip,
+ ZipFile *zf)
+{
+ size_t i;
+ ClientData handle;
+
+ zf->nameLength = 0;
+ zf->isMemBuffer = 0;
+#ifdef _WIN32
+ zf->data = NULL;
+ zf->mountHandle = INVALID_HANDLE_VALUE;
+#else /* !_WIN32 */
+ zf->data = MAP_FAILED;
+#endif /* _WIN32 */
+ zf->length = 0;
+ zf->numFiles = 0;
+ zf->baseOffset = zf->passOffset = 0;
+ zf->ptrToFree = NULL;
+ zf->passBuf[0] = 0;
+ zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0);
+ if (!zf->chan) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) {
+ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
+ if (zf->length == ERROR_LENGTH) {
+ ZIPFS_POSIX_ERROR(interp, "seek error");
+ goto error;
+ }
+ 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) {
+ ZIPFS_POSIX_ERROR(interp, "seek error");
+ goto error;
+ }
+ 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);
+ if (i != zf->length) {
+ ZIPFS_POSIX_ERROR(interp, "file read error");
+ goto error;
+ }
+ Tcl_Close(interp, zf->chan);
+ zf->chan = NULL;
+ } else {
+#ifdef _WIN32
+ int readSuccessful;
+# ifdef _WIN64
+ i = GetFileSizeEx((HANDLE) handle, (PLARGE_INTEGER) &zf->length);
+ readSuccessful = (i != 0);
+# else /* !_WIN64 */
+ zf->length = GetFileSize((HANDLE) handle, 0);
+ readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE);
+# endif /* _WIN64 */
+ if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) {
+ ZIPFS_POSIX_ERROR(interp, "invalid file size");
+ goto error;
+ }
+ zf->mountHandle = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY,
+ 0, zf->length, 0);
+ if (zf->mountHandle == INVALID_HANDLE_VALUE) {
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ goto error;
+ }
+ zf->data = MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0,
+ zf->length);
+ if (!zf->data) {
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ goto error;
+ }
+#else /* !_WIN32 */
+ zf->length = lseek(PTR2INT(handle), 0, SEEK_END);
+ if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) {
+ ZIPFS_POSIX_ERROR(interp, "invalid file size");
+ goto error;
+ }
+ lseek(PTR2INT(handle), 0, SEEK_SET);
+ zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ,
+ MAP_FILE | MAP_PRIVATE, PTR2INT(handle), 0);
+ if (zf->data == MAP_FAILED) {
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ goto error;
+ }
+#endif /* _WIN32 */
+ }
+ return ZipFSFindTOC(interp, needZip, zf);
+
+ error:
+ ZipFSCloseArchive(interp, zf);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSRootNode --
+ *
+ * This function generates the root node for a ZIPFS filesystem.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL.
+ *
+ * Side effects:
+ * ...
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSCatalogFilesystem(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ ZipFile *zf0,
+ const char *mountPoint, /* Mount point path. */
+ const char *passwd, /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+ const char *zipname) /* Path to ZIP file to build a catalog of. */
+{
+ int pwlen, isNew;
+ size_t i;
+ ZipFile *zf;
+ ZipEntry *z;
+ Tcl_HashEntry *hPtr;
+ Tcl_DString ds, dsm, fpBuf;
+ unsigned char *q;
+
+ /*
+ * Basic verification of the password for sanity.
+ */
+
+ pwlen = 0;
+ if (passwd) {
+ pwlen = strlen(passwd);
+ if ((pwlen > 255) || strchr(passwd, 0xff)) {
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("illegal password", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
+ }
+ return TCL_ERROR;
+ }
+ }
+
+ WriteLock();
+
+ /*
+ * Mount point sometimes is a relative or otherwise denormalized path.
+ * But an absolute name is needed as mount point here.
+ */
+
+ Tcl_DStringInit(&ds);
+ Tcl_DStringInit(&dsm);
+ if (strcmp(mountPoint, "/") == 0) {
+ mountPoint = "";
+ } else {
+ mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
+ }
+ hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew);
+ if (!isNew) {
+ if (interp) {
+ 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);
+ return TCL_ERROR;
+ }
+ zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
+ if (!zf) {
+ if (interp) {
+ Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ Unlock();
+ ZipFSCloseArchive(interp, zf0);
+ return TCL_ERROR;
+ }
+ Unlock();
+
+ *zf = *zf0;
+ zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
+ zf->mountPointLen = strlen(zf->mountPoint);
+ zf->nameLength = strlen(zipname);
+ zf->name = ckalloc(zf->nameLength + 1);
+ memcpy(zf->name, zipname, zf->nameLength + 1);
+ zf->entries = NULL;
+ zf->topEnts = NULL;
+ zf->numOpen = 0;
+ Tcl_SetHashValue(hPtr, zf);
+ if ((zf->passBuf[0] == 0) && pwlen) {
+ int k = 0;
+
+ zf->passBuf[k++] = pwlen;
+ for (i = pwlen; i-- > 0 ;) {
+ zf->passBuf[k++] = (passwd[i] & 0x0f)
+ | pwrot[(passwd[i] >> 4) & 0x0f];
+ }
+ zf->passBuf[k] = '\0';
+ }
+ if (mountPoint[0] != '\0') {
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew);
+ if (isNew) {
+ z = ckalloc(sizeof(ZipEntry));
+ Tcl_SetHashValue(hPtr, z);
+
+ z->tnext = NULL;
+ z->depth = CountSlashes(mountPoint);
+ z->zipFilePtr = zf;
+ z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */
+ z->isEncrypted = 0;
+ z->offset = zf->baseOffset;
+ z->crc32 = 0;
+ z->timestamp = 0;
+ z->numBytes = z->numCompressedBytes = 0;
+ z->compressMethod = ZIP_COMPMETH_STORED;
+ z->data = NULL;
+ z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
+ z->next = zf->entries;
+ zf->entries = z;
+ }
+ }
+ q = zf->data + zf->directoryOffset;
+ Tcl_DStringInit(&fpBuf);
+ for (i = 0; i < zf->numFiles; i++) {
+ int extra, isdir = 0, dosTime, dosDate, nbcompr;
+ size_t offs, pathlen, comlen;
+ unsigned char *lq, *gq = NULL;
+ char *fullpath, *path;
+
+ pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS);
+ comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
+ extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS);
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen);
+ path = Tcl_DStringValue(&ds);
+ if ((pathlen > 0) && (path[pathlen - 1] == '/')) {
+ Tcl_DStringSetLength(&ds, pathlen - 1);
+ path = Tcl_DStringValue(&ds);
+ isdir = 1;
+ }
+ if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) {
+ goto nextent;
+ }
+ lq = zf->data + zf->baseOffset
+ + ZipReadInt(q + ZIP_CENTRAL_LOCALHDR_OFFS);
+ if ((lq < zf->data) || (lq > zf->data + zf->length)) {
+ goto nextent;
+ }
+ nbcompr = ZipReadInt(lq + ZIP_LOCAL_COMPLEN_OFFS);
+ if (!isdir && (nbcompr == 0)
+ && (ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0)
+ && (ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) {
+ gq = q;
+ nbcompr = ZipReadInt(gq + ZIP_CENTRAL_COMPLEN_OFFS);
+ }
+ offs = (lq - zf->data)
+ + ZIP_LOCAL_HEADER_LEN
+ + ZipReadShort(lq + ZIP_LOCAL_PATHLEN_OFFS)
+ + ZipReadShort(lq + ZIP_LOCAL_EXTRALEN_OFFS);
+ if (offs + nbcompr > zf->length) {
+ goto nextent;
+ }
+ if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) {
+#ifdef ANDROID
+ /*
+ * When mounting the ZIP archive on the root directory try to
+ * remap top level regular files of the archive to
+ * /assets/.root/... since this directory should not be in a valid
+ * APK due to the leading dot in the file name component. This
+ * trick should make the files AndroidManifest.xml,
+ * resources.arsc, and classes.dex visible to Tcl.
+ */
+ Tcl_DString ds2;
+
+ Tcl_DStringInit(&ds2);
+ Tcl_DStringAppend(&ds2, "assets/.root/", -1);
+ Tcl_DStringAppend(&ds2, path, -1);
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2));
+ if (hPtr) {
+ /* should not happen but skip it anyway */
+ Tcl_DStringFree(&ds2);
+ goto nextent;
+ }
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2),
+ Tcl_DStringLength(&ds2));
+ path = Tcl_DStringValue(&ds);
+ Tcl_DStringFree(&ds2);
+#else /* !ANDROID */
+ /*
+ * Regular files skipped when mounting on root.
+ */
+ goto nextent;
+#endif /* ANDROID */
+ }
+ Tcl_DStringSetLength(&fpBuf, 0);
+ fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1);
+ z = ckalloc(sizeof(ZipEntry));
+ z->name = NULL;
+ z->tnext = NULL;
+ z->depth = CountSlashes(fullpath);
+ z->zipFilePtr = zf;
+ z->isDirectory = isdir;
+ z->isEncrypted = (ZipReadShort(lq + ZIP_LOCAL_FLAGS_OFFS) & 1)
+ && (nbcompr > 12);
+ z->offset = offs;
+ if (gq) {
+ z->crc32 = ZipReadInt(gq + ZIP_CENTRAL_CRC32_OFFS);
+ dosDate = ZipReadShort(gq + ZIP_CENTRAL_MDATE_OFFS);
+ dosTime = ZipReadShort(gq + ZIP_CENTRAL_MTIME_OFFS);
+ z->timestamp = DosTimeDate(dosDate, dosTime);
+ z->numBytes = ZipReadInt(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS);
+ z->compressMethod = ZipReadShort(gq + ZIP_CENTRAL_COMPMETH_OFFS);
+ } else {
+ z->crc32 = ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS);
+ dosDate = ZipReadShort(lq + ZIP_LOCAL_MDATE_OFFS);
+ dosTime = ZipReadShort(lq + ZIP_LOCAL_MTIME_OFFS);
+ z->timestamp = DosTimeDate(dosDate, dosTime);
+ z->numBytes = ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS);
+ z->compressMethod = ZipReadShort(lq + ZIP_LOCAL_COMPMETH_OFFS);
+ }
+ z->numCompressedBytes = nbcompr;
+ z->data = NULL;
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
+ if (!isNew) {
+ /* should not happen but skip it anyway */
+ ckfree(z);
+ } else {
+ Tcl_SetHashValue(hPtr, z);
+ z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
+ z->next = zf->entries;
+ zf->entries = z;
+ if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) {
+ z->tnext = zf->topEnts;
+ zf->topEnts = z;
+ }
+ if (!z->isDirectory && (z->depth > 1)) {
+ char *dir, *end;
+ ZipEntry *zd;
+
+ Tcl_DStringSetLength(&ds, strlen(z->name) + 8);
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, z->name, -1);
+ dir = Tcl_DStringValue(&ds);
+ for (end = strrchr(dir, '/'); end && (end != dir);
+ end = strrchr(dir, '/')) {
+ Tcl_DStringSetLength(&ds, end - dir);
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
+ if (!isNew) {
+ break;
+ }
+ zd = ckalloc(sizeof(ZipEntry));
+ zd->name = NULL;
+ zd->tnext = NULL;
+ zd->depth = CountSlashes(dir);
+ zd->zipFilePtr = zf;
+ zd->isDirectory = 1;
+ zd->isEncrypted = 0;
+ zd->offset = z->offset;
+ zd->crc32 = 0;
+ zd->timestamp = z->timestamp;
+ zd->numBytes = zd->numCompressedBytes = 0;
+ zd->compressMethod = ZIP_COMPMETH_STORED;
+ zd->data = NULL;
+ Tcl_SetHashValue(hPtr, zd);
+ zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
+ zd->next = zf->entries;
+ zf->entries = zd;
+ if ((mountPoint[0] == '\0') && (zd->depth == 1)) {
+ zd->tnext = zf->topEnts;
+ zf->topEnts = zd;
+ }
+ }
+ }
+ }
+ nextent:
+ q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
+ }
+ Tcl_DStringFree(&fpBuf);
+ Tcl_DStringFree(&ds);
+ Tcl_FSMountsChanged(NULL);
+ Unlock();
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipfsSetup --
+ *
+ * Common initialisation code. ZipFS.initialized must *not* be set prior
+ * to the call.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipfsSetup(void)
+{
+#if TCL_THREADS
+ static const Tcl_Time t = { 0, 0 };
+
+ /*
+ * Inflate condition variable.
+ */
+
+ Tcl_MutexLock(&ZipFSMutex);
+ Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t);
+ Tcl_MutexUnlock(&ZipFSMutex);
+#endif /* TCL_THREADS */
+
+ Tcl_FSRegister(NULL, &zipfsFilesystem);
+ 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;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ListMountPoints --
+ *
+ * This procedure lists the mount points and what's mounted there, or
+ * reports whether there are any mounts (if there's no interpreter). The
+ * read lock must be held by the caller.
+ *
+ * Results:
+ * A standard Tcl result. TCL_OK (or TCL_BREAK if no mounts and no
+ * interpreter).
+ *
+ * Side effects:
+ * Interpreter result may be updated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline int
+ListMountPoints(
+ Tcl_Interp *interp)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ ZipFile *zf;
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ if (!interp) {
+ return TCL_OK;
+ }
+ zf = Tcl_GetHashValue(hPtr);
+ Tcl_AppendElement(interp, zf->mountPoint);
+ Tcl_AppendElement(interp, zf->name);
+ }
+ return (interp ? TCL_OK : TCL_BREAK);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * DescribeMounted --
+ *
+ * This procedure describes what is mounted at the given the mount point.
+ * The interpreter result is not updated if there is nothing mounted at
+ * the given point. The read lock must be held by the caller.
+ *
+ * Results:
+ * A standard Tcl result. TCL_OK (or TCL_BREAK if nothing mounted there
+ * and no interpreter).
+ *
+ * Side effects:
+ * Interpreter result may be updated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline int
+DescribeMounted(
+ Tcl_Interp *interp,
+ const char *mountPoint)
+{
+ Tcl_HashEntry *hPtr;
+ ZipFile *zf;
+
+ if (interp) {
+ hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
+ if (hPtr) {
+ zf = Tcl_GetHashValue(hPtr);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1));
+ return TCL_OK;
+ }
+ }
+ return (interp ? TCL_OK : TCL_BREAK);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Mount --
+ *
+ * This procedure is invoked to mount a given ZIP archive file on a given
+ * mountpoint with optional ZIP password.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is read, analyzed and mounted, resources are
+ * allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Mount(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint, /* Mount point path. */
+ const char *zipname, /* Path to ZIP file to mount. */
+ const char *passwd) /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+{
+ ZipFile *zf;
+
+ ReadLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+
+ /*
+ * No mount point, so list all mount points and what is mounted there.
+ */
+
+ if (!mountPoint) {
+ int ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ /*
+ * Mount point but no file, so describe what is mounted at that mount
+ * point.
+ */
+
+ if (!zipname) {
+ DescribeMounted(interp, mountPoint);
+ Unlock();
+ return TCL_OK;
+ }
+ Unlock();
+
+ /*
+ * Have both a mount point and a file (name) to mount there.
+ */
+
+ if (passwd) {
+ if ((strlen(passwd) > 255) || strchr(passwd, 0xff)) {
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("illegal password", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
+ }
+ return TCL_ERROR;
+ }
+ }
+ zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
+ if (!zf) {
+ if (interp) {
+ Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_MountBuffer --
+ *
+ * This procedure is invoked to mount a given ZIP archive file on a given
+ * mountpoint with optional ZIP password.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is read, analyzed and mounted, resources are
+ * allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_MountBuffer(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint, /* Mount point path. */
+ unsigned char *data,
+ size_t datalen,
+ int copy)
+{
+ ZipFile *zf;
+
+ ReadLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+
+ /*
+ * No mount point, so list all mount points and what is mounted there.
+ */
+
+ if (!mountPoint) {
+ int ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ /*
+ * Mount point but no data, so describe what is mounted at that mount
+ * point.
+ */
+
+ if (!data) {
+ DescribeMounted(interp, mountPoint);
+ Unlock();
+ return TCL_OK;
+ }
+ Unlock();
+
+ /*
+ * Have both a mount point and data to mount there.
+ */
+
+ zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
+ if (!zf) {
+ if (interp) {
+ Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ return TCL_ERROR;
+ }
+ zf->isMemBuffer = 1;
+ zf->length = datalen;
+ if (copy) {
+ zf->data = attemptckalloc(datalen);
+ if (!zf->data) {
+ if (interp) {
+ Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ return TCL_ERROR;
+ }
+ memcpy(zf->data, data, datalen);
+ zf->ptrToFree = zf->data;
+ } else {
+ zf->data = data;
+ zf->ptrToFree = NULL;
+ }
+ if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL,
+ "Memory Buffer");
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Unmount --
+ *
+ * This procedure is invoked to unmount a given ZIP archive.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A mounted ZIP archive file is unmounted, resources are free'd.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Unmount(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint) /* Mount point path. */
+{
+ ZipFile *zf;
+ ZipEntry *z, *znext;
+ Tcl_HashEntry *hPtr;
+ Tcl_DString dsm;
+ int ret = TCL_OK, unmounted = 0;
+
+ WriteLock();
+ if (!ZipFS.initialized) {
+ goto done;
+ }
+
+ /*
+ * Mount point sometimes is a relative or otherwise denormalized path.
+ * But an absolute name is needed as mount point here.
+ */
+
+ Tcl_DStringInit(&dsm);
+ mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
+
+ hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
+ /* don't report no-such-mount as an error */
+ if (!hPtr) {
+ goto done;
+ }
+
+ zf = Tcl_GetHashValue(hPtr);
+ if (zf->numOpen > 0) {
+ ZIPFS_ERROR(interp, "filesystem is busy");
+ ret = TCL_ERROR;
+ goto done;
+ }
+ Tcl_DeleteHashEntry(hPtr);
+ for (z = zf->entries; z; z = znext) {
+ znext = z->next;
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name);
+ if (hPtr) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ if (z->data) {
+ ckfree(z->data);
+ }
+ ckfree(z);
+ }
+ ZipFSCloseArchive(interp, zf);
+ ckfree(zf);
+ unmounted = 1;
+ done:
+ Unlock();
+ if (unmounted) {
+ Tcl_FSMountsChanged(NULL);
+ }
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMountObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs mount] command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is mounted, resources are allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMountObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?mountpoint? ?zipfile? ?password?");
+ return TCL_ERROR;
+ }
+
+ return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL,
+ (objc > 2) ? Tcl_GetString(objv[2]) : NULL,
+ (objc > 3) ? Tcl_GetString(objv[3]) : NULL);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMountBufferObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs mount_data] command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is mounted, resources are allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMountBufferObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ const char *mountPoint; /* Mount point path. */
+ unsigned char *data;
+ int length;
+
+ if (objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?");
+ return TCL_ERROR;
+ }
+ if (objc < 2) {
+ int ret;
+
+ ReadLock();
+ ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ mountPoint = Tcl_GetString(objv[1]);
+ if (objc < 3) {
+ ReadLock();
+ DescribeMounted(interp, mountPoint);
+ Unlock();
+ return TCL_OK;
+ }
+
+ data = Tcl_GetByteArrayFromObj(objv[2], &length);
+ return TclZipfs_MountBuffer(interp, mountPoint, data, length, 1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSRootObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs root] command. It
+ * returns the root that all zipfs file systems are mounted under.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSRootObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSUnmountObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs unmount] command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A mounted ZIP archive file is unmounted, resources are free'd.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSUnmountObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "zipfile");
+ return TCL_ERROR;
+ }
+ return TclZipfs_Unmount(interp, Tcl_GetString(objv[1]));
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkKeyObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs mkkey] command. It
+ * produces a rotated password to be embedded into an image file.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkKeyObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int len, i = 0;
+ char *pw, passBuf[264];
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "password");
+ return TCL_ERROR;
+ }
+ pw = Tcl_GetString(objv[1]);
+ len = strlen(pw);
+ if (len == 0) {
+ return TCL_OK;
+ }
+ if ((len > 255) || strchr(pw, 0xff)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1));
+ return TCL_ERROR;
+ }
+ while (len > 0) {
+ int ch = pw[len - 1];
+
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ i++;
+ len--;
+ }
+ passBuf[i] = i;
+ ++i;
+ passBuf[i++] = (char) ZIP_PASSWORD_END_SIG;
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8);
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16);
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24);
+ passBuf[i] = '\0';
+ Tcl_AppendResult(interp, passBuf, (char *) NULL);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipAddFile --
+ *
+ * This procedure is used by ZipFSMkZipOrImgCmd() to add a single file to
+ * the output ZIP archive file being written. A ZipEntry struct about the
+ * input file is added to the given fileHash table for later creation of
+ * the central ZIP directory.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Input file is read and (compressed and) written to the output ZIP
+ * archive file.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipAddFile(
+ Tcl_Interp *interp, /* Current interpreter. */
+ const char *path,
+ const char *name,
+ Tcl_Channel out,
+ const char *passwd, /* Password for encoding the file, or NULL if
+ * the file is to be unprotected. */
+ char *buf,
+ int bufsize,
+ Tcl_HashTable *fileHash)
+{
+ Tcl_Channel in;
+ Tcl_HashEntry *hPtr;
+ ZipEntry *z;
+ z_stream stream;
+ const char *zpath;
+ int crc, flush, zpathlen;
+ size_t nbyte, nbytecompr, len, olen, align = 0;
+ Tcl_WideInt pos[3];
+ int mtime = 0, isNew, compMeth;
+ unsigned long keys[3], keys0[3];
+ char obuf[4096];
+
+ /*
+ * Trim leading '/' characters. If this results in an empty string, we've
+ * nothing to do.
+ */
+
+ zpath = name;
+ while (zpath && zpath[0] == '/') {
+ zpath++;
+ }
+ if (!zpath || (zpath[0] == '\0')) {
+ return TCL_OK;
+ }
+
+ zpathlen = strlen(zpath);
+ 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);
+ if (!in) {
+#ifdef _WIN32
+ /* hopefully a directory */
+ if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) {
+ Tcl_Close(interp, in);
+ return TCL_OK;
+ }
+#endif /* _WIN32 */
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ } else {
+ Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1);
+ Tcl_StatBuf statBuf;
+
+ Tcl_IncrRefCount(pathObj);
+ if (Tcl_FSStat(pathObj, &statBuf) != -1) {
+ mtime = statBuf.st_mtime;
+ }
+ Tcl_DecrRefCount(pathObj);
+ }
+ Tcl_ResetResult(interp);
+ crc = 0;
+ nbyte = nbytecompr = 0;
+ while (1) {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ if (nbyte == 0 && errno == EISDIR) {
+ Tcl_Close(interp, in);
+ return TCL_OK;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s",
+ path, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ if (len == 0) {
+ break;
+ }
+ crc = crc32(crc, (unsigned char *) buf, len);
+ nbyte += len;
+ }
+ if (Tcl_Seek(in, 0, SEEK_SET) == -1) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s",
+ path, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ pos[0] = Tcl_Tell(out);
+ memset(buf, '\0', ZIP_LOCAL_HEADER_LEN);
+ memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen);
+ len = zpathlen + ZIP_LOCAL_HEADER_LEN;
+ if ((size_t) Tcl_Write(out, buf, len) != len) {
+ wrerr:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error on %s: %s", path, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ if ((len + pos[0]) & 3) {
+ unsigned char abuf[8];
+
+ /*
+ * Align payload to next 4-byte boundary using a dummy extra entry
+ * similar to the zipalign tool from Android's SDK.
+ */
+
+ align = 4 + ((len + pos[0]) & 3);
+ ZipWriteShort(abuf, 0xffff);
+ ZipWriteShort(abuf + 2, align - 4);
+ ZipWriteInt(abuf + 4, 0x03020100);
+ if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) {
+ goto wrerr;
+ }
+ }
+ if (passwd) {
+ int i, ch, tmp;
+ unsigned char kvbuf[24];
+ Tcl_Obj *ret;
+
+ init_keys(passwd, keys, crc32tab);
+ for (i = 0; i < 12 - 2; i++) {
+ double r;
+
+ if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != 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;
+ }
+ 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;
+ }
+ ch = (int) (r * 256);
+ kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp);
+ }
+ Tcl_ResetResult(interp);
+ init_keys(passwd, keys, crc32tab);
+ for (i = 0; i < 12 - 2; i++) {
+ kvbuf[i] = (unsigned char)
+ zencode(keys, crc32tab, kvbuf[i + 12], tmp);
+ }
+ kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp);
+ kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp);
+ len = Tcl_Write(out, (char *) kvbuf, 12);
+ memset(kvbuf, 0, 24);
+ if (len != 12) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error on %s: %s", path, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ memcpy(keys0, keys, sizeof(keys0));
+ nbytecompr += 12;
+ }
+ Tcl_Flush(out);
+ pos[2] = Tcl_Tell(out);
+ compMeth = ZIP_COMPMETH_DEFLATED;
+ memset(&stream, 0, sizeof(z_stream));
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8,
+ 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;
+ }
+ do {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "read error on %s: %s", path, Tcl_PosixError(interp)));
+ deflateEnd(&stream);
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ stream.avail_in = len;
+ stream.next_in = (unsigned char *) buf;
+ flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH;
+ do {
+ stream.avail_out = sizeof(obuf);
+ stream.next_out = (unsigned char *) obuf;
+ len = deflate(&stream, flush);
+ 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;
+ }
+ olen = sizeof(obuf) - stream.avail_out;
+ if (passwd) {
+ size_t i;
+ int tmp;
+
+ for (i = 0; i < olen; i++) {
+ obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp);
+ }
+ }
+ if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ deflateEnd(&stream);
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ nbytecompr += olen;
+ } while (stream.avail_out == 0);
+ } while (flush != Z_FINISH);
+ deflateEnd(&stream);
+ Tcl_Flush(out);
+ pos[1] = Tcl_Tell(out);
+ if (nbyte - nbytecompr <= 0) {
+ /*
+ * Compressed file larger than input, write it again uncompressed.
+ */
+ if (Tcl_Seek(in, 0, SEEK_SET) != 0) {
+ goto seekErr;
+ }
+ if (Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) {
+ seekErr:
+ Tcl_Close(interp, in);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ nbytecompr = (passwd ? 12 : 0);
+ while (1) {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "read error on \"%s\": %s",
+ path, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ } else if (len == 0) {
+ break;
+ }
+ if (passwd) {
+ size_t i;
+ int tmp;
+
+ for (i = 0; i < len; i++) {
+ buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp);
+ }
+ }
+ if ((size_t) Tcl_Write(out, buf, len) != len) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ nbytecompr += len;
+ }
+ compMeth = ZIP_COMPMETH_STORED;
+ Tcl_Flush(out);
+ pos[1] = Tcl_Tell(out);
+ Tcl_TruncateChannel(out, pos[1]);
+ }
+ 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;
+ z->zipFilePtr = NULL;
+ z->isDirectory = 0;
+ z->isEncrypted = (passwd ? 1 : 0);
+ z->offset = pos[0];
+ z->crc32 = crc;
+ z->timestamp = mtime;
+ z->numBytes = nbyte;
+ z->numCompressedBytes = nbytecompr;
+ z->compressMethod = compMeth;
+ z->data = NULL;
+ z->name = Tcl_GetHashKey(fileHash, hPtr);
+ z->next = NULL;
+
+ /*
+ * Write final local header information.
+ */
+ ZipWriteInt(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
+ ZipWriteShort(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted);
+ ZipWriteShort(buf + ZIP_LOCAL_COMPMETH_OFFS, z->compressMethod);
+ ZipWriteShort(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp));
+ ZipWriteShort(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp));
+ ZipWriteInt(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32);
+ ZipWriteInt(buf + ZIP_LOCAL_COMPLEN_OFFS, z->numCompressedBytes);
+ ZipWriteInt(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes);
+ ZipWriteShort(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen);
+ ZipWriteShort(buf + ZIP_LOCAL_EXTRALEN_OFFS, align);
+ if (Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ Tcl_Flush(out);
+ if (Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkZipOrImgObjCmd --
+ *
+ * This procedure is creates a new ZIP archive file or image file given
+ * output filename, input directory of files to be archived, optional
+ * password, and optional image to be prepended to the output ZIP archive
+ * file.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A new ZIP archive file or image file is written.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkZipOrImgObjCmd(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int isImg,
+ int isList,
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Channel out;
+ int pwlen = 0, count, ret = TCL_ERROR, lobjc;
+ size_t len, slen = 0, i = 0;
+ Tcl_WideInt pos[3];
+ Tcl_Obj **lobjv, *list = NULL;
+ ZipEntry *z;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_HashTable fileHash;
+ char *strip = NULL, *pw = NULL, passBuf[264], buf[4096];
+
+ /*
+ * Caller has verified that the number of arguments is correct.
+ */
+
+ passBuf[0] = 0;
+ if (objc > (isList ? 3 : 4)) {
+ pw = Tcl_GetString(objv[isList ? 3 : 4]);
+ pwlen = strlen(pw);
+ 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;
+ }
+ }
+ if (isList) {
+ list = objv[2];
+ Tcl_IncrRefCount(list);
+ } else {
+ Tcl_Obj *cmd[3];
+
+ cmd[1] = Tcl_NewStringObj("::tcl::zipfs::find", -1);
+ cmd[2] = objv[2];
+ cmd[0] = Tcl_NewListObj(2, cmd + 1);
+ Tcl_IncrRefCount(cmd[0]);
+ if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) {
+ Tcl_DecrRefCount(cmd[0]);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(cmd[0]);
+ list = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(list);
+ }
+ if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+ if (isList && (lobjc % 2)) {
+ 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);
+ if (out == NULL) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+ if (pwlen <= 0) {
+ pw = NULL;
+ pwlen = 0;
+ }
+ if (isImg) {
+ ZipFile *zf, zf0;
+ int isMounted = 0;
+ const char *imgName;
+
+ if (isList) {
+ imgName = (objc > 4) ? Tcl_GetString(objv[4]) :
+ Tcl_GetNameOfExecutable();
+ } else {
+ imgName = (objc > 5) ? Tcl_GetString(objv[5]) :
+ Tcl_GetNameOfExecutable();
+ }
+ if (pwlen) {
+ i = 0;
+ for (len = pwlen; len-- > 0;) {
+ int ch = pw[len];
+
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ i++;
+ }
+ passBuf[i] = i;
+ ++i;
+ passBuf[i++] = (char) ZIP_PASSWORD_END_SIG;
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8);
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16);
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24);
+ passBuf[i] = '\0';
+ }
+
+ /*
+ * Check for mounted image.
+ */
+
+ WriteLock();
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ zf = Tcl_GetHashValue(hPtr);
+ if (strcmp(zf->name, imgName) == 0) {
+ isMounted = 1;
+ zf->numOpen++;
+ break;
+ }
+ }
+ Unlock();
+ if (!isMounted) {
+ zf = &zf0;
+ }
+ if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) {
+ if ((size_t) Tcl_Write(out, (char *) zf->data,
+ zf->passOffset) != zf->passOffset) {
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, out);
+ if (zf == &zf0) {
+ ZipFSCloseArchive(interp, zf);
+ } else {
+ WriteLock();
+ zf->numOpen--;
+ Unlock();
+ }
+ return TCL_ERROR;
+ }
+ if (zf == &zf0) {
+ ZipFSCloseArchive(interp, zf);
+ } else {
+ WriteLock();
+ zf->numOpen--;
+ Unlock();
+ }
+ } else {
+ size_t k;
+ int m, n;
+ Tcl_Channel in;
+ const char *errMsg = "seek error";
+
+ /*
+ * Fall back to read it as plain file which hopefully is a static
+ * tclsh or wish binary with proper zipfs infrastructure built in.
+ */
+
+ Tcl_ResetResult(interp);
+ in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644);
+ if (!in) {
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_DecrRefCount(list);
+ Tcl_Close(interp, out);
+ return TCL_ERROR;
+ }
+ i = Tcl_Seek(in, 0, SEEK_END);
+ if (i == ERROR_LENGTH) {
+ cperr:
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s: %s", errMsg, Tcl_PosixError(interp)));
+ Tcl_Close(interp, out);
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ Tcl_Seek(in, 0, SEEK_SET);
+ for (k = 0; k < i; k += m) {
+ m = i - k;
+ if (m > (int) sizeof(buf)) {
+ m = (int) sizeof(buf);
+ }
+ n = Tcl_Read(in, buf, m);
+ if (n == -1) {
+ errMsg = "read error";
+ goto cperr;
+ } else if (n == 0) {
+ break;
+ }
+ m = Tcl_Write(out, buf, n);
+ if (m != n) {
+ errMsg = "write error";
+ goto cperr;
+ }
+ }
+ Tcl_Close(interp, in);
+ }
+ len = strlen(passBuf);
+ if (len > 0) {
+ i = Tcl_Write(out, passBuf, len);
+ if (i != len) {
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, out);
+ return TCL_ERROR;
+ }
+ }
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_Flush(out);
+ }
+ Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
+ pos[0] = Tcl_Tell(out);
+ if (!isList && (objc > 3)) {
+ strip = Tcl_GetString(objv[3]);
+ slen = strlen(strip);
+ }
+ for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) {
+ const char *path, *name;
+
+ path = Tcl_GetString(lobjv[i]);
+ if (isList) {
+ name = Tcl_GetString(lobjv[i + 1]);
+ } else {
+ name = path;
+ if (slen > 0) {
+ len = strlen(name);
+ if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
+ continue;
+ }
+ name += slen;
+ }
+ }
+ while (name[0] == '/') {
+ ++name;
+ }
+ if (name[0] == '\0') {
+ continue;
+ }
+ if (ZipAddFile(interp, path, name, out, pw, buf, sizeof(buf),
+ &fileHash) != TCL_OK) {
+ goto done;
+ }
+ }
+ pos[1] = Tcl_Tell(out);
+ count = 0;
+ for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) {
+ const char *path, *name;
+
+ path = Tcl_GetString(lobjv[i]);
+ if (isList) {
+ name = Tcl_GetString(lobjv[i + 1]);
+ } else {
+ name = path;
+ if (slen > 0) {
+ len = strlen(name);
+ if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
+ continue;
+ }
+ name += slen;
+ }
+ }
+ while (name[0] == '/') {
+ ++name;
+ }
+ if (name[0] == '\0') {
+ continue;
+ }
+ hPtr = Tcl_FindHashEntry(&fileHash, name);
+ if (!hPtr) {
+ continue;
+ }
+ z = Tcl_GetHashValue(hPtr);
+ len = strlen(z->name);
+ ZipWriteInt(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG);
+ ZipWriteShort(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted);
+ ZipWriteShort(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->compressMethod);
+ ZipWriteShort(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp));
+ ZipWriteShort(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp));
+ ZipWriteInt(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32);
+ ZipWriteInt(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->numCompressedBytes);
+ ZipWriteInt(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes);
+ ZipWriteShort(buf + ZIP_CENTRAL_PATHLEN_OFFS, len);
+ ZipWriteShort(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_IATTR_OFFS, 0);
+ ZipWriteInt(buf + ZIP_CENTRAL_EATTR_OFFS, 0);
+ ZipWriteInt(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]);
+ if ((Tcl_Write(out, buf,
+ ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN)
+ || ((size_t) Tcl_Write(out, z->name, len) != len)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ goto done;
+ }
+ count++;
+ }
+ Tcl_Flush(out);
+ pos[2] = Tcl_Tell(out);
+ ZipWriteInt(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG);
+ ZipWriteShort(buf + ZIP_CENTRAL_DISKNO_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_ENTS_OFFS, count);
+ ZipWriteShort(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count);
+ ZipWriteInt(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]);
+ ZipWriteInt(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]);
+ ZipWriteShort(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0);
+ if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ goto done;
+ }
+ Tcl_Flush(out);
+ ret = TCL_OK;
+
+ done:
+ if (ret == TCL_OK) {
+ ret = Tcl_Close(interp, out);
+ } else {
+ Tcl_Close(interp, out);
+ }
+ Tcl_DecrRefCount(list);
+ for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ z = Tcl_GetHashValue(hPtr);
+ ckfree(z);
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ Tcl_DeleteHashTable(&fileHash);
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd --
+ *
+ * These procedures are invoked to process the [zipfs mkzip] and [zipfs
+ * lmkzip] commands. See description of ZipFSMkZipOrImgCmd().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See description of ZipFSMkZipOrImgCmd().
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkZipObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ 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?");
+ return TCL_ERROR;
+ }
+ 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(interp, 0, 0, objc, objv);
+}
+
+static int
+ZipFSLMkZipObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?");
+ return TCL_ERROR;
+ }
+ 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(interp, 0, 1, objc, objv);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd --
+ *
+ * These procedures are invoked to process the [zipfs mkimg] and [zipfs
+ * lmkimg] commands. See description of ZipFSMkZipOrImgCmd().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See description of ZipFSMkZipOrImgCmd().
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkImgObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc < 3 || objc > 6) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "outfile indir ?strip? ?password? ?infile?");
+ return TCL_ERROR;
+ }
+ 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(interp, 1, 0, objc, objv);
+}
+
+static int
+ZipFSLMkImgObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ 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?");
+ return TCL_ERROR;
+ }
+ 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(interp, 1, 1, objc, objv);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSCanonicalObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs canonical] command.
+ * It returns the canonical name for a file within zipfs
+ *
+ * Results:
+ * Always TCL_OK provided the right number of arguments are supplied.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSCanonicalObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *mntpoint = NULL;
+ char *filename = NULL;
+ char *result;
+ Tcl_DString dPath;
+
+ if (objc < 2 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename ?inZipfs?");
+ return TCL_ERROR;
+ }
+ Tcl_DStringInit(&dPath);
+ if (objc == 2) {
+ filename = Tcl_GetString(objv[1]);
+ result = CanonicalPath("", filename, &dPath, 1);
+ } else if (objc == 3) {
+ mntpoint = Tcl_GetString(objv[1]);
+ filename = Tcl_GetString(objv[2]);
+ result = CanonicalPath(mntpoint, filename, &dPath, 1);
+ } else {
+ int zipfs = 0;
+
+ if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) {
+ return TCL_ERROR;
+ }
+ mntpoint = Tcl_GetString(objv[1]);
+ filename = Tcl_GetString(objv[2]);
+ result = CanonicalPath(mntpoint, filename, &dPath, zipfs);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSExistsObjCmd --
+ *
+ * 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.
+ *
+ * Results:
+ * Always TCL_OK provided the right number of arguments are supplied.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSExistsObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *filename;
+ int exists;
+ Tcl_DString ds;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "filename");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Prepend ZIPFS_VOLUME to filename, eliding the final /
+ */
+
+ filename = Tcl_GetString(objv[1]);
+ Tcl_DStringInit(&ds);
+ Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1);
+ Tcl_DStringAppend(&ds, filename, -1);
+ filename = Tcl_DStringValue(&ds);
+
+ ReadLock();
+ exists = ZipFSLookup(filename) != NULL;
+ Unlock();
+
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSInfoObjCmd --
+ *
+ * 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.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSInfoObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *filename;
+ ZipEntry *z;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "filename");
+ return TCL_ERROR;
+ }
+ filename = Tcl_GetString(objv[1]);
+ ReadLock();
+ z = ZipFSLookup(filename);
+ if (z) {
+ Tcl_Obj *result = Tcl_GetObjResult(interp);
+
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->zipFilePtr->name, -1));
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewWideIntObj(z->numBytes));
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewWideIntObj(z->numCompressedBytes));
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset));
+ }
+ Unlock();
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSListObjCmd --
+ *
+ * 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).
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSListObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *pattern = NULL;
+ Tcl_RegExp regexp = NULL;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_Obj *result = Tcl_GetObjResult(interp);
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ int n;
+ char *what = Tcl_GetStringFromObj(objv[1], &n);
+
+ if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) {
+ pattern = Tcl_GetString(objv[2]);
+ } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) {
+ regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2]));
+ if (!regexp) {
+ return TCL_ERROR;
+ }
+ } 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) {
+ pattern = Tcl_GetString(objv[1]);
+ }
+ ReadLock();
+ if (pattern) {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = Tcl_GetHashValue(hPtr);
+
+ if (Tcl_StringMatch(z->name, pattern)) {
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ } else if (regexp) {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = Tcl_GetHashValue(hPtr);
+
+ if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) {
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ } else {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = Tcl_GetHashValue(hPtr);
+
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ Unlock();
+ 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 inline int
+WCharToUtf(
+ const WCHAR *wSrc,
+ char *dst)
+{
+ char *start = dst;
+
+ while (*wSrc != '\0') {
+ dst += Tcl_UniCharToUtf(*wSrc, dst);
+ wSrc++;
+ }
+ *dst = '\0';
+ return (int) (dst - start);
+}
+#endif /* _WIN32 */
+
+Tcl_Obj *
+TclZipfs_TclLibrary(void)
+{
+ Tcl_Obj *vfsInitScript;
+ int found;
+#ifdef _WIN32
+ HMODULE hModule;
+ WCHAR wName[MAX_PATH + LIBRARY_SIZE];
+ char dllName[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
+#endif /* _WIN32 */
+
+ /*
+ * Use the cached value if that has been set; we don't want to repeat the
+ * searching and mounting.
+ */
+
+ if (zipfs_literal_tcl_library) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+
+ /*
+ * 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);
+ }
+
+ /*
+ * 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)
+ 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 anything set the cache (but subsequently failed) go with that
+ * anyway.
+ */
+
+ if (zipfs_literal_tcl_library) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+ return NULL;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSTclLibraryObjCmd --
+ *
+ * This procedure is invoked to process the
+ * [::tcl::zipfs::tcl_library_init] command, usually called during the
+ * execution of Tcl's interpreter startup. 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, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (!Tcl_IsSafe(interp)) {
+ Tcl_Obj *pResult = TclZipfs_TclLibrary();
+
+ if (!pResult) {
+ pResult = Tcl_NewObj();
+ }
+ Tcl_SetObjResult(interp, pResult);
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelClose --
+ *
+ * This function is called to close a channel.
+ *
+ * Results:
+ * Always TCL_OK.
+ *
+ * Side effects:
+ * Resources are free'd.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelClose(
+ ClientData instanceData,
+ Tcl_Interp *interp) /* Current interpreter. */
+{
+ ZipChannel *info = instanceData;
+
+ if (info->iscompr && info->ubuf) {
+ ckfree(info->ubuf);
+ info->ubuf = NULL;
+ }
+ if (info->isEncrypted) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ }
+ if (info->isWriting) {
+ ZipEntry *z = info->zipEntryPtr;
+ unsigned char *newdata = attemptckrealloc(info->ubuf, info->numRead);
+
+ if (newdata) {
+ if (z->data) {
+ ckfree(z->data);
+ }
+ z->data = newdata;
+ z->numBytes = z->numCompressedBytes = info->numBytes;
+ z->compressMethod = ZIP_COMPMETH_STORED;
+ z->timestamp = time(NULL);
+ z->isDirectory = 0;
+ z->isEncrypted = 0;
+ z->offset = 0;
+ z->crc32 = 0;
+ } else {
+ ckfree(info->ubuf);
+ }
+ }
+ WriteLock();
+ info->zipFilePtr->numOpen--;
+ Unlock();
+ ckfree(info);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelRead --
+ *
+ * This function is called to read data from channel.
+ *
+ * Results:
+ * Number of bytes read or -1 on error with error number set.
+ *
+ * Side effects:
+ * Data is read and file pointer is advanced.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelRead(
+ ClientData instanceData,
+ char *buf,
+ int toRead,
+ int *errloc)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+ unsigned long nextpos;
+
+ if (info->isDirectory < 0) {
+ /*
+ * Special case: when executable combined with ZIP archive file read
+ * data in front of ZIP, i.e. the executable itself.
+ */
+
+ nextpos = info->numRead + toRead;
+ if (nextpos > info->zipFilePtr->baseOffset) {
+ toRead = info->zipFilePtr->baseOffset - info->numRead;
+ nextpos = info->zipFilePtr->baseOffset;
+ }
+ if (toRead == 0) {
+ return 0;
+ }
+ memcpy(buf, info->zipFilePtr->data, toRead);
+ info->numRead = nextpos;
+ *errloc = 0;
+ return toRead;
+ }
+ if (info->isDirectory) {
+ *errloc = EISDIR;
+ return -1;
+ }
+ nextpos = info->numRead + toRead;
+ if (nextpos > info->numBytes) {
+ toRead = info->numBytes - info->numRead;
+ nextpos = info->numBytes;
+ }
+ if (toRead == 0) {
+ return 0;
+ }
+ if (info->isEncrypted) {
+ int i;
+
+ for (i = 0; i < toRead; i++) {
+ int ch = info->ubuf[i + info->numRead];
+
+ buf[i] = zdecode(info->keys, crc32tab, ch);
+ }
+ } else {
+ memcpy(buf, info->ubuf + info->numRead, toRead);
+ }
+ info->numRead = nextpos;
+ *errloc = 0;
+ return toRead;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelWrite --
+ *
+ * This function is called to write data into channel.
+ *
+ * Results:
+ * Number of bytes written or -1 on error with error number set.
+ *
+ * Side effects:
+ * Data is written and file pointer is advanced.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelWrite(
+ ClientData instanceData,
+ const char *buf,
+ int toWrite,
+ int *errloc)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+ unsigned long nextpos;
+
+ if (!info->isWriting) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ nextpos = info->numRead + toWrite;
+ if (nextpos > info->maxWrite) {
+ toWrite = info->maxWrite - info->numRead;
+ nextpos = info->maxWrite;
+ }
+ if (toWrite == 0) {
+ return 0;
+ }
+ memcpy(info->ubuf + info->numRead, buf, toWrite);
+ info->numRead = nextpos;
+ if (info->numRead > info->numBytes) {
+ info->numBytes = info->numRead;
+ }
+ *errloc = 0;
+ return toWrite;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelSeek --
+ *
+ * This function is called to position file pointer of channel.
+ *
+ * Results:
+ * New file position or -1 on error with error number set.
+ *
+ * Side effects:
+ * File pointer is repositioned according to offset and mode.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelSeek(
+ ClientData instanceData,
+ long offset,
+ int mode,
+ int *errloc)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+ unsigned long end;
+
+ if (!info->isWriting && (info->isDirectory < 0)) {
+ /*
+ * Special case: when executable combined with ZIP archive file, seek
+ * within front of ZIP, i.e. the executable itself.
+ */
+ end = info->zipFilePtr->baseOffset;
+ } else if (info->isDirectory) {
+ *errloc = EINVAL;
+ return -1;
+ } else {
+ end = info->numBytes;
+ }
+ switch (mode) {
+ case SEEK_CUR:
+ offset += info->numRead;
+ break;
+ case SEEK_END:
+ offset += end;
+ break;
+ case SEEK_SET:
+ break;
+ default:
+ *errloc = EINVAL;
+ return -1;
+ }
+ if (offset < 0) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ if (info->isWriting) {
+ if ((unsigned long) offset > info->maxWrite) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ if ((unsigned long) offset > info->numBytes) {
+ info->numBytes = offset;
+ }
+ } else if ((unsigned long) offset > end) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ info->numRead = (unsigned long) offset;
+ return info->numRead;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelWatchChannel --
+ *
+ * This function is called for event notifications on channel. Does
+ * nothing.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipChannelWatchChannel(
+ ClientData instanceData,
+ int mask)
+{
+ return;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelGetFile --
+ *
+ * This function is called to retrieve OS handle for channel.
+ *
+ * Results:
+ * Always TCL_ERROR since there's never an OS handle for a file within a
+ * ZIP archive.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelGetFile(
+ ClientData instanceData,
+ int direction,
+ ClientData *handlePtr)
+{
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelOpen --
+ *
+ * This function opens a Tcl_Channel on a file from a mounted ZIP archive
+ * according to given open mode.
+ *
+ * Results:
+ * Tcl_Channel on success, or NULL on error.
+ *
+ * Side effects:
+ * Memory is allocated, the file from the ZIP archive is uncompressed.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Channel
+ZipChannelOpen(
+ Tcl_Interp *interp, /* Current interpreter. */
+ char *filename,
+ int mode,
+ int permissions)
+{
+ ZipEntry *z;
+ ZipChannel *info;
+ int i, ch, trunc, wr, flags = 0;
+ char cname[128];
+
+ if ((mode & O_APPEND)
+ || ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) {
+ 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\": %s", filename,
+ Tcl_PosixError(interp)));
+ }
+ goto error;
+ }
+ trunc = (mode & O_TRUNC) != 0;
+ wr = (mode & (O_WRONLY | O_RDWR)) != 0;
+ 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 {
+ flags = TCL_WRITABLE;
+ }
+ 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;
+ info->zipEntryPtr = z;
+ info->numRead = 0;
+ if (wr) {
+ flags |= TCL_WRITABLE;
+ info->isWriting = 1;
+ info->isDirectory = 0;
+ info->maxWrite = ZipFS.wrmax;
+ info->iscompr = 0;
+ info->isEncrypted = 0;
+ info->ubuf = attemptckalloc(info->maxWrite);
+ if (!info->ubuf) {
+ merror0:
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ckfree(info);
+ ZIPFS_ERROR(interp, "out of memory");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ goto error;
+ }
+ memset(info->ubuf, 0, info->maxWrite);
+ if (trunc) {
+ info->numBytes = 0;
+ } else if (z->data) {
+ unsigned int j = z->numBytes;
+
+ if (j > info->maxWrite) {
+ j = info->maxWrite;
+ }
+ memcpy(info->ubuf, z->data, j);
+ info->numBytes = j;
+ } else {
+ unsigned char *zbuf = z->zipFilePtr->data + z->offset;
+
+ if (z->isEncrypted) {
+ int len = z->zipFilePtr->passBuf[0];
+ char passBuf[260];
+
+ for (i = 0; i < len; i++) {
+ ch = z->zipFilePtr->passBuf[len - i];
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ }
+ passBuf[i] = '\0';
+ init_keys(passBuf, info->keys, crc32tab);
+ memset(passBuf, 0, sizeof(passBuf));
+ for (i = 0; i < 12; i++) {
+ ch = info->ubuf[i];
+ zdecode(info->keys, crc32tab, ch);
+ }
+ zbuf += i;
+ }
+ if (z->compressMethod == ZIP_COMPMETH_DEFLATED) {
+ z_stream stream;
+ int err;
+ unsigned char *cbuf = NULL;
+
+ memset(&stream, 0, sizeof(z_stream));
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ stream.avail_in = z->numCompressedBytes;
+ if (z->isEncrypted) {
+ unsigned int j;
+
+ stream.avail_in -= 12;
+ cbuf = attemptckalloc(stream.avail_in);
+ if (!cbuf) {
+ goto merror0;
+ }
+ for (j = 0; j < stream.avail_in; j++) {
+ ch = info->ubuf[j];
+ cbuf[j] = zdecode(info->keys, crc32tab, ch);
+ }
+ stream.next_in = cbuf;
+ } else {
+ stream.next_in = zbuf;
+ }
+ stream.next_out = info->ubuf;
+ stream.avail_out = info->maxWrite;
+ if (inflateInit2(&stream, -15) != Z_OK) {
+ goto cerror0;
+ }
+ err = inflate(&stream, Z_SYNC_FLUSH);
+ inflateEnd(&stream);
+ if ((err == Z_STREAM_END)
+ || ((err == Z_OK) && (stream.avail_in == 0))) {
+ if (cbuf) {
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(cbuf);
+ }
+ goto wrapchan;
+ }
+ cerror0:
+ if (cbuf) {
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(cbuf);
+ }
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ 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++) {
+ ch = zbuf[i];
+ info->ubuf[i] = zdecode(info->keys, crc32tab, ch);
+ }
+ } else {
+ memcpy(info->ubuf, zbuf, z->numBytes);
+ }
+ memset(info->keys, 0, sizeof(info->keys));
+ goto wrapchan;
+ }
+ } else if (z->data) {
+ flags |= TCL_READABLE;
+ info->isWriting = 0;
+ info->iscompr = 0;
+ info->isDirectory = 0;
+ info->isEncrypted = 0;
+ info->numBytes = z->numBytes;
+ info->maxWrite = 0;
+ info->ubuf = z->data;
+ } else {
+ flags |= TCL_READABLE;
+ info->isWriting = 0;
+ info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED);
+ info->ubuf = z->zipFilePtr->data + z->offset;
+ info->isDirectory = z->isDirectory;
+ info->isEncrypted = z->isEncrypted;
+ info->numBytes = z->numBytes;
+ info->maxWrite = 0;
+ if (info->isEncrypted) {
+ int len = z->zipFilePtr->passBuf[0];
+ char passBuf[260];
+
+ for (i = 0; i < len; i++) {
+ ch = z->zipFilePtr->passBuf[len - i];
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ }
+ passBuf[i] = '\0';
+ init_keys(passBuf, info->keys, crc32tab);
+ memset(passBuf, 0, sizeof(passBuf));
+ for (i = 0; i < 12; i++) {
+ ch = info->ubuf[i];
+ zdecode(info->keys, crc32tab, ch);
+ }
+ info->ubuf += i;
+ }
+ if (info->iscompr) {
+ z_stream stream;
+ int err;
+ unsigned char *ubuf = NULL;
+ unsigned int j;
+
+ memset(&stream, 0, sizeof(z_stream));
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ stream.avail_in = z->numCompressedBytes;
+ if (info->isEncrypted) {
+ stream.avail_in -= 12;
+ ubuf = attemptckalloc(stream.avail_in);
+ if (!ubuf) {
+ info->ubuf = NULL;
+ goto merror;
+ }
+ for (j = 0; j < stream.avail_in; j++) {
+ ch = info->ubuf[j];
+ ubuf[j] = zdecode(info->keys, crc32tab, ch);
+ }
+ stream.next_in = ubuf;
+ } else {
+ stream.next_in = info->ubuf;
+ }
+ stream.next_out = info->ubuf = attemptckalloc(info->numBytes);
+ if (!info->ubuf) {
+ merror:
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ ckfree(info);
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("out of memory", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ goto error;
+ }
+ stream.avail_out = info->numBytes;
+ if (inflateInit2(&stream, -15) != Z_OK) {
+ goto cerror;
+ }
+ err = inflate(&stream, Z_SYNC_FLUSH);
+ inflateEnd(&stream);
+ if ((err == Z_STREAM_END)
+ || ((err == Z_OK) && (stream.avail_in == 0))) {
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ goto wrapchan;
+ }
+ cerror:
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ckfree(info);
+ ZIPFS_ERROR(interp, "decompression error");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL);
+ }
+ goto error;
+ }
+ }
+
+ wrapchan:
+ sprintf(cname, "zipfs_%" TCL_LL_MODIFIER "x_%d", z->offset,
+ ZipFS.idCount++);
+ z->zipFilePtr->numOpen++;
+ Unlock();
+ return Tcl_CreateChannel(&ZipChannelType, cname, info, flags);
+
+ error:
+ Unlock();
+ return NULL;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipEntryStat --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of stat.
+ *
+ * Results:
+ * See stat documentation.
+ *
+ * Side effects:
+ * See stat documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipEntryStat(
+ char *path,
+ Tcl_StatBuf *buf)
+{
+ ZipEntry *z;
+ int ret = -1;
+
+ ReadLock();
+ z = ZipFSLookup(path);
+ if (z) {
+ memset(buf, 0, sizeof(Tcl_StatBuf));
+ if (z->isDirectory) {
+ buf->st_mode = S_IFDIR | 0555;
+ } else {
+ buf->st_mode = S_IFREG | 0555;
+ }
+ buf->st_size = z->numBytes;
+ buf->st_mtime = z->timestamp;
+ buf->st_ctime = z->timestamp;
+ buf->st_atime = z->timestamp;
+ ret = 0;
+ }
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipEntryAccess --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of access.
+ *
+ * Results:
+ * See access documentation.
+ *
+ * Side effects:
+ * See access documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipEntryAccess(
+ char *path,
+ int mode)
+{
+ ZipEntry *z;
+
+ if (mode & 3) {
+ return -1;
+ }
+ ReadLock();
+ z = ZipFSLookup(path);
+ Unlock();
+ return (z ? 0 : -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSOpenFileChannelProc --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Channel
+ZipFSOpenFileChannelProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *pathPtr,
+ int mode,
+ int permissions)
+{
+ int len;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return NULL;
+ }
+ return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode,
+ permissions);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSStatProc --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of stat.
+ *
+ * Results:
+ * See stat documentation.
+ *
+ * Side effects:
+ * See stat documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSStatProc(
+ Tcl_Obj *pathPtr,
+ Tcl_StatBuf *buf)
+{
+ int len;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSAccessProc --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of access.
+ *
+ * Results:
+ * See access documentation.
+ *
+ * Side effects:
+ * See access documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSAccessProc(
+ Tcl_Obj *pathPtr,
+ int mode)
+{
+ int len;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFilesystemSeparatorProc --
+ *
+ * This function returns the separator to be used for a given path. The
+ * object returned should have a refCount of zero
+ *
+ * Results:
+ * A Tcl object, with a refCount of zero. If the caller needs to retain a
+ * reference to the object, it should call Tcl_IncrRefCount, and should
+ * otherwise free the object.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSFilesystemSeparatorProc(
+ Tcl_Obj *pathPtr)
+{
+ return Tcl_NewStringObj("/", -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMatchInDirectoryProc --
+ *
+ * This routine is used by the globbing code to search a directory for
+ * all files which match a given pattern.
+ *
+ * Results:
+ * The return value is a standard Tcl result indicating whether an error
+ * occurred in globbing. Errors are left in interp, good results are
+ * lappend'ed to resultPtr (which must be a valid object).
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMatchInDirectoryProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *result,
+ Tcl_Obj *pathPtr,
+ const char *pattern,
+ Tcl_GlobTypeData *types)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ int scnt, l, dirOnly = -1, prefixLen, strip = 0;
+ size_t len;
+ char *pat, *prefix, *path;
+ Tcl_DString dsPref;
+
+ if (!normPathPtr) {
+ return -1;
+ }
+ if (types) {
+ dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR;
+ }
+
+ /*
+ * The prefix that gets prepended to results.
+ */
+
+ prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen);
+
+ /*
+ * The (normalized) path we're searching.
+ */
+
+ path = Tcl_GetString(normPathPtr);
+ len = normPathPtr->length;
+
+ Tcl_DStringInit(&dsPref);
+ Tcl_DStringAppend(&dsPref, prefix, prefixLen);
+
+ if (strcmp(prefix, path) == 0) {
+ prefix = NULL;
+ } else {
+ strip = len + 1;
+ }
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, "/", 1);
+ prefixLen++;
+ prefix = Tcl_DStringValue(&dsPref);
+ }
+ ReadLock();
+ if (types && (types->type == TCL_GLOB_TYPE_MOUNT)) {
+ l = CountSlashes(path);
+ if (path[len - 1] == '/') {
+ len--;
+ } else {
+ l++;
+ }
+ if (!pattern || (pattern[0] == '\0')) {
+ pattern = "*";
+ }
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = Tcl_GetHashValue(hPtr);
+
+ if (zf->mountPointLen == 0) {
+ ZipEntry *z;
+
+ for (z = zf->topEnts; z; z = z->tnext) {
+ size_t lenz = strlen(z->name);
+
+ if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0)
+ && (z->name[len] == '/')
+ && (CountSlashes(z->name) == l)
+ && Tcl_StringCaseMatch(z->name + len + 1, pattern,
+ 0)) {
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, z->name, lenz);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
+ Tcl_DStringLength(&dsPref)));
+ Tcl_DStringSetLength(&dsPref, prefixLen);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(z->name, lenz));
+ }
+ }
+ }
+ } else if ((zf->mountPointLen > len + 1)
+ && (strncmp(zf->mountPoint, path, len) == 0)
+ && (zf->mountPoint[len] == '/')
+ && (CountSlashes(zf->mountPoint) == l)
+ && Tcl_StringCaseMatch(zf->mountPoint + len + 1,
+ pattern, 0)) {
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, zf->mountPoint,
+ zf->mountPointLen);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
+ Tcl_DStringLength(&dsPref)));
+ Tcl_DStringSetLength(&dsPref, prefixLen);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(zf->mountPoint,
+ zf->mountPointLen));
+ }
+ }
+ }
+ goto end;
+ }
+
+ if (!pattern || (pattern[0] == '\0')) {
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
+ if (hPtr) {
+ ZipEntry *z = Tcl_GetHashValue(hPtr);
+
+ if ((dirOnly < 0) || (!dirOnly && !z->isDirectory)
+ || (dirOnly && z->isDirectory)) {
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, z->name, -1);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
+ Tcl_DStringLength(&dsPref)));
+ Tcl_DStringSetLength(&dsPref, prefixLen);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ }
+ goto end;
+ }
+
+ l = strlen(pattern);
+ pat = ckalloc(len + l + 2);
+ memcpy(pat, path, len);
+ while ((len > 1) && (pat[len - 1] == '/')) {
+ --len;
+ }
+ if ((len > 1) || (pat[0] != '/')) {
+ pat[len] = '/';
+ ++len;
+ }
+ memcpy(pat + len, pattern, l + 1);
+ scnt = CountSlashes(pat);
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = Tcl_GetHashValue(hPtr);
+
+ if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory)
+ || (!dirOnly && z->isDirectory))) {
+ continue;
+ }
+ if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) {
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, z->name + strip, -1);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
+ Tcl_DStringLength(&dsPref)));
+ Tcl_DStringSetLength(&dsPref, prefixLen);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(z->name + strip, -1));
+ }
+ }
+ }
+ ckfree(pat);
+
+ end:
+ Unlock();
+ Tcl_DStringFree(&dsPref);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSPathInFilesystemProc --
+ *
+ * This function determines if the given path object is in the ZIP
+ * filesystem.
+ *
+ * Results:
+ * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSPathInFilesystemProc(
+ Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ int ret = -1;
+ size_t len;
+ char *path;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+
+ path = Tcl_GetString(pathPtr);
+ if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) {
+ return -1;
+ }
+
+ len = pathPtr->length;
+
+ ReadLock();
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
+ if (hPtr) {
+ ret = TCL_OK;
+ goto endloop;
+ }
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = Tcl_GetHashValue(hPtr);
+
+ if (zf->mountPointLen == 0) {
+ ZipEntry *z;
+
+ for (z = zf->topEnts; z != NULL; z = z->tnext) {
+ size_t lenz = strlen(z->name);
+
+ if ((len >= lenz) && (strncmp(path, z->name, lenz) == 0)) {
+ ret = TCL_OK;
+ goto endloop;
+ }
+ }
+ } else if ((len >= zf->mountPointLen) &&
+ (strncmp(path, zf->mountPoint, zf->mountPointLen) == 0)) {
+ ret = TCL_OK;
+ break;
+ }
+ }
+
+ endloop:
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSListVolumesProc --
+ *
+ * Lists the currently mounted ZIP filesystem volumes.
+ *
+ * Results:
+ * The list of volumes.
+ *
+ * Side effects:
+ * None
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSListVolumesProc(void)
+{
+ return Tcl_NewStringObj(ZIPFS_VOLUME, -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFileAttrStringsProc --
+ *
+ * This function implements the ZIP filesystem dependent 'file
+ * attributes' subcommand, for listing the set of possible attribute
+ * strings.
+ *
+ * Results:
+ * An array of strings
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static const char *const *
+ZipFSFileAttrStringsProc(
+ Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef)
+{
+ static const char *const attrs[] = {
+ "-uncompsize",
+ "-compsize",
+ "-offset",
+ "-mount",
+ "-archive",
+ "-permissions",
+ NULL,
+ };
+ return attrs;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFileAttrsGetProc --
+ *
+ * This function implements the ZIP filesystem specific 'file attributes'
+ * subcommand, for 'get' operations.
+ *
+ * Results:
+ * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
+ * was returned) is likely to have a refCount of zero. Either way we must
+ * either store it somewhere (e.g. the Tcl result), or Incr/Decr its
+ * refCount to ensure it is properly freed.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFileAttrsGetProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int index,
+ Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef)
+{
+ int len, ret = TCL_OK;
+ char *path;
+ ZipEntry *z;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ path = Tcl_GetStringFromObj(pathPtr, &len);
+ ReadLock();
+ z = ZipFSLookup(path);
+ if (!z) {
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_POSIX_ERROR(interp, "file not found");
+ ret = TCL_ERROR;
+ goto done;
+ }
+ switch (index) {
+ case 0:
+ *objPtrRef = Tcl_NewWideIntObj(z->numBytes);
+ break;
+ case 1:
+ *objPtrRef = Tcl_NewWideIntObj(z->numCompressedBytes);
+ break;
+ case 2:
+ *objPtrRef = Tcl_NewWideIntObj(z->offset);
+ break;
+ case 3:
+ *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
+ z->zipFilePtr->mountPointLen);
+ break;
+ case 4:
+ *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1);
+ break;
+ case 5:
+ *objPtrRef = Tcl_NewStringObj("0555", -1);
+ break;
+ default:
+ ZIPFS_ERROR(interp, "unknown attribute");
+ ret = TCL_ERROR;
+ }
+
+ done:
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFileAttrsSetProc --
+ *
+ * This function implements the ZIP filesystem specific 'file attributes'
+ * subcommand, for 'set' operations.
+ *
+ * Results:
+ * Standard Tcl return code.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFileAttrsSetProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int index,
+ Tcl_Obj *pathPtr,
+ Tcl_Obj *objPtr)
+{
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFilesystemPathTypeProc --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSFilesystemPathTypeProc(
+ Tcl_Obj *pathPtr)
+{
+ return Tcl_NewStringObj("zip", -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLoadFile --
+ *
+ * This functions deals with loading native object code. If the given
+ * path object refers to a file within the ZIP filesystem, an approriate
+ * error code is returned to delegate loading to the caller (by copying
+ * the file to temp store and loading from there). As fallback when the
+ * file refers to the ZIP file system but is not present, it is looked up
+ * relative to the executable and loaded from there when available.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with error message left.
+ *
+ * Side effects:
+ * Loads native code into the process address space.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSLoadFile(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *path,
+ Tcl_LoadHandle *loadHandle,
+ Tcl_FSUnloadFileProc **unloadProcPtr,
+ int flags)
+{
+ Tcl_FSLoadFileProc2 *loadFileProc;
+#ifdef ANDROID
+ /*
+ * Force loadFileProc to native implementation since the package manager
+ * already extracted the shared libraries from the APK at install time.
+ */
+
+ loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc;
+ if (loadFileProc) {
+ return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags);
+ }
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_ERROR(interp, Tcl_PosixError(interp));
+ return TCL_ERROR;
+#else /* !ANDROID */
+ Tcl_Obj *altPath = NULL;
+ int ret = TCL_ERROR;
+ Tcl_Obj *objs[2] = { NULL, NULL };
+
+ if (Tcl_FSAccess(path, R_OK) == 0) {
+ /*
+ * EXDEV should trigger loading by copying to temp store.
+ */
+
+ Tcl_SetErrno(EXDEV);
+ ZIPFS_ERROR(interp, Tcl_PosixError(interp));
+ return ret;
+ }
+
+ objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME);
+ if (objs[1] && (ZipFSAccessProc(objs[1], R_OK) == 0)) {
+ const char *execName = Tcl_GetNameOfExecutable();
+
+ /*
+ * Shared object is not in ZIP but its path prefix is, thus try to
+ * load from directory where the executable came from.
+ */
+
+ TclDecrRefCount(objs[1]);
+ objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL);
+
+ /*
+ * Get directory name of executable manually to deal with cases where
+ * [file dirname [info nameofexecutable]] is equal to [info
+ * nameofexecutable] due to VFS effects.
+ */
+
+ if (execName) {
+ const char *p = strrchr(execName, '/');
+
+ if (p > execName + 1) {
+ --p;
+ objs[0] = Tcl_NewStringObj(execName, p - execName);
+ }
+ }
+ if (!objs[0]) {
+ objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(),
+ TCL_PATH_DIRNAME);
+ }
+ if (objs[0]) {
+ altPath = TclJoinPath(2, objs);
+ if (altPath) {
+ Tcl_IncrRefCount(altPath);
+ if (Tcl_FSAccess(altPath, R_OK) == 0) {
+ path = altPath;
+ }
+ }
+ }
+ }
+ if (objs[0]) {
+ Tcl_DecrRefCount(objs[0]);
+ }
+ if (objs[1]) {
+ Tcl_DecrRefCount(objs[1]);
+ }
+
+ loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc;
+ if (loadFileProc) {
+ ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags);
+ } else {
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_ERROR(interp, Tcl_PosixError(interp));
+ }
+ if (altPath) {
+ Tcl_DecrRefCount(altPath);
+ }
+ return ret;
+#endif /* ANDROID */
+}
+
+#endif /* HAVE_ZLIB */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Init --
+ *
+ * Perform per interpreter initialization of this module.
+ *
+ * Results:
+ * The return value is a standard Tcl result.
+ *
+ * Side effects:
+ * Initializes this module if not already initialized, and adds module
+ * related commands to the given interpreter.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+MODULE_SCOPE int
+TclZipfs_Init(
+ Tcl_Interp *interp) /* Current interpreter. */
+{
+#ifdef HAVE_ZLIB
+ static const EnsembleImplMap initMap[] = {
+ {"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, 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},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
+ static const char findproc[] =
+ "namespace eval ::tcl::zipfs {}\n"
+ "proc ::tcl::zipfs::Find dir {\n"
+ " set result {}\n"
+ " if {[catch {glob -directory $dir -nocomplain * .*} list]} {\n"
+ " return $result\n"
+ " }\n"
+ " foreach file $list {\n"
+ " if {[file tail $file] in {. ..}} {\n"
+ " continue\n"
+ " }\n"
+ " lappend result $file {*}[Find $file]\n"
+ " }\n"
+ " return $result\n"
+ "}\n"
+ "proc ::tcl::zipfs::find {directoryName} {\n"
+ " return [lsort [Find $directoryName]]\n"
+ "}\n";
+
+ /*
+ * One-time initialization.
+ */
+
+ WriteLock();
+ /* Tcl_StaticPackage(interp, "zipfs", TclZipfs_Init, TclZipfs_Init); */
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+ Unlock();
+
+ if (interp) {
+ Tcl_Command ensemble;
+ Tcl_Obj *mapObj;
+
+ Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL);
+ Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax,
+ TCL_LINK_INT);
+ ensemble = TclMakeEnsemble(interp, "zipfs",
+ Tcl_IsSafe(interp) ? (initMap + 4) : initMap);
+
+ /*
+ * Add the [zipfs find] subcommand.
+ */
+
+ Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
+ Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1),
+ Tcl_NewStringObj("::tcl::zipfs::find", -1));
+ Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
+ ZipFSTclLibraryObjCmd, NULL, NULL);
+ Tcl_PkgProvide(interp, "zipfs", "2.0");
+ }
+ return TCL_OK;
+#else /* !HAVE_ZLIB */
+ ZIPFS_ERROR(interp, "no zlib available");
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ return TCL_ERROR;
+#endif /* HAVE_ZLIB */
+}
+
+static int
+ZipfsAppHookFindTclInit(
+ const char *archive)
+{
+ Tcl_Obj *vfsInitScript;
+ int found;
+
+ if (zipfs_literal_tcl_library) {
+ return TCL_ERROR;
+ }
+ if (TclZipfs_Mount(NULL, ZIPFS_ZIP_MOUNT, archive, NULL)) {
+ /* Either the file doesn't exist or it is not a zip archive */
+ return TCL_ERROR;
+ }
+
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_ZIP_MOUNT "/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == 0) {
+ zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT;
+ return TCL_OK;
+ }
+
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == 0) {
+ zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library";
+ return TCL_OK;
+ }
+
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_AppHook --
+ *
+ * Performs the argument munging for the shell
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_AppHook(
+ int *argcPtr, /* Pointer to argc */
+#ifdef _WIN32
+ TCHAR
+#else /* !_WIN32 */
+ char
+#endif /* _WIN32 */
+ ***argvPtr) /* Pointer to argv */
+{
+ char *archive;
+
+ Tcl_FindExecutable((*argvPtr)[0]);
+ archive = (char *) Tcl_GetNameOfExecutable();
+ TclZipfs_Init(NULL);
+
+ /*
+ * Look for init.tcl in one of the locations mounted later in this
+ * function.
+ */
+
+ if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) {
+ int found;
+ Tcl_Obj *vfsInitScript;
+
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
+ /*
+ * Startup script should be set before calling Tcl_AppInit
+ */
+
+ Tcl_SetStartupScript(vfsInitScript, NULL);
+ } else {
+ Tcl_DecrRefCount(vfsInitScript);
+ }
+
+ /*
+ * Set Tcl Encodings
+ */
+
+ if (!zipfs_literal_tcl_library) {
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
+ 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_OK;
+ }
+ }
+#ifdef SUPPORT_BUILTIN_ZIP_INSTALL
+ } else if (*argcPtr > 1) {
+ /*
+ * 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];
+#endif /* _WIN32 */
+ if (strcmp(archive, "install") == 0) {
+ Tcl_Obj *vfsInitScript;
+
+ /*
+ * Run this now to ensure the file is present by the time Tcl_Main
+ * wants it.
+ */
+
+ TclZipfs_TclLibrary();
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
+ Tcl_SetStartupScript(vfsInitScript, NULL);
+ }
+ return TCL_OK;
+ } else if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) {
+ int found;
+ Tcl_Obj *vfsInitScript;
+
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
+ /*
+ * Startup script should be set before calling Tcl_AppInit
+ */
+
+ Tcl_SetStartupScript(vfsInitScript, NULL);
+ } else {
+ Tcl_DecrRefCount(vfsInitScript);
+ }
+ /* Set Tcl Encodings */
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
+ 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_OK;
+ }
+ }
+#ifdef _WIN32
+ Tcl_DStringFree(&ds);
+#endif /* _WIN32 */
+#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */
+ }
+ return TCL_OK;
+}
+
+#ifndef HAVE_ZLIB
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount --
+ *
+ * Dummy version when no ZLIB support available.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Mount(
+ Tcl_Interp *interp, /* Current interpreter. */
+ const char *mountPoint, /* Mount point path. */
+ const char *zipname, /* Path to ZIP file to mount. */
+ const char *passwd) /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ }
+ return TCL_ERROR;
+}
+
+int
+TclZipfs_MountBuffer(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint, /* Mount point path. */
+ unsigned char *data,
+ size_t datalen,
+ int copy)
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ }
+ return TCL_ERROR;
+}
+
+int
+TclZipfs_Unmount(
+ Tcl_Interp *interp, /* Current interpreter. */
+ 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 */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 994bcef..d4a8ecb 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -117,7 +117,7 @@ typedef struct {
z_stream outStream; /* Structure used by zlib for compression of
* output. */
char *inBuffer, *outBuffer; /* Working buffers. */
- int inAllocated, outAllocated;
+ size_t inAllocated, outAllocated;
/* Sizes of working buffers. */
GzipHeader inHeader; /* Header read from input stream, when
* decompressing a gzip stream. */
@@ -1515,7 +1515,7 @@ Tcl_ZlibStreamGet(
Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
if (itemLen-zshPtr->outPos >= count-dataPos) {
- unsigned len = count - dataPos;
+ size_t len = count - dataPos;
memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
zshPtr->outPos += len;
@@ -1524,7 +1524,7 @@ Tcl_ZlibStreamGet(
zshPtr->outPos = 0;
}
} else {
- unsigned len = itemLen - zshPtr->outPos;
+ size_t len = itemLen - zshPtr->outPos;
memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
dataPos += len;
@@ -2931,7 +2931,7 @@ ZlibTransformClose(
result = TCL_ERROR;
break;
}
- if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) {
+ if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) == TCL_IO_FAILURE) {
/* TODO: is this the right way to do errors on close?
* Note: when close is called from FinalizeIOSubsystem then
* interp may be NULL */
@@ -3130,7 +3130,7 @@ ZlibTransformOutput(
break;
}
- if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
+ if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) == TCL_IO_FAILURE) {
*errorCodePtr = Tcl_GetErrno();
return -1;
}
@@ -3186,7 +3186,7 @@ ZlibTransformFlush(
* Write the bytes we've received to the next layer.
*/
- if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) {
+ if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) == TCL_IO_FAILURE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"problem flushing channel: %s",
Tcl_PosixError(interp)));
@@ -3909,6 +3909,12 @@ TclZlibInit(
Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
/*
+ * Allow command type introspection to do something sensible with streams.
+ */
+
+ TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream");
+
+ /*
* Formally provide the package as a Tcl built-in.
*/