summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog29
-rw-r--r--doc/dde.n22
-rw-r--r--generic/tclFileName.c4
-rw-r--r--generic/tclIORChan.c4
-rw-r--r--generic/tclOO.c68
-rw-r--r--generic/tclOOBasic.c138
-rw-r--r--generic/tclOODefineCmds.c103
-rw-r--r--generic/tclOOInt.h9
-rw-r--r--generic/tclOOMethod.c9
-rw-r--r--generic/tclPathObj.c2
-rw-r--r--generic/tclZlib.c102
-rw-r--r--library/dde/pkgIndex.tcl4
-rw-r--r--tests/all.tcl1
-rw-r--r--tests/io.test6
-rw-r--r--tests/oo.test110
-rw-r--r--tests/socket.test2
-rw-r--r--tests/winDde.test18
-rw-r--r--unix/tclUnixSock.c3
-rw-r--r--win/Makefile.in12
-rwxr-xr-xwin/configure4
-rw-r--r--win/configure.in4
-rw-r--r--win/makefile.bc4
-rw-r--r--win/makefile.vc2
-rw-r--r--win/tclWinDde.c103
24 files changed, 497 insertions, 266 deletions
diff --git a/ChangeLog b/ChangeLog
index e8cecb8..2166fb8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,32 @@
+2012-05-23 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclZlib.c (ZlibTransformInput): [Bug 3525907]: Ensure that
+ decompressed input is flushed through the transform correctly when the
+ input stream gets to the end. Thanks to Alexandre Ferrieux and Andreas
+ Kupries for their work on this.
+
+2012-05-21 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclFileName.c: When using Tcl_SetObjLength() calls to grow
+ * generic/tclPathObj.c: and shrink the objPtr->bytes buffer, care must be
+ taken that the value cannot possibly become pure Unicode. Calling
+ Tcl_AppendToObj() has the possibility of making such a conversion. Bug
+ found while valgrinding the trunk.
+
+2012-05-21 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/tclWinDde.c: TIP #106: Add Encoding Abilities to the [dde]
+ * library/dde/pkgIndex.tcl: Command. Dde version is now 1.4.0.
+ * tests/winDde.test:
+ * doc/dde.n:
+
+2012-05-20 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut
+ the amount of hackiness in class constructors, and refactor some of
+ the error message handling from [oo::define] to be saner in the face
+ of odd happenings.
+
2012-05-17 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): [Bug 3106532]: Corrected
diff --git a/doc/dde.n b/doc/dde.n
index a02c582..60dd058 100644
--- a/doc/dde.n
+++ b/doc/dde.n
@@ -17,9 +17,11 @@ dde \- Execute a Dynamic Data Exchange command
.sp
\fBdde servername\fR ?\fB\-force\fR? ?\fB\-handler \fIproc\fR? ?\fB\-\|\-\fR? ?\fItopic\fR?
.sp
-\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR
+.VS 8.6
+\fBdde execute\fR ?\fB\-async\fR? ?\fB\-binary\fR? \fIservice topic data\fR
.sp
-\fBdde poke\fR \fIservice topic item data\fR
+\fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR
+.VE 8.6
.sp
\fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR
.sp
@@ -69,7 +71,7 @@ procedure is called with all the arguments provided by the remote
call.
.RE
.TP
-\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR
+\fBdde execute\fR ?\fB\-async\fR? ?\fB\-binary\fR? \fIservice topic data\fR
.
\fBdde execute\fR takes the \fIdata\fR and sends it to the server indicated
by \fIservice\fR with the topic indicated by \fItopic\fR. Typically,
@@ -80,8 +82,13 @@ script is run in the application. The \fB\-async\fR option requests
asynchronous invocation. The command returns an error message if the
script did not run, unless the \fB\-async\fR flag was used, in which case
the command returns immediately with no error.
+.VS 8.6
+The \fB\-binary\fR option treats \fIdata\fR as binary data, otherwise an utf-8
+string is sent. Combining \fB-binary\fR with the result of
+\fBencoding convertto\fR may be used to send data in arbitrary encodings.
+.VE 8.6
.TP
-\fBdde poke \fIservice topic item data\fR
+\fBdde poke ?\fB\-binary\fR? \fIservice topic item data\fR
.
\fBdde poke\fR passes the \fIdata\fR to the server indicated by
\fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically,
@@ -90,6 +97,10 @@ specific but can be a command to the server or the name of a file to work
on. The \fIitem\fR is also application specific and is often not used, but
it must always be non-null. The \fIdata\fR field is given to the remote
application.
+.VS 8.6
+The \fB\-binary\fR option treats \fIdata\fR as binary data, otherwise an utf-8
+string is sent.
+.VE 8.6
.TP
\fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR
.
@@ -168,3 +179,6 @@ package require dde
tk(n), winfo(n), send(n)
.SH KEYWORDS
application, dde, name, remote execution
+'\"Local Variables:
+'\"mode: nroff
+'\"End:
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 5048308..b130169 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -863,7 +863,7 @@ TclpNativeJoinPath(
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
- length++;
+ Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -899,7 +899,7 @@ TclpNativeJoinPath(
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
- length++;
+ Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 2d31da3..938def2 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -934,8 +934,11 @@ TclChanPostEventObjCmd(
* We have the channel and the events to post.
*/
+#ifdef TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
+#endif
Tcl_NotifyChannel (chan, events);
+#ifdef TCL_THREADS
} else {
ReflectEvent* ev = ckalloc (sizeof (ReflectEvent));
ev->header.proc = ReflectEventRun;
@@ -965,6 +968,7 @@ TclChanPostEventObjCmd(
Tcl_ThreadQueueEvent (rcPtr->owner, (Tcl_Event*) ev, TCL_QUEUE_TAIL);
Tcl_ThreadAlert (rcPtr->owner);
}
+#endif
/*
* Squash interp results left by the event script.
diff --git a/generic/tclOO.c b/generic/tclOO.c
index d5cc6e1..26e6d75 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -123,6 +123,16 @@ static const DeclaredClassMethod objMethods[] = {
};
/*
+ * And for the oo::class constructor...
+ */
+
+static const Tcl_MethodType classConstructor = {
+ TCL_OO_METHOD_VERSION_CURRENT,
+ "oo::class constructor",
+ TclOO_Class_Constructor, NULL, NULL
+};
+
+/*
* Scripted parts of TclOO. First, the master script (cannot be outside this
* file).
*/
@@ -135,18 +145,6 @@ static const char *initScript =
/* " tcloo.tcl OO_LIBRARY oo::library;"; */
/*
- * The body of the constructor for oo::class.
- */
-
-static const char *classConstructorBody =
-"set script [list ::oo::define [self] $definitionScript];"
-"lassign [::oo::UpCatch $script] msg opts;"
-"if {[dict get $opts -code] == 1} {"
-" dict set opts -errorline 0xDeadBeef"
-"};"
-"return -options $opts $msg;";
-
-/*
* The scripted part of the definitions of slots.
*/
@@ -340,12 +338,12 @@ InitFoundation(
TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
+ TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
Tcl_IncrRefCount(fPtr->constructorName);
Tcl_IncrRefCount(fPtr->destructorName);
Tcl_IncrRefCount(fPtr->clonedName);
- Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd,
- TclOONRUpcatch, NULL, NULL);
+ Tcl_IncrRefCount(fPtr->defineName);
Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
TclOOUnknownDefinition, NULL, NULL);
TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
@@ -418,28 +416,19 @@ InitFoundation(
bodyPtr = Tcl_NewStringObj(clonedBody, -1);
TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
bodyPtr, NULL);
- Tcl_DecrRefCount(argsPtr);
+ 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.
- *
- * The 0xDeadBeef is a special signal to the errorInfo logger that is used
- * by constructors that stops it from generating extra error information
- * that is confusing.
*/
TclNewLiteralStringObj(namePtr, "new");
Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
-
- TclNewLiteralStringObj(argsPtr, "{definitionScript {}}");
- Tcl_IncrRefCount(argsPtr);
- bodyPtr = Tcl_NewStringObj(classConstructorBody, -1);
- fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
- fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
- Tcl_DecrRefCount(argsPtr);
+ fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
+ (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
/*
* Create non-object commands and plug ourselves into the Tcl [info]
@@ -529,10 +518,11 @@ KillFoundation(
DelRef(fPtr->objectCls->thisPtr);
DelRef(fPtr->objectCls);
- Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
- Tcl_DecrRefCount(fPtr->constructorName);
- Tcl_DecrRefCount(fPtr->destructorName);
- Tcl_DecrRefCount(fPtr->clonedName);
+ TclDecrRefCount(fPtr->unknownMethodNameObj);
+ TclDecrRefCount(fPtr->constructorName);
+ TclDecrRefCount(fPtr->destructorName);
+ TclDecrRefCount(fPtr->clonedName);
+ TclDecrRefCount(fPtr->defineName);
ckfree(fPtr);
}
@@ -789,7 +779,7 @@ ObjectRenamedTrace(
if (flags & TCL_TRACE_RENAME) {
if (oPtr->cachedNameObj) {
- Tcl_DecrRefCount(oPtr->cachedNameObj);
+ TclDecrRefCount(oPtr->cachedNameObj);
oPtr->cachedNameObj = NULL;
}
return;
@@ -1044,7 +1034,7 @@ ReleaseClassContents(
Tcl_Obj *filterObj;
FOREACH(filterObj, clsPtr->filters) {
- Tcl_DecrRefCount(filterObj);
+ TclDecrRefCount(filterObj);
}
ckfree(clsPtr->filters.list);
clsPtr->filters.num = 0;
@@ -1123,7 +1113,7 @@ ObjectNamespaceDeleted(
}
FOREACH(filterObj, oPtr->filters) {
- Tcl_DecrRefCount(filterObj);
+ TclDecrRefCount(filterObj);
}
if (i) {
ckfree(oPtr->filters.list);
@@ -1138,7 +1128,7 @@ ObjectNamespaceDeleted(
}
FOREACH(variableObj, oPtr->variables) {
- Tcl_DecrRefCount(variableObj);
+ TclDecrRefCount(variableObj);
}
if (i) {
ckfree(oPtr->variables.list);
@@ -1149,7 +1139,7 @@ ObjectNamespaceDeleted(
}
if (oPtr->cachedNameObj) {
- Tcl_DecrRefCount(oPtr->cachedNameObj);
+ TclDecrRefCount(oPtr->cachedNameObj);
oPtr->cachedNameObj = NULL;
}
@@ -1180,7 +1170,7 @@ ObjectNamespaceDeleted(
}
FOREACH(filterObj, clsPtr->filters) {
- Tcl_DecrRefCount(filterObj);
+ TclDecrRefCount(filterObj);
}
if (i) {
ckfree(clsPtr->filters.list);
@@ -1225,7 +1215,7 @@ ObjectNamespaceDeleted(
TclOODelMethodRef(clsPtr->destructorPtr);
FOREACH(variableObj, clsPtr->variables) {
- Tcl_DecrRefCount(variableObj);
+ TclDecrRefCount(variableObj);
}
if (i) {
ckfree(clsPtr->variables.list);
@@ -2490,7 +2480,7 @@ TclOOObjectCmdCore(
result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
(Tcl_Class *) startClsPtr, mappedMethodName);
if (result != TCL_OK) {
- Tcl_DecrRefCount(mappedMethodName);
+ TclDecrRefCount(mappedMethodName);
if (result == TCL_BREAK) {
goto noMapping;
} else if (result == TCL_ERROR) {
@@ -2506,7 +2496,7 @@ TclOOObjectCmdCore(
Tcl_IncrRefCount(mappedMethodName);
contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
- Tcl_DecrRefCount(mappedMethodName);
+ TclDecrRefCount(mappedMethodName);
if (contextPtr == NULL) {
Tcl_AppendResult(interp, "impossible to invoke method \"",
TclGetString(methodNamePtr),
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 329f0a4..5e983fc 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -19,6 +19,8 @@
static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
static int AfterNRDestructor(ClientData data[],
Tcl_Interp *interp, int result);
+static int DecrRefsPostClassConstructor(ClientData data[],
+ Tcl_Interp *interp, int result);
static int FinalizeConstruction(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeEval(ClientData data[],
@@ -70,6 +72,74 @@ FinalizeConstruction(
/*
* ----------------------------------------------------------------------
*
+ * TclOO_Class_Constructor --
+ *
+ * Implementation for oo::class constructor.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_Constructor(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Obj *invoke[3];
+
+ if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "?definitionScript?");
+ return TCL_ERROR;
+ } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
+ return TCL_OK;
+ }
+
+ /*
+ * Delegate to [oo::define] to do the work.
+ */
+
+ invoke[0] = oPtr->fPtr->defineName;
+ invoke[1] = TclOOObjectName(interp, oPtr);
+ invoke[2] = objv[objc-1];
+
+ /*
+ * Must add references or errors in configuration script will cause
+ * trouble.
+ */
+
+ Tcl_IncrRefCount(invoke[0]);
+ Tcl_IncrRefCount(invoke[1]);
+ Tcl_IncrRefCount(invoke[2]);
+ TclNRAddCallback(interp, DecrRefsPostClassConstructor,
+ invoke[0], invoke[1], invoke[2], NULL);
+
+ /*
+ * Tricky point: do not want the extra reported level in the Tcl stack
+ * trace, so use TCL_EVAL_NOERR.
+ */
+
+ return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
+}
+
+static int
+DecrRefsPostClassConstructor(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ TclDecrRefCount((Tcl_Obj *) data[0]);
+ TclDecrRefCount((Tcl_Obj *) data[1]);
+ TclDecrRefCount((Tcl_Obj *) data[2]);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOO_Class_Create --
*
* Implementation for oo::class->create method.
@@ -1141,74 +1211,6 @@ TclOOCopyObjectCmd(
}
/*
- * ----------------------------------------------------------------------
- *
- * TclOOUpcatchCmd --
- *
- * Implementation of the [oo::UpCatch] command, which is a combination of
- * [uplevel 1] and [catch] that makes it easier to write transparent
- * error handling in scripts.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOOUpcatchCmd(
- ClientData ignored,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv);
-}
-
-static int
-UpcatchCallback(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *savedFramePtr = data[0];
- Tcl_Obj *resultObj[2];
- int rewind = iPtr->execEnvPtr->rewind;
-
- iPtr->varFramePtr = savedFramePtr;
- if (rewind || Tcl_LimitExceeded(interp)) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp)));
- return TCL_ERROR;
- }
- resultObj[0] = Tcl_GetObjResult(interp);
- resultObj[1] = Tcl_GetReturnOptions(interp, result);
- Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
- return TCL_OK;
-}
-
-int
-TclOONRUpcatch(
- ClientData ignored,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *savedFramePtr = iPtr->varFramePtr;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "script");
- return TCL_ERROR;
- }
- if (iPtr->varFramePtr->callerVarPtr != NULL) {
- iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
- }
-
- Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL);
- return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR,
- iPtr->cmdFramePtr, 1);
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 3d72690..69cffb0 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -17,6 +17,13 @@
#include "tclOOInt.h"
/*
+ * The maximum length of fully-qualified object name to use in an errorinfo
+ * message. Longer than this will be curtailed.
+ */
+
+#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30
+
+/*
* Some things that make it easier to declare a slot.
*/
@@ -40,6 +47,8 @@ struct DeclaredSlot {
static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr);
+static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
+ Tcl_Obj *savedNameObj, const char *typeOfSubject);
static inline Class * GetClassInOuterContext(Tcl_Interp *interp,
Tcl_Obj *className, const char *errMsg);
static inline int InitDefineContext(Tcl_Interp *interp,
@@ -673,6 +682,7 @@ TclOOGetDefineCmdContext(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Object object;
if ((iPtr->varFramePtr == NULL)
|| (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
@@ -682,7 +692,14 @@ TclOOGetDefineCmdContext(
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
- return (Tcl_Object) iPtr->varFramePtr->clientData;
+ object = iPtr->varFramePtr->clientData;
+ if (Tcl_ObjectDeleted(object)) {
+ Tcl_AppendResult(interp, "this command cannot be called when the "
+ "object has been deleted", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return NULL;
+ }
+ return object;
}
/*
@@ -730,6 +747,44 @@ GetClassInOuterContext(
/*
* ----------------------------------------------------------------------
*
+ * GenerateErrorInfo --
+ * Factored out code to generate part of the error trace messages.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+GenerateErrorInfo(
+ Tcl_Interp *interp, /* Where to store the error info trace. */
+ Object *oPtr, /* What object (or class) was being configured
+ * when the error occurred? */
+ Tcl_Obj *savedNameObj, /* Name of object saved from before script was
+ * evaluated, which is needed if the object
+ * goes away part way through execution. OTOH,
+ * if the object isn't deleted then its
+ * current name (post-execution) has to be
+ * used. This matters, because the object
+ * could have been renamed... */
+ const char *typeOfSubject) /* Part of the message, saying whether it was
+ * an object, class or class-as-object that
+ * was being configured. */
+{
+ int length;
+ Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
+ ? savedNameObj : TclOOObjectName(interp, oPtr);
+ const char *objName = Tcl_GetStringFromObj(realNameObj, &length);
+ int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in definition script for %s \"%.*s%s\" line %d)",
+ typeOfSubject, (overflow ? limit : length), objName,
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineObjCmd --
* Implementation of the "oo::define" command. Works by effectively doing
* the same as 'namespace eval', but with extra magic applied so that the
@@ -779,20 +834,15 @@ TclOODefineObjCmd(
AddRef(oPtr);
if (objc == 3) {
+ Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[2], 0,
((Interp *)interp)->cmdFramePtr, 2);
-
if (result == TCL_ERROR) {
- int length;
- const char *objName = Tcl_GetStringFromObj(objv[1], &length);
- int limit = 60;
- int overflow = (length > limit);
-
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in definition script for object \"%.*s%s\" line %d)",
- (overflow ? limit : length), objName,
- (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ GenerateErrorInfo(interp, oPtr, objNameObj, "class");
}
+ TclDecrRefCount(objNameObj);
} else {
Tcl_Obj *objPtr, *obj2Ptr, **objs;
Interp *iPtr = (Interp *) interp;
@@ -898,20 +948,15 @@ TclOOObjDefObjCmd(
AddRef(oPtr);
if (objc == 3) {
+ Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[2], 0,
((Interp *)interp)->cmdFramePtr, 2);
-
if (result == TCL_ERROR) {
- int length;
- const char *objName = Tcl_GetStringFromObj(objv[1], &length);
- int limit = 60;
- int overflow = (length > limit);
-
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in definition script for object \"%.*s%s\" line %d)",
- (overflow ? limit : length), objName,
- (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ GenerateErrorInfo(interp, oPtr, objNameObj, "object");
}
+ TclDecrRefCount(objNameObj);
} else {
Tcl_Obj *objPtr, *obj2Ptr, **objs;
Interp *iPtr = (Interp *) interp;
@@ -1017,21 +1062,15 @@ TclOODefineSelfObjCmd(
AddRef(oPtr);
if (objc == 2) {
+ Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[1], 0,
((Interp *)interp)->cmdFramePtr, 2);
-
if (result == TCL_ERROR) {
- int length;
- const char *objName = Tcl_GetStringFromObj(
- TclOOObjectName(interp, oPtr), &length);
- int limit = 60;
- int overflow = (length > limit);
-
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (in definition script for object \"%.*s%s\" line %d)",
- (overflow ? limit : length), objName,
- (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
}
+ TclDecrRefCount(objNameObj);
} else {
Tcl_Obj *objPtr, *obj2Ptr, **objs;
Interp *iPtr = (Interp *) interp;
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 7988452..631961f 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -322,6 +322,7 @@ typedef struct Foundation {
* destructor. */
Tcl_Obj *clonedName; /* Shared object containing the name of a
* "<cloned>" pseudo-constructor. */
+ Tcl_Obj *defineName; /* Fully qualified name of oo::define. */
} Foundation;
/*
@@ -453,6 +454,9 @@ MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData,
* Method implementations (in tclOOBasic.c).
*/
+MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Class_Create(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
@@ -519,8 +523,6 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp,
Tcl_Obj *const *objv, int skip);
MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
const DeclaredClassMethod *dcm);
-MODULE_SCOPE int TclOONRUpcatch(ClientData ignored, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr,
@@ -532,9 +534,6 @@ MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp,
MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr,
CallContext *contextPtr);
MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
-MODULE_SCOPE int TclOOUpcatchCmd(ClientData ignored,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
/*
* Include all the private API, generated from tclOO.decls.
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 4e7edb8..877c3db 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1204,15 +1204,6 @@ ConstructorErrorHandler(
const char *objectName, *kindName;
int objectNameLen;
- if (Tcl_GetErrorLine(interp) == (int) 0xDEADBEEF) {
- /*
- * Horrible hack to deal with certain constructors that must not add
- * information to the error trace.
- */
-
- return;
- }
-
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
kindName = "object";
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 4f86755..2402128 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -1087,7 +1087,7 @@ TclJoinPath(
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
- length++;
+ Tcl_GetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + (int) strlen(strElt));
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 731176c..0c38602 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -91,7 +91,7 @@ typedef struct {
GzipHeader outHeader; /* Header to write to an output stream, when
* compressing a gzip stream. */
Tcl_TimerToken timer; /* Timer used for keeping events fresh. */
- Tcl_DString result; /* Buffer for decompression results */
+ Tcl_DString result; /* Buffer for decompression results. */
} ZlibChannelData;
/*
@@ -140,6 +140,10 @@ static void ConvertError(Tcl_Interp *interp, int code);
static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
GzipHeader *headerPtr, int *extraSizePtr);
+static int ResultCopy(Tcl_DString *r, unsigned char *buf,
+ int toRead);
+static int ResultGenerate(ZlibChannelData *cd, int n, int flush,
+ int *errorCodePtr);
static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp,
int mode, int format, int level,
Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr);
@@ -148,9 +152,6 @@ static void ZlibTransformTimerKill(ZlibChannelData *cd);
static void ZlibTransformTimerRun(ClientData clientData);
static void ZlibTransformTimerSetup(ZlibChannelData *cd);
-static int ResultCopy(Tcl_DString* r, unsigned char *buf, int toRead);
-static int ResultGenerate(ZlibChannelData *cd, int n, int flush, int* errorCodePtr);
-
/*
* Type of zlib-based compressing and decompressing channels.
*/
@@ -2434,7 +2435,7 @@ ZlibTransformInput(
* converted and returned.
*/
- if (ResultGenerate (cd, 0, Z_SYNC_FLUSH, errorCodePtr) < 0) {
+ if (ResultGenerate(cd, 0, Z_SYNC_FLUSH, errorCodePtr) < 0) {
goto error;
}
@@ -2461,7 +2462,7 @@ ZlibTransformInput(
* iteration will put it into the result.
*/
- if (ResultGenerate (cd, readBytes, Z_NO_FLUSH, errorCodePtr) < 0) {
+ if (ResultGenerate(cd, readBytes, Z_NO_FLUSH, errorCodePtr) < 0) {
goto error;
}
} /* while toRead > 0 */
@@ -2914,54 +2915,71 @@ ZlibStackChannelTransform(
static int
ResultCopy(
- Tcl_DString* ds, /* The buffer to read from */
+ Tcl_DString *ds, /* The buffer to read from */
unsigned char *buf, /* The buffer to copy into */
int toRead) /* Number of requested bytes */
{
- int copied;
- int have = Tcl_DStringLength (ds);
+ int have = Tcl_DStringLength(ds);
if (have == 0) {
/*
* Nothing to copy in the case of an empty buffer.
*/
- copied = 0;
- } else if (have > toRead) {
+ return 0;
+ }
+ if (have > toRead) {
/*
* The internal buffer contains more than requested. Copy the
* requested subset to the caller, shift the remaining bytes down, and
* truncate.
*/
- char* src = Tcl_DStringValue (ds);
+ char *src = Tcl_DStringValue(ds);
memcpy(buf, src, toRead);
memmove(src, src + toRead, have - toRead);
- Tcl_DStringSetLength (ds, have - toRead);
- copied = toRead;
+ Tcl_DStringSetLength(ds, have - toRead);
+ return toRead;
} else /* have <= toRead */ {
/*
* There is just or not enough in the buffer to fully satisfy the
* caller, so take everything as best effort.
*/
- memcpy(buf, Tcl_DStringValue (ds), have);
- Tcl_DStringSetLength (ds, 0);
- copied = have;
+ memcpy(buf, Tcl_DStringValue(ds), have);
+ Tcl_DStringSetLength(ds, 0);
+ return have;
}
-
- /* -- common postwork code ------- */
-
- return copied;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * ResultGenerate --
+ *
+ * Extract uncompressed bytes from the compression engine and store them
+ * in our working buffer.
+ *
+ * Result:
+ * Zero on success, -1 on error (with *errorCodePtr updated with reason).
+ *
+ * Side effects:
+ * See above.
+ *
+ *----------------------------------------------------------------------
+ */
+
static int
-ResultGenerate(ZlibChannelData *cd, int n, int flush, int* errorCodePtr)
+ResultGenerate(
+ ZlibChannelData *cd,
+ int n,
+ int flush,
+ int *errorCodePtr)
{
-#define MAXBUF 1024
- unsigned char buf [MAXBUF];
+#define MAXBUF 1024
+ unsigned char buf[MAXBUF];
int e, written;
cd->inStream.next_in = (Bytef *) cd->inBuffer;
@@ -2974,21 +2992,23 @@ ResultGenerate(ZlibChannelData *cd, int n, int flush, int* errorCodePtr)
e = inflate(&cd->inStream, flush);
/*
- * avail_out is now the left over space in the output.
- * Therefore "MAXBUF - avail_out" is the amount of bytes
- * generated.
+ * avail_out is now the left over space in the output. Therefore
+ * "MAXBUF - avail_out" is the amount of bytes generated.
*/
written = MAXBUF - cd->inStream.avail_out;
-
if (written) {
- Tcl_DStringAppend (&cd->result, (char*) buf, written);
+ Tcl_DStringAppend(&cd->result, (char*) buf, written);
}
- if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) ||
- (e == Z_STREAM_END) ||
- (e==Z_OK && cd->inStream.avail_out==0)) {
- break;
+ /*
+ * The cases where we're definitely done.
+ */
+
+ if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR))
+ || (e == Z_STREAM_END)
+ || (e == Z_OK && cd->inStream.avail_out == 0)) {
+ return 0;
}
/*
@@ -2996,13 +3016,15 @@ ResultGenerate(ZlibChannelData *cd, int n, int flush, int* errorCodePtr)
*
* Just indicates that the zlib couldn't consume input/produce output,
* and is fixed by supplying more input.
+ *
+ * Otherwise, we've got errors and need to report to higher-up.
*/
if ((e != Z_OK) && (e != Z_BUF_ERROR)) {
Tcl_Obj *errObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, errObj,
- Tcl_NewStringObj(cd->inStream.msg, -1));
+ Tcl_NewStringObj(cd->inStream.msg, -1));
Tcl_SetChannelError(cd->parent, errObj);
*errorCodePtr = EINVAL;
return -1;
@@ -3012,18 +3034,10 @@ ResultGenerate(ZlibChannelData *cd, int n, int flush, int* errorCodePtr)
* Check if the inflate stopped early.
*/
- if (cd->inStream.avail_in > 0) {
- continue;
- }
-
- if (flush == Z_SYNC_FLUSH) {
- continue;
+ if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) {
+ return 0;
}
-
- break;
}
-
- return 0;
}
/*
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index ce92028..5b4eae9 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,7 +1,7 @@
if {![package vsatisfies [package provide Tcl] 8.5]} return
if {[string compare [info sharedlibextension] .dll]} return
if {[::tcl::pkgconfig get debug]} {
- package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde]
+ package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde]
} else {
- package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde]
+ package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde]
}
diff --git a/tests/all.tcl b/tests/all.tcl
index b436fbe..05d3024 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -10,6 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+package prefer latest
package require Tcl 8.5
package require tcltest 2.2
namespace import tcltest::*
diff --git a/tests/io.test b/tests/io.test
index e6cea16..386179e 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -2748,13 +2748,13 @@ test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} {
set f [open $path(script2) w]
puts $f {after 2000}
close $f
- set t1 [clock seconds]
+ set t1 [clock milliseconds]
set ff [open "|[list [interpreter] $path(script2)]" w]
catch {unset ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT)}
exec [interpreter] $path(script) >@ $ff
- set t2 [clock seconds]
+ set t2 [clock milliseconds]
close $ff
- expr {($t2-$t1)/2}
+ expr {($t2-$t1)/2000 ? $t2-$t1 : 0}
} 0
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} {
variable c 0
diff --git a/tests/oo.test b/tests/oo.test
index f3c0bda..00663e9 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1974,7 +1974,7 @@ test oo-18.1 {OO: define command support} {
} {1 foo {foo
while executing
"error foo"
- (in definition script for object "oo::object" line 1)
+ (in definition script for class "::oo::object" line 1)
invoked from within
"oo::define oo::object {error foo}"}}
test oo-18.2 {OO: define command support} {
@@ -1987,7 +1987,7 @@ test oo-18.3 {OO: define command support} {
} {1 bar {bar
while executing
"error bar"
- (in definition script for object "::foo" line 1)
+ (in definition script for class "::foo" line 1)
invoked from within
"oo::class create foo {error bar}"}}
test oo-18.3a {OO: define command support} {
@@ -1997,7 +1997,7 @@ test oo-18.3a {OO: define command support} {
} {1 bar {bar
while executing
"error bar"
- (in definition script for object "::foo" line 2)
+ (in definition script for class "::foo" line 2)
invoked from within
"oo::class create foo {
error bar
@@ -2015,7 +2015,7 @@ test oo-18.3b {OO: define command support} {
("eval" body line 1)
invoked from within
"eval eval error bar"
- (in definition script for object "::foo" line 2)
+ (in definition script for class "::foo" line 2)
invoked from within
"oo::class create foo {
eval eval error bar
@@ -2070,6 +2070,106 @@ test oo-18.5 {OO: more error traces from the guts} -setup {
(class "::cls" method "eval" line 1)
invoked from within
"obj eval {error bar}"}}
+test oo-18.6 {class construction reference management and errors} -setup {
+ oo::class create super_abc
+} -body {
+ catch {
+oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}
+ } msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ super_abc destroy
+} -result {foo
+ while executing
+"::error foo"
+ (in definition script for class "::def" line 4)
+ invoked from within
+"oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}"}
+test oo-18.7 {OO: objdefine command support} -setup {
+ oo::object create ::inst
+} -body {
+ list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo
+} -cleanup {
+ catch {::inst destroy}
+ catch {::INST destroy}
+} -result {1 foo {foo
+ while executing
+"error foo"
+ (in definition script for object "::INST" line 1)
+ invoked from within
+"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
+test oo-18.8 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::bar" line 1)
+ invoked from within
+"self {error foobar}"
+ (in definition script for class "::bar" line 1)
+ invoked from within
+"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
+test oo-18.9 {OO: define/self command support} -setup {
+ oo::class create master
+ set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
+ superclass master
+ }]
+} -body {
+ catch {oo::define $c {error err}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {err
+ while executing
+"error err"
+ (in definition script for class "::now_this_is_a_very_very_long..." line 1)
+ invoked from within
+"oo::define $c {error err}"}
+test oo-18.10 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::foo" line 1)
+ invoked from within
+"self {rename ::foo {}; error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {self {rename ::foo {}; error foobar}}"}
+test oo-18.11 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {this command cannot be called when the object has been deleted
+ while executing
+"self {error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {rename ::foo {}; self {error foobar}}"}
test oo-19.1 {OO: varname method} -setup {
oo::object create inst
@@ -3189,7 +3289,7 @@ test oo-33.2 {TIP 380: slots - defaulting} -setup {
} -cleanup {
rename $s {}
} -result {{} {a b c destroy unknown}}
-test oo-32.3 {TIP 380: slots - defaulting} -setup {
+test oo-33.3 {TIP 380: slots - defaulting} -setup {
set s [SampleSlot new]
} -body {
oo::objdefine $s forward --default-operation my -set
diff --git a/tests/socket.test b/tests/socket.test
index f06a548..d88eb65 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -64,7 +64,7 @@ package require tcltest 2
namespace import -force ::tcltest::*
# Some tests require the Thread package or exec command
-testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6.6}]}]
testConstraint exec [llength [info commands exec]]
# Produce a random port number in the Dynamic/Private range
diff --git a/tests/winDde.test b/tests/winDde.test
index ca50a96..bc64a24 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -156,6 +156,20 @@ test winDde-3.5 {DDE request locally} {win dde} {
dde execute TclEval self {set a "foo"}
dde request -binary TclEval self a
} "foo\x00"
+# Set variable a to A with diaeresis (unicode C4) by relying on the fact
+# that utf8 is sent (e.g. "c3 84" on the wire)
+test winDde-3.6 {DDE request utf8} {win dde} {
+ set a "not set"
+ dde execute TclEval self "set a \xc4"
+ scan $a %c
+} 196
+# Set variable a to A with diaeresis (unicode C4) using binary execute
+# and compose utf-8 (e.g. "c3 84" ) manualy
+test winDde-3.7 {DDE request binary} {win dde} {
+ set a "not set"
+ dde execute -binary TclEval self "set a \xc3\x84\x00"
+ scan $a %c
+} 196
# -------------------------------------------------------------------------
@@ -202,13 +216,13 @@ test winDde-4.4 {DDE eval remotely} {stdio win dde} {
test winDde-5.1 {check for bad arguments} -constraints {win dde} -body {
dde execute "" "" "" ""
-} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
+} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
test winDde-5.2 {check for bad arguments} -constraints {win dde} -body {
dde execute "" "" ""
} -returnCodes error -result {cannot execute null data}
test winDde-5.3 {check for bad arguments} -constraints {win dde} -body {
dde execute -foo "" "" ""
-} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
+} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
test winDde-5.4 {DDE eval bad arguments} -constraints {win dde} -body {
dde eval "" "foo"
} -returnCodes error -result {invalid service name ""}
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index e48cc2b..12e5a9a 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -545,6 +545,9 @@ TcpCloseProc(
*/
for (fds = &statePtr->fds; fds != NULL; fds = fds->next) {
+ if (fds->fd < 0) {
+ continue;
+ }
Tcl_DeleteFileHandler(fds->fd);
if (close(fds->fd) < 0) {
errorCode = errno;
diff --git a/win/Makefile.in b/win/Makefile.in
index 8492b8f..111f455 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -606,23 +606,23 @@ install-binaries: binaries
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo installing $(DDE_DLL_FILE); \
- $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde1.3; \
+ $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \
$(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
- $(LIB_INSTALL_DIR)/dde1.3; \
+ $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \
fi
@if [ -f $(DDE_LIB_FILE) ]; then \
echo installing $(DDE_LIB_FILE); \
- $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.3; \
+ $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo installing $(REG_DLL_FILE); \
- $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg1.3; \
+ $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
$(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \
- $(LIB_INSTALL_DIR)/reg1.3; \
+ $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo installing $(REG_LIB_FILE); \
- $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg1.3; \
+ $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \
fi
install-libraries: libraries install-tzdata install-msgs
diff --git a/win/configure b/win/configure
index 5edf012..fed0959 100755
--- a/win/configure
+++ b/win/configure
@@ -1314,9 +1314,9 @@ TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL="b2"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.3
+TCL_DDE_VERSION=1.4
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=3
+TCL_DDE_MINOR_VERSION=4
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
TCL_REG_VERSION=1.3
diff --git a/win/configure.in b/win/configure.in
index f4e10ee..2377938 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -17,9 +17,9 @@ TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL="b2"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.3
+TCL_DDE_VERSION=1.4
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=3
+TCL_DDE_MINOR_VERSION=4
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
TCL_REG_VERSION=1.3
diff --git a/win/makefile.bc b/win/makefile.bc
index 338205e..d17c624 100644
--- a/win/makefile.bc
+++ b/win/makefile.bc
@@ -126,8 +126,8 @@ STUBPREFIX = $(NAMEPREFIX)stub
DOTVERSION = 8.6
VERSION = 86
-DDEVERSION = 13
-DDEDOTVERSION = 1.3
+DDEVERSION = 14
+DDEDOTVERSION = 1.4
REGVERSION = 13
REGDOTVERSION = 1.3
diff --git a/win/makefile.vc b/win/makefile.vc
index bc16584..96ae7f6 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -186,7 +186,7 @@ STUBPREFIX = $(PROJECT)stub
DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
-DDEDOTVERSION = 1.3
+DDEDOTVERSION = 1.4
DDEVERSION = $(DDEDOTVERSION:.=)
REGDOTVERSION = 1.3
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index d508c02..617e4e5 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -88,7 +88,7 @@ static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
-#define TCL_DDE_VERSION "1.3.3"
+#define TCL_DDE_VERSION "1.4.0"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME TEXT("TclEval")
#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT")
@@ -1184,13 +1184,19 @@ DdeObjCmd(
DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
};
static const char *const ddeExecOptions[] = {
+ "-async", "-binary", NULL
+ };
+ enum DdeExecOptions {
+ DDE_EXEC_ASYNC, DDE_EXEC_BINARY
+ };
+ static const char *const ddeEvalOptions[] = {
"-async", NULL
};
static const char *const ddeReqOptions[] = {
"-binary", NULL
};
- int index, i, length;
+ int index, i, length, argIndex;
int async = 0, binary = 0, exact = 0;
int result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
@@ -1218,7 +1224,6 @@ DdeObjCmd(
switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
for (i = 2; i < objc; i++) {
- int argIndex;
if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
"option", 0, &argIndex) != TCL_OK) {
/*
@@ -1265,39 +1270,53 @@ DdeObjCmd(
if (objc == 5) {
firstArg = 2;
break;
- } else if (objc == 6) {
- int dummy;
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
- &dummy) == TCL_OK) {
- async = 1;
- firstArg = 3;
- break;
+ } else if (objc >= 6 && objc <= 7) {
+ firstArg = objc - 3;
+ for (i = 2; i < firstArg; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions,
+ "option", 0, &argIndex) != TCL_OK) {
+ goto wrongDdeExecuteArgs;
+ }
+ if (argIndex == DDE_EXEC_ASYNC) {
+ async = 1;
+ } else {
+ binary = 1;
+ }
}
+ break;
}
/* otherwise... */
+ wrongDdeExecuteArgs:
Tcl_WrongNumArgs(interp, 2, objv,
- "?-async? serviceName topicName value");
+ "?-async? ?-binary? serviceName topicName value");
return TCL_ERROR;
case DDE_POKE:
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "serviceName topicName item value");
- return TCL_ERROR;
+ if (objc == 6) {
+ firstArg = 2;
+ break;
+ } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2],
+ ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
+ binary = 1;
+ firstArg = 3;
+ break;
}
- firstArg = 2;
- break;
+
+ /*
+ * Otherwise...
+ */
+
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-binary? serviceName topicName item value");
+ return TCL_ERROR;
case DDE_REQUEST:
if (objc == 5) {
firstArg = 2;
break;
- } else if (objc == 6) {
- int dummy;
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
- &dummy) == TCL_OK) {
- binary = 1;
- firstArg = 3;
- break;
- }
+ } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2],
+ ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
+ binary = 1;
+ firstArg = 3;
+ break;
}
/*
@@ -1320,11 +1339,9 @@ DdeObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args");
return TCL_ERROR;
} else {
- int dummy;
-
firstArg = 2;
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option",
- 0, &dummy) == TCL_OK) {
+ if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option",
+ 0, &argIndex) == TCL_OK) {
if (objc < 5) {
goto wrongDdeEvalArgs;
}
@@ -1373,10 +1390,18 @@ DdeObjCmd(
case DDE_EXECUTE: {
int dataLength;
- BYTE *dataString = (BYTE *) Tcl_GetStringFromObj(
- objv[firstArg + 2], &dataLength);
+ BYTE *dataString;
+
+ if (binary) {
+ dataString = (BYTE *)
+ Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength);
+ } else {
+ dataString = (BYTE *)
+ Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
+ dataLength += 1;
+ }
- if (dataLength == 0) {
+ if (dataLength <= (binary ? 0 : sizeof(TCHAR))) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot execute null data", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
@@ -1394,7 +1419,7 @@ DdeObjCmd(
}
ddeData = DdeCreateDataHandle(ddeInstance, dataString,
- (DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
+ (DWORD) dataLength, 0, 0, CF_TEXT, 0);
if (ddeData != NULL) {
if (async) {
DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
@@ -1481,8 +1506,14 @@ DdeObjCmd(
result = TCL_ERROR;
goto cleanup;
}
- dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3],
- &length);
+ if (binary) {
+ dataString = (BYTE *)
+ Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length);
+ } else {
+ dataString = (BYTE *)
+ Tcl_GetStringFromObj(objv[firstArg + 3], &length);
+ length += 1;
+ }
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
@@ -1495,7 +1526,7 @@ DdeObjCmd(
ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
CP_WINUNICODE);
if (ddeItem != NULL) {
- ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
+ ddeData = DdeClientTransaction(dataString, (DWORD) length,
hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
generated by cgit v0.12 at 2024-07-09 05:33:51 (GMT)