From fa08af34c6ae5907fc9a6f4c20182dd11ba28f45 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 31 Mar 2012 13:48:11 +0000 Subject: Start of implementation of TIP 400: zlib improvements --- generic/tcl.decls | 4 ++++ generic/tclDecls.h | 5 +++++ generic/tclStubInit.c | 1 + generic/tclZlib.c | 23 ++++++++++++++++++++++- 4 files changed, 32 insertions(+), 1 deletion(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 7e5bbbb..bb9f71e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2318,6 +2318,10 @@ declare 629 { int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr) } +declare 630 { + void* Tcl_ZlibStreamGetZstreamp(Tcl_ZlibStream zshandle) +} + # ----- BASELINE -- FOR -- 8.6.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1f7dfe6..1d6a866 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1807,6 +1807,8 @@ EXTERN void* Tcl_FindSymbol(Tcl_Interp *interp, /* 629 */ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr); +/* 630 */ +EXTERN void* Tcl_ZlibStreamGetZstreamp(Tcl_ZlibStream zshandle); typedef struct TclStubHooks { const struct TclPlatStubs *tclPlatStubs; @@ -2472,6 +2474,7 @@ typedef struct TclStubs { int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void* (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ + void* (*tcl_ZlibStreamGetZstreamp) (Tcl_ZlibStream zshandle); /* 630 */ } TclStubs; #ifdef __cplusplus @@ -3764,6 +3767,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ +#define Tcl_ZlibStreamGetZstreamp \ + (tclStubsPtr->tcl_ZlibStreamGetZstreamp) /* 630 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 32e9557..eec540c 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1301,6 +1301,7 @@ const TclStubs tclStubs = { Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ + Tcl_ZlibStreamGetZstreamp, /* 630 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 81012dc..6f82e06 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -864,7 +864,7 @@ Tcl_ZlibStreamEof( */ int -Tcl_ZlibStreamChecksum( +Tcl_ZlibStreamGetZstreamp( Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */ { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; @@ -875,6 +875,27 @@ Tcl_ZlibStreamChecksum( /* *---------------------------------------------------------------------- * + * Tcl_ZlibStreamGetZstreamp -- + * + * Return the z_streamp for the stream (though not typed as such, so as + * to avoid type interface poisoning). Shouldn't be used to poke around + * excessively. + * + *---------------------------------------------------------------------- + */ + +void * +Tcl_ZlibStreamGetZstreamp( + Tcl_ZlibStream zshandle) +{ + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; + + return &zshPtr->stream; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ZlibStreamPut -- * * Add data to the stream for compression or decompression from a -- cgit v0.12 From c2b055522373e593d24bf733ca603a9661ecb497 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 31 Mar 2012 14:06:43 +0000 Subject: D'oh! --- generic/tclZlib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6f82e06..2e5a833 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -864,7 +864,7 @@ Tcl_ZlibStreamEof( */ int -Tcl_ZlibStreamGetZstreamp( +Tcl_ZlibStreamChecksum( Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */ { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; -- cgit v0.12 From 5d7df5123c85eb31c88822372afd51eee47eb01c Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 31 Mar 2012 15:16:45 +0000 Subject: Another step on the road to implementation. --- generic/tclZlib.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 67 insertions(+), 2 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 2e5a833..85c6655 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -64,6 +64,9 @@ typedef struct { int wbits; /* The encoded compression mode, so we can * restart the stream if necessary. */ Tcl_Command cmd; /* Token for the associated Tcl command. */ + Tcl_Obj *compDictObj; /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ } ZlibStreamHandle; /* @@ -209,6 +212,7 @@ ConvertError( case Z_MEM_ERROR: codeStr = "MEM"; break; case Z_BUF_ERROR: codeStr = "BUF"; break; case Z_VERSION_ERROR: codeStr = "VERSION"; break; + case Z_NEED_DICT: codeStr = "NEED_DICT"; break; default: codeStr = "unknown"; codeStr2 = codeStrBuf; @@ -542,6 +546,7 @@ Tcl_ZlibStreamInit( zshPtr->wbits = wbits; zshPtr->currentInput = NULL; zshPtr->streamEnd = 0; + zshPtr->compDictObj = NULL; memset(&zshPtr->stream, 0, sizeof(z_stream)); /* @@ -551,6 +556,14 @@ Tcl_ZlibStreamInit( if (mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && zshPtr->compDictObj) { + int dictLen; + unsigned char *dictBytes = + Tcl_GetByteArrayFromObj(zshPtr->compDictObj, &dictLen); + + e = deflateSetDictionary(&zshPtr->stream, dictBytes, + (unsigned) dictLen); + } } else { e = inflateInit2(&zshPtr->stream, wbits); } @@ -618,6 +631,9 @@ Tcl_ZlibStreamInit( return TCL_OK; error: + if (zshPtr->compDictObj) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } ckfree(zshPtr); return TCL_ERROR; } @@ -725,6 +741,9 @@ ZlibStreamCleanup( if (zshPtr->currentInput) { Tcl_DecrRefCount(zshPtr->currentInput); } + if (zshPtr->compDictObj) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } ckfree(zshPtr); } @@ -777,6 +796,14 @@ Tcl_ZlibStreamReset( if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED, zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && zshPtr->compDictObj) { + int dictLen; + unsigned char *dictBytes = + Tcl_GetByteArrayFromObj(zshPtr->compDictObj, &dictLen); + + e = deflateSetDictionary(&zshPtr->stream, dictBytes, + (unsigned) dictLen); + } } else { e = inflateInit2(&zshPtr->stream, zshPtr->wbits); } @@ -1091,7 +1118,22 @@ Tcl_ZlibStreamGet( } } - e = inflate(&zshPtr->stream, zshPtr->flush); + while (1) { + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e != Z_NEED_DICT || zshPtr->compDictObj == NULL) { + break; + } else { + int dictLen; + unsigned char *dictBytes = + Tcl_GetByteArrayFromObj(zshPtr->compDictObj,&dictLen); + + e = inflateSetDictionary(&zshPtr->stream, dictBytes, + (unsigned) dictLen); + if (e != Z_OK) { + break; + } + } + } Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) @@ -1145,7 +1187,23 @@ Tcl_ZlibStreamGet( * And call inflate again. */ - e = inflate(&zshPtr->stream, zshPtr->flush); + while (1) { + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e != Z_NEED_DICT || zshPtr->compDictObj == NULL) { + break; + } else { + int dictLen; + unsigned char *dictBytes = + Tcl_GetByteArrayFromObj(zshPtr->compDictObj, + &dictLen); + + e = inflateSetDictionary(&zshPtr->stream, dictBytes, + (unsigned) dictLen); + if (e != Z_OK) { + break; + } + } + } } if (zshPtr->stream.avail_out > 0) { Tcl_SetByteArrayLength(data, @@ -2994,6 +3052,13 @@ Tcl_ZlibAdler32( { return 0; } + +void * +Tcl_ZlibStreamGetZstreamp( + Tcl_ZlibStream zshandle) +{ + return NULL; +} #endif /* HAVE_ZLIB */ /* -- cgit v0.12 From 5abf91100c465debae7d91fde02bc28bbc12ba0f Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 7 Apr 2012 17:41:10 +0000 Subject: Another bit more --- generic/tclZlib.c | 87 ++++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 73 insertions(+), 14 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 85c6655..6ac1a59 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1879,52 +1879,111 @@ ZlibCmd( return TCL_ERROR; } return TCL_OK; - case CMD_STREAM: /* stream deflate/inflate/...gunzip \ + case CMD_STREAM: { /* stream deflate/inflate/...gunzip \ * ?level? * -> handleCmd */ - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); + Tcl_Obj *compDictObj = NULL; + Tcl_Obj *gzipHeaderObj = NULL; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?options...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, &format) != TCL_OK) { return TCL_ERROR; } - mode = TCL_ZLIB_STREAM_INFLATE; switch ((enum zlibFormats) format) { case FMT_DEFLATE: + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); + return TCL_ERROR; + } mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + level = Z_DEFAULT_COMPRESSION; + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level < 0 || level > 9) { + goto badLevel; + } + } + break; case FMT_INFLATE: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "mode"); + return TCL_ERROR; + } + mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_RAW; + level = Z_DEFAULT_COMPRESSION; break; case FMT_COMPRESS: + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); + return TCL_ERROR; + } mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + level = Z_DEFAULT_COMPRESSION; + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level < 0 || level > 9) { + goto badLevel; + } + } + break; case FMT_DECOMPRESS: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "mode"); + return TCL_ERROR; + } + mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_ZLIB; + level = Z_DEFAULT_COMPRESSION; break; case FMT_GZIP: + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); + return TCL_ERROR; + } mode = TCL_ZLIB_STREAM_DEFLATE; - case FMT_GUNZIP: format = TCL_ZLIB_FORMAT_GZIP; + level = Z_DEFAULT_COMPRESSION; + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level < 0 || level > 9) { + goto badLevel; + } + } break; - } - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], - (int *) &level) != TCL_OK) { + case FMT_GUNZIP: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "mode"); return TCL_ERROR; } - if (level < 0 || level > 9) { - goto badLevel; - } - } else { + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; level = Z_DEFAULT_COMPRESSION; + break; } - if (Tcl_ZlibStreamInit(interp, mode, format, level, NULL, + if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, &zh) != TCL_OK) { return TCL_ERROR; } + if (compDictObj != NULL) { + ((ZlibStreamHandle *) zh)->compDictObj = compDictObj; + Tcl_IncrRefCount(compDictObj); + } Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); return TCL_OK; + } case CMD_PUSH: { /* push mode channel options... * -> channel */ Tcl_Channel chan; -- cgit v0.12 From 905c2a3e016c14449e0ae261f8c6183b8c0b5cf6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 8 Apr 2012 17:16:43 +0000 Subject: Another few bits of zlib stream core hacking --- generic/tclZlib.c | 50 ++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 44 insertions(+), 6 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6ac1a59..35513d5 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -67,6 +67,8 @@ typedef struct { Tcl_Obj *compDictObj; /* Byte-array object containing compression * dictionary (not dictObj!) to use if * necessary. */ + GzipHeader *gzHeaderPtr; /* If we've allocated a gzip header + * structure. */ } ZlibStreamHandle; /* @@ -298,7 +300,9 @@ GenerateHeader( NULL); headerPtr->nativeCommentBuf[len] = '\0'; headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf; - *extraSizePtr += len; + if (extraSizePtr != NULL) { + *extraSizePtr += len; + } } if (GetValue(interp, dictObj, "crc", &value) != TCL_OK) { @@ -316,7 +320,9 @@ GenerateHeader( headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf; - *extraSizePtr += len; + if (extraSizePtr != NULL) { + *extraSizePtr += len; + } } if (GetValue(interp, dictObj, "os", &value) != TCL_OK) { @@ -480,6 +486,7 @@ Tcl_ZlibStreamInit( ZlibStreamHandle *zshPtr = NULL; Tcl_DString cmdname; Tcl_CmdInfo cmdinfo; + GzipHeader *gzHeaderPtr = NULL; switch (mode) { case TCL_ZLIB_STREAM_DEFLATE: @@ -494,6 +501,15 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; + if (dictObj) { + gzHeaderPtr = ckalloc(sizeof(GzipHeader)); + memset(gzHeaderPtr, 0, sizeof(GzipHeader)); + if (GenerateHeader(interp, dictObj, gzHeaderPtr, + NULL) != TCL_OK) { + ckfree(gzHeaderPtr); + return TCL_ERROR; + } + } break; case TCL_ZLIB_FORMAT_ZLIB: wbits = WBITS_ZLIB; @@ -520,6 +536,14 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; + gzHeaderPtr = ckalloc(sizeof(GzipHeader)); + memset(gzHeaderPtr, 0, sizeof(GzipHeader)); + gzHeaderPtr->header.name = (Bytef *) + gzHeaderPtr->nativeFilenameBuf; + gzHeaderPtr->header.name_max = MAXPATHLEN - 1; + gzHeaderPtr->header.comment = (Bytef *) + gzHeaderPtr->nativeCommentBuf; + gzHeaderPtr->header.name_max = MAX_COMMENT_LEN - 1; break; case TCL_ZLIB_FORMAT_ZLIB: wbits = WBITS_ZLIB; @@ -547,6 +571,7 @@ Tcl_ZlibStreamInit( zshPtr->currentInput = NULL; zshPtr->streamEnd = 0; zshPtr->compDictObj = NULL; + zshPtr->gzHeaderPtr = gzHeaderPtr; memset(&zshPtr->stream, 0, sizeof(z_stream)); /* @@ -556,6 +581,10 @@ Tcl_ZlibStreamInit( if (mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e == Z_OK && zshPtr->gzHeaderPtr) { + e = deflateSetHeader(&zshPtr->stream, + &zshPtr->gzHeaderPtr->header); + } if (e == Z_OK && zshPtr->compDictObj) { int dictLen; unsigned char *dictBytes = @@ -566,6 +595,10 @@ Tcl_ZlibStreamInit( } } else { e = inflateInit2(&zshPtr->stream, wbits); + if (e == Z_OK && zshPtr->gzHeaderPtr) { + e = inflateGetHeader(&zshPtr->stream, + &zshPtr->gzHeaderPtr->header); + } } if (e != Z_OK) { @@ -630,10 +663,14 @@ Tcl_ZlibStreamInit( } return TCL_OK; - error: + + error: if (zshPtr->compDictObj) { Tcl_DecrRefCount(zshPtr->compDictObj); } + if (zshPtr->gzHeaderPtr) { + ckfree(zshPtr->gzHeaderPtr); + } ckfree(zshPtr); return TCL_ERROR; } @@ -744,6 +781,9 @@ ZlibStreamCleanup( if (zshPtr->compDictObj) { Tcl_DecrRefCount(zshPtr->compDictObj); } + if (zshPtr->gzHeaderPtr) { + ckfree(zshPtr->gzHeaderPtr); + } ckfree(zshPtr); } @@ -2880,11 +2920,9 @@ ZlibStackChannelTransform( if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) { if (mode == TCL_ZLIB_STREAM_DEFLATE) { if (gzipHeaderDictPtr) { - int dummy = 0; - cd->flags |= OUT_HEADER; if (GenerateHeader(interp, gzipHeaderDictPtr, &cd->outHeader, - &dummy) != TCL_OK) { + NULL) != TCL_OK) { goto error; } } -- cgit v0.12 From 67d714cab480480fb736bb1a1c6fa30f9b2d845c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 10 Apr 2012 07:29:38 +0000 Subject: Argument parsing update --- generic/tclZlib.c | 116 +++++++++++++++++++++++++++--------------------------- 1 file changed, 58 insertions(+), 58 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 35513d5..ecc4f07 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1920,13 +1920,34 @@ ZlibCmd( } return TCL_OK; case CMD_STREAM: { /* stream deflate/inflate/...gunzip \ - * ?level? + * ?options...? * -> handleCmd */ + typedef struct { + const char *name; + Tcl_Obj **valueVar; + } OptDescriptor; Tcl_Obj *compDictObj = NULL; Tcl_Obj *gzipHeaderObj = NULL; + Tcl_Obj *levelObj = NULL; + OptDescriptor compressionOpts[] = { + { "-dictionary", &compDictObj }, + { "-level", &levelObj }, + { NULL, NULL } + }; + OptDescriptor gzipOpts[] = { + { "-dictionary", &compDictObj }, + { "-header", &gzipHeaderObj }, + { "-level", &levelObj }, + { NULL, NULL } + }; + OptDescriptor expansionOpts[] = { + { "-dictionary", &compDictObj }, + { NULL, NULL } + }; + OptDescriptor *desc; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?options...?"); + if (objc < 3 || !(objc & 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, @@ -1935,90 +1956,69 @@ ZlibCmd( } switch ((enum zlibFormats) format) { case FMT_DEFLATE: - if (objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); - return TCL_ERROR; - } + desc = compressionOpts; mode = TCL_ZLIB_STREAM_DEFLATE; format = TCL_ZLIB_FORMAT_RAW; - level = Z_DEFAULT_COMPRESSION; - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } break; case FMT_INFLATE: - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mode"); - return TCL_ERROR; - } + desc = expansionOpts; mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_RAW; - level = Z_DEFAULT_COMPRESSION; break; case FMT_COMPRESS: - if (objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); - return TCL_ERROR; - } + desc = compressionOpts; mode = TCL_ZLIB_STREAM_DEFLATE; format = TCL_ZLIB_FORMAT_ZLIB; - level = Z_DEFAULT_COMPRESSION; - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } break; case FMT_DECOMPRESS: - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mode"); - return TCL_ERROR; - } + desc = expansionOpts; mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_ZLIB; - level = Z_DEFAULT_COMPRESSION; break; case FMT_GZIP: - if (objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?level?"); - return TCL_ERROR; - } + desc = gzipOpts; mode = TCL_ZLIB_STREAM_DEFLATE; format = TCL_ZLIB_FORMAT_GZIP; - level = Z_DEFAULT_COMPRESSION; - if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } break; case FMT_GUNZIP: - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "mode"); - return TCL_ERROR; - } + desc = expansionOpts; mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; - level = Z_DEFAULT_COMPRESSION; break; } + + for (i=3 ; i 9) { + goto badLevel; + } + } + if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, &zh) != TCL_OK) { return TCL_ERROR; } if (compDictObj != NULL) { - ((ZlibStreamHandle *) zh)->compDictObj = compDictObj; + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zh; + + zshPtr->compDictObj = compDictObj; Tcl_IncrRefCount(compDictObj); } Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); -- cgit v0.12 From e697d980199dc1c2b172feffd18aa3c9b156843c Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 11 Apr 2012 07:16:45 +0000 Subject: towards dictionary setting on transforms --- generic/tclZlib.c | 146 ++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 93 insertions(+), 53 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index ecc4f07..068308a 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -95,6 +95,9 @@ 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_Obj *compDictObj; /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ } ZlibChannelData; /* @@ -146,7 +149,8 @@ static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, int mode, int format, int level, - Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr); + Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, + Tcl_Obj *compDictObj); static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); static void ZlibTransformTimerKill(ZlibChannelData *cd); static void ZlibTransformTimerRun(ClientData clientData); @@ -448,6 +452,34 @@ ExtractHeader( } } +static int +SetInflateDictionary( + z_streamp strm, + Tcl_Obj *compDictObj) +{ + if (compDictObj != NULL) { + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + + return inflateSetDictionary(strm, bytes, (unsigned) length); + } + return Z_OK; +} + +static int +SetDeflateDictionary( + z_streamp strm, + Tcl_Obj *compDictObj) +{ + if (compDictObj != NULL) { + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + + return deflateSetDictionary(strm, bytes, (unsigned) length); + } + return Z_OK; +} + /* *---------------------------------------------------------------------- * @@ -586,12 +618,7 @@ Tcl_ZlibStreamInit( &zshPtr->gzHeaderPtr->header); } if (e == Z_OK && zshPtr->compDictObj) { - int dictLen; - unsigned char *dictBytes = - Tcl_GetByteArrayFromObj(zshPtr->compDictObj, &dictLen); - - e = deflateSetDictionary(&zshPtr->stream, dictBytes, - (unsigned) dictLen); + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); } } else { e = inflateInit2(&zshPtr->stream, wbits); @@ -599,6 +626,9 @@ Tcl_ZlibStreamInit( e = inflateGetHeader(&zshPtr->stream, &zshPtr->gzHeaderPtr->header); } + if (format==TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj && e==Z_OK) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + } } if (e != Z_OK) { @@ -837,15 +867,14 @@ Tcl_ZlibStreamReset( e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED, zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); if (e == Z_OK && zshPtr->compDictObj) { - int dictLen; - unsigned char *dictBytes = - Tcl_GetByteArrayFromObj(zshPtr->compDictObj, &dictLen); - - e = deflateSetDictionary(&zshPtr->stream, dictBytes, - (unsigned) dictLen); + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); } } else { e = inflateInit2(&zshPtr->stream, zshPtr->wbits); + if (zshPtr->format == TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj + && e == Z_OK) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + } } if (e != Z_OK) { @@ -1158,22 +1187,13 @@ Tcl_ZlibStreamGet( } } - while (1) { - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e != Z_NEED_DICT || zshPtr->compDictObj == NULL) { - break; - } else { - int dictLen; - unsigned char *dictBytes = - Tcl_GetByteArrayFromObj(zshPtr->compDictObj,&dictLen); - - e = inflateSetDictionary(&zshPtr->stream, dictBytes, - (unsigned) dictLen); - if (e != Z_OK) { - break; - } + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e == Z_NEED_DICT && zshPtr->compDictObj) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + e = inflate(&zshPtr->stream, zshPtr->flush); } - } + }; Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); while ((zshPtr->stream.avail_out > 0) @@ -1227,21 +1247,11 @@ Tcl_ZlibStreamGet( * And call inflate again. */ - while (1) { - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e != Z_NEED_DICT || zshPtr->compDictObj == NULL) { - break; - } else { - int dictLen; - unsigned char *dictBytes = - Tcl_GetByteArrayFromObj(zshPtr->compDictObj, - &dictLen); - - e = inflateSetDictionary(&zshPtr->stream, dictBytes, - (unsigned) dictLen); - if (e != Z_OK) { - break; - } + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e == Z_NEED_DICT && zshPtr->compDictObj) { + e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj); + if (e == Z_OK) { + e = inflate(&zshPtr->stream, zshPtr->flush); } } } @@ -2160,7 +2170,7 @@ ZlibCmd( } if (ZlibStackChannelTransform(interp, mode, format, level, chan, - headerObj) == NULL) { + headerObj, NULL) == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, objv[3]); @@ -2481,12 +2491,10 @@ ZlibTransformClose( /* TODO: is this the right way to do errors on close? * Note: when close is called from FinalizeIOSubsystem * then interp may be NULL */ - if (!TclInThreadExit()) { - if (interp) { - Tcl_AppendResult(interp, - "error while finalizing file: ", - Tcl_PosixError(interp), NULL); - } + if (!TclInThreadExit() && interp) { + Tcl_AppendResult(interp, + "error while finalizing file: ", + Tcl_PosixError(interp), NULL); } result = TCL_ERROR; break; @@ -2538,6 +2546,12 @@ ZlibTransformInput( } while (1) { e = inflate(&cd->inStream, flush); + if (e == Z_NEED_DICT && cd->compDictObj) { + e = SetInflateDictionary(&cd->inStream, cd->compDictObj); + if (e == Z_OK) { + continue; + } + } if ((e == Z_STREAM_END) || (e==Z_OK && cd->inStream.avail_out==0)) { return toRead - cd->inStream.avail_out; } @@ -2651,9 +2665,13 @@ ZlibTransformSetOption( /* not used */ ZlibChannelData *cd = instanceData; Tcl_DriverSetOptionProc *setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "flush"; + static const char *chanOptions = "dictionary flush"; int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); + if (optionName && strcmp(optionName, "-dictionary") == 0) { + // TODO dictionary option + } + if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { int flushType; @@ -2715,7 +2733,7 @@ ZlibTransformGetOption( ZlibChannelData *cd = instanceData; Tcl_DriverGetOptionProc *getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "checksum header"; + static const char *chanOptions = "checksum dictionary header"; /* * The "crc" option reports the current CRC (calculated with the Adler32 @@ -2743,6 +2761,10 @@ ZlibTransformGetOption( } } + if (optionName == NULL || strcmp(optionName, "-dictionary") == 0) { + // TODO dictionary option + } + /* * The "header" option, which is only valid on inflating gzip channels, * reports the header that has been read from the start of the stream. @@ -2901,9 +2923,12 @@ ZlibStackChannelTransform( int level, /* What compression level to use. Ignored for * decompressing transforms. */ Tcl_Channel channel, /* The channel to attach to. */ - Tcl_Obj *gzipHeaderDictPtr) /* A description of header to use, or NULL to + Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to * use a default. Ignored if not compressing * to produce gzip-format data. */ + Tcl_Obj *compDictObj) /* Byte-array object containing compression + * dictionary (not dictObj!) to use if + * necessary. */ { ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData)); Tcl_Channel chan; @@ -2937,6 +2962,12 @@ ZlibStackChannelTransform( } } + if (compDictObj != NULL) { + cd->compDictObj = Tcl_DuplicateObj(compDictObj); + Tcl_IncrRefCount(cd->compDictObj); + Tcl_GetByteArrayFromObj(cd->compDictObj, NULL); + } + if (format == TCL_ZLIB_FORMAT_RAW) { wbits = WBITS_RAW; } else if (format == TCL_ZLIB_FORMAT_ZLIB) { @@ -2980,6 +3011,12 @@ ZlibStackChannelTransform( goto error; } } + if (cd->compDictObj) { + e = SetDeflateDictionary(&cd->outStream, cd->compDictObj); + if (e != Z_OK) { + goto error; + } + } } chan = Tcl_StackChannel(interp, &zlibChannelType, cd, @@ -3001,6 +3038,9 @@ ZlibStackChannelTransform( ckfree(cd->outBuffer); deflateEnd(&cd->outStream); } + if (cd->compDictObj) { + Tcl_DecrRefCount(cd->compDictObj); + } ckfree(cd); return NULL; } -- cgit v0.12 From 6f233b426d4ed93956bdfb664f808bf6df832dbc Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Apr 2012 21:05:43 +0000 Subject: Refactor some [zlib] subcommands into their own functions --- generic/tclZlib.c | 567 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 320 insertions(+), 247 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 9b231df..f88e0e1 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -147,11 +147,15 @@ 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 ZlibPushSubcmd(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, int mode, int format, int level, Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, Tcl_Obj *compDictObj); static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); +static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static void ZlibTransformTimerKill(ZlibChannelData *cd); static void ZlibTransformTimerRun(ClientData clientData); static void ZlibTransformTimerSetup(ZlibChannelData *cd); @@ -1712,11 +1716,10 @@ ZlibCmd( int objc, Tcl_Obj *const objv[]) { - int command, dlen, mode, format, i, option, level = -1; + int command, dlen, i, option, level = -1; unsigned start, buffersize = 0; - Tcl_ZlibStream zh; Byte *data; - Tcl_Obj *headerDictObj, *headerVarObj; + Tcl_Obj *headerDictObj; const char *extraInfoStr = NULL; static const char *const commands[] = { "adler32", "compress", "crc32", "decompress", "deflate", "gunzip", @@ -1727,14 +1730,6 @@ ZlibCmd( CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE, CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM }; - static const char *const stream_formats[] = { - "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", - NULL - }; - enum zlibFormats { - FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, - FMT_INFLATE - }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?"); @@ -1882,8 +1877,10 @@ ZlibCmd( } return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], buffersize, NULL); - case CMD_GUNZIP: /* gunzip gzippeddata ?bufferSize? + case CMD_GUNZIP: { /* gunzip gzippeddata ?bufferSize? * -> decompressedData */ + Tcl_Obj *headerVarObj; + if (objc < 3 || objc > 5 || ((objc & 1) == 0)) { Tcl_WrongNumArgs(interp, 2, objv, "data ?-headerVar varName?"); return TCL_ERROR; @@ -1929,268 +1926,344 @@ ZlibCmd( return TCL_ERROR; } return TCL_OK; - case CMD_STREAM: { /* stream deflate/inflate/...gunzip \ + } + case CMD_STREAM: /* stream deflate/inflate/...gunzip \ * ?options...? * -> handleCmd */ - typedef struct { - const char *name; - Tcl_Obj **valueVar; - } OptDescriptor; - Tcl_Obj *compDictObj = NULL; - Tcl_Obj *gzipHeaderObj = NULL; - Tcl_Obj *levelObj = NULL; - OptDescriptor compressionOpts[] = { - { "-dictionary", &compDictObj }, - { "-level", &levelObj }, - { NULL, NULL } - }; - OptDescriptor gzipOpts[] = { - { "-dictionary", &compDictObj }, - { "-header", &gzipHeaderObj }, - { "-level", &levelObj }, - { NULL, NULL } - }; - OptDescriptor expansionOpts[] = { - { "-dictionary", &compDictObj }, - { NULL, NULL } - }; - OptDescriptor *desc; - - if (objc < 3 || !(objc & 1)) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - desc = compressionOpts; - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_INFLATE: - desc = expansionOpts; - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - desc = compressionOpts; - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_DECOMPRESS: - desc = expansionOpts; - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - desc = gzipOpts; - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - case FMT_GUNZIP: - desc = expansionOpts; - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - } + return ZlibStreamSubcmd(interp, objc, objv); + case CMD_PUSH: /* push mode channel options... + * -> channel */ + return ZlibPushSubcmd(interp, objc, objv); + }; - for (i=3 ; i 9) { - goto badLevel; - } - } + if (objc < 3 || !(objc & 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, + &format) != TCL_OK) { + return TCL_ERROR; + } - if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, - &zh) != TCL_OK) { - return TCL_ERROR; - } - if (compDictObj != NULL) { - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zh; + /* + * The format determines the compression mode and the options that may be + * specified. + */ - zshPtr->compDictObj = compDictObj; - Tcl_IncrRefCount(compDictObj); - } - Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); - return TCL_OK; + switch ((enum zlibFormats) format) { + case FMT_DEFLATE: + desc = compressionOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_INFLATE: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_COMPRESS: + desc = compressionOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_DECOMPRESS: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_GZIP: + desc = gzipOpts; + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + case FMT_GUNZIP: + desc = expansionOpts; + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + default: + Tcl_AppendResult(interp, "IMPOSSIBLE", NULL); + return TCL_ERROR; } - case CMD_PUSH: { /* push mode channel options... - * -> channel */ - Tcl_Channel chan; - int chanMode; - static const char *const pushOptions[] = { - "-header", "-level", "-limit", - NULL - }; - enum pushOptions {poHeader, poLevel, poLimit}; - Tcl_Obj *headerObj = NULL; - int limit = 1, dummy; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_INFLATE: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_DECOMPRESS: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - case FMT_GUNZIP: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - default: - Tcl_AppendResult(interp, "IMPOSSIBLE", NULL); - return TCL_ERROR; - } + /* + * Parse the options. + */ - if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, - 0) != TCL_OK) { + for (i=3 ; i 9) { + Tcl_AppendResult(interp, "level must be 0 to 9", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); + Tcl_AddErrorInfo(interp, "\n (in -level option)"); + return TCL_ERROR; + } + + /* + * Construct the stream now we know its configuration. + */ + + if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj, + &zh) != TCL_OK) { + return TCL_ERROR; + } + if (compDictObj != NULL) { + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zh; + + zshPtr->compDictObj = compDictObj; + Tcl_IncrRefCount(compDictObj); + } + Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ZlibPushSubcmd -- + * + * Implementation of the [zlib push] subcommand. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibPushSubcmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *const stream_formats[] = { + "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", + NULL + }; + enum zlibFormats { + FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, + FMT_INFLATE + }; + Tcl_Channel chan; + int chanMode, format, mode, level, i, option; + static const char *const pushOptions[] = { + "-header", "-level", "-limit", NULL + }; + enum pushOptions {poHeader, poLevel, poLimit}; + Tcl_Obj *headerObj = NULL; + int limit = 1, dummy; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, + &format) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum zlibFormats) format) { + case FMT_DEFLATE: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_INFLATE: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_RAW; + break; + case FMT_COMPRESS: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_DECOMPRESS: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_ZLIB; + break; + case FMT_GZIP: + mode = TCL_ZLIB_STREAM_DEFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + case FMT_GUNZIP: + mode = TCL_ZLIB_STREAM_INFLATE; + format = TCL_ZLIB_FORMAT_GZIP; + break; + default: + Tcl_AppendResult(interp, "IMPOSSIBLE", NULL); + return TCL_ERROR; + } + + if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK){ + return TCL_ERROR; + } + + /* + * Sanity checks. + */ + + if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { + Tcl_AppendResult(interp, + "compression may only be applied to writable channels", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL); + return TCL_ERROR; + } + if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { + Tcl_AppendResult(interp, + "decompression may only be applied to readable channels", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL); + return TCL_ERROR; + } + + /* + * Parse options. + */ + + level = Z_DEFAULT_COMPRESSION; + for (i=4 ; i objc-1) { + Tcl_AppendResult(interp, "value missing for -header option", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } - switch ((enum pushOptions) option) { - case poHeader: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -header option", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - headerObj = objv[i]; - if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -header option)"); - return TCL_ERROR; - } - break; - case poLevel: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -level option", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i], - (int *) &level) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -level option)"); - return TCL_ERROR; - } - if (level < 0 || level > 9) { - extraInfoStr = "\n (in -level option)"; - goto badLevel; - } - break; - case poLimit: - if (++i > objc-1) { - Tcl_AppendResult(interp, - "value missing for -limit option", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i], - (int *) &limit) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (in -limit option)"); - return TCL_ERROR; - } - if (limit < 1) { - limit = 1; - } - break; + headerObj = objv[i]; + if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (in -header option)"); + return TCL_ERROR; } + break; + case poLevel: + if (++i > objc-1) { + Tcl_AppendResult(interp, + "value missing for -level option", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (in -level option)"); + return TCL_ERROR; + } + if (level < 0 || level > 9) { + Tcl_AppendResult(interp, "level must be 0 to 9", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", + NULL); + Tcl_AddErrorInfo(interp, "\n (in -level option)"); + return TCL_ERROR; + } + break; + case poLimit: + if (++i > objc-1) { + Tcl_AppendResult(interp, "value missing for -limit option", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (in -limit option)"); + return TCL_ERROR; + } + if (limit < 1) { + limit = 1; + } + break; } - - if (ZlibStackChannelTransform(interp, mode, format, level, chan, - headerObj, NULL) == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[3]); - return TCL_OK; } - }; - - return TCL_ERROR; - badLevel: - Tcl_AppendResult(interp, "level must be 0 to 9", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); - if (extraInfoStr) { - Tcl_AddErrorInfo(interp, extraInfoStr); + if (ZlibStackChannelTransform(interp, mode, format, level, chan, + headerObj, NULL) == NULL) { + return TCL_ERROR; } - return TCL_ERROR; - badBuffer: - Tcl_AppendResult(interp, "buffer size must be 32 to 65536", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, objv[3]); + return TCL_OK; } /* -- cgit v0.12 From cabd03de9c061b66cb7735abc1dc4ccee55b84b2 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Apr 2012 07:42:58 +0000 Subject: Working towards the channel transform config options. --- generic/tclZlib.c | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index f88e0e1..0caa02b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2130,10 +2130,10 @@ ZlibPushSubcmd( Tcl_Channel chan; int chanMode, format, mode, level, i, option; static const char *const pushOptions[] = { - "-header", "-level", "-limit", NULL + "-dictionary", "-header", "-level", "-limit", NULL }; - enum pushOptions {poHeader, poLevel, poLimit}; - Tcl_Obj *headerObj = NULL; + enum pushOptions {poDictionary, poHeader, poLevel, poLimit}; + Tcl_Obj *headerObj = NULL, *compDictObj = NULL; int limit = 1, dummy; if (objc < 4) { @@ -2255,6 +2255,15 @@ ZlibPushSubcmd( limit = 1; } break; + case poDictionary: + if (++i > objc-1) { + Tcl_AppendResult(interp, + "value missing for -dictionary option", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[i]; + break; } } @@ -2262,6 +2271,10 @@ ZlibPushSubcmd( headerObj, NULL) == NULL) { return TCL_ERROR; } + if ((compDictObj != NULL) && (Tcl_SetChannelOption(interp, chan, + "-dictionary", TclGetString(compDictObj)) != TCL_OK)) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, objv[3]); return TCL_OK; } @@ -2742,7 +2755,16 @@ ZlibTransformSetOption( /* not used */ int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); if (optionName && strcmp(optionName, "-dictionary") == 0) { - // TODO dictionary option + Tcl_Obj *compDictObj; + + TclNewStringObj(compDictObj, value, strlen(value)); + Tcl_IncrRefCount(compDictObj); + (void) Tcl_GetByteArrayFromObj(compDictObj, NULL); + if (cd->compDictObj) { + TclDecrRefCount(cd->compDictObj); + } + cd->compDictObj = compDictObj; + // TODO: consider whether to apply immediately } if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { -- cgit v0.12 From ace56e587278e676259306f1a89602f3ca679f52 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 20 Apr 2012 10:22:03 +0000 Subject: another bit of fconfigure guts --- generic/tclZlib.c | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 0caa02b..6290d60 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2859,7 +2859,24 @@ ZlibTransformGetOption( } if (optionName == NULL || strcmp(optionName, "-dictionary") == 0) { - // TODO dictionary option + /* + * Embedded NUL bytes are ok; they'll be C080-encoded. + */ + + if (optionName == NULL) { + Tcl_DStringAppendElement(dsPtr, "-dictionary"); + if (cd->compDictObj) { + Tcl_DStringAppendElement(dsPtr, + Tcl_GetString(cd->compDictObj)); + } else { + Tcl_DStringAppendElement(dsPtr, ""); + } + } else { + int len; + const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + + Tcl_DStringAppend(dsPtr, str, len); + } } /* -- cgit v0.12 From 6dc349d4991d4514c4419c39e9918cf4c7998cfd Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 29 Apr 2012 07:18:30 +0000 Subject: Differentiate what options may be set by format type. --- generic/tclZlib.c | 26 +++++++++++++++++++++----- tests/zlib.test | 20 ++++++++++++++++++++ 2 files changed, 41 insertions(+), 5 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 51d6beb..a1b8afc 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -83,6 +83,9 @@ typedef struct { * for compression on output, or * TCL_ZLIB_STREAM_INFLATE for decompression * on input. */ + int format; /* What format of data is going on the wire. + * Needed so that the correct [fconfigure] + * options can be enabled. */ z_stream inStream; /* Structure used by zlib for decompression of * input. */ z_stream outStream; /* Structure used by zlib for compression of @@ -1985,7 +1988,6 @@ ZlibStreamSubcmd( { NULL, NULL } }; const OptDescriptor gzipOpts[] = { - { "-dictionary", &compDictObj }, { "-header", &gzipHeaderObj }, { "-level", &levelObj }, { NULL, NULL } @@ -2038,7 +2040,7 @@ ZlibStreamSubcmd( format = TCL_ZLIB_FORMAT_GZIP; break; case FMT_GUNZIP: - desc = expansionOpts; + desc = expansionOpts; // FIXME - get header, not set compDict mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; break; @@ -2258,6 +2260,12 @@ ZlibPushSubcmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } + if (format == TCL_ZLIB_FORMAT_GZIP) { + Tcl_AppendResult(interp, "a compression dictionary may not " + "be set in the gzip format", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); + return TCL_ERROR; + } compDictObj = objv[i]; break; } @@ -2748,9 +2756,11 @@ ZlibTransformSetOption( /* not used */ Tcl_DriverSetOptionProc *setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent)); static const char *chanOptions = "dictionary flush"; + static const char *gzipChanOptions = "flush"; int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); - if (optionName && strcmp(optionName, "-dictionary") == 0) { + if (optionName && (strcmp(optionName, "-dictionary") == 0) + && (cd->format != TCL_ZLIB_FORMAT_GZIP)) { Tcl_Obj *compDictObj; TclNewStringObj(compDictObj, value, strlen(value)); @@ -2809,7 +2819,11 @@ ZlibTransformSetOption( /* not used */ } if (setOptionProc == NULL) { - return Tcl_BadChannelOption(interp, optionName, chanOptions); + if (cd->format == TCL_ZLIB_FORMAT_GZIP) { + return Tcl_BadChannelOption(interp, optionName, gzipChanOptions); + } else { + return Tcl_BadChannelOption(interp, optionName, chanOptions); + } } return setOptionProc(Tcl_GetChannelInstanceData(cd->parent), interp, @@ -2854,7 +2868,8 @@ ZlibTransformGetOption( } } - if (optionName == NULL || strcmp(optionName, "-dictionary") == 0) { + if ((cd->format != TCL_ZLIB_FORMAT_GZIP) && + (optionName == NULL || strcmp(optionName, "-dictionary") == 0)) { /* * Embedded NUL bytes are ok; they'll be C080-encoded. */ @@ -3051,6 +3066,7 @@ ZlibStackChannelTransform( memset(cd, 0, sizeof(ZlibChannelData)); cd->mode = mode; + cd->format = format; if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) { if (mode == TCL_ZLIB_STREAM_DEFLATE) { diff --git a/tests/zlib.test b/tests/zlib.test index 3aaca29..017243b 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -168,6 +168,26 @@ test zlib-8.4 {transformation and flushing: Bug 3517696} -setup { catch {close $fd} removeFile $file } -result {} +test zlib-8.5 {transformation and fconfigure} -setup { + set file [makeFile {} test.z] + set fd [open $file wb] +} -constraints zlib -body { + list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \ + [chan pop $fd; fconfigure $fd] +} -cleanup { + catch {close $fd} + removeFile $file +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +test zlib-8.6 {transformation and fconfigure} -setup { + set file [makeFile {} test.gz] + set fd [open $file wb] +} -constraints zlib -body { + list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \ + [chan pop $fd; fconfigure $fd] +} -cleanup { + catch {close $fd} + removeFile $file +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From a0fbc952a8b199b3bc07bf4dbef4d504a9eae73e Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 1 May 2012 08:29:11 +0000 Subject: first actual test of doing something with a compression dictionary --- generic/tclZlib.c | 16 ++++++++++------ tests/zlib.test | 15 +++++++++++++++ 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index a1b8afc..1fe5b05 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2272,11 +2272,7 @@ ZlibPushSubcmd( } if (ZlibStackChannelTransform(interp, mode, format, level, chan, - headerObj, NULL) == NULL) { - return TCL_ERROR; - } - if ((compDictObj != NULL) && (Tcl_SetChannelOption(interp, chan, - "-dictionary", TclGetString(compDictObj)) != TCL_OK)) { + headerObj, compDictObj) == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, objv[3]); @@ -2762,6 +2758,7 @@ ZlibTransformSetOption( /* not used */ if (optionName && (strcmp(optionName, "-dictionary") == 0) && (cd->format != TCL_ZLIB_FORMAT_GZIP)) { Tcl_Obj *compDictObj; + int code; TclNewStringObj(compDictObj, value, strlen(value)); Tcl_IncrRefCount(compDictObj); @@ -2770,7 +2767,14 @@ ZlibTransformSetOption( /* not used */ TclDecrRefCount(cd->compDictObj); } cd->compDictObj = compDictObj; - // TODO: consider whether to apply immediately + if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { + code = SetDeflateDictionary(&cd->outStream, compDictObj); + if (code != Z_OK) { + ConvertError(interp, code); + return TCL_ERROR; + } + } + return TCL_OK; } if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { diff --git a/tests/zlib.test b/tests/zlib.test index 017243b..05b5ed5 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -188,6 +188,21 @@ test zlib-8.6 {transformation and fconfigure} -setup { catch {close $fd} removeFile $file } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +test zlib-8.7 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set msg [string repeat "am i all that i am at all? i am all that i am!" 400] + set dict "thatallam i " +} -constraints zlib -body { + zlib push compress $outSide -dictionary $dict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $msg + chan pop $outSide + string length [read $inSide] +} -cleanup { + catch {close $outSide} + catch {close $inSide} +} -result 103 test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From ee3d9db0cccb2c38010453b8432933b3233f8f15 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 4 May 2012 21:18:59 +0000 Subject: Add ability to get gzip header out of streaming zlib access --- generic/tclZlib.c | 31 ++++++++++++++++++++++++++++--- 1 file changed, 28 insertions(+), 3 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 1fe5b05..be2f540 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1996,6 +1996,9 @@ ZlibStreamSubcmd( { "-dictionary", &compDictObj }, { NULL, NULL } }; + const OptDescriptor gunzipOpts[] = { + { NULL, NULL } + }; const OptDescriptor *desc; Tcl_ZlibStream zh; @@ -2040,7 +2043,7 @@ ZlibStreamSubcmd( format = TCL_ZLIB_FORMAT_GZIP; break; case FMT_GUNZIP: - desc = expansionOpts; // FIXME - get header, not set compDict + desc = gunzipOpts; mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; break; @@ -2301,12 +2304,12 @@ ZlibStreamCmd( Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", - "fullflush", "get", "put", "reset", + "fullflush", "get", "header", "put", "reset", NULL }; enum zlibStreamCommands { zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, - zs_fullflush, zs_get, zs_put, zs_reset + zs_fullflush, zs_get, zs_header, zs_put, zs_reset }; static const char *const add_options[] = { "-buffer", "-finalize", "-flush", "-fullflush", NULL @@ -2431,6 +2434,7 @@ ZlibStreamCmd( case ao_buffer: Tcl_AppendResult(interp, "\"-buffer\" option not supported here", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); return TCL_ERROR; } if (flush == -2) { @@ -2528,6 +2532,27 @@ ZlibStreamCmd( return TCL_ERROR; } return Tcl_ZlibStreamReset(zstream); + case zs_header: { /* $strm header */ + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zstream; + Tcl_Obj *resultObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE + || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) { + Tcl_AppendResult(interp, + "only gunzip streams can produce header information", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); + return TCL_ERROR; + } + + TclNewObj(resultObj); + ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } } return TCL_OK; -- cgit v0.12 From b4ee8396d0f8b3626646235fd727414e997b8bbc Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 5 May 2012 14:29:48 +0000 Subject: start writing some documentation --- doc/zlib.n | 8 +++++++- generic/tclZlib.c | 2 +- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index 9fa83c6..6f1564c 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -1,5 +1,5 @@ '\" -'\" Copyright (c) 2008 Donal K. Fellows +'\" Copyright (c) 2008-2012 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -317,6 +317,12 @@ A short-cut for Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the transformation applied. If \fIcount\fR is omitted, the entire contents of the buffers are returned. +. +\fIstream \fBheader\fR +. +Return the gzip header description dictionary extracted from the stream. Only +supported for streams created with their \fImode\fR parameter set to +\fBgunzip\fR. .TP \fIstream \fBput\fR ?\fIoption\fR? \fIdata\fR . diff --git a/generic/tclZlib.c b/generic/tclZlib.c index be2f540..96cda4e 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -5,7 +5,7 @@ * * Copyright (C) 2004-2005 Pascal Scheffers * Copyright (C) 2005 Unitas Software B.V. - * Copyright (c) 2008-2009 Donal K. Fellows + * Copyright (c) 2008-2012 Donal K. Fellows * * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the * public domain March 2003. -- cgit v0.12 From 61f3f8291f95e147c2bcda26e7eb02ec7927f5e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 10 May 2012 09:22:48 +0000 Subject: updated C API to be more focused on supporting just some operations --- generic/tcl.decls | 4 +++- generic/tclDecls.h | 10 +++++---- generic/tclStubInit.c | 2 +- generic/tclZlib.c | 61 +++++++++++++++++++++++++++++++++++++++++---------- 4 files changed, 59 insertions(+), 18 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index afeae51..36e92fa 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2318,8 +2318,10 @@ declare 629 { int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr) } +# TIP #400 declare 630 { - void* Tcl_ZlibStreamGetZstreamp(Tcl_ZlibStream zshandle) + void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj) } # ----- BASELINE -- FOR -- 8.6.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0c1dedf..7c3e1de 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1808,7 +1808,9 @@ EXTERN void * Tcl_FindSymbol(Tcl_Interp *interp, EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 630 */ -EXTERN void* Tcl_ZlibStreamGetZstreamp(Tcl_ZlibStream zshandle); +EXTERN void Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj); typedef struct TclStubHooks { const struct TclPlatStubs *tclPlatStubs; @@ -2474,7 +2476,7 @@ typedef struct TclStubs { int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ - void* (*tcl_ZlibStreamGetZstreamp) (Tcl_ZlibStream zshandle); /* 630 */ + void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ } TclStubs; #ifdef __cplusplus @@ -3767,8 +3769,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ -#define Tcl_ZlibStreamGetZstreamp \ - (tclStubsPtr->tcl_ZlibStreamGetZstreamp) /* 630 */ +#define Tcl_ZlibStreamSetCompressionDictionary \ + (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a74101d..7fb0f1c 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1340,7 +1340,7 @@ const TclStubs tclStubs = { Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ - Tcl_ZlibStreamGetZstreamp, /* 630 */ + Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 96cda4e..7785dea 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -67,10 +67,15 @@ typedef struct { Tcl_Obj *compDictObj; /* Byte-array object containing compression * dictionary (not dictObj!) to use if * necessary. */ + int flags; /* Miscellaneous flag bits. */ GzipHeader *gzHeaderPtr; /* If we've allocated a gzip header * structure. */ } ZlibStreamHandle; +#define DICT_TO_SET 0x1 /* If we need to set a compression dictionary + * in the low-level engine at the next + * opportunity. */ + /* * Structure used for stacked channel compression and decompression. */ @@ -606,6 +611,7 @@ Tcl_ZlibStreamInit( zshPtr->currentInput = NULL; zshPtr->streamEnd = 0; zshPtr->compDictObj = NULL; + zshPtr->flags = 0; zshPtr->gzHeaderPtr = gzHeaderPtr; memset(&zshPtr->stream, 0, sizeof(z_stream)); @@ -974,22 +980,32 @@ Tcl_ZlibStreamChecksum( /* *---------------------------------------------------------------------- * - * Tcl_ZlibStreamGetZstreamp -- + * Tcl_ZlibStreamSetCompressionDictionary -- * - * Return the z_streamp for the stream (though not typed as such, so as - * to avoid type interface poisoning). Shouldn't be used to poke around - * excessively. + * Sets the compression dictionary for a stream. This will be used as + * appropriate for the next compression or decompression action performed + * on the stream. * *---------------------------------------------------------------------- */ -void * -Tcl_ZlibStreamGetZstreamp( - Tcl_ZlibStream zshandle) +void +Tcl_ZlibStreamSetCompressionDictionary( + Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj) { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - return &zshPtr->stream; + if (compressionDictionaryObj != NULL) { + Tcl_IncrRefCount(compressionDictionaryObj); + zshPtr->flags |= DICT_TO_SET; + } else { + zshPtr->flags &= ~DICT_TO_SET; + } + if (zshPtr->compDictObj != NULL) { + Tcl_DecrRefCount(zshPtr->compDictObj); + } + zshPtr->compDictObj = compressionDictionaryObj; } /* @@ -1028,6 +1044,17 @@ Tcl_ZlibStreamPut( zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size); zshPtr->stream.avail_in = size; + if (zshPtr->flags & DICT_TO_SET) { + e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e != Z_OK) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e); + } + return TCL_ERROR; + } + zshPtr->flags &= ~DICT_TO_SET; + } + /* * Deflatebound doesn't seem to take various header sizes into * account, so we add 100 extra bytes. @@ -1065,6 +1092,12 @@ Tcl_ZlibStreamPut( e = deflate(&zshPtr->stream, flush); } + if (e != Z_OK) { + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e); + } + return TCL_ERROR; + } /* * And append the final data block. @@ -3345,11 +3378,15 @@ Tcl_ZlibAdler32( return 0; } -void * -Tcl_ZlibStreamGetZstreamp( - Tcl_ZlibStream zshandle) +int +Tcl_ZlibStreamSetCompressionDictionary( + Tcl_Interp *interp, + Tcl_ZlibStream zhandle, + Tcl_Obj *compressionDictionaryObj) { - return NULL; + Tcl_SetResult(interp, "unimplemented", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); + return TCL_ERROR; } #endif /* HAVE_ZLIB */ -- cgit v0.12 From e859f7d69ec73922d1dbdfaa19df6e7f0b82c593 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 18 May 2012 00:01:58 +0000 Subject: typofix --- generic/tclZlib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 7785dea..356772e 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -991,7 +991,7 @@ Tcl_ZlibStreamChecksum( void Tcl_ZlibStreamSetCompressionDictionary( - Tcl_ZlibStream zhandle, + Tcl_ZlibStream zshandle, Tcl_Obj *compressionDictionaryObj) { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; -- cgit v0.12 From 7be9fc1d1b852e4acfcb37a711374be1f4712411 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 5 Jun 2012 16:25:29 +0000 Subject: better test that dictionaries work --- tests/zlib.test | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/tests/zlib.test b/tests/zlib.test index 642b2a4..cc3900d 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -225,19 +225,21 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} test zlib-8.8 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide - set msg [string repeat "am i all that i am at all? i am all that i am!" 400] - set dict "thatallam i " + # Input is headers from fetching SPDY draft + # Dictionary is that which is proposed _in_ SPDY draft + set msg "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" + set dict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" } -constraints zlib -body { - zlib push compress $outSide -dictionary $dict + zlib push deflate $outSide -dictionary $dict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $msg chan pop $outSide - string length [read $inSide] + list [string length [zlib deflate $msg]] [string length [read $inSide]] } -cleanup { catch {close $outSide} catch {close $inSide} -} -result 103 +} -result {254 212} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From c4e779ece448364066a7669b7040a9bdbcc632a9 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 5 Jun 2012 16:36:11 +0000 Subject: fix broken tests --- generic/tclZlib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 16bed47..537fa68 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1091,7 +1091,7 @@ Tcl_ZlibStreamPut( e = deflate(&zshPtr->stream, flush); } - if (e != Z_OK) { + if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) { if (zshPtr->interp) { ConvertError(zshPtr->interp, e); } -- cgit v0.12 From dc3657b1b7d4d243084c3d11d2ddf5ff47135ebc Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 5 Jun 2012 16:50:52 +0000 Subject: more test tinkering --- generic/tclZlib.c | 32 +++++++++++++++++++------------- tests/zlib.test | 9 ++++++--- 2 files changed, 25 insertions(+), 16 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 537fa68..333c2fa 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -146,7 +146,8 @@ static Tcl_DriverWatchProc ZlibTransformWatch; static Tcl_ObjCmdProc ZlibCmd; static Tcl_ObjCmdProc ZlibStreamCmd; -static void ConvertError(Tcl_Interp *interp, int code); +static void ConvertError(Tcl_Interp *interp, int code, + uLong adler); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); @@ -210,7 +211,8 @@ static void ConvertError( Tcl_Interp *interp, /* Interpreter to store the error in. May be * NULL, in which case nothing happens. */ - int code) /* The zlib error code. */ + int code, /* The zlib error code. */ + uLong adler) /* The checksum expected (for Z_NEED_DICT) */ { if (interp == NULL) { return; @@ -228,7 +230,11 @@ ConvertError( case Z_MEM_ERROR: codeStr = "MEM"; break; case Z_BUF_ERROR: codeStr = "BUF"; break; case Z_VERSION_ERROR: codeStr = "VERSION"; break; - case Z_NEED_DICT: codeStr = "NEED_DICT"; break; + case Z_NEED_DICT: + codeStr = "NEED_DICT"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%lu", adler); + break; default: codeStr = "unknown"; codeStr2 = codeStrBuf; @@ -640,7 +646,7 @@ Tcl_ZlibStreamInit( } if (e != Z_OK) { - ConvertError(interp, e); + ConvertError(interp, e, zshPtr->stream.adler); goto error; } @@ -886,7 +892,7 @@ Tcl_ZlibStreamReset( } if (e != Z_OK) { - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); /* TODO:cleanup */ return TCL_ERROR; } @@ -1047,7 +1053,7 @@ Tcl_ZlibStreamPut( e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { if (zshPtr->interp) { - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); } return TCL_ERROR; } @@ -1093,7 +1099,7 @@ Tcl_ZlibStreamPut( } if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) { if (zshPtr->interp) { - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); } return TCL_ERROR; } @@ -1296,7 +1302,7 @@ Tcl_ZlibStreamGet( } if (!(e==Z_OK || e==Z_STREAM_END || e==Z_BUF_ERROR)) { Tcl_SetByteArrayLength(data, existing); - ConvertError(zshPtr->interp, e); + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); return TCL_ERROR; } if (e == Z_STREAM_END) { @@ -1512,7 +1518,7 @@ Tcl_ZlibDeflate( return TCL_OK; error: - ConvertError(interp, e); + ConvertError(interp, e, stream.adler); TclDecrRefCount(obj); return TCL_ERROR; } @@ -1691,7 +1697,7 @@ Tcl_ZlibInflate( error: TclDecrRefCount(obj); - ConvertError(interp, e); + ConvertError(interp, e, stream.adler); if (nameBuf) { ckfree(nameBuf); } @@ -2629,7 +2635,7 @@ ZlibTransformClose( if (e != Z_OK && e != Z_STREAM_END) { /* TODO: is this the right way to do errors on close? */ if (!TclInThreadExit()) { - ConvertError(interp, e); + ConvertError(interp, e, cd->outStream.adler); } result = TCL_ERROR; break; @@ -2915,7 +2921,7 @@ ZlibTransformSetOption( /* not used */ if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { code = SetDeflateDictionary(&cd->outStream, compDictObj); if (code != Z_OK) { - ConvertError(interp, code); + ConvertError(interp, code, cd->outStream.adler); return TCL_ERROR; } } @@ -2951,7 +2957,7 @@ ZlibTransformSetOption( /* not used */ if (e == Z_BUF_ERROR) { break; } else if (e != Z_OK) { - ConvertError(interp, e); + ConvertError(interp, e, cd->outStream.adler); return TCL_ERROR; } else if (cd->outStream.avail_out == 0) { break; diff --git a/tests/zlib.test b/tests/zlib.test index cc3900d..ba21cd1 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -230,16 +230,19 @@ test zlib-8.8 {transformtion and fconfigure} -setup { set msg "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set dict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" } -constraints zlib -body { - zlib push deflate $outSide -dictionary $dict + zlib push compress $outSide -dictionary $dict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $msg chan pop $outSide - list [string length [zlib deflate $msg]] [string length [read $inSide]] + set compressed [read $inSide] + catch {zlib decompress $compressed} err opt + list [string length [zlib deflate $msg]] [string length $compressed] \ + $err [dict get $opt -errorcode] [zlib adler32 $dict] } -cleanup { catch {close $outSide} catch {close $inSide} -} -result {254 212} +} -result {254 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From dd548295cad0d0d2a8171953d79a2380efdd7244 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 6 Jun 2012 09:30:31 +0000 Subject: more tests, more failures, more docs --- doc/zlib.n | 35 ++++++++++++++++++++++++---- generic/tclZlib.c | 15 ++++++++++-- tests/zlib.test | 68 +++++++++++++++++++++++++++++++++++++++++++++++-------- 3 files changed, 102 insertions(+), 16 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index 2e08d71..ec3ea5a 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -277,10 +277,10 @@ the transformed data. The full set of subcommands supported by a streaming instance command, \fIstream\fR, is as follows: .TP -\fIstream \fBadd\fR ?\fIoption\fR? \fIdata\fR +\fIstream \fBadd\fR ?\fIoption...\fR? \fIdata\fR . A short-cut for -.QW "\fIstream \fBput \fIoption data\fR" +.QW "\fIstream \fBput \fR?\fIoption...\fR? \fIdata\fR" followed by .QW "\fIstream \fBget\fR" . .TP @@ -325,14 +325,24 @@ Return the gzip header description dictionary extracted from the stream. Only supported for streams created with their \fImode\fR parameter set to \fBgunzip\fR. .TP -\fIstream \fBput\fR ?\fIoption\fR? \fIdata\fR +\fIstream \fBput\fR ?\fIoption...\fR? \fIdata\fR . Append the contents of the binary string \fIdata\fR to \fIstream\fR's internal -buffers while applying the transformation. If present, \fIoption\fR must be -one of the following (or an unambiguous prefix) which are used to modify the +buffers while applying the transformation. The following \fIoption\fRs are +supported (or an unambiguous prefix of them), which are used to modify the way in which the transformation is applied: .RS .TP +\fB\-buffer\fI bufferSize\fR +. +\fITODO: document this\fR +.TP +\fB\-dictionary\fI compressionDictionary\fR +.VS "TIP 400" +Sets a compression dictionary to use when working with compressing or +decompressing the data. +.VE +.TP \fB\-finalize\fR . Mark the stream as finished, ensuring that all bytes have been wholly @@ -340,12 +350,22 @@ compressed or decompressed. For gzip streams, this also ensures that the footer is written to the stream. The stream will need to be reset before having more data written to it after this, though data can still be read out of the stream with the \fBget\fR subcommand. +.RS +.PP +This option is mutually exclusive with the \fB\-flush\fR and \fB\-fullflush\fR +options. +.RE .TP \fB\-flush\fR . Ensure that a decompressor consuming the bytes that the current (compressing) stream is producing will be able to produce all the bytes that have been compressed so far, at some performance penalty. +.RS +.PP +This option is mutually exclusive with the \fB\-finalize\fR and +\fB\-fullflush\fR options. +.RE .TP \fB\-fullflush\fR . @@ -353,6 +373,11 @@ Ensure that not only can a decompressor handle all the bytes produced so far (as with \fB\-flush\fR above) but also that it can restart from this point if it detects that the stream is partially corrupt. This incurs a substantial performance penalty. +.RS +.PP +This option is mutually exclusive with the \fB\-finalize\fR and \fB\-flush\fR +options. +.RE .RE .TP \fIstream \fBreset\fR diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 333c2fa..22ab061 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2350,10 +2350,10 @@ ZlibStreamCmd( zs_fullflush, zs_get, zs_header, zs_put, zs_reset }; static const char *const add_options[] = { - "-buffer", "-finalize", "-flush", "-fullflush", NULL + "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum addOptions { - ao_buffer, ao_finalize, ao_flush, ao_fullflush + ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush }; if (objc < 2) { @@ -2415,6 +2415,12 @@ ZlibStreamCmd( NULL); return TCL_ERROR; } + break; + case ao_dictionary: + Tcl_AppendResult(interp, + "\"-dictionary\" option not implemented", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); + return TCL_ERROR; } if (flush == -2) { @@ -2474,6 +2480,11 @@ ZlibStreamCmd( "\"-buffer\" option not supported here", NULL); Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); return TCL_ERROR; + case ao_dictionary: + Tcl_AppendResult(interp, + "\"-dictionary\" option not implemented", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); + return TCL_ERROR; } if (flush == -2) { Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " diff --git a/tests/zlib.test b/tests/zlib.test index ba21cd1..cfde1be 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -223,26 +223,76 @@ test zlib-8.7 {transformation and fconfigure} -setup { catch {close $fd} removeFile $file } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +# Input is headers from fetching SPDY draft +# Dictionary is that which is proposed _in_ SPDY draft +set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" +set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" test zlib-8.8 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide - # Input is headers from fetching SPDY draft - # Dictionary is that which is proposed _in_ SPDY draft - set msg "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" - set dict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" } -constraints zlib -body { - zlib push compress $outSide -dictionary $dict + zlib push compress $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary - puts -nonewline $outSide $msg + puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] catch {zlib decompress $compressed} err opt - list [string length [zlib deflate $msg]] [string length $compressed] \ - $err [dict get $opt -errorcode] [zlib adler32 $dict] + list [string length [zlib compress $spdyHeaders]] \ + [string length $compressed] \ + $err [dict get $opt -errorcode] [zlib adler32 $spdyDict] } -cleanup { catch {close $outSide} catch {close $inSide} -} -result {254 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} +} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} +test zlib-8.9 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream decompress] +} -constraints zlib -body { + zlib push compress $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + $strm put -dictionary $spdyDict [read $inSide] + list [string length $spdyHeaders] [string length [$strm get]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {260 222} +test zlib-8.10 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push deflate $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + set compressed [read $inSide] + catch {zlib inflate $compressed} err opt + list [string length [zlib deflate $spdyHeaders]] \ + [string length $compressed] \ + $err [dict get $opt -errorcode] +} -cleanup { + catch {close $outSide} + catch {close $inSide} +} -result {254 212 {data error} {TCL ZLIB DATA}} +test zlib-8.11 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream inflate] +} -constraints zlib -body { + zlib push deflate $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + $strm put -dictionary $spdyDict [read $inSide] + list [string length $spdyHeaders] [string length [$strm get]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {260 222} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From eb41635caa3911f42cd3be3ed014fc094e50b614 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 6 Jun 2012 10:34:12 +0000 Subject: making the -dictionary option work with streams --- generic/tclZlib.c | 48 ++++++++++++++++++++++++++++++++++++++---------- tests/zlib.test | 4 ++-- 2 files changed, 40 insertions(+), 12 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 22ab061..63d2aca 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2339,7 +2339,7 @@ ZlibStreamCmd( { Tcl_ZlibStream zstream = cd; int command, index, count, code, buffersize = -1, flush = -1, i; - Tcl_Obj *obj; + Tcl_Obj *obj, *compDictObj = NULL; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", "fullflush", "get", "header", "put", "reset", @@ -2404,7 +2404,7 @@ ZlibStreamCmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[i+1], + if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) { return TCL_ERROR; } @@ -2417,10 +2417,15 @@ ZlibStreamCmd( } break; case ao_dictionary: - Tcl_AppendResult(interp, - "\"-dictionary\" option not implemented", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); - return TCL_ERROR; + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-dictionary\" option must be " + "followed by compression dictionary bytes", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; } if (flush == -2) { @@ -2434,6 +2439,15 @@ ZlibStreamCmd( flush = 0; } + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { return TCL_ERROR; } @@ -2481,10 +2495,15 @@ ZlibStreamCmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); return TCL_ERROR; case ao_dictionary: - Tcl_AppendResult(interp, - "\"-dictionary\" option not implemented", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); - return TCL_ERROR; + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-dictionary\" option must be " + "followed by compression dictionary bytes", + NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; } if (flush == -2) { Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " @@ -2496,6 +2515,15 @@ ZlibStreamCmd( if (flush == -1) { flush = 0; } + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); case zs_get: /* $strm get ?count? */ diff --git a/tests/zlib.test b/tests/zlib.test index cfde1be..18b6f55 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -259,7 +259,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} catch {$strm close} -} -result {260 222} +} -result {358 358} test zlib-8.10 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { @@ -292,7 +292,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} catch {$strm close} -} -result {260 222} +} -result {358 358} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From ead79a6f602323485474451f0e652db7f176c902 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 7 Jun 2012 07:12:47 +0000 Subject: compressing transforms now work with dictionaries, even if raw --- generic/tclZlib.c | 16 ++++++++++++++++ tests/zlib.test | 16 ++++++++++++++++ 2 files changed, 32 insertions(+) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 585b500..544ba50 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1237,6 +1237,22 @@ Tcl_ZlibStreamGet( } } + /* + * When dealing with a raw stream, we set the dictionary here, once. + * (You can't do it in response to getting Z_NEED_DATA as raw streams + * don't ever issue that.) + */ + + if (zshPtr->format == TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj) { + e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e != Z_OK) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + return TCL_ERROR; + } + Tcl_DecrRefCount(zshPtr->compDictObj); + zshPtr->compDictObj = NULL; + } + e = inflate(&zshPtr->stream, zshPtr->flush); if (e == Z_NEED_DICT && zshPtr->compDictObj) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); diff --git a/tests/zlib.test b/tests/zlib.test index 18b6f55..5d46926 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -293,6 +293,22 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} +test zlib-8.13 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream compress] +} -constraints {zlib knownBug} -body { + set data [$strm add -dictionary $spdyDict $spdyHeaders] + zlib push decompress $inSide + fconfigure $outSide -blocking 0 -translation binary + fconfigure $inSide -translation binary -dictionary $spdyDict + puts -nonewline $outSide $data + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From 8f7427729b4a792c9c2461dd4218643694863cf8 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 9 Jun 2012 17:52:05 +0000 Subject: tidy up, fix test --- generic/tclZlib.c | 65 ++++++++++++++++++++++++++++++++----------------------- tests/zlib.test | 8 +++---- 2 files changed, 42 insertions(+), 31 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 544ba50..dc9a895 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -87,6 +87,15 @@ typedef struct { * opportunity. */ /* + * Macros to make it clearer in some of the twiddlier accesses what is + * happening. + */ + +#define IsRawStream(zshPtr) ((zshPtr)->format == TCL_ZLIB_FORMAT_RAW) +#define HaveDictToSet(zshPtr) ((zshPtr)->flags & DICT_TO_SET) +#define DictWasSet(zshPtr) ((zshPtr)->flags |= ~DICT_TO_SET) + +/* * Structure used for stacked channel compression and decompression. */ @@ -640,18 +649,12 @@ Tcl_ZlibStreamInit( e = deflateSetHeader(&zshPtr->stream, &zshPtr->gzHeaderPtr->header); } - if (e == Z_OK && zshPtr->compDictObj) { - e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); - } } else { e = inflateInit2(&zshPtr->stream, wbits); if (e == Z_OK && zshPtr->gzHeaderPtr) { e = inflateGetHeader(&zshPtr->stream, &zshPtr->gzHeaderPtr->header); } - if (format==TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj && e==Z_OK) { - e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); - } } if (e != Z_OK) { @@ -889,14 +892,19 @@ Tcl_ZlibStreamReset( if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED, zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); - if (e == Z_OK && zshPtr->compDictObj) { + if (e == Z_OK && HaveDictToSet(zshPtr)) { e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + } } } else { e = inflateInit2(&zshPtr->stream, zshPtr->wbits); - if (zshPtr->format == TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj - && e == Z_OK) { + if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr) && e == Z_OK) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); + if (e == Z_OK) { + DictWasSet(zshPtr); + } } } @@ -1011,6 +1019,10 @@ Tcl_ZlibStreamSetCompressionDictionary( ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; if (compressionDictionaryObj != NULL) { + if (Tcl_IsShared(compressionDictionaryObj)) { + compressionDictionaryObj = + Tcl_DuplicateObj(compressionDictionaryObj); + } Tcl_IncrRefCount(compressionDictionaryObj); zshPtr->flags |= DICT_TO_SET; } else { @@ -1058,7 +1070,7 @@ Tcl_ZlibStreamPut( zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size); zshPtr->stream.avail_in = size; - if (zshPtr->flags & DICT_TO_SET) { + if (HaveDictToSet(zshPtr)) { e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { if (zshPtr->interp) { @@ -1066,7 +1078,7 @@ Tcl_ZlibStreamPut( } return TCL_ERROR; } - zshPtr->flags &= ~DICT_TO_SET; + DictWasSet(zshPtr); } /* @@ -1243,20 +1255,21 @@ Tcl_ZlibStreamGet( * don't ever issue that.) */ - if (zshPtr->format == TCL_ZLIB_FORMAT_RAW && zshPtr->compDictObj) { + if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + if (zshPtr->interp) { + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + } return TCL_ERROR; } - Tcl_DecrRefCount(zshPtr->compDictObj); - zshPtr->compDictObj = NULL; + DictWasSet(zshPtr); } - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e == Z_NEED_DICT && zshPtr->compDictObj) { + if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e == Z_OK) { + DictWasSet(zshPtr); e = inflate(&zshPtr->stream, zshPtr->flush); } }; @@ -1313,13 +1326,14 @@ Tcl_ZlibStreamGet( * And call inflate again. */ - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e == Z_NEED_DICT && zshPtr->compDictObj) { - e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj); - if (e == Z_OK) { - e = inflate(&zshPtr->stream, zshPtr->flush); + do { + e = inflate(&zshPtr->stream, zshPtr->flush); + if (e != Z_NEED_DICT || !HaveDictToSet(zshPtr)) { + break; } - } + e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj); + DictWasSet(zshPtr); + } while (e == Z_OK); } if (zshPtr->stream.avail_out > 0) { Tcl_SetByteArrayLength(data, @@ -2158,10 +2172,7 @@ ZlibStreamSubcmd( return TCL_ERROR; } if (compDictObj != NULL) { - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zh; - - zshPtr->compDictObj = compDictObj; - Tcl_IncrRefCount(compDictObj); + Tcl_ZlibStreamSetCompressionDictionary(zh, compDictObj); } Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); return TCL_OK; diff --git a/tests/zlib.test b/tests/zlib.test index 5d46926..9058817 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -293,15 +293,15 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] -} -constraints {zlib knownBug} -body { - set data [$strm add -dictionary $spdyDict $spdyHeaders] +} -constraints zlib -body { + $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide fconfigure $outSide -blocking 0 -translation binary fconfigure $inSide -translation binary -dictionary $spdyDict - puts -nonewline $outSide $data + puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] } -cleanup { -- cgit v0.12 From 13c5b8cf121d2e55d4d9e4a34bcc9d8e08d99e65 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 9 Jun 2012 23:15:51 +0000 Subject: more cross-testing of dictionary-powered compression; describe package configuration --- generic/tclZlib.c | 222 +++++++++++++++++++++++++++++++++++++++++++----------- tests/zlib.test | 58 +++++++++++++- 2 files changed, 235 insertions(+), 45 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index dc9a895..5c90c01 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -166,6 +166,7 @@ static Tcl_ObjCmdProc ZlibStreamCmd; static void ConvertError(Tcl_Interp *interp, int code, uLong adler); +static Tcl_Obj * ConvertErrorToList(int code, uLong adler); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); @@ -232,41 +233,130 @@ ConvertError( int code, /* The zlib error code. */ uLong adler) /* The checksum expected (for Z_NEED_DICT) */ { + const char *codeStr, *codeStr2 = NULL; + char codeStrBuf[TCL_INTEGER_SPACE]; + if (interp == NULL) { return; } - if (code == Z_ERRNO) { + switch (code) { + /* + * Firstly, the case that is *different* because it's really coming + * from the OS and is just being reported via zlib. It should be + * really uncommon because Tcl handles all I/O rather than delegating + * it to zlib, but proving it can't happen is hard. + */ + + case Z_ERRNO: Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp),-1)); - } else { - const char *codeStr, *codeStr2 = NULL; - char codeStrBuf[TCL_INTEGER_SPACE]; - - switch (code) { - case Z_STREAM_ERROR: codeStr = "STREAM"; break; - case Z_DATA_ERROR: codeStr = "DATA"; break; - case Z_MEM_ERROR: codeStr = "MEM"; break; - case Z_BUF_ERROR: codeStr = "BUF"; break; - case Z_VERSION_ERROR: codeStr = "VERSION"; break; - case Z_NEED_DICT: - codeStr = "NEED_DICT"; - codeStr2 = codeStrBuf; - sprintf(codeStrBuf, "%lu", adler); - break; - default: - codeStr = "unknown"; - codeStr2 = codeStrBuf; - sprintf(codeStrBuf, "%d", code); - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); + return; + + /* + * Normal errors/conditions, some of which have additional detail and + * some which don't. (This is not defined by array lookup because zlib + * error codes are sometimes negative.) + */ + + case Z_STREAM_ERROR: + codeStr = "STREAM"; + break; + case Z_DATA_ERROR: + codeStr = "DATA"; + break; + case Z_MEM_ERROR: + codeStr = "MEM"; + break; + case Z_BUF_ERROR: + codeStr = "BUF"; + break; + case Z_VERSION_ERROR: + codeStr = "VERSION"; + break; + case Z_NEED_DICT: + codeStr = "NEED_DICT"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%lu", adler); + break; + default: + codeStr = "unknown"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%d", code); + break; + + /* + * Finally, these should _not_ happen! This function is for dealing + * with error cases, not non-errors! + */ + + case Z_OK: + Tcl_Panic("unexpected zlib result in error handler: Z_OK"); + case Z_STREAM_END: + Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); + + /* + * Tricky point! We might pass NULL twice here (and will when the error + * type is known). + */ + + Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); +} + +static Tcl_Obj * +ConvertErrorToList( + int code, /* The zlib error code. */ + uLong adler) /* The checksum expected (for Z_NEED_DICT) */ +{ + Tcl_Obj *objv[4]; + + TclNewLiteralStringObj(objv[0], "TCL"); + TclNewLiteralStringObj(objv[1], "ZLIB"); + switch (code) { + case Z_STREAM_ERROR: + TclNewLiteralStringObj(objv[2], "STREAM"); + return Tcl_NewListObj(3, objv); + case Z_DATA_ERROR: + TclNewLiteralStringObj(objv[2], "DATA"); + return Tcl_NewListObj(3, objv); + case Z_MEM_ERROR: + TclNewLiteralStringObj(objv[2], "MEM"); + return Tcl_NewListObj(3, objv); + case Z_BUF_ERROR: + TclNewLiteralStringObj(objv[2], "BUF"); + return Tcl_NewListObj(3, objv); + case Z_VERSION_ERROR: + TclNewLiteralStringObj(objv[2], "VERSION"); + return Tcl_NewListObj(3, objv); + case Z_ERRNO: + TclNewLiteralStringObj(objv[2], "POSIX"); + objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + return Tcl_NewListObj(4, objv); + case Z_NEED_DICT: + TclNewLiteralStringObj(objv[2], "NEED_DICT"); + objv[3] = Tcl_NewWideIntObj((Tcl_WideInt) adler); + return Tcl_NewListObj(4, objv); + + /* + * These should _not_ happen! This function is for dealing with error + * cases, not non-errors! + */ + + case Z_OK: + Tcl_Panic("unexpected zlib result in error handler: Z_OK"); + case Z_STREAM_END: + Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); /* - * Tricky point! We might pass NULL twice here (and will when the - * error type is known). + * Catch-all. Should be unreachable because all cases are already + * listed above. */ - Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); + default: + TclNewLiteralStringObj(objv[2], "unknown"); + TclNewIntObj(objv[3], code); + return Tcl_NewListObj(4, objv); } } @@ -1832,7 +1922,7 @@ ZlibCmd( } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - Tcl_ZlibAdler32(start, data, dlen))); + (uLong) Tcl_ZlibAdler32(start, data, dlen))); return TCL_OK; case CMD_CRC: /* crc32 str ?startvalue? * -> checksum */ @@ -1849,7 +1939,7 @@ ZlibCmd( } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - Tcl_ZlibCRC32(start, data, dlen))); + (uLong) Tcl_ZlibCRC32(start, data, dlen))); return TCL_OK; case CMD_DEFLATE: /* deflate data ?level? * -> rawCompressedData */ @@ -2637,7 +2727,7 @@ ZlibStreamCmd( return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - Tcl_ZlibStreamChecksum(zstream))); + (uLong) Tcl_ZlibStreamChecksum(zstream))); return TCL_OK; case zs_reset: /* $strm reset */ if (objc != 2) { @@ -2924,6 +3014,7 @@ ZlibTransformOutput( Tcl_DriverOutputProc *outProc = Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent)); int e, produced; + Tcl_Obj *errObj; if (cd->mode == TCL_ZLIB_STREAM_INFLATE) { return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite, @@ -2947,14 +3038,19 @@ ZlibTransformOutput( } } while (e == Z_OK && produced > 0 && cd->outStream.avail_in > 0); - if (e != Z_OK) { - Tcl_SetChannelError(cd->parent, - Tcl_NewStringObj(cd->outStream.msg, -1)); - *errorCodePtr = EINVAL; - return -1; + if (e == Z_OK) { + return toWrite - cd->outStream.avail_in; } - return toWrite - cd->outStream.avail_in; + errObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); + Tcl_ListObjAppendElement(NULL, errObj, + ConvertErrorToList(e, cd->outStream.adler)); + Tcl_ListObjAppendElement(NULL, errObj, + Tcl_NewStringObj(cd->outStream.msg, -1)); + Tcl_SetChannelError(cd->parent, errObj); + *errorCodePtr = EINVAL; + return -1; } /* @@ -2993,12 +3089,19 @@ ZlibTransformSetOption( /* not used */ TclDecrRefCount(cd->compDictObj); } cd->compDictObj = compDictObj; + code = Z_OK; if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { code = SetDeflateDictionary(&cd->outStream, compDictObj); if (code != Z_OK) { ConvertError(interp, code, cd->outStream.adler); return TCL_ERROR; } + } else if (cd->format == TCL_ZLIB_FORMAT_RAW) { + code = SetInflateDictionary(&cd->inStream, compDictObj); + if (code != Z_OK) { + ConvertError(interp, code, cd->inStream.adler); + return TCL_ERROR; + } } return TCL_OK; } @@ -3391,6 +3494,14 @@ ZlibStackChannelTransform( goto error; } } + if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) { + e = SetInflateDictionary(&cd->inStream, cd->compDictObj); + if (e != Z_OK) { + goto error; + } + TclDecrRefCount(cd->compDictObj); + cd->compDictObj = NULL; + } } else { e = deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); @@ -3525,7 +3636,8 @@ ResultGenerate( { #define MAXBUF 1024 unsigned char buf[MAXBUF]; - int e, written; + int e, written,total=0; + Tcl_Obj *errObj; cd->inStream.next_in = (Bytef *) cd->inBuffer; cd->inStream.avail_in = n; @@ -3578,13 +3690,7 @@ ResultGenerate( */ 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_SetChannelError(cd->parent, errObj); - *errorCodePtr = EINVAL; - return TCL_ERROR; + goto handleError; } /* @@ -3595,6 +3701,17 @@ ResultGenerate( return TCL_OK; } } + + handleError: + errObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); + Tcl_ListObjAppendElement(NULL, errObj, + ConvertErrorToList(e, cd->inStream.adler)); + Tcl_ListObjAppendElement(NULL, errObj, + Tcl_NewStringObj(cd->inStream.msg, -1)); + Tcl_SetChannelError(cd->parent, errObj); + *errorCodePtr = EINVAL; + return TCL_ERROR; } /* @@ -3607,6 +3724,8 @@ int TclZlibInit( Tcl_Interp *interp) { + Tcl_Config cfg[2]; + /* * This does two things. It creates a counter used in the creation of * stream commands, and it creates the namespace that will contain those @@ -3620,6 +3739,23 @@ TclZlibInit( */ Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0); + + /* + * Store the underlying configuration information. + * + * TODO: Describe whether we're using the system version of the library or + * a compatibility version built into Tcl? + */ + + cfg[0].key = "zlibVersion"; + cfg[0].value = zlibVersion(); + cfg[1].key = NULL; + Tcl_RegisterConfig(interp, "zlib", cfg, "ascii"); + + /* + * Formally provide the package as a Tcl built-in. + */ + return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); } diff --git a/tests/zlib.test b/tests/zlib.test index 9058817..e63bd84 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -23,6 +23,9 @@ test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body { test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body { zlib ? {} } -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream} +test zlib-1.3 {zlib basics} -constraints zlib -body { + zlib::pkgconfig list +} -result zlibVersion test zlib-2.1 {zlib compress/decompress} zlib { zlib decompress [zlib compress abcdefghijklm] @@ -252,14 +255,15 @@ test zlib-8.9 {transformtion and fconfigure} -setup { fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders + set result [fconfigure $outSide -checksum] chan pop $outSide $strm put -dictionary $spdyDict [read $inSide] - list [string length $spdyHeaders] [string length [$strm get]] + lappend result [string length $spdyHeaders] [string length [$strm get]] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} -} -result {358 358} +} -result {3064818174 358 358} test zlib-8.10 {transformtion and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { @@ -303,6 +307,56 @@ test zlib-8.12 {transformtion and fconfigure} -setup { fconfigure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] \ + [fconfigure $inSide -checksum] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358 3064818174} +test zlib-8.13 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream compress] +} -constraints zlib -body { + $strm put -dictionary $spdyDict -finalize $spdyHeaders + zlib push decompress $inSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary + fconfigure $inSide -translation binary + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] \ + [fconfigure $inSide -checksum] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358 3064818174} +test zlib-8.14 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream deflate] +} -constraints zlib -body { + $strm put -finalize -dictionary $spdyDict $spdyHeaders + zlib push inflate $inSide + fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $inSide -translation binary -dictionary $spdyDict + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358} +test zlib-8.15 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream deflate] +} -constraints zlib -body { + $strm put -finalize -dictionary $spdyDict $spdyHeaders + zlib push inflate $inSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $inSide -translation binary + puts -nonewline $outSide [$strm get] + close $outSide list [string length $spdyHeaders] [string length [read $inSide]] } -cleanup { catch {close $outSide} -- cgit v0.12 From d893a31f9f960d1906332988842de1b8bd0c4f5c Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 11 Jun 2012 00:07:52 +0000 Subject: verify zlib package presence and version --- tests/zlib.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/zlib.test b/tests/zlib.test index e63bd84..5f1e5fc 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -26,6 +26,9 @@ test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body { test zlib-1.3 {zlib basics} -constraints zlib -body { zlib::pkgconfig list } -result zlibVersion +test zlib-1.4 {zlib basics} -constraints zlib -body { + package present zlib +} -result 2.0 test zlib-2.1 {zlib compress/decompress} zlib { zlib decompress [zlib compress abcdefghijklm] -- cgit v0.12 From 923c6db1585b8fb8e69b0733b11a12f3149adf2d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 11 Jun 2012 09:34:02 +0000 Subject: new attempt, with only those parts of frq-3527238 which don't introduce new command options, so don't require a TIP --- win/tclWinDde.c | 45 ++++++++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/win/tclWinDde.c b/win/tclWinDde.c index e40e114..1e485f9 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1432,15 +1432,15 @@ DdeObjCmd( case DDE_EXECUTE: { int dataLength; - const char *dataString; + const Tcl_UniChar *dataString; if (flags & DDE_FLAG_BINARY) { - dataString = (const char *) + dataString = (const Tcl_UniChar *) Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); } else { dataString = - Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); - dataLength += 1; + Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength); + dataLength = (dataLength + 1) * sizeof(Tcl_UniChar); } if (dataLength <= 0) { @@ -1461,15 +1461,15 @@ DdeObjCmd( } ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString, - (DWORD) dataLength, 0, 0, CF_TEXT, 0); + (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0); if (ddeData != NULL) { if (flags & DDE_FLAG_ASYNC) { DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, - hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL); + hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeReturn == 0) { SetDdeError(interp); result = TCL_ERROR; @@ -1506,22 +1506,23 @@ DdeObjCmd( CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, - CF_TEXT, XTYP_REQUEST, 5000, NULL); + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { DWORD tmp; - const char *dataString = (const char *) DdeAccessData(ddeData, &tmp); + const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); } else { - if (tmp && !dataString[tmp-1]) { + tmp >>= 1; + if (tmp && !dataString[(tmp-1)]) { --tmp; } - returnObjPtr = Tcl_NewStringObj(dataString, + returnObjPtr = Tcl_NewUnicodeObj(dataString, (int) tmp); } DdeUnaccessData(ddeData); @@ -1569,7 +1570,7 @@ DdeObjCmd( CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(dataString, (DWORD) length, - hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL); + hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; @@ -1712,24 +1713,24 @@ DdeObjCmd( } objPtr = Tcl_ConcatObj(objc, objv); - string = Tcl_GetStringFromObj(objPtr, &length); + string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length); ddeItemData = DdeCreateDataHandle(ddeInstance, - (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0); + (BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 0); if (flags & DDE_FLAG_ASYNC) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, 30000, NULL); + CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { ddeCookie = DdeCreateStringHandle(ddeInstance, TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, - CF_TEXT, XTYP_REQUEST, 30000, NULL); + CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); } } @@ -1743,6 +1744,7 @@ DdeObjCmd( if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; + Tcl_UniChar *ddeDataString; /* * The return handle has a two or four element list in it. The @@ -1755,10 +1757,11 @@ DdeObjCmd( resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); - Tcl_SetObjLength(resultPtr, (length + 1) * sizeof(TCHAR) - 1); - string = Tcl_GetString(resultPtr); - DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0); - Tcl_SetObjLength(resultPtr, (int) strlen(string)); + ddeDataString = ckalloc(length); + DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); + length = (length >> 1) - 1; + resultPtr = Tcl_NewUnicodeObj(ddeDataString, length); + ckfree(ddeDataString); if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); -- cgit v0.12 From eb3f8d5d55d1b0f7f274cd344bf5f53534ab5e61 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Jun 2012 07:51:38 +0000 Subject: Start to split apart the stream command implementation for easier maintenance. --- generic/tclZlib.c | 418 +++++++++++++++++++++++++++++++----------------------- 1 file changed, 238 insertions(+), 180 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 5c90c01..a7c4453 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -163,6 +163,9 @@ static Tcl_DriverSetOptionProc ZlibTransformSetOption; static Tcl_DriverWatchProc ZlibTransformWatch; static Tcl_ObjCmdProc ZlibCmd; static Tcl_ObjCmdProc ZlibStreamCmd; +static Tcl_ObjCmdProc ZlibStreamAddCmd; +static Tcl_ObjCmdProc ZlibStreamHeaderCmd; +static Tcl_ObjCmdProc ZlibStreamPutCmd; static void ConvertError(Tcl_Interp *interp, int code, uLong adler); @@ -2464,8 +2467,8 @@ ZlibStreamCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = cd; - int command, index, count, code, buffersize = -1, flush = -1, i; - Tcl_Obj *obj, *compDictObj = NULL; + int command, count, code; + Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", "fullflush", "get", "header", "put", "reset", @@ -2475,12 +2478,6 @@ ZlibStreamCmd( zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, zs_fullflush, zs_get, zs_header, zs_put, zs_reset }; - static const char *const add_options[] = { - "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL - }; - enum addOptions { - ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush - }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option data ?...?"); @@ -2494,163 +2491,11 @@ ZlibStreamCmd( switch ((enum zlibStreamCommands) command) { case zs_add: /* $strm add ?$flushopt? $data */ - for (i=2; i -1) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case ao_fullflush: /* -fullflush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case ao_finalize: /* -finalize */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case ao_buffer: /* -buffer */ - if (i == objc-2) { - Tcl_AppendResult(interp, "\"-buffer\" option must be " - "followed by integer decompression buffersize", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[++i], - &buffersize) != TCL_OK) { - return TCL_ERROR; - } - if (buffersize < 1 || buffersize > 65536) { - Tcl_AppendResult(interp, - "buffer size must be 32 to 65536", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", - NULL); - return TCL_ERROR; - } - break; - case ao_dictionary: - if (i == objc-2) { - Tcl_AppendResult(interp, "\"-dictionary\" option must be " - "followed by compression dictionary bytes", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - compDictObj = objv[++i]; - break; - } - - if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - - if (compDictObj != NULL) { - int len; - - (void) Tcl_GetByteArrayFromObj(compDictObj, &len); - if (len == 0) { - compDictObj = NULL; - } - Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); - } - if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { - return TCL_ERROR; - } - TclNewObj(obj); - code = Tcl_ZlibStreamGet(zstream, obj, buffersize); - if (code == TCL_OK) { - Tcl_SetObjResult(interp, obj); - } else { - TclDecrRefCount(obj); - } - return code; - + return ZlibStreamAddCmd(zstream, interp, objc, objv); + case zs_header: /* $strm header */ + return ZlibStreamHeaderCmd(zstream, interp, objc, objv); case zs_put: /* $strm put ?$flushopt? $data */ - for (i=2; i -1) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case ao_fullflush: /* -fullflush */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case ao_finalize: /* -finalize */ - if (flush > -1) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case ao_buffer: - Tcl_AppendResult(interp, - "\"-buffer\" option not supported here", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); - return TCL_ERROR; - case ao_dictionary: - if (i == objc-2) { - Tcl_AppendResult(interp, "\"-dictionary\" option must be " - "followed by compression dictionary bytes", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - compDictObj = objv[++i]; - break; - } - if (flush == -2) { - Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " - "\"-finalize\" options are mutually exclusive", NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - if (compDictObj != NULL) { - int len; - - (void) Tcl_GetByteArrayFromObj(compDictObj, &len); - if (len == 0) { - compDictObj = NULL; - } - Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); - } - return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); + return ZlibStreamPutCmd(zstream, interp, objc, objv); case zs_get: /* $strm get ?count? */ if (objc > 3) { @@ -2735,29 +2580,242 @@ ZlibStreamCmd( return TCL_ERROR; } return Tcl_ZlibStreamReset(zstream); - case zs_header: { /* $strm header */ - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zstream; - Tcl_Obj *resultObj; + } - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_OK; +} + +static int +ZlibStreamAddCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_ZlibStream zstream = cd; + int index, code, buffersize = -1, flush = -1, i; + Tcl_Obj *obj, *compDictObj = NULL; + static const char *const add_options[] = { + "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL + }; + enum addOptions { + ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush + }; + + for (i=2; imode != TCL_ZLIB_STREAM_INFLATE - || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) { - Tcl_AppendResult(interp, - "only gunzip streams can produce header information", - NULL); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); + } + + switch ((enum addOptions) index) { + case ao_flush: /* -flush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_SYNC_FLUSH; + } + break; + case ao_fullflush: /* -fullflush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FULL_FLUSH; + } + break; + case ao_finalize: /* -finalize */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FINISH; + } + break; + case ao_buffer: /* -buffer */ + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-buffer\" option must be " + "followed by integer decompression buffersize", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) { + return TCL_ERROR; + } + if (buffersize < 1 || buffersize > 65536) { + Tcl_AppendResult(interp, "buffer size must be 32 to 65536", + NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + return TCL_ERROR; + } + break; + case ao_dictionary: + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-dictionary\" option must be " + "followed by compression dictionary bytes", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; + } + + if (flush == -2) { + Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " + "\"-finalize\" options are mutually exclusive", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); return TCL_ERROR; } + } + if (flush == -1) { + flush = 0; + } - TclNewObj(resultObj); - ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; + /* + * Set the compression dictionary if requested. + */ + + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } + + /* + * Send the data to the stream core, along with any flushing directive. + */ + + if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get such data out as we can (up to the requested length). + */ + + TclNewObj(obj); + code = Tcl_ZlibStreamGet(zstream, obj, buffersize); + if (code == TCL_OK) { + Tcl_SetObjResult(interp, obj); + } else { + TclDecrRefCount(obj); } + return code; +} + +static int +ZlibStreamPutCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_ZlibStream zstream = cd; + int index, flush = -1, i; + Tcl_Obj *compDictObj = NULL; + static const char *const put_options[] = { + "-dictionary", "-finalize", "-flush", "-fullflush", NULL + }; + enum putOptions { + po_dictionary, po_finalize, po_flush, po_fullflush + }; + + for (i=2; i -1) { + flush = -2; + } else { + flush = Z_SYNC_FLUSH; + } + break; + case po_fullflush: /* -fullflush */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FULL_FLUSH; + } + break; + case po_finalize: /* -finalize */ + if (flush > -1) { + flush = -2; + } else { + flush = Z_FINISH; + } + break; + case po_dictionary: + if (i == objc-2) { + Tcl_AppendResult(interp, "\"-dictionary\" option must be " + "followed by compression dictionary bytes", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + return TCL_ERROR; + } + compDictObj = objv[++i]; + break; + } + if (flush == -2) { + Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and " + "\"-finalize\" options are mutually exclusive", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); + return TCL_ERROR; + } + } + if (flush == -1) { + flush = 0; + } + + /* + * Set the compression dictionary if requested. + */ + + if (compDictObj != NULL) { + int len; + + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); + if (len == 0) { + compDictObj = NULL; + } + Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); + } + + /* + * Send the data to the stream core, along with any flushing directive. + */ + + return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); +} + +static int +ZlibStreamHeaderCmd( + ClientData cd, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + ZlibStreamHandle *zshPtr = cd; + Tcl_Obj *resultObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE + || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) { + Tcl_AppendResult(interp, + "only gunzip streams can produce header information", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); + return TCL_ERROR; } + TclNewObj(resultObj); + ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj); + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -3636,7 +3694,7 @@ ResultGenerate( { #define MAXBUF 1024 unsigned char buf[MAXBUF]; - int e, written,total=0; + int e, written; Tcl_Obj *errObj; cd->inStream.next_in = (Bytef *) cd->inBuffer; -- cgit v0.12 From 397b74eec937a0848cd4c55dc47a7a35c9cdae68 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Jun 2012 07:52:24 +0000 Subject: Documenting the stream command options better. --- doc/zlib.n | 39 +++++++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index ec3ea5a..2edd62f 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -222,39 +222,54 @@ command works, see \fBSTREAMING INSTANCE COMMAND\fR below. The following modes are supported: .RS .TP -\fBzlib stream compress\fR ?\fIlevel\fR? +\fBzlib stream compress\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces zlib-format output, using compression level \fIlevel\fR (if specified) which will be an integer -from 0 to 9. +from 0 to 9, +.VS +and the compression dictionary \fIbindata\fR (if specified). +.VE .TP -\fBzlib stream decompress\fR +\fBzlib stream decompress\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes zlib-format input and produces uncompressed output. +.VS +If \fIbindata\fR is supplied, it is a compression dictionary to use if +required. +.VE .TP -\fBzlib stream deflate\fR ?\fIlevel\fR? +\fBzlib stream deflate\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces raw output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 -to 9. +to 9, +.VS +and the compression dictionary \fIbindata\fR (if specified). Note that +the raw compressed data includes no metadata about what compression +dictionary was used, if any; that is a feature of the zlib-format data. +.VE .TP -\fBzlib stream gunzip\fR +\fBzlib stream gunzip\fR ?\fIlevel\fR? . The stream will be a decompressing stream that takes gzip-format input and produces uncompressed output. .TP -\fBzlib stream gzip\fR ?\fIlevel\fR? +\fBzlib stream gzip\fR ?\fB\-header \fIheader\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces gzip-format output, using compression level \fIlevel\fR (if specified) which will be an integer -from 0 to 9. +from 0 to 9, and the header descriptor dictionary \fIheader\fR (if specified; +for keys see \fBzlib gzip\fR). '\" TODO: Header dictionary! .TP -\fBzlib stream inflate\fR +\fBzlib stream inflate\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes raw compressed input and -produces uncompressed output. +produces uncompressed output. If \fIbindata\fR is supplied, it is a +compression dictionary to use. Note that there are no checks in place +to determine whether the compression dictionary is correct. .RE .SS "CHECKSUMMING SUBCOMMANDS" .TP @@ -333,10 +348,6 @@ supported (or an unambiguous prefix of them), which are used to modify the way in which the transformation is applied: .RS .TP -\fB\-buffer\fI bufferSize\fR -. -\fITODO: document this\fR -.TP \fB\-dictionary\fI compressionDictionary\fR .VS "TIP 400" Sets a compression dictionary to use when working with compressing or -- cgit v0.12 From 4eb006ef70aa3737a687697eb03ba83b080e1a1a Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Jun 2012 15:15:36 +0000 Subject: add configurability of readahead limit --- doc/zlib.n | 41 ++++++++++++-------- generic/tclZlib.c | 113 +++++++++++++++++++++++++++++++++++------------------- 2 files changed, 99 insertions(+), 55 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index a78e8e3..0233ba8 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -179,15 +179,24 @@ Passes a description of the gzip header to create, in the same format that . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). -'\".TP -'\"\fB\-limit\fI readaheadLimit\fR -'\". -'\"The maximum number of bytes ahead to read. -'\"\fITODO: not yet implemented!\fR +.TP +\fB\-limit\fI readaheadLimit\fR +. +The maximum number of bytes ahead to read when decompressing. This defaults to +1, which ensures that data is always decompressed correctly, but may be +increased to improve performance. This is more useful when the channel is +non-blocking. .PP Both compressing and decompressing channel transformations add extra -configuration options that may be accessed through \fBchan configure\fR. Each -option is either a read-only or a write-only option. The options are: +configuration options that may be accessed through \fBchan configure\fR. The +options are: +.TP +\fB\-checksum\fI checksum\fR +. +This read-only option gets the current checksum for the uncompressed data that +the compression engine has seen so far. It is valid for both compressing and +decompressing transforms, but not for the raw inflate and deflate formats. The +compression algorithm depends on what format is being produced or consumed. .TP \fB\-flush\fI type\fR . @@ -198,19 +207,19 @@ expensive flush respectively. Flushing degrades the compression ratio, but makes it easier for a decompressor to recover more of the file in the case of data corruption. .TP -\fB\-checksum\fR -. -This read-only option gets the current checksum for the uncompressed data -that the compression engine has seen so far. It is valid for both -compressing and decompressing transforms, but not for the raw inflate -and deflate formats. The compression algorithm depends on what -format is being produced or consumed. -.TP -\fB\-header\fR +\fB\-header\fI dictionary\fR . This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. +.TP +\fB\-limit\fI readaheadLimit\fR +. +This read-write option is used by decompressing channels to control the +maximum number of bytes ahead to read from the underlying data source. This +defaults to 1, which ensures that data is always decompressed correctly, but +may be increased to improve performance. This is more useful when the channel +is non-blocking. .RE .SS "STREAMING SUBCOMMAND" .TP diff --git a/generic/tclZlib.c b/generic/tclZlib.c index a7c4453..c96594d 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -110,6 +110,8 @@ typedef struct { int format; /* What format of data is going on the wire. * Needed so that the correct [fconfigure] * options can be enabled. */ + int readAheadLimit; /* The maximum number of bytes to read from + * the underlying stream in one go. */ z_stream inStream; /* Structure used by zlib for decompression of * input. */ z_stream outStream; /* Structure used by zlib for compression of @@ -2958,7 +2960,7 @@ ZlibTransformInput( * reading over the border. */ - readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1); + readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); /* * Three cases here: @@ -3131,8 +3133,10 @@ ZlibTransformSetOption( /* not used */ ZlibChannelData *cd = instanceData; Tcl_DriverSetOptionProc *setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "dictionary flush"; + static const char *compressChanOptions = "dictionary flush"; static const char *gzipChanOptions = "flush"; + static const char *decompressChanOptions = "dictionary limit"; + static const char *gunzipChanOptions = "flush limit"; int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE); if (optionName && (strcmp(optionName, "-dictionary") == 0) @@ -3164,56 +3168,75 @@ ZlibTransformSetOption( /* not used */ return TCL_OK; } - if (haveFlushOpt && optionName && strcmp(optionName, "-flush") == 0) { - int flushType; + if (haveFlushOpt) { + if (optionName && strcmp(optionName, "-flush") == 0) { + int flushType; - if (value[0] == 'f' && strcmp(value, "full") == 0) { - flushType = Z_FULL_FLUSH; - } else if (value[0] == 's' && strcmp(value, "sync") == 0) { - flushType = Z_SYNC_FLUSH; - } else { - Tcl_AppendResult(interp, "unknown -flush type \"", value, - "\": must be full or sync", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); - return TCL_ERROR; - } + if (value[0] == 'f' && strcmp(value, "full") == 0) { + flushType = Z_FULL_FLUSH; + } else if (value[0] == 's' && strcmp(value, "sync") == 0) { + flushType = Z_SYNC_FLUSH; + } else { + Tcl_AppendResult(interp, "unknown -flush type \"", value, + "\": must be full or sync", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); + return TCL_ERROR; + } - /* - * Try to actually do the flush now. - */ + /* + * Try to actually do the flush now. + */ - cd->outStream.avail_in = 0; - while (1) { - int e; + cd->outStream.avail_in = 0; + while (1) { + int e; - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = cd->outAllocated; + cd->outStream.next_out = (Bytef *) cd->outBuffer; + cd->outStream.avail_out = cd->outAllocated; - e = deflate(&cd->outStream, flushType); - if (e == Z_BUF_ERROR) { - break; - } else if (e != Z_OK) { - ConvertError(interp, e, cd->outStream.adler); - return TCL_ERROR; - } else if (cd->outStream.avail_out == 0) { - break; + e = deflate(&cd->outStream, flushType); + if (e == Z_BUF_ERROR) { + break; + } else if (e != Z_OK) { + ConvertError(interp, e, cd->outStream.adler); + return TCL_ERROR; + } else if (cd->outStream.avail_out == 0) { + break; + } + + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, + cd->outStream.next_out - (Bytef *) cd->outBuffer)<0) { + Tcl_AppendResult(interp, "problem flushing channel: ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } } + return TCL_OK; + } + } else { + if (optionName && strcmp(optionName, "-limit") == 0) { + int newLimit; - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, - cd->outStream.next_out - (Bytef *) cd->outBuffer) < 0) { - Tcl_AppendResult(interp, "problem flushing channel: ", - Tcl_PosixError(interp), NULL); + if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) { + return TCL_ERROR; + } else if (newLimit < 1 || newLimit > 65535) { + Tcl_AppendResult(interp, "-limit must be between 1 and 65535", + NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL); return TCL_ERROR; } } - return TCL_OK; } if (setOptionProc == NULL) { if (cd->format == TCL_ZLIB_FORMAT_GZIP) { - return Tcl_BadChannelOption(interp, optionName, gzipChanOptions); + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? gzipChanOptions : gunzipChanOptions); } else { - return Tcl_BadChannelOption(interp, optionName, chanOptions); + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? compressChanOptions : decompressChanOptions); } } @@ -3246,7 +3269,10 @@ ZlibTransformGetOption( ZlibChannelData *cd = instanceData; Tcl_DriverGetOptionProc *getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent)); - static const char *chanOptions = "checksum dictionary header"; + static const char *compressChanOptions = "checksum dictionary"; + static const char *gzipChanOptions = "checksum"; + static const char *decompressChanOptions = "checksum dictionary limit"; + static const char *gunzipChanOptions = "checksum header limit"; /* * The "crc" option reports the current CRC (calculated with the Adler32 @@ -3331,7 +3357,15 @@ ZlibTransformGetOption( if (optionName == NULL) { return TCL_OK; } - return Tcl_BadChannelOption(interp, optionName, chanOptions); + if (cd->format == TCL_ZLIB_FORMAT_GZIP) { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? gzipChanOptions : gunzipChanOptions); + } else { + return Tcl_BadChannelOption(interp, optionName, + (cd->mode == TCL_ZLIB_STREAM_DEFLATE) + ? compressChanOptions : decompressChanOptions); + } } /* @@ -3496,6 +3530,7 @@ ZlibStackChannelTransform( memset(cd, 0, sizeof(ZlibChannelData)); cd->mode = mode; cd->format = format; + cd->readAheadLimit = 1; if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) { if (mode == TCL_ZLIB_STREAM_DEFLATE) { -- cgit v0.12 From 470dc679b3ef5fad8fa57ec1e90b9f13b676c229 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Jul 2012 17:09:44 +0000 Subject: Release candidate branch for Tcl 8.6b3. --- README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- tools/tcl.wse.in | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 9 files changed, 10 insertions(+), 10 deletions(-) diff --git a/README b/README index 0442a0e..56f7e38 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6b2 source distribution. + This is the Tcl 8.6b3 source distribution. http://tcl.sourceforge.net/ You can get any source release of Tcl from the file distributions link at the above URL. diff --git a/generic/tcl.h b/generic/tcl.h index 729e521..32d8e1e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -58,10 +58,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_BETA_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 3 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6b2" +#define TCL_PATCH_LEVEL "8.6b3" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index d8de540..e4b14d2 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -15,7 +15,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6b2 +package require -exact Tcl 8.6b3 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index 653b1e1..77beb41 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -12,7 +12,7 @@ item: Global Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 - Disk Label=tcl8.6b2 + Disk Label=tcl8.6b3 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 diff --git a/unix/configure b/unix/configure index 2e36ad2..0b8bc82 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL="b2" +TCL_PATCH_LEVEL="b3" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 79a546d..beff4a3 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL="b2" +TCL_PATCH_LEVEL="b3" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index b35e220..0c42aa4 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6b2 +Version: 8.6b3 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index fed0959..04a5e90 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL="b2" +TCL_PATCH_LEVEL="b3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index 2377938..ae91a0a 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL="b2" +TCL_PATCH_LEVEL="b3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From ff0e2463cb108f9b0481ac516251142506818114 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 12 Jul 2012 10:54:48 +0000 Subject: Update TclOO package to 0.7, correct copyright dates. --- generic/tclOO.c | 2 +- generic/tclOO.h | 5 +++-- generic/tclOOBasic.c | 2 +- generic/tclOOCall.c | 2 +- generic/tclOODefineCmds.c | 2 +- generic/tclOOInfo.c | 2 +- generic/tclOOInt.h | 2 +- generic/tclOOMethod.c | 2 +- tests/oo.test | 4 ++-- tests/ooNext2.test | 10 ++++------ unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 12 files changed, 18 insertions(+), 19 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 821befd..47544f2 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -3,7 +3,7 @@ * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOO.h b/generic/tclOO.h index fef2bd0..280481c 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -4,7 +4,7 @@ * This file contains the public API definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2010 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -34,11 +34,12 @@ extern const char *TclOOInitializeStubs( * version in the files: * * tests/oo.test + * tests/ooNext2.test * unix/tclooConfig.sh * win/tclooConfig.sh */ -#define TCLOO_VERSION "0.6.3" +#define TCLOO_VERSION "0.7" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 35ad1eb..fb1ebc2 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 760bd7b..a79e4fa 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -4,7 +4,7 @@ * This file contains the method call chain management code for the * object-system core. * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 69cffb0..b95681c 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index f298320..c27a1cc 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo-related [info] * subcommands. * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 631961f..ab54964 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -4,7 +4,7 @@ * This file contains the structure definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2011 by Donal K. Fellows + * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 877c3db..f735853 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -3,7 +3,7 @@ * * This file contains code to create and manage methods. * - * Copyright (c) 2005-2008 by Donal K. Fellows + * Copyright (c) 2005-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/oo.test b/tests/oo.test index 00663e9..540cdf3 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,12 +2,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2011 Donal K. Fellows +# Copyright (c) 2006-2012 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require -exact TclOO 0.6.3 ;# Must match value in generic/tclOO.h +package require -exact TclOO 0.7 ;# Must match value in generic/tclOO.h package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index eeade11..e78e0d0 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -2,16 +2,14 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2008 Donal K. Fellows +# Copyright (c) 2006-2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: oo.test,v 1.59 2011/01/18 16:10:48 dkf Exp $ -package require -exact TclOO 0.6.3 ;# Must match value in configure.in -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +package require -exact TclOO 0.7 ;# Must match value in configure.in +package require tcltest 2 +if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 68de106..dce540a 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS=-DUSE_TCLOO_STUBS -TCLOO_VERSION=0.6.3 +TCLOO_VERSION=0.7 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 68de106..dce540a 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS=-DUSE_TCLOO_STUBS -TCLOO_VERSION=0.6.3 +TCLOO_VERSION=0.7 -- cgit v0.12 From b368bda168f6c601da96e6caa9b6d7bc8ba98fc5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 16 Jul 2012 08:36:20 +0000 Subject: make dde 1.4 loadlable when ::tcl::pkgconfig is available --- library/dde/pkgIndex.tcl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index fef4f24..4cf73d0 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,5 +1,5 @@ -if {![package vsatisfies [package provide Tcl] 8.5]} return -if {[info sharedlibextension] ne ".dll"} return +if {([info commands ::tcl::pkgconfig] eq "") + || ([info sharedlibextension] ne ".dll")} return if {[::tcl::pkgconfig get debug]} { package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde] } else { -- cgit v0.12 From ff601c88100652c703080ff83ba89801e0ea0aba Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 16 Jul 2012 20:31:44 +0000 Subject: [Bug 3496014]: Unecessary memset() in Tcl_SetByteArrayObj() --- generic/tclBinary.c | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 444e7fa..ae8172f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -307,12 +307,8 @@ Tcl_SetByteArrayObj( byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if (length) { - if (bytes) { - memcpy(byteArrayPtr->bytes, bytes, (size_t) length); - } else { - memset(byteArrayPtr->bytes, 0, (size_t) length); - } + if (length && bytes) { + memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } objPtr->typePtr = &tclByteArrayType; -- cgit v0.12 From e47ba9f0c364c577be35a2cc155d90078742a2d7 Mon Sep 17 00:00:00 2001 From: max Date: Thu, 19 Jul 2012 10:54:13 +0000 Subject: [Bug: 3545363]: Use a large enough buffer for accept()ing IPv6 connections. Fix conversion of host and port for passing to the accept proc to be independent of the IP version. --- ChangeLog | 7 +++++++ win/tclWinSock.c | 11 +++++++---- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 427b3e4..b726d9c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2012-07-19 Reinhard Max + + * win/tclWinSock.c (TcpAccept): [Bug: 3545363]: Use a large enough + buffer for accept()ing IPv6 connections. Fix conversion of host + and port for passing to the accept proc to be independent of the + IP version. + 2012-07-17 Jan Nijtmans * win/makefile.vc: [Bug 3544932]: Visual studio compiler check fails diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 97b10a3..5603ef3 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1556,18 +1556,19 @@ TcpAccept( SOCKET newSocket; SocketInfo *newInfoPtr; SocketInfo *infoPtr = fds->infoPtr; - SOCKADDR_IN addr; + address addr; int len; char channelName[16 + TCL_INTEGER_SPACE]; + char host[NI_MAXHOST], port[NI_MAXSERV]; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); /* * Accept the incoming connection request. */ - len = sizeof(SOCKADDR_IN); + len = sizeof(address); - newSocket = accept(fds->fd, (SOCKADDR *) &addr, &len); + newSocket = accept(fds->fd, &(addr.sa), &len); /* * Protect access to sockets (acceptEventCount, readyEvents) in socketList @@ -1644,8 +1645,10 @@ TcpAccept( */ if (infoPtr->acceptProc != NULL) { + getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel, - inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); + host, atoi(port)); } } -- cgit v0.12 From e574cc448ea3a74b469753686dbe9e2c5ac90037 Mon Sep 17 00:00:00 2001 From: twylite Date: Tue, 24 Jul 2012 13:58:44 +0000 Subject: [Bug: 3545363]: Handle socket with multiple underlying file descriptors where required (TcpCloseProc, SocketProc). Refactor socket/descriptor setup. Fix memory leak in socket close (TcpCloseProc) and related dangling pointers in SocketEventProc. --- win/tclWinSock.c | 307 +++++++++++++++++++++++++++++++++---------------------- 1 file changed, 187 insertions(+), 120 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 5603ef3..c651deb 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -220,7 +220,7 @@ static void SocketExitHandler(ClientData clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); -static void TcpAccept(TcpFdList *fds); +static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForSocketEvent(SocketInfo *infoPtr, int events, int *errorCodePtr); static DWORD WINAPI SocketThread(LPVOID arg); @@ -692,6 +692,9 @@ SocketEventProc( int mask = 0, events; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); TcpFdList *fds; + SOCKET newSocket; + address addr; + int len; if (!(flags & TCL_FILE_EVENTS)) { return 0; @@ -708,13 +711,13 @@ SocketEventProc( break; } } - SetEvent(tsdPtr->socketListLock); /* * Discard events that have gone stale. */ if (!infoPtr) { + SetEvent(tsdPtr->socketListLock); return 1; } @@ -726,11 +729,65 @@ SocketEventProc( if (infoPtr->readyEvents & FD_ACCEPT) { for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { - TcpAccept(fds); + + /* + * Accept the incoming connection request. + */ + len = sizeof(address); + + newSocket = accept(fds->fd, &(addr.sa), &len); + + /* On Tcl server sockets with multiple OS fds we loop over the fds trying + * an accept() on each, so we expect INVALID_SOCKET. There are also other + * network stack conditions that can result in FD_ACCEPT but a subsequent + * failure on accept() by the time we get around to it. + * Access to sockets (acceptEventCount, readyEvents) in socketList + * is still protected by the lock (prevents reintroduction of + * SF Tcl Bug 3056775. + */ + + if (newSocket == INVALID_SOCKET) { + /* int err = WSAGetLastError(); */ + continue; + } + + /* + * It is possible that more than one FD_ACCEPT has been sent, so an extra + * count must be kept. Decrement the count, and reset the readyEvent bit + * if the count is no longer > 0. + */ + infoPtr->acceptEventCount--; + + if (infoPtr->acceptEventCount <= 0) { + infoPtr->readyEvents &= ~(FD_ACCEPT); + } + + SetEvent(tsdPtr->socketListLock); + + /* Caution: TcpAccept() has the side-effect of evaluating the server + * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can + * close the server socket and invalidate infoPtr and fds. + * If TcpAccept() accepts a socket we must return immediately and let + * SocketCheckProc queue additional FD_ACCEPT events. + */ + TcpAccept(fds, newSocket, addr); + return 1; } + + /* Loop terminated with no sockets accepted; clear the ready mask so + * we can detect the next connection request. Note that connection + * requests are level triggered, so if there is a request already + * pending, a new event will be generated. + */ + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_ACCEPT); + + SetEvent(tsdPtr->socketListLock); return 1; } + SetEvent(tsdPtr->socketListLock); + /* * Mask off unwanted events and compute the read/write mask so we can * notify the channel. @@ -872,9 +929,15 @@ TcpCloseProc( * background. */ - if (closesocket(infoPtr->sockets->fd) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); + while ( infoPtr->sockets != NULL ) { + TcpFdList *thisfd = infoPtr->sockets; + infoPtr->sockets = thisfd->next; + + if (closesocket(thisfd->fd) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } + ckfree(thisfd); } } @@ -934,6 +997,8 @@ TcpClose2Proc( return TCL_ERROR; } + /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or + * TCL_WRITABLE so this should never be called for a server socket. */ if (shutdown(infoPtr->sockets->fd, sd) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); errorCode = Tcl_GetErrno(); @@ -945,6 +1010,51 @@ TcpClose2Proc( /* *---------------------------------------------------------------------- * + * AddSocketInfoFd -- + * + * This function adds a SOCKET file descriptor to the 'sockets' linked + * list of a SocketInfo structure. + * + * Results: + * None. + * + * Side effects: + * None, except for allocation of memory. + * + *---------------------------------------------------------------------- + */ + +static void +AddSocketInfoFd( + SocketInfo *infoPtr, + SOCKET socket) +{ + TcpFdList *fds = infoPtr->sockets; + + if ( fds == NULL ) { + /* Add the first FD */ + infoPtr->sockets = ckalloc(sizeof(TcpFdList)); + fds = infoPtr->sockets; + } else { + /* Find end of list and append FD */ + while ( fds->next != NULL ) { + fds = fds->next; + } + + fds->next = ckalloc(sizeof(TcpFdList)); + fds = fds->next; + } + + /* Populate new FD */ + fds->fd = socket; + fds->infoPtr = infoPtr; + fds->next = NULL; +} + + +/* + *---------------------------------------------------------------------- + * * NewSocketInfo -- * * This function allocates and initializes a new SocketInfo structure. @@ -963,14 +1073,10 @@ NewSocketInfo( SOCKET socket) { SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo)); - TcpFdList *fds = ckalloc(sizeof(TcpFdList)); - fds->fd = socket; - fds->next = NULL; - fds->infoPtr = infoPtr; /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ infoPtr->channel = 0; - infoPtr->sockets = fds; + infoPtr->sockets = NULL; infoPtr->flags = 0; infoPtr->watchEvents = 0; infoPtr->readyEvents = 0; @@ -988,6 +1094,8 @@ NewSocketInfo( infoPtr->nextPtr = NULL; + AddSocketInfoFd(infoPtr, socket); + return infoPtr; } @@ -1057,7 +1165,6 @@ CreateSocket( } if (server) { - TcpFdList *fds = NULL, *newfds; for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { sock = socket(addrPtr->ai_family, SOCK_STREAM, 0); @@ -1140,7 +1247,6 @@ CreateSocket( */ infoPtr = NewSocketInfo(sock); - fds = infoPtr->sockets; /* * Set up the select mask for connection request events. @@ -1150,13 +1256,7 @@ CreateSocket( infoPtr->watchEvents |= FD_ACCEPT; } else { - newfds = ckalloc(sizeof(TcpFdList)); - memset(newfds, (int) 0, sizeof(TcpFdList)); - newfds->fd = sock; - newfds->infoPtr = infoPtr; - newfds->next = NULL; - fds->next = newfds; - fds = newfds; + AddSocketInfoFd( infoPtr, sock ); } } } else { @@ -1537,8 +1637,9 @@ Tcl_OpenTcpServer( * * TcpAccept -- * - * Accept a TCP socket connection. This is called by SocketEventProc and - * it in turns calls the registered accept function. + * Creates a channel for a newly accepted socket connection. This is + * called by SocketEventProc and it in turns calls the registered + * accept function. * * Results: * None. @@ -1551,61 +1652,18 @@ Tcl_OpenTcpServer( static void TcpAccept( - TcpFdList *fds) /* Socket to accept. */ + TcpFdList *fds, /* Server socket that accepted newSocket. */ + SOCKET newSocket, /* Newly accepted socket. */ + address addr) /* Address of new socket. */ { - SOCKET newSocket; SocketInfo *newInfoPtr; SocketInfo *infoPtr = fds->infoPtr; - address addr; - int len; + int len = sizeof(addr); char channelName[16 + TCL_INTEGER_SPACE]; char host[NI_MAXHOST], port[NI_MAXSERV]; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); /* - * Accept the incoming connection request. - */ - - len = sizeof(address); - - newSocket = accept(fds->fd, &(addr.sa), &len); - - /* - * Protect access to sockets (acceptEventCount, readyEvents) in socketList - * by the lock. Fix for SF Tcl Bug 3056775. - */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - - /* - * Clear the ready mask so we can detect the next connection request. Note - * that connection requests are level triggered, so if there is a request - * already pending, a new event will be generated. - */ - - if (newSocket == INVALID_SOCKET) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_ACCEPT); - - SetEvent(tsdPtr->socketListLock); - return; - } - - /* - * It is possible that more than one FD_ACCEPT has been sent, so an extra - * count must be kept. Decrement the count, and reset the readyEvent bit - * if the count is no longer > 0. - */ - - infoPtr->acceptEventCount--; - - if (infoPtr->acceptEventCount <= 0) { - infoPtr->readyEvents &= ~(FD_ACCEPT); - } - - SetEvent(tsdPtr->socketListLock); - - /* * Win-NT has a misfeature that sockets are inherited in child processes * by default. Turn off the inherit bit. */ @@ -1648,7 +1706,7 @@ TcpAccept( getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel, - host, atoi(port)); + host, atoi(port)); } } @@ -1723,6 +1781,7 @@ TcpInputProc( while (1) { SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); + /* single fd operation: this proc is only called for a connected socket. */ bytesRead = recv(infoPtr->sockets->fd, buf, toRead, 0); infoPtr->readyEvents &= ~(FD_READ); @@ -1843,6 +1902,7 @@ TcpOutputProc( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); + /* single fd operation: this proc is only called for a connected socket. */ bytesWritten = send(infoPtr->sockets->fd, buf, toWrite, 0); if (bytesWritten != SOCKET_ERROR) { /* @@ -1938,6 +1998,7 @@ TcpSetOptionProc( } #ifdef TCL_FEATURE_KEEPALIVE_NAGLE + #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat infoPtr->sockets as single fd or list" sock = infoPtr->sockets->fd; if (!strcasecmp(optionName, "-keepalive")) { @@ -2401,6 +2462,7 @@ SocketProc( int event, error; SOCKET socket; SocketInfo *infoPtr; + TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 GetWindowLongPtr(hwnd, GWLP_USERDATA); @@ -2445,58 +2507,60 @@ SocketProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->sockets->fd == socket) { - /* - * Update the socket state. - * - * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event - * happens, then clear the FD_ACCEPT count. Otherwise, - * increment the count if the current event is an FD_ACCEPT. - */ - - if (event & FD_CLOSE) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); - } else if (event & FD_ACCEPT) { - infoPtr->acceptEventCount++; - } - - if (event & FD_CONNECT) { + for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { + if (fds->fd == socket) { /* - * The socket is now connected, clear the async connect - * flag. + * Update the socket state. + * + * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event + * happens, then clear the FD_ACCEPT count. Otherwise, + * increment the count if the current event is an FD_ACCEPT. */ - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + if (event & FD_CLOSE) { + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + } else if (event & FD_ACCEPT) { + infoPtr->acceptEventCount++; + } - /* - * Remember any error that occurred so we can report - * connection failures. - */ + if (event & FD_CONNECT) { + /* + * The socket is now connected, clear the async connect + * flag. + */ + + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - if (error != ERROR_SUCCESS) { - TclWinConvertError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); + /* + * Remember any error that occurred so we can report + * connection failures. + */ + + if (error != ERROR_SUCCESS) { + TclWinConvertError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); + } } - } - if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - if (error != ERROR_SUCCESS) { - TclWinConvertError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); + if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + if (error != ERROR_SUCCESS) { + TclWinConvertError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); + } + infoPtr->readyEvents |= FD_WRITE; } - infoPtr->readyEvents |= FD_WRITE; - } - infoPtr->readyEvents |= event; + infoPtr->readyEvents |= event; - /* - * Wake up the Main Thread. - */ + /* + * Wake up the Main Thread. + */ - SetEvent(tsdPtr->readyEvent); - Tcl_ThreadAlert(tsdPtr->threadId); - break; + SetEvent(tsdPtr->readyEvent); + Tcl_ThreadAlert(tsdPtr->threadId); + break; + } } } SetEvent(tsdPtr->socketListLock); @@ -2504,15 +2568,18 @@ SocketProc( case SOCKET_SELECT: infoPtr = (SocketInfo *) lParam; - if (wParam == SELECT) { - WSAAsyncSelect(infoPtr->sockets->fd, hwnd, - SOCKET_MESSAGE, infoPtr->selectEvents); - } else { - /* - * Clear the selection mask - */ + for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { + infoPtr = (SocketInfo *) lParam; + if (wParam == SELECT) { + WSAAsyncSelect(fds->fd, hwnd, + SOCKET_MESSAGE, infoPtr->selectEvents); + } else { + /* + * Clear the selection mask + */ - WSAAsyncSelect(infoPtr->sockets->fd, hwnd, 0, 0); + WSAAsyncSelect(fds->fd, hwnd, 0, 0); + } } break; -- cgit v0.12 From 0a213115cc2d64e0bf3608839b2b3f079e89c04e Mon Sep 17 00:00:00 2001 From: twylite Date: Mon, 30 Jul 2012 14:01:35 +0000 Subject: Updated ChangeLog for changes in [7a82c3e6] --- ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ChangeLog b/ChangeLog index b726d9c..2ed0d85 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-07-24 Trevor Davel + + * win/tclWinSock.c: [Bug: 3545363]: Loop over multiple underlying file + descriptors for a socket where required (TcpCloseProc, SocketProc). Refactor + socket/descriptor setup to manage linked list operations in one place. Fix + memory leak in socket close (TcpCloseProc) and related dangling pointers in + SocketEventProc. + 2012-07-19 Reinhard Max * win/tclWinSock.c (TcpAccept): [Bug: 3545363]: Use a large enough -- cgit v0.12 -- cgit v0.12 From 79878e7af5ae502d353130a4cca867147152bfc2 Mon Sep 17 00:00:00 2001 From: twylite Date: Fri, 3 Aug 2012 16:39:49 +0000 Subject: [Patch-3163961] Implementation of TIP #405 merged from private branch. Includes 'mapeach', 'dict map' and 'foreacha' commands, test suite (partial for 'foreacha') and man pages (except for 'foreacha'). --- doc/dict.n | 22 ++- doc/mapeach.n | 91 ++++++++++ generic/tcl.h | 1 + generic/tclBasic.c | 4 +- generic/tclCmdAH.c | 110 +++++++++-- generic/tclCompCmds.c | 197 +++++++++++++++++++- generic/tclCompile.h | 1 + generic/tclDictObj.c | 67 +++++-- generic/tclExecute.c | 17 +- generic/tclInt.h | 30 +++ tests/dict.test | 246 +++++++++++++++++++++++++ tests/foreach.test | 9 + tests/foreacha.test | 217 ++++++++++++++++++++++ tests/mapeach.test | 493 ++++++++++++++++++++++++++++++++++++++++++++++++++ 14 files changed, 1466 insertions(+), 39 deletions(-) create mode 100644 doc/mapeach.n create mode 100644 tests/foreacha.test create mode 100644 tests/mapeach.test diff --git a/doc/dict.n b/doc/dict.n index 361a112..b9b4767 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -147,6 +147,24 @@ keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the value that the key maps to to not be representable as a list. .TP +\fBdict map {\fIkeyVar valueVar\fB} \fIdictionaryValue body\fR +. +This command takes three arguments, the first a two-element list of +variable names (for the key and value respectively of each mapping in +the dictionary), the second the dictionary value to iterate across, +and the third a script to be evaluated for each mapping with the key +and value variables set appropriately (in the manner of \fBmapeach\fR.) +In an iteration where the evaluated script completes normally +(\fBTCL_OK\fR) the script result is appended to an accumulator list. +The result of the \fBdict map\fB command is the accumulator list. +If any evaluation of the body generates a \fBTCL_BREAK\fR result, no +further pairs from the dictionary will be iterated over and the +\fBdict map\fR command will terminate successfully immediately. If any +evaluation of the body generates a \fBTCL_CONTINUE\fR result, the +current iteration is aborted and the accumulator list is not modified. +The order of iteration is the order in which the keys were inserted into +the dictionary. +.TP \fBdict merge \fR?\fIdictionaryValue ...\fR? . Return a dictionary that contains the contents of each of the @@ -408,9 +426,9 @@ puts $foo # prints: \fIa b foo {a b} bar 2 baz 3\fR .CE .SH "SEE ALSO" -append(n), array(n), foreach(n), incr(n), list(n), lappend(n), set(n) +append(n), array(n), foreach(n), mapeach(n), incr(n), list(n), lappend(n), set(n) .SH KEYWORDS -dictionary, create, update, lookup, iterate, filter +dictionary, create, update, lookup, iterate, filter, map '\" Local Variables: '\" mode: nroff '\" End: diff --git a/doc/mapeach.n b/doc/mapeach.n new file mode 100644 index 0000000..c89f7d9 --- /dev/null +++ b/doc/mapeach.n @@ -0,0 +1,91 @@ +'\" +'\" Copyright (c) 2012 Trevor Davel +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.so man.macros +.TH mapeach n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +mapeach \- Iterate over all elements in one or more lists and collect results +.SH SYNOPSIS +\fBmapeach \fIvarname list body\fR +.br +\fBmapeach \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR +.BE + +.SH DESCRIPTION +.PP +The \fBmapeach\fR command implements a loop where the loop +variable(s) take on values from one or more lists, and the loop returns a list +of results collected from each iteration. +.PP +In the simplest case there is one loop variable, \fIvarname\fR, +and one list, \fIlist\fR, that is a list of values to assign to \fIvarname\fR. +The \fIbody\fR argument is a Tcl script. +For each element of \fIlist\fR (in order +from first to last), \fBmapeach\fR assigns the contents of the +element to \fIvarname\fR as if the \fBlindex\fR command had been used +to extract the element, then calls the Tcl interpreter to execute +\fIbody\fR. If execution of the body completes normally then the result of the +body is appended to an accumulator list. \fBmapeach\fR returns the accumulator +list. + +.PP +In the general case there can be more than one value list +(e.g., \fIlist1\fR and \fIlist2\fR), +and each value list can be associated with a list of loop variables +(e.g., \fIvarlist1\fR and \fIvarlist2\fR). +During each iteration of the loop +the variables of each \fIvarlist\fR are assigned +consecutive values from the corresponding \fIlist\fR. +Values in each \fIlist\fR are used in order from first to last, +and each value is used exactly once. +The total number of loop iterations is large enough to use +up all the values from all the value lists. +If a value list does not contain enough +elements for each of its loop variables in each iteration, +empty values are used for the missing elements. +.PP +The \fBbreak\fR and \fBcontinue\fR statements may be +invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR +and \fBforeach\fR commands. In these cases the body does not complete normally +and the result is not appended to the accumulator list. +.SH EXAMPLES +.PP +Zip lists together: +.PP +.CS +'\" Maintainers: notice the tab hacking below! +.ta 3i +set list1 {a b c d} +set list2 {1 2 3 4} +set zipped [\fBmapeach\fR a $list1 b $list2 {list $a $b}] +# The value of zipped is "{a 1} {b 2} {c 3} {d 4}" +.CE +.PP +Filter a list: +.PP +.CS +set values {1 2 3 4 5 6 7 8} +proc isGood {n} { expr { ($n % 2) == 0 } } +set goodOnes [\fBmapeach\fR x $values {expr {[isGood $x] ? $x : [continue]}}] +# The value of goodOnes is "2 4 6 8" +.CE +.PP +Take a prefix from a list: +.PP +.CS +set values {8 7 6 5 4 3 2 1} +proc isGood {n} { expr { $n > 3 } } +set prefix [\fBmapeach\fR x $values {expr {[isGood $x] ? $x : [break]}}] +# The value of prefix is "8 7 6 5 4" +.CE + +.SH "SEE ALSO" +for(n), while(n), break(n), continue(n), foreach(n) + +.SH KEYWORDS +foreach, iteration, list, loop, map diff --git a/generic/tcl.h b/generic/tcl.h index 729e521..9a7c224 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1359,6 +1359,7 @@ typedef struct { int epoch; /* Epoch marker for dictionary being searched, * or -1 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ + Tcl_Obj *resultList; /* List of result values from the loop body. */ } Tcl_DictSearch; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 537750e..fe8fa5a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -219,6 +219,7 @@ static const CmdInfo builtInCmds[] = { {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, + {"foreacha", Tcl_ForeachaObjCmd, TclCompileForeachaCmd, TclNRForeachaCmd, 1}, {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, @@ -237,6 +238,7 @@ static const CmdInfo builtInCmds[] = { {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, + {"mapeach", Tcl_MapeachObjCmd, TclCompileMapeachCmd, TclNRMapeachCmd, 1}, {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, @@ -8849,7 +8851,7 @@ NRCoroInjectObjCmd( return TCL_OK; } - + int TclNRInterpCoroutine( ClientData clientData, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f09ee70..333946a 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -32,6 +32,7 @@ struct ForeachState { int *argcList; /* Array of value list sizes. */ Tcl_Obj ***argvList; /* Array of value lists. */ Tcl_Obj **aCopyList; /* Copies of value list arguments. */ + Tcl_Obj *resultList; /* List of result values from the loop body. */ }; /* @@ -44,7 +45,7 @@ static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, - struct ForeachState *statePtr); + struct ForeachState *statePtr, int collect); static inline void ForeachCleanup(Tcl_Interp *interp, struct ForeachState *statePtr); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -52,6 +53,8 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); +static int TclNREachloopCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[], int collect); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ExprCallback; static Tcl_NRPostProc ForSetupCallback; @@ -2560,7 +2563,7 @@ ForPostNextCallback( /* *---------------------------------------------------------------------- * - * Tcl_ForeachObjCmd, TclNRForeachCmd -- + * Tcl_ForeachObjCmd, TclNRForeachCmd, TclNREachloopCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. @@ -2592,6 +2595,58 @@ TclNRForeachCmd( int objc, Tcl_Obj *const objv[]) { + return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_KEEP_NONE); +} + +int +Tcl_MapeachObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRMapeachCmd, dummy, objc, objv); +} + +int +TclNRMapeachCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_COLLECT); +} + +int +Tcl_ForeachaObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRForeachaCmd, dummy, objc, objv); +} + +int +TclNRForeachaCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_ACCUM); +} + +int +TclNREachloopCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[], + int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ +{ + int numLists = (objc-2) / 2; register struct ForeachState *statePtr; int i, j, result; @@ -2635,6 +2690,8 @@ TclNRForeachCmd( statePtr->bodyPtr = objv[objc - 1]; statePtr->bodyIdx = objc - 1; + statePtr->resultList = Tcl_NewListObj(0, NULL); + /* * Break up the value lists and variable lists into elements. */ @@ -2663,9 +2720,13 @@ TclNRForeachCmd( TclListObjGetElements(NULL, statePtr->aCopyList[i], &statePtr->argcList[i], &statePtr->argvList[i]); - j = statePtr->argcList[i] / statePtr->varcList[i]; - if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { - j++; + j = (i == 0) && (collect == TCL_EACH_ACCUM); /* Accumulator present? */ + /* If accumulator is only var in list, then we iterate j=1 times */ + if (statePtr->varcList[i] > j) { + /* We need listLen/numVars round up = ((listLen+numVars-1)/numVars) + * When accum is present we need (listLen-1)/(numVars-1) round up */ + j = (statePtr->argcList[i] - j + statePtr->varcList[i] - j - 1) + / (statePtr->varcList[i] - j); } if (j > statePtr->maxj) { statePtr->maxj = j; @@ -2678,12 +2739,12 @@ TclNRForeachCmd( */ if (statePtr->maxj > 0) { - result = ForeachAssignments(interp, statePtr); + result = ForeachAssignments(interp, statePtr, collect); if (result == TCL_ERROR) { goto done; } - TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); + TclNRAddCallback(interp, ForeachLoopStep, statePtr, collect, NULL, NULL); return TclNREvalObjEx(interp, objv[objc-1], 0, ((Interp *) interp)->cmdFramePtr, objc-1); } @@ -2710,6 +2771,7 @@ ForeachLoopStep( int result) { register struct ForeachState *statePtr = data[0]; + int collect = (int)data[1]; /* Selected collecting or accumulating mode. */ /* * Process the result code from this run of the [foreach] body. Note that @@ -2719,11 +2781,15 @@ ForeachLoopStep( switch (result) { case TCL_CONTINUE: result = TCL_OK; + break; case TCL_OK: + if (collect == TCL_EACH_COLLECT) { + Tcl_ListObjAppendElement(interp, statePtr->resultList, Tcl_GetObjResult(interp)); + } break; case TCL_BREAK: result = TCL_OK; - goto done; + goto finish; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"foreach\" body line %d)", Tcl_GetErrorLine(interp))); @@ -2737,12 +2803,12 @@ ForeachLoopStep( */ if (statePtr->maxj > ++statePtr->j) { - result = ForeachAssignments(interp, statePtr); + result = ForeachAssignments(interp, statePtr, collect); if (result == TCL_ERROR) { goto done; } - TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); + TclNRAddCallback(interp, ForeachLoopStep, statePtr, collect, NULL, NULL); return TclNREvalObjEx(interp, statePtr->bodyPtr, 0, ((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx); } @@ -2750,8 +2816,18 @@ ForeachLoopStep( /* * We're done. Tidy up our work space and finish off. */ - - Tcl_ResetResult(interp); +finish: + if (collect == TCL_EACH_ACCUM) { + Tcl_Obj* valueObj = Tcl_ObjGetVar2(interp, statePtr->varvList[0][0], + NULL, TCL_LEAVE_ERR_MSG); + if (valueObj == NULL) { + goto done; + } + Tcl_SetObjResult(interp, valueObj); + } else { + Tcl_SetObjResult(interp, statePtr->resultList); + statePtr->resultList = NULL; /* Don't clean it up */ + } done: ForeachCleanup(interp, statePtr); return result; @@ -2764,13 +2840,16 @@ ForeachLoopStep( static inline int ForeachAssignments( Tcl_Interp *interp, - struct ForeachState *statePtr) + struct ForeachState *statePtr, + int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ { int i, v, k; Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { - for (v=0 ; vvarcList[i] ; v++) { + /* Don't modify the accumulator except on the first iteration */ + v = ((i == 0) && (collect == TCL_EACH_ACCUM) && (statePtr->index[i] > 0)); + for (; vvarcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { @@ -2813,6 +2892,9 @@ ForeachCleanup( TclDecrRefCount(statePtr->aCopyList[i]); } } + if (statePtr->resultList) { + TclDecrRefCount(statePtr->resultList); + } TclStackFree(interp, statePtr); } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3540716..07a5eea 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -40,6 +40,13 @@ static int PushVarName(Tcl_Interp *interp, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line, int *clNext); +static int TclCompileEachloopCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, + int collect); +static int TclCompileDictEachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr, int collect); + /* * Macro that encapsulates an efficiency trick that avoids a function call for @@ -586,6 +593,7 @@ TclCompileContinueCmd( * dict incr * dict keys [*] * dict lappend + * dict map * dict set * dict unset * @@ -787,11 +795,37 @@ TclCompileDictForCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + return TclCompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, 0); +} + +int +TclCompileDictMapCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return TclCompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, 1); +} + +int +TclCompileDictEachCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int collect) /* Flag == 1 to collect and return loop body result. */ +{ DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; int numVars, endTargetOffset; + int collectTemp; /* Index of temp var holding the result list. */ int savedStackDepth = envPtr->currStackDepth; /* Needed because jumps confuse the stack * space calculator. */ @@ -864,6 +898,22 @@ TclCompileDictForCmd( } /* + * Create temporary variable to capture return values from loop body. + */ + + if (collect == 1) { + collectTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, envPtr); + + PushLiteral(envPtr, "", 0); + if (collectTemp <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, collectTemp, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + + /* * Preparation complete; issue instructions. Note that this code issues * fixed-sized jumps. That simplifies things a lot! * @@ -908,6 +958,13 @@ TclCompileDictForCmd( SetLineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); + if (collect == 1) { + if (collectTemp <= 255) { + TclEmitInstInt1(INST_LAPPEND_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_SCALAR4, collectTemp, envPtr); + } + } TclEmitOpcode( INST_POP, envPtr); /* @@ -975,14 +1032,22 @@ TclCompileDictForCmd( /* * Final stage of the command (normal case) is that we push an empty - * object. This is done last to promote peephole optimization when it's - * dropped immediately. + * object (or push the accumulator as the result object). This is done + * last to promote peephole optimization when it's dropped immediately. */ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, envPtr->codeStart + endTargetOffset); - PushLiteral(envPtr, "", 0); + if (collect == 1) { + if (collectTemp <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, collectTemp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } return TCL_OK; } @@ -1846,9 +1911,9 @@ TclCompileForCmd( /* *---------------------------------------------------------------------- * - * TclCompileForeachCmd -- + * TclCompileForeachCmd, TclCompileForeachaCmd -- * - * Procedure called to compile the "foreach" command. + * Procedure called to compile the "foreach" and "foreacha" commands. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -1870,6 +1935,49 @@ TclCompileForeachCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 0); +} + +int +TclCompileForeachaCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 2); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileEachloopCmd -- + * + * Procedure called to compile the "foreach" and "mapeach" commands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "foreach" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +TclCompileEachloopCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ +{ Proc *procPtr = envPtr->procPtr; ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData @@ -1878,6 +1986,8 @@ TclCompileForeachCmd( * used to point to a value list. */ int loopCtTemp; /* Index of temp var holding the loop's * iteration count. */ + int collectTemp = -1; /* Index of temp var holding the result var index. */ + Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; @@ -2026,6 +2136,7 @@ TclCompileForeachCmd( infoPtr->numLists = numLists; infoPtr->firstValueTemp = firstValueTemp; infoPtr->loopCtTemp = loopCtTemp; + infoPtr->collect = collect; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; @@ -2039,6 +2150,9 @@ TclCompileForeachCmd( varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, nameChars, /*create*/ 1, envPtr); + if ((collect == TCL_EACH_ACCUM) && ((loopIndex + j) == 0)) { + collectTemp = varListPtr->varIndexes[j]; + } } infoPtr->varLists[loopIndex] = varListPtr; } @@ -2069,6 +2183,22 @@ TclCompileForeachCmd( } /* + * Create temporary variable to capture return values from loop body. + */ + + if (collect == TCL_EACH_COLLECT) { + collectTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, envPtr); + + PushLiteral(envPtr, "", 0); + if (collectTemp <= 255) { + TclEmitInstInt1( INST_STORE_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, collectTemp, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); + } + + /* * Initialize the temporary var that holds the count of loop iterations. */ @@ -2092,7 +2222,16 @@ TclCompileForeachCmd( CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; - TclEmitOpcode( INST_POP, envPtr); + + if (collect == TCL_EACH_COLLECT) { + if (collectTemp <= 255) { + TclEmitInstInt1( INST_LAPPEND_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4( INST_LAPPEND_SCALAR4, collectTemp, envPtr); + } + } + TclEmitOpcode( INST_POP, envPtr); + /* * Jump back to the test at the top of the loop. Generate a 4 byte jump if @@ -2142,11 +2281,20 @@ TclCompileForeachCmd( ExceptionRangeTarget(envPtr, range, breakOffset); /* - * The foreach command's result is an empty string. + * The command's result is an empty string if not collecting, or the + * list of results from evaluating the loop body. */ envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + if (collectTemp >= 0) { + if (collectTemp <= 255) { + TclEmitInstInt1( INST_LOAD_SCALAR1, collectTemp, envPtr); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, collectTemp, envPtr); + } + } else { + PushLiteral(envPtr, "", 0); + } envPtr->currStackDepth = savedStackDepth + 1; done: @@ -2196,6 +2344,7 @@ DupForeachInfo( dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; + dupPtr->collect = srcPtr->collect; for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; @@ -2286,6 +2435,8 @@ PrintForeachInfo( } Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", (unsigned) infoPtr->loopCtTemp); + Tcl_AppendPrintfToObj(appendObj, "], collect=%%v%u", + (unsigned) infoPtr->collect); for (i=0 ; inumLists ; i++) { if (i) { Tcl_AppendToObj(appendObj, ",", -1); @@ -3700,6 +3851,36 @@ TclCompileLsetCmd( /* *---------------------------------------------------------------------- * + * TclCompileMapeachCmd -- + * + * Procedure called to compile the "mapeach" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "mapeach" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileMapeachCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 1); +} + +/* + *---------------------------------------------------------------------- + * * TclCompileNamespaceCmd -- * * Procedure called to compile the "namespace" command; currently, only diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ba78c36..7a41bb1 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -807,6 +807,7 @@ typedef struct ForeachInfo { * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ + int collect; /* Selected collecting or accumulating mode. */ ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index ac2cb62..2e24d75 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -76,7 +76,11 @@ static int FinalizeDictWith(ClientData data[], Tcl_Interp *interp, int result); static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int DictForLoopCallback(ClientData data[], +static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictEachNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv, int collect); +static int DictEachLoopCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -95,6 +99,7 @@ static const EnsembleImplMap implementationMap[] = { {"info", DictInfoCmd, NULL, NULL, NULL, 0 }, {"keys", DictKeysCmd, NULL, NULL, NULL, 0 }, {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, + {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, {"merge", DictMergeCmd, NULL, NULL, NULL, 0 }, {"remove", DictRemoveCmd, NULL, NULL, NULL, 0 }, {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, @@ -2329,11 +2334,11 @@ DictAppendCmd( /* *---------------------------------------------------------------------- * - * DictForNRCmd -- + * DictForNRCmd, DictMapNRCmd, DictEachNRCmd -- * - * This function implements the "dict for" Tcl command. See the user - * documentation for details on what it does, and TIP#111 for the formal - * specification. + * These functions implement the "dict for" and "dict map" Tcl commands. + * See the user documentation for details on what it does, and TIP#111 + * and TIP#405 for the formal specification. * * Results: * A standard Tcl result. @@ -2351,6 +2356,27 @@ DictForNRCmd( int objc, Tcl_Obj *const *objv) { + return DictEachNRCmd(dummy, interp, objc, objv, 0); +} + +static int +DictMapNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return DictEachNRCmd(dummy, interp, objc, objv, 1); +} + +static int +DictEachNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv, + int collect) /* Flag == 1 to collect and return loop body result. */ +{ Interp *iPtr = (Interp *) interp; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; @@ -2376,6 +2402,7 @@ DictForNRCmd( return TCL_ERROR; } searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); + searchPtr->resultList = (collect ? Tcl_NewListObj(0, NULL) : NULL ); if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj, &done) != TCL_OK) { TclStackFree(interp, searchPtr); @@ -2419,7 +2446,7 @@ DictForNRCmd( * Run the script. */ - TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj, + TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj, valueVarObj, scriptObj); return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); @@ -2437,7 +2464,7 @@ DictForNRCmd( } static int -DictForLoopCallback( +DictEachLoopCallback( ClientData data[], Tcl_Interp *interp, int result) @@ -2462,19 +2489,34 @@ DictForLoopCallback( result = TCL_OK; } else if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"dict for\" body line %d)", + ((searchPtr->resultList == NULL) ? + "\n (\"dict for\" body line %d)" : + "\n (\"dict map\" body line %d)"), Tcl_GetErrorLine(interp))); } goto done; } /* + * Capture result if collecting. + */ + + if (searchPtr->resultList != NULL) { + Tcl_ListObjAppendElement(interp, searchPtr->resultList, Tcl_GetObjResult(interp)); + } + + /* * Get the next mapping from the dictionary. */ Tcl_DictObjNext(searchPtr, &keyObj, &valueObj, &done); if (done) { - Tcl_ResetResult(interp); + if (searchPtr->resultList != NULL) { + Tcl_SetObjResult(interp, searchPtr->resultList); + searchPtr->resultList = NULL; /* Don't clean it up */ + } else { + Tcl_ResetResult(interp); + } goto done; } @@ -2499,7 +2541,7 @@ DictForLoopCallback( * Run the script. */ - TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj, + TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj, valueVarObj, scriptObj); return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); @@ -2507,9 +2549,12 @@ DictForLoopCallback( * For unwinding everything once the iterating is done. */ - done: +done: TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); + if (searchPtr->resultList != NULL) { + TclDecrRefCount(searchPtr->resultList); + } TclDecrRefCount(scriptObj); Tcl_DictObjDone(searchPtr); TclStackFree(interp, searchPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..952eb32 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5492,7 +5492,15 @@ TEBCresume( opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); goto gotError; } - if (listLen > iterNum * numVars) { + + /* If the accumulator is the only variable then this list gets + * just one iteration. Otherwise we must keep going until the + * list is exhausted by non-accumulator loop vars */ + j = ((i == 0) && (iterNum > 0) + && (infoPtr->collect == TCL_EACH_ACCUM)); + /* j is 1 if the accumulator is present but does not consume + * an element, or 0 otherwise (consuming or not-present). */ + if ((numVars > j) && (listLen > (iterNum * (numVars - j) + j))) { continueLoop = 1; } listTmpIndex++; @@ -5517,8 +5525,11 @@ TEBCresume( listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); TclListObjGetElements(interp, listPtr, &listLen, &elements); - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { + /* Don't modify the accumulator except on the first iteration */ + j = ((i == 0) && (iterNum > 0) + && (infoPtr->collect == TCL_EACH_ACCUM)); + valIndex = (iterNum * (numVars - j) + j); + for (; j < numVars; j++) { if (valIndex >= listLen) { TclNewObj(valuePtr); } else { diff --git a/generic/tclInt.h b/generic/tclInt.h index 53a88d6..6600dd9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2773,7 +2773,9 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachaCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRMapeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; @@ -2854,6 +2856,19 @@ struct Tcl_LoadHandle_ { #define TCL_DD_SHORTEST0 0x0 /* 'Shortest possible' after masking */ +/* Modes for collecting or accumulating in TclNREachloopCmd, + * TclCompileEachloopCmd and INST_FOREACH_STEP4. */ + +#define TCL_EACH_KEEP_NONE 0 + /* Discard iteration result like [foreach] */ + +#define TCL_EACH_COLLECT 1 + /* Collect iteration result like [mapeach] */ + +#define TCL_EACH_ACCUM 2 + /* First loop var is accumulator like [foreacha] */ + + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: @@ -3299,6 +3314,9 @@ MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ForeachaObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3366,6 +3384,9 @@ MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_MapeachObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy, Tcl_Interp *interp, int objc, @@ -3492,6 +3513,9 @@ MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3525,6 +3549,9 @@ MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileForeachaCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3561,6 +3588,9 @@ MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileMapeachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/dict.test b/tests/dict.test index 77bacf6..398493a 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1521,6 +1521,252 @@ j }} [linenumber]}} } 5 rename linenumber {} + +test dict-24.1 {dict map command: syntax} -returnCodes error -body { + dict map +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.2 {dict map command: syntax} -returnCodes error -body { + dict map x +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.3 {dict map command: syntax} -returnCodes error -body { + dict map x x +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.4 {dict map command: syntax} -returnCodes error -body { + dict map x x x x +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.5 {dict map command: syntax} -returnCodes error -body { + dict map x x x +} -result {must have exactly two variable names} +test dict-24.6 {dict map command: syntax} -returnCodes error -body { + dict map {x x x} x x +} -result {must have exactly two variable names} +test dict-24.7 {dict map command: syntax} -returnCodes error -body { + dict map "\{x" x x +} -result {unmatched open brace in list} +test dict-24.8 {dict map command} -body { + # This test confirms that [dict keys], [dict values] and [dict map] + # all traverse a dictionary in the same order. + set dictv {a A b B c C} + set values {} + set keys [dict map {k v} $dictv { + lappend values $v + set k + }] + set result [expr { + $keys eq [dict keys $dictv] && $values eq [dict values $dictv] + }] + expr {$result ? "YES" : [list "NO" $dictv $keys $values]} +} -cleanup { + unset result keys values k v dictv +} -result YES +test dict-24.9 {dict map command} { + dict map {k v} {} { + error "unexpected execution of 'dict map' body" + } +} {} +test dict-24.10 {dict map command: script results} -body { + set times 0 + dict map {k v} {a a b b} { + incr times + continue + error "shouldn't get here" + } + return $times +} -cleanup { + unset times k v +} -result 2 +test dict-24.11 {dict map command: script results} -body { + set times 0 + dict map {k v} {a a b b} { + incr times + break + error "shouldn't get here" + } + return $times +} -cleanup { + unset times k v +} -result 1 +test dict-24.12 {dict map command: script results} -body { + set times 0 + list [catch { + dict map {k v} {a a b b} { + incr times + error test + } + } msg] $msg $times $::errorInfo +} -cleanup { + unset times k v msg +} -result {1 test 1 {test + while executing +"error test" + ("dict map" body line 3) + invoked from within +"dict map {k v} {a a b b} { + incr times + error test + }"}} +test dict-24.13 {dict map command: script results} { + apply {{} { + dict map {k v} {a b} { + return ok,$k,$v + error "skipped return completely" + } + error "return didn't go far enough" + }} +} ok,a,b +test dict-24.14 {dict map command: handle representation loss} -body { + set dictVar {a b c d e f g h} + set values {} + set keys [dict map {k v} $dictVar { + if {[llength $dictVar]} { + lappend values $v + return -level 0 $k + } + }] + list [lsort $keys] [lsort $values] +} -cleanup { + unset dictVar keys values k v +} -result {{a c e g} {b d f h}} +test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup { + unset -nocomplain accum + array set accum {} +} -body { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + dict map {k v} $dictVar { + append accum($k) $v, + } + set result [lsort [array names accum]] + lappend result : + foreach k $result { + catch {lappend result $accum($k)} + } + return $result +} -cleanup { + unset dictVar k v result accum +} -result {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,} +test dict-24.16 {dict map command in compilation context} { + apply {{} { + set res {x x x x x x} + dict map {k v} {a 0 b 1 c 2 d 3 e 4 f 5} { + lset res $v $k + continue + } + return $res + }} +} {a b c d e f} +test dict-24.17 {dict map command in compilation context} { + # Bug 1379349 (dict for) + apply {{} { + set d [dict create a 1] ;# Dict must be unshared! + dict map {k v} $d { + dict set d $k 0 ;# Any modification will do + } + return $d + }} +} {a 0} +test dict-24.17a {dict map command in compilation context} { + # Bug 1379349 (dict for) + apply {{} { + set d [dict create a 1] ;# Dict must be unshared! + dict map {k v} $d { + dict set d $k 0 ;# Any modification will do + } + }} +} {{a 0}} +test dict-24.18 {dict map command in compilation context} { + # Bug 1382528 (dict for) + apply {{} { + dict map {k v} {} {} ;# Note empty dict + catch { error foo } ;# Note compiled [catch] + }} +} 1 +test dict-24.19 {dict map and invalid dicts: 'dict for' bug 1531184} -body { + di[list]ct map {k v} x {} +} -returnCodes 1 -result {missing value to go with key} +test dict-24.20 {dict map stack space compilation: 'dict for' bug 1903325} { + apply {{x y args} { + dict map {a b} $x {} + concat "c=$y,$args" + }} {} 1 2 3 +} {c=1,2 3} +proc linenumber {} { + dict get [info frame -1] line +} +test dict-24.20 {dict compilation crash: 'dict for' bug 3487626} { + apply {{} {apply {n { + set e {} + set k {} + dict map {a b} {c {d {e {f g}}}} { + ::tcl::dict::map {h i} $b { + dict update i e j { + ::tcl::dict::update j f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [linenumber]}} +} 5 +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug { + apply {{} {apply {n { + set e {} + set k {} + dict map {a { +b +}} {c {d {e {f g}}}} { + ::tcl::dict::map {h { +i +}} ${ +b +} { + dict update { +i +} e { +j +} { + ::tcl::dict::update { +j +} f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [linenumber]}} +} 5 +rename linenumber {} +test dict-24.22 {dict map results (non-compiled)} { + dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { + return -level 0 "$k,$v" + } +} {{1 a,2 b} {3 c,4 d}} +test dict-24.23 {dict map results (compiled)} { + apply {{} { + dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { + return -level 0 "$k,$v" + } + }} +} {{1 a,2 b} {3 c,4 d}} +test dict-24.23a {dict map results (compiled)} { + apply {{list} { + dict map {k v} [dict map {k v} $list { list $v $k }] { + return -level 0 "$k,$v" + } + }} {a 1 b 2 c 3 d 4} +} {{1 a,2 b} {3 c,4 d}} +test dict-24.24 {dict map with huge dict (non-compiled)} { + tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 1000000 x] x] { + expr { $k * $v } + }] +} 166666416666500000 +test dict-24.25 {dict map with huge dict (compiled)} { + apply {{n} { + tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat $n y] y] { + expr { $k * $v } + }] + }} 1000000 +} 166666416666500000 + # cleanup ::tcltest::cleanupTests diff --git a/tests/foreach.test b/tests/foreach.test index a4b652a..6c69b29 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -266,6 +266,15 @@ test foreach-10.1 {foreach: [Bug 1671087]} -setup { rename demo {} } -result {} +test foreach-11.1 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { error x } } + set a +} 0 +test foreach-11.2 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + # cleanup catch {unset a} catch {unset x} diff --git a/tests/foreacha.test b/tests/foreacha.test new file mode 100644 index 0000000..09a90e4 --- /dev/null +++ b/tests/foreacha.test @@ -0,0 +1,217 @@ +# Commands covered: foreach, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +catch {unset a} +catch {unset x} + +# ----- Basic "foreacha" operation (non-compiled) ------------------------------ + +test foreacha-1.1 {basic foreacha tests (non-compiled) - foldl/reduce with initial value} { + set x {} + set c [foreacha a 0 b {1 2 3 4} { lappend x $a ; incr a $b }] + list $a $b $c $x +} {10 4 10 {0 1 3 6}} + +test foreacha-1.2 {basic foreacha tests (non-compiled) - foldl/reduce without initial value} { + set x {} + set c [foreacha {a b} {1 2 3 4 5 6} { lappend x $a ; incr a $b }] + list $a $b $c $x +} {21 6 21 {1 3 6 10 15}} + +test foreacha-1.3 {basic foreacha tests (non-compiled) - filter} { + foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } { lappend a $b } } +} {2 4 6} + +test foreacha-1.3.1 {basic foreacha tests (non-compiled) - filter (via continue)} { + foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } continue; lappend a $b } +} {1 3 5} + +test foreacha-1.4 {basic foreacha tests (non-compiled) - map} { + foreacha a {} b {1 2 3 4 5 6} { lappend a [lrepeat $b $b] } +} {1 {2 2} {3 3 3} {4 4 4 4} {5 5 5 5 5} {6 6 6 6 6 6}} + +test foreacha-1.5 {basic foreacha tests (non-compiled) - prefix (via break)} { + foreacha a {} b {1 2 3 4 5 6} { if { $b > 4 } break; lappend a $b } +} {1 2 3 4} + +test foreacha-1.6 {basic foreacha tests (non-compiled) - accumulator doesn't iterate} { + set x {} + set b [foreacha a {1 2 3 4} { lappend x $a }] + list $a $b $x +} {1 1 1} + +test foreacha-1.7 {basic foreacha tests (non-compiled) - accumulator doesn't iterate} { + set x {} + set c [foreacha a {1 2 3 4} b 0 { lappend x $a $b ; append a $b ; append b $a }] + list $a $b $c $x +} {10 010 10 {1 0}} + +test foreacha-1.8 {basic foreacha tests (non-compiled) - huge list} { + foreacha {a b} [lsearch -all [lrepeat 1000000 x] x] { incr a $b } +} 499999500000 + +test foreacha-1.9 {basic foreacha tests (non-compiled) - spaghetti} { + foreacha {a b} [foreacha a {} {b c} [lsearch -all [lrepeat 1000 x] x] { + lappend a [expr { $b * $c }] + }] { + incr a $b + } +} 166416500 + +test foreacha-1.9.1 {basic foreacha tests (non-compiled) - spaghetti with mapeach} { + foreacha {a b} [mapeach {b c} [lsearch -all [lrepeat 1000 x] x] { + expr { $b * $c } + }] { + incr a $b + } +} 166416500 + +test foreacha-1.10 {basic foreacha tests (non-compiled) - nested} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + incr a [foreacha c 10 d [lrepeat $b $b] { incr c $b }] + } +} 332843490 + +test foreacha-1.10.1 {basic foreacha tests (non-compiled) - nested with loop var collision} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + foreacha a 10 b [lrepeat $b $b] { incr a $b } + } +} 998011 + +test foreacha-1.10.2 {basic foreacha tests (non-compiled) - nested, inner non-compiled} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + incr a [eval foreacha c 10 d [list [lrepeat $b $b] { incr c $b }]] + } +} 332843490 + + +# ----- Basic "foreacha" operation (compiled) ---------------------------------- + +test foreacha-2.1 {basic foreacha tests (compiled) - foldl/reduce with initial value} { + apply {{} { + set x {} + set c [foreacha a 0 b {1 2 3 4} { lappend x $a ; incr a $b }] + list $a $b $c $x + }} +} {10 4 10 {0 1 3 6}} + +test foreacha-2.2 {basic foreacha tests (compiled) - foldl/reduce without initial value} { + apply {{} { + set x {} + set c [foreacha {a b} {1 2 3 4 5 6} { lappend x $a ; incr a $b }] + list $a $b $c $x + }} +} {21 6 21 {1 3 6 10 15}} + +test foreacha-2.3 {basic foreacha tests (compiled) - filter} { + apply {{} { + foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } { lappend a $b } } + }} +} {2 4 6} + +test foreacha-2.3.1 {basic foreacha tests (non-compiled) - filter (via continue)} { + apply {{} { + foreacha a {} b {1 2 3 4 5 6} { if { ($b % 2)==0 } continue; lappend a $b } + }} +} {1 3 5} + +test foreacha-2.4 {basic foreacha tests (compiled) - map} { + apply {{} { + foreacha a {} b {1 2 3 4 5 6} { lappend a [lrepeat $b $b] } + }} +} {1 {2 2} {3 3 3} {4 4 4 4} {5 5 5 5 5} {6 6 6 6 6 6}} + +test foreacha-2.5 {basic foreacha tests (non-compiled) - prefix (via break)} { + apply {{} { + foreacha a {} b {1 2 3 4 5 6} { if { $b > 4 } break; lappend a $b } + }} +} {1 2 3 4} + +test foreacha-2.6 {basic foreacha tests (compiled) - accumulator doesn't iterate} { + apply {{} { + set x {} + set b [foreacha a {1 2 3 4} { lappend x $a }] + list $a $b $x + }} +} {1 1 1} + +test foreacha-2.7 {basic foreacha tests (compiled) - accumulator doesn't iterate} { + apply {{} { + set x {} + set c [foreacha a {1 2 3 4} b 0 { lappend x $a $b ; append a $b ; append b $a }] + list $a $b $c $x + }} +} {10 010 10 {1 0}} + +test foreacha-2.8 {basic foreacha tests (compiled) - huge list} { + apply {{} { + foreacha {a b} [lsearch -all [lrepeat 1000000 x] x] { incr a $b } + }} +} 499999500000 + +test foreacha-2.9 {basic foreacha tests (compiled) - spaghetti} { + apply {{} { + foreacha {a b} [foreacha a {} {b c} [lsearch -all [lrepeat 1000 x] x] { + lappend a [expr { $b * $c }] + }] { + incr a $b + } + }} +} 166416500 + +test foreacha-2.9.1 {basic foreacha tests (compiled) - spaghetti with mapeach} { + apply {{} { + foreacha {a b} [mapeach {b c} [lsearch -all [lrepeat 1000 x] x] { + expr { $b * $c } + }] { + incr a $b + } + }} +} 166416500 + +test foreacha-2.10 {basic foreacha tests (compiled) - nested} { + apply {{} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + incr a [foreacha c 10 d [lrepeat $b $b] { incr c $b }] + } + }} +} 332843490 + +test foreacha-2.10.1 {basic foreacha tests (compiled) - nested with loop var collision} { + apply {{} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + foreacha a 10 b [lrepeat $b $b] { incr a $b } + } + }} +} 998011 + +test foreacha-2.10.2 {basic foreacha tests (compiled) - nested, inner non-compiled} { + apply {{} { + foreacha {a b} [lsearch -all [lrepeat 1000 x] x] { + incr a [eval foreacha c 10 d [list [lrepeat $b $b] { incr c $b }]] + } + }} +} 332843490 + + + +# cleanup +catch {unset a} +catch {unset x} +catch {rename foo {}} +::tcltest::cleanupTests +return diff --git a/tests/mapeach.test b/tests/mapeach.test new file mode 100644 index 0000000..9ad9d72 --- /dev/null +++ b/tests/mapeach.test @@ -0,0 +1,493 @@ +# Commands covered: mapeach, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 2011 Trevor Davel +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +catch {unset a} +catch {unset i} +catch {unset x} + +# ----- Non-compiled operation ------------------------------------------------- + + +# Basic "mapeach" operation (non-compiled) + +test mapeach-1.1 {basic mapeach tests} { + set a {} + mapeach i {a b c d} { + set a [concat $a $i] + } +} {a {a b} {a b c} {a b c d}} +test mapeach-1.2 {basic mapeach tests} { + mapeach i {a b {{c d} e} {123 {{x}}}} { + set i + } +} {a b {{c d} e} {123 {{x}}}} +test mapeach-1.2a {basic mapeach tests} { + mapeach i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } +} {a b {{c d} e} {123 {{x}}}} +test mapeach-1.3 {basic mapeach tests} {catch {mapeach} msg} 1 +test mapeach-1.4 {basic mapeach tests} { + catch {mapeach} msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-1.5 {basic mapeach tests} {catch {mapeach i} msg} 1 +test mapeach-1.6 {basic mapeach tests} { + catch {mapeach i} msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-1.7 {basic mapeach tests} {catch {mapeach i j} msg} 1 +test mapeach-1.8 {basic mapeach tests} { + catch {mapeach i j} msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-1.9 {basic mapeach tests} {catch {mapeach i j k l} msg} 1 +test mapeach-1.10 {basic mapeach tests} { + catch {mapeach i j k l} msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-1.11 {basic mapeach tests} { + mapeach i {} { + set i + } +} {} +test mapeach-1.12 {basic mapeach tests} { + mapeach i {} { + return -level 0 x + } +} {} +test mapeach-1.13 {mapeach errors} { + list [catch {mapeach {{a}{b}} {1 2 3} {}} msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test mapeach-1.14 {mapeach errors} { + list [catch {mapeach a {{1 2}3} {}} msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test mapeach-1.15 {mapeach errors} { + catch {unset a} + set a(0) 44 + list [catch {mapeach a {1 2 3} {}} msg o] $msg $::errorInfo +} {1 {can't set "a": variable is array} {can't set "a": variable is array + (setting foreach loop variable "a") + invoked from within +"mapeach a {1 2 3} {}"}} +test mapeach-1.16 {mapeach errors} { + list [catch {mapeach {} {} {}} msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + + +# Parallel "mapeach" operation (non-compiled) + +test mapeach-2.1 {parallel mapeach tests} { + mapeach {a b} {1 2 3 4} { + list $b $a + } +} {{2 1} {4 3}} +test mapeach-2.2 {parallel mapeach tests} { + mapeach {a b} {1 2 3 4 5} { + list $b $a + } +} {{2 1} {4 3} {{} 5}} +test mapeach-2.3 {parallel mapeach tests} { + mapeach a {1 2 3} b {4 5 6} { + list $b $a + } +} {{4 1} {5 2} {6 3}} +test mapeach-2.4 {parallel mapeach tests} { + mapeach a {1 2 3} b {4 5 6 7 8} { + list $b $a + } +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test mapeach-2.5 {parallel mapeach tests} { + mapeach {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test mapeach-2.6 {parallel mapeach tests} { + mapeach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } +} {11111 22222 33333} +test mapeach-2.7 {parallel mapeach tests} { + mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } +} {{1111 2} 222 33 4} +test mapeach-2.8 {parallel mapeach tests} { + mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test mapeach-2.9 {mapeach only sets vars if repeating loop} { + namespace eval ::mapeach_test { + set rgb {65535 0 0} + mapeach {r g b} [set rgb] {} + set ::x "r=$r, g=$g, b=$b" + } + namespace delete ::mapeach_test + set x +} {r=65535, g=0, b=0} +test mapeach-2.10 {mapeach only supports local scalar variables} { + catch { unset a } + mapeach {a(3)} {1 2 3 4} {set {a(3)}} +} {1 2 3 4} +catch { unset a } + + +# "mapeach" with "continue" and "break" (non-compiled) + +test mapeach-3.1 {continue tests} { + mapeach i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } +} {a c d} +test mapeach-3.2 {continue tests} { + set x 0 + list [mapeach i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x +} {b 4} +test mapeach-3.3 {break tests} { + set x 0 + list [mapeach i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x +} {{a b} 3} +# Check for bug similar to #406709 +test mapeach-3.4 {break tests} { + set a 1 + mapeach b b {list [concat a; break]; incr a} + incr a +} {2} + + +# ----- Compiled operation ------------------------------------------------------ + +# Basic "mapeach" operation (compiled) + +test mapeach-4.1 {basic mapeach tests} { + apply {{} { + set a {} + mapeach i {a b c d} { + set a [concat $a $i] + } + }} +} {a {a b} {a b c} {a b c d}} +test mapeach-4.2 {basic mapeach tests} { + apply {{} { + mapeach i {a b {{c d} e} {123 {{x}}}} { + set i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test mapeach-4.2a {basic mapeach tests} { + apply {{} { + mapeach i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test mapeach-4.3 {basic mapeach tests} {catch { apply {{} { mapeach }} } msg} 1 +test mapeach-4.4 {basic mapeach tests} { + catch { apply {{} { mapeach }} } msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-4.5 {basic mapeach tests} {catch { apply {{} { mapeach i }} } msg} 1 +test mapeach-4.6 {basic mapeach tests} { + catch { apply {{} { mapeach i }} } msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-4.7 {basic mapeach tests} {catch { apply {{} { mapeach i j }} } msg} 1 +test mapeach-4.8 {basic mapeach tests} { + catch { apply {{} { mapeach i j }} } msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-4.9 {basic mapeach tests} {catch { apply {{} { mapeach i j k l }} } msg} 1 +test mapeach-4.10 {basic mapeach tests} { + catch { apply {{} { mapeach i j k l }} } msg + set msg +} {wrong # args: should be "mapeach varList list ?varList list ...? command"} +test mapeach-4.11 {basic mapeach tests} { + apply {{} { mapeach i {} { set i } }} +} {} +test mapeach-4.12 {basic mapeach tests} { + apply {{} { mapeach i {} { return -level 0 x } }} +} {} +test mapeach-4.13 {mapeach errors} { + list [catch { apply {{} { mapeach {{a}{b}} {1 2 3} {} }} } msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test mapeach-4.14 {mapeach errors} { + list [catch { apply {{} { mapeach a {{1 2}3} {} }} } msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test mapeach-4.15 {mapeach errors} { + apply {{} { + set a(0) 44 + list [catch {mapeach a {1 2 3} {}} msg o] $msg $::errorInfo + }} +} {1 {can't set "a": variable is array} {can't set "a": variable is array + while executing +"mapeach a {1 2 3} {}"}} +test mapeach-4.16 {mapeach errors} { + list [catch { apply {{} { mapeach {} {} {} }} } msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + + +# Parallel "mapeach" operation (compiled) + +test mapeach-5.1 {parallel mapeach tests} { + apply {{} { + mapeach {a b} {1 2 3 4} { + list $b $a + } + }} +} {{2 1} {4 3}} +test mapeach-5.2 {parallel mapeach tests} { + apply {{} { + mapeach {a b} {1 2 3 4 5} { + list $b $a + } + }} +} {{2 1} {4 3} {{} 5}} +test mapeach-5.3 {parallel mapeach tests} { + apply {{} { + mapeach a {1 2 3} b {4 5 6} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3}} +test mapeach-5.4 {parallel mapeach tests} { + apply {{} { + mapeach a {1 2 3} b {4 5 6 7 8} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test mapeach-5.5 {parallel mapeach tests} { + apply {{} { + mapeach {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } + }} +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test mapeach-5.6 {parallel mapeach tests} { + apply {{} { + mapeach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } + }} +} {11111 22222 33333} +test mapeach-5.7 {parallel mapeach tests} { + apply {{} { + mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } + }} +} {{1111 2} 222 33 4} +test mapeach-5.8 {parallel mapeach tests} { + apply {{} { + mapeach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } + }} +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test mapeach-5.9 {mapeach only sets vars if repeating loop} { + apply {{} { + set rgb {65535 0 0} + mapeach {r g b} [set rgb] {} + return "r=$r, g=$g, b=$b" + }} +} {r=65535, g=0, b=0} +test mapeach-5.10 {mapeach only supports local scalar variables} { + apply {{} { + mapeach {a(3)} {1 2 3 4} {set {a(3)}} + }} +} {1 2 3 4} + + +# "mapeach" with "continue" and "break" (compiled) + +test mapeach-6.1 {continue tests} { + apply {{} { + mapeach i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } + }} +} {a c d} +test mapeach-6.2 {continue tests} { + apply {{} { + list [mapeach i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x + }} +} {b 4} +test mapeach-6.3 {break tests} { + apply {{} { + list [mapeach i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x + }} +} {{a b} 3} +# Check for bug similar to #406709 +test mapeach-6.4 {break tests} { + apply {{} { + set a 1 + mapeach b b {list [concat a; break]; incr a} + incr a + }} +} {2} + + + +# ----- Special cases and bugs ------------------------------------------------- + + +test mapeach-7.1 {compiled mapeach backward jump works correctly} { + catch {unset x} + array set x {0 zero 1 one 2 two 3 three} + lsort [apply {{arrayName} { + upvar 1 $arrayName a + mapeach member [array names a] { + list $member [set a($member)] + } + }} x] +} [lsort {{0 zero} {1 one} {2 two} {3 three}}] + +test mapeach-7.2 {noncompiled mapeach and shared variable or value list objects that are converted to another type} { + catch {unset x} + mapeach {12.0} {a b c} { + set x 12.0 + set x [expr $x + 1] + } +} {13.0 13.0 13.0} + +# Test for incorrect "double evaluation" semantics +test mapeach-7.3 {delayed substitution of body} { + apply {{} { + set a 0 + mapeach a [list 1 2 3] " + set x $a + " + set x + }} +} {0} + +# Related to "foreach" test for [Bug 1189274]; crash on failure +test mapeach-7.4 {empty list handling} { + proc crash {} { + rename crash {} + set a "x y z" + set b "" + mapeach aa $a bb $b { set x "aa = $aa bb = $bb" } + } + crash +} {{aa = x bb = } {aa = y bb = } {aa = z bb = }} + +# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled version +test mapeach-7.5 {compiled empty var list} { + proc foo {} { + mapeach {} x { + error "reached body" + } + } + list [catch { foo } msg] $msg +} {1 {foreach varlist is empty}} + +test mapeach-7.6 {mapeach: related to "foreach" [Bug 1671087]} -setup { + proc demo {} { + set vals {1 2 3 4} + trace add variable x write {string length $vals ;# } + mapeach {x y} $vals {format $y} + } +} -body { + demo +} -cleanup { + rename demo {} +} -result {2 4} + +# Huge lists must not overflow the bytecode interpreter (development bug) +test mapeach-7.7 {huge list non-compiled} { + set x [mapeach a [lrepeat 1000000 x] { set b y$a }] + list $b [llength $x] [string length $x] +} {yx 1000000 2999999} + +test mapeach-7.8 {huge list compiled} { + set x [apply {{times} { mapeach a [lrepeat $times x] { set b y$a }}} 1000000] + list $b [llength $x] [string length $x] +} {yx 1000000 2999999} + +test mapeach-7.9 {error then dereference loop var (dev bug)} { + catch { mapeach a 0 b {1 2 3} { error x } } + set a +} 0 +test mapeach-7.9a {error then dereference loop var (dev bug)} { + catch { mapeach a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + +# ----- Coroutines ------------------------------------------------------------- + +test mapeach-8.1 {mapeach non-compiled with coroutines} { + coroutine coro apply {{} { + set values [yield [info coroutine]] + eval mapeach i [list $values] {{ yield $i }} + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} {{1 2 3 4 5 6} {}} + +test mapeach-8.2 {mapeach compiled with coroutines} { + coroutine coro apply {{} { + set values [yield [info coroutine]] + mapeach i $values { yield $i } + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} {{1 2 3 4 5 6} {}} + + +# cleanup +catch {unset a} +catch {unset x} +catch {rename foo {}} +::tcltest::cleanupTests +return -- cgit v0.12 From c1c198bb1f699e668cb78c2bf0275ceb6eb25435 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 4 Aug 2012 12:09:26 +0000 Subject: Reduce the amount of ifdeffery somewhat by requiring at least OSX Tiger. That's now everyone we care to support, given that the version after is now not supported by Apple... --- unix/tclLoadDyld.c | 252 +++++++++++++++++------------------------------------ 1 file changed, 78 insertions(+), 174 deletions(-) diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 31d15b2..95735a4 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -16,42 +16,36 @@ #include "tclInt.h" #ifndef MODULE_SCOPE -#define MODULE_SCOPE extern +# define MODULE_SCOPE extern #endif -#ifndef TCL_DYLD_USE_DLFCN /* * Use preferred dlfcn API on 10.4 and later */ -# if !defined(NO_DLFCN_H) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1040 -# define TCL_DYLD_USE_DLFCN 1 -# else + +#ifndef TCL_DYLD_USE_DLFCN +# ifdef NO_DLFCN_H # define TCL_DYLD_USE_DLFCN 0 +# else +# define TCL_DYLD_USE_DLFCN 1 # endif #endif -#ifndef TCL_DYLD_USE_NSMODULE + /* * Use deprecated NSModule API only to support 10.3 and earlier: */ -# if MAC_OS_X_VERSION_MIN_REQUIRED < 1040 -# define TCL_DYLD_USE_NSMODULE 1 -# else -# define TCL_DYLD_USE_NSMODULE 0 -# endif + +#ifndef TCL_DYLD_USE_NSMODULE +# define TCL_DYLD_USE_NSMODULE 0 #endif -#if TCL_DYLD_USE_DLFCN -#include -#if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040 /* - * Support for weakly importing dlfcn API. + * Use includes for the API we're using. */ -extern void *dlopen(const char *path, int mode) WEAK_IMPORT_ATTRIBUTE; -extern void *dlsym(void *handle, const char *symbol) WEAK_IMPORT_ATTRIBUTE; -extern int dlclose(void *handle) WEAK_IMPORT_ATTRIBUTE; -extern char *dlerror(void) WEAK_IMPORT_ATTRIBUTE; -#endif -#endif + +#if TCL_DYLD_USE_DLFCN +# include +#endif /* TCL_DYLD_USE_DLFCN */ #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) #include @@ -60,38 +54,23 @@ extern char *dlerror(void) WEAK_IMPORT_ATTRIBUTE; #include #include #include -#include typedef struct Tcl_DyldModuleHandle { struct Tcl_DyldModuleHandle *nextPtr; NSModule module; } Tcl_DyldModuleHandle; -#endif /* TCL_DYLD_USE_NSMODULE */ +#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */ -typedef struct Tcl_DyldLoadHandle { -#if TCL_DYLD_USE_DLFCN +typedef struct { void *dlHandle; -#endif #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) const struct mach_header *dyldLibHeader; Tcl_DyldModuleHandle *modulePtr; #endif } Tcl_DyldLoadHandle; -#if (TCL_DYLD_USE_DLFCN && MAC_OS_X_VERSION_MIN_REQUIRED < 1040) || \ - defined(TCL_LOAD_FROM_MEMORY) -MODULE_SCOPE long tclMacOSXDarwinRelease; -#endif - -#ifdef TCL_DEBUG_LOAD -#define TclLoadDbgMsg(m, ...) \ - do { \ - fprintf(stderr, "%s:%d: %s(): " m ".\n", \ - strrchr(__FILE__, '/')+1, __LINE__, __func__, \ - ##__VA_ARGS__); \ - } while (0) -#else -#define TclLoadDbgMsg(m, ...) +#if TCL_DYLD_USE_DLFCN || defined(TCL_LOAD_FROM_MEMORY) +MODULE_SCOPE long tclMacOSXDarwinRelease; #endif /* @@ -102,7 +81,6 @@ static void * FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol); static void UnloadFile(Tcl_LoadHandle handle); -#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) /* *---------------------------------------------------------------------- * @@ -120,6 +98,7 @@ static void UnloadFile(Tcl_LoadHandle handle); *---------------------------------------------------------------------- */ +#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) static const char * DyldOFIErrorMsg( int err) @@ -141,7 +120,7 @@ DyldOFIErrorMsg( return "unknown error"; } } -#endif /* TCL_DYLD_USE_NSMODULE */ +#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */ /* *---------------------------------------------------------------------- @@ -176,9 +155,7 @@ TclpDlopen( { Tcl_DyldLoadHandle *dyldLoadHandle; Tcl_LoadHandle newHandle; -#if TCL_DYLD_USE_DLFCN void *dlHandle = NULL; -#endif #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) const struct mach_header *dyldLibHeader = NULL; Tcl_DyldModuleHandle *modulePtr = NULL; @@ -187,11 +164,10 @@ TclpDlopen( NSLinkEditErrors editError; int errorNumber; const char *errorName, *objFileImageErrMsg = NULL; -#endif +#endif /* TCL_DYLD_USE_NSMODULE */ const char *errMsg = NULL; int result; Tcl_DString ds; - char *fileName = NULL; const char *nativePath, *nativeFileName = NULL; /* @@ -201,46 +177,36 @@ TclpDlopen( */ nativePath = Tcl_FSGetNativePath(pathPtr); + nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), + -1, &ds); #if TCL_DYLD_USE_DLFCN -#if MAC_OS_X_VERSION_MIN_REQUIRED < 1040 - if (tclMacOSXDarwinRelease >= 8) -#endif - { /* * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070] */ - dlHandle = dlopen(nativePath, RTLD_NOW | RTLD_LOCAL); - if (!dlHandle) { - /* - * Let the OS loader examine the binary search path for whatever - * string the user gave us which hopefully refers to a file on the - * binary path. - */ - fileName = Tcl_GetString(pathPtr); - nativeFileName = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - /* - * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070] - */ - dlHandle = dlopen(nativeFileName, RTLD_NOW | RTLD_LOCAL); - } - if (dlHandle) { - TclLoadDbgMsg("dlopen() successful"); - } else { + dlHandle = dlopen(nativePath, RTLD_NOW | RTLD_LOCAL); + if (!dlHandle) { + /* + * Let the OS loader examine the binary search path for whatever string + * the user gave us which hopefully refers to a file on the binary + * path. + * + * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070] + */ + + dlHandle = dlopen(nativeFileName, RTLD_NOW | RTLD_LOCAL); + if (!dlHandle) { errMsg = dlerror(); - TclLoadDbgMsg("dlopen() failed: %s", errMsg); } } - if (!dlHandle) #endif /* TCL_DYLD_USE_DLFCN */ - { + + if (!dlHandle) { #if TCL_DYLD_USE_NSMODULE dyldLibHeader = NSAddImage(nativePath, NSADDIMAGE_OPTION_RETURN_ON_ERROR); - if (dyldLibHeader) { - TclLoadDbgMsg("NSAddImage() successful"); - } else { + if (!dyldLibHeader) { NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); if (editError == NSLinkEditFileAccessError) { /* @@ -249,20 +215,12 @@ TclpDlopen( * which hopefully refers to a file on the binary path. */ - if (!fileName) { - fileName = Tcl_GetString(pathPtr); - nativeFileName = Tcl_UtfToExternalDString(NULL, fileName, - -1, &ds); - } dyldLibHeader = NSAddImage(nativeFileName, NSADDIMAGE_OPTION_WITH_SEARCHING | NSADDIMAGE_OPTION_RETURN_ON_ERROR); - if (dyldLibHeader) { - TclLoadDbgMsg("NSAddImage() successful"); - } else { + if (!dyldLibHeader) { NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - TclLoadDbgMsg("NSAddImage() failed: %s", errMsg); } } else if ((editError == NSLinkEditFileFormatError && errorNumber == EBADMACHO) @@ -279,8 +237,6 @@ TclpDlopen( err = NSCreateObjectFileImageFromFile(nativePath, &dyldObjFileImage); if (err == NSObjectFileImageSuccess && dyldObjFileImage) { - TclLoadDbgMsg("NSCreateObjectFileImageFromFile() " - "successful"); module = NSLinkModule(dyldObjFileImage, nativePath, NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR); @@ -289,37 +245,29 @@ TclpDlopen( modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = NULL; - TclLoadDbgMsg("NSLinkModule() successful"); } else { NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - TclLoadDbgMsg("NSLinkModule() failed: %s", errMsg); } } else { objFileImageErrMsg = DyldOFIErrorMsg(err); - TclLoadDbgMsg("NSCreateObjectFileImageFromFile() failed: " - "%s", objFileImageErrMsg); } } } #endif /* TCL_DYLD_USE_NSMODULE */ } - if (0 -#if TCL_DYLD_USE_DLFCN - || dlHandle -#endif + + if (dlHandle #if TCL_DYLD_USE_NSMODULE || dyldLibHeader || modulePtr -#endif +#endif /* TCL_DYLD_USE_NSMODULE */ ) { dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle)); -#if TCL_DYLD_USE_DLFCN dyldLoadHandle->dlHandle = dlHandle; -#endif #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) dyldLoadHandle->dyldLibHeader = dyldLibHeader; dyldLoadHandle->modulePtr = modulePtr; -#endif +#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */ newHandle = ckalloc(sizeof(*newHandle)); newHandle->clientData = dyldLoadHandle; newHandle->findSymbolProcPtr = &FindSymbol; @@ -328,18 +276,23 @@ TclpDlopen( *loadHandle = newHandle; result = TCL_OK; } else { - Tcl_AppendResult(interp, errMsg, NULL); + Tcl_Obj *errObj = Tcl_NewObj(); + + if (errMsg != NULL) { + Tcl_AppendToObj(errObj, errMsg, -1); + } #if TCL_DYLD_USE_NSMODULE if (objFileImageErrMsg) { - Tcl_AppendResult(interp, "\nNSCreateObjectFileImageFromFile() " - "error: ", objFileImageErrMsg, NULL); + Tcl_AppendPrintfToObj(errObj, + "\nNSCreateObjectFileImageFromFile() error: %s", + objFileImageErrMsg); } -#endif +#endif /* TCL_DYLD_USE_NSMODULE */ + Tcl_SetObjResult(interp, errObj); result = TCL_ERROR; } - if(fileName) { - Tcl_DStringFree(&ds); - } + + Tcl_DStringFree(&ds); return result; } @@ -372,18 +325,14 @@ FindSymbol( const char *native; native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); -#if TCL_DYLD_USE_DLFCN if (dyldLoadHandle->dlHandle) { +#if TCL_DYLD_USE_DLFCN proc = dlsym(dyldLoadHandle->dlHandle, native); - if (proc) { - TclLoadDbgMsg("dlsym() successful"); - } else { + if (!proc) { errMsg = dlerror(); - TclLoadDbgMsg("dlsym() failed: %s", errMsg); } - } else #endif /* TCL_DYLD_USE_DLFCN */ - { + } else { #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) NSSymbol nsSymbol = NULL; Tcl_DString newName; @@ -400,13 +349,12 @@ FindSymbol( native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR); if (nsSymbol) { - TclLoadDbgMsg("NSLookupSymbolInImage() successful"); -#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING /* * Until dyld supports unloading of MY_DYLIB binaries, the * following is not needed. */ +#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING NSModule module = NSModuleForSymbol(nsSymbol); Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr; @@ -429,32 +377,21 @@ FindSymbol( const char *errorName; NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - TclLoadDbgMsg("NSLookupSymbolInImage() failed: %s", errMsg); } } else if (dyldLoadHandle->modulePtr) { nsSymbol = NSLookupSymbolInModule( dyldLoadHandle->modulePtr->module, native); - if (nsSymbol) { - TclLoadDbgMsg("NSLookupSymbolInModule() successful"); - } else { - TclLoadDbgMsg("NSLookupSymbolInModule() failed"); - } } if (nsSymbol) { proc = NSAddressOfSymbol(nsSymbol); - if (proc) { - TclLoadDbgMsg("NSAddressOfSymbol() successful"); - } else { - TclLoadDbgMsg("NSAddressOfSymbol() failed"); - } } Tcl_DStringFree(&newName); #endif /* TCL_DYLD_USE_NSMODULE */ } Tcl_DStringFree(&ds); if (errMsg && (interp != NULL)) { - Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\": ", - errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\": %s", symbol, errMsg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } @@ -489,34 +426,19 @@ UnloadFile( { Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData; -#if TCL_DYLD_USE_DLFCN if (dyldLoadHandle->dlHandle) { - int result; - - result = dlclose(dyldLoadHandle->dlHandle); - if (!result) { - TclLoadDbgMsg("dlclose() successful"); - } else { - TclLoadDbgMsg("dlclose() failed: %s", dlerror()); - } - } else +#if TCL_DYLD_USE_DLFCN + (void) dlclose(dyldLoadHandle->dlHandle); #endif /* TCL_DYLD_USE_DLFCN */ - { + } else { #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr; while (modulePtr != NULL) { - void *ptr; - bool result; + void *ptr = modulePtr; - result = NSUnLinkModule(modulePtr->module, + (void) NSUnLinkModule(modulePtr->module, NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES); - if (result) { - TclLoadDbgMsg("NSUnLinkModule() successful"); - } else { - TclLoadDbgMsg("NSUnLinkModule() failed"); - } - ptr = modulePtr; modulePtr = modulePtr->nextPtr; ckfree(ptr); } @@ -556,7 +478,6 @@ TclGuessPackageName( return 0; } -#ifdef TCL_LOAD_FROM_MEMORY /* *---------------------------------------------------------------------- * @@ -573,6 +494,7 @@ TclGuessPackageName( *---------------------------------------------------------------------- */ +#ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void * TclpLoadMemoryGetBuffer( Tcl_Interp *interp, /* Used for error reporting. */ @@ -597,6 +519,7 @@ TclpLoadMemoryGetBuffer( } return buffer; } +#endif /* TCL_LOAD_FROM_MEMORY */ /* *---------------------------------------------------------------------- @@ -616,6 +539,7 @@ TclpLoadMemoryGetBuffer( *---------------------------------------------------------------------- */ +#ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE int TclpLoadMemory( Tcl_Interp *interp, /* Used for error reporting. */ @@ -658,7 +582,7 @@ TclpLoadMemory( # define mh_size sizeof(struct mach_header_64) # define mh_magic MH_MAGIC_64 # define arch_abi CPU_ARCH_ABI64 -#endif +#endif /* __LP64__ */ if ((size_t) codeSize >= sizeof(struct fat_header) && fh->magic == OSSwapHostToBigInt32(FAT_MAGIC)) { @@ -668,7 +592,6 @@ TclpLoadMemory( * Fat binary, try to find mach_header for our architecture */ - TclLoadDbgMsg("Fat binary, %d archs", fh_nfat_arch); if ((size_t) codeSize >= sizeof(struct fat_header) + fh_nfat_arch * sizeof(struct fat_arch)) { void *fatarchs = (char*)buffer + sizeof(struct fat_header); @@ -681,22 +604,15 @@ TclpLoadMemory( fa = NXFindBestFatArch(arch->cputype | arch_abi, arch->cpusubtype, fatarchs, fh_nfat_arch); if (fa) { - TclLoadDbgMsg("NXFindBestFatArch() successful: " - "local cputype %d subtype %d, " - "fat cputype %d subtype %d", - arch->cputype | arch_abi, arch->cpusubtype, - fa->cputype, fa->cpusubtype); - mh = (void*)((char*)buffer + fa->offset); + mh = (void *)((char *) buffer + fa->offset); ms = fa->size; } else { - TclLoadDbgMsg("NXFindBestFatArch() failed"); err = NSObjectFileImageInappropriateFile; } if (fh->magic != FAT_MAGIC) { swap_fat_arch(fatarchs, fh_nfat_arch, arch->byteorder); } } else { - TclLoadDbgMsg("Fat binary header failure"); err = NSObjectFileImageInappropriateFile; } } else { @@ -704,26 +620,18 @@ TclpLoadMemory( * Thin binary */ - TclLoadDbgMsg("Thin binary"); mh = buffer; ms = codeSize; } if (ms && !(ms >= mh_size && mh->magic == mh_magic && mh->filetype == MH_BUNDLE)) { - TclLoadDbgMsg("Inappropriate file: magic %x filetype %d", - mh->magic, mh->filetype); err = NSObjectFileImageInappropriateFile; } if (err == NSObjectFileImageSuccess) { err = NSCreateObjectFileImageFromMemory(buffer, codeSize, &dyldObjFileImage); - if (err == NSObjectFileImageSuccess) { - TclLoadDbgMsg("NSCreateObjectFileImageFromMemory() " - "successful"); - } else { + if (err != NSObjectFileImageSuccess) { objFileImageErrMsg = DyldOFIErrorMsg(err); - TclLoadDbgMsg("NSCreateObjectFileImageFromMemory() failed: %s", - objFileImageErrMsg); } } else { objFileImageErrMsg = DyldOFIErrorMsg(err); @@ -738,8 +646,9 @@ TclpLoadMemory( if (dyldObjFileImage == NULL) { vm_deallocate(mach_task_self(), (vm_address_t) buffer, size); if (objFileImageErrMsg != NULL) { - Tcl_AppendResult(interp, "NSCreateObjectFileImageFromMemory() " - "error: ", objFileImageErrMsg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "NSCreateObjectFileImageFromMemory() error: ", + objFileImageErrMsg)); } return TCL_ERROR; } @@ -751,16 +660,13 @@ TclpLoadMemory( module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]", NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR); NSDestroyObjectFileImage(dyldObjFileImage); - if (module) { - TclLoadDbgMsg("NSLinkModule() successful"); - } else { + if (!module) { NSLinkEditErrors editError; int errorNumber; const char *errorName, *errMsg; NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - TclLoadDbgMsg("NSLinkModule() failed: %s", errMsg); - Tcl_AppendResult(interp, errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); return TCL_ERROR; } @@ -772,9 +678,7 @@ TclpLoadMemory( modulePtr->module = module; modulePtr->nextPtr = NULL; dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle)); -#if TCL_DYLD_USE_DLFCN dyldLoadHandle->dlHandle = NULL; -#endif dyldLoadHandle->dyldLibHeader = NULL; dyldLoadHandle->modulePtr = modulePtr; newHandle = ckalloc(sizeof(*newHandle)); -- cgit v0.12 From 911e356870519d1379c9246402fcfdd3076c484c Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 4 Aug 2012 13:04:41 +0000 Subject: more result generation conversion --- unix/tclLoadDl.c | 10 +++++----- unix/tclLoadNext.c | 27 +++++++++++++-------------- unix/tclLoadOSF.c | 12 +++++++----- unix/tclLoadShl.c | 11 ++++++----- win/tclWinLoad.c | 34 ++++++++++++++++++---------------- 5 files changed, 49 insertions(+), 45 deletions(-) diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index d86e7fd..4f9c6b8 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -112,8 +112,9 @@ TclpDlopen( const char *errorStr = dlerror(); - Tcl_AppendResult(interp, "couldn't load file \"", - Tcl_GetString(pathPtr), "\": ", errorStr, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load file \"%s\": %s", + Tcl_GetString(pathPtr), errorStr)); return TCL_ERROR; } newHandle = ckalloc(sizeof(*newHandle)); @@ -175,9 +176,8 @@ FindSymbol( } Tcl_DStringFree(&ds); if (proc == NULL && interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\": ", - dlerror(), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\": %s", symbol, dlerror()); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index c74a29a..06df2db 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -16,10 +16,9 @@ /* Static procedures defined within this file */ -static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, - const char* symbol); -static void UnloadFile(Tcl_LoadHandle loadHandle); - +static void * FindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, const char* symbol); +static void UnloadFile(Tcl_LoadHandle loadHandle); /* *---------------------------------------------------------------------- @@ -93,15 +92,15 @@ TclpDlopen( char *data; int len, maxlen; - NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); - Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", - data, NULL); + NXGetMemoryBuffer(errorStream, &data, &len, &maxlen); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load file \"%s\": %s", fileName, data)); NXCloseMemory(errorStream, NX_FREEBUFFER); return TCL_ERROR; } NXCloseMemory(errorStream, NX_FREEBUFFER); - newHandle = ckalloc(sizeof(*newHandle)); + newHandle = ckalloc(sizeof(Tcl_LoadHandle)); newHandle->clientData = INT2PTR(1); newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; @@ -127,25 +126,25 @@ TclpDlopen( *---------------------------------------------------------------------- */ -static void* +static void * FindSymbol( Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol) { Tcl_PackageInitProc *proc = NULL; - if (symbol) { + + if (symbol) { char sym[strlen(symbol) + 2]; sym[0] = '_'; sym[1] = 0; strcat(sym, symbol); - rld_lookup(NULL, sym, (unsigned long *)&proc); + rld_lookup(NULL, sym, (unsigned long *) &proc); } if (proc == NULL && interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot find symbol \"", symbol, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\"", symbol)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } return proc; diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index fbd4d5f..6515b89 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -103,8 +103,9 @@ TclpDlopen( } if (lm == LDR_NULL_MODULE) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load file \"%s\": %s", + fileName, Tcl_PosixError(interp)); return TCL_ERROR; } @@ -155,10 +156,11 @@ FindSymbol( Tcl_LoadHandle loadHandle, const char *symbol) { - void* retval = ldr_lookup_package((char *)loadHandle, symbol); + void *retval = ldr_lookup_package((char *) loadHandle, symbol); + if (retval == NULL && interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot find symbol\"", symbol, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\"", symbol)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } return retval; diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index eddd80a..968f232 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -100,8 +100,9 @@ TclpDlopen( } if (handle == NULL) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load file \"%s\": %s", + fileName, Tcl_PosixError(interp))); return TCL_ERROR; } newHandle = ckalloc(sizeof(*newHandle)); @@ -155,9 +156,9 @@ FindSymbol( Tcl_DStringFree(&newName); } if (proc == NULL && interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot find symbol\"", symbol, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\": %s", + symbol, Tcl_PosixError(interp))); } return proc; } diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index b59ccba..6294086 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -91,9 +91,8 @@ TclpDlopen( if (hInstance == NULL) { DWORD lastError = GetLastError(); - - Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", NULL); + Tcl_Obj *errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", + Tcl_GetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, @@ -109,29 +108,30 @@ TclpDlopen( case ERROR_DLL_NOT_FOUND: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL); notFoundMsg: - Tcl_AppendResult(interp, "this library or a dependent library" - " could not be found in library path", NULL); + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " could not be found in library path", -1); break; case ERROR_PROC_NOT_FOUND: Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); - Tcl_AppendResult(interp, "A function specified in the import" - " table could not be resolved by the system. Windows" - " is not telling which one, I'm sorry.", NULL); + Tcl_AppendToObj(errMsg, "A function specified in the import" + " table could not be resolved by the system. Windows" + " is not telling which one, I'm sorry.", -1); break; case ERROR_INVALID_DLL: Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); - Tcl_AppendResult(interp, "this library or a dependent library" - " is damaged", NULL); + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " is damaged", -1); break; case ERROR_DLL_INIT_FAILED: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); - Tcl_AppendResult(interp, "the library initialization" - " routine failed", NULL); + Tcl_AppendToObj(errMsg, "the library initialization" + " routine failed", -1); break; default: TclWinConvertError(lastError); - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); + Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1); } + Tcl_SetObjResult(interp, errMsg); return TCL_ERROR; } @@ -190,7 +190,8 @@ FindSymbol( Tcl_DStringFree(&ds); } if (proc == NULL && interp != NULL) { - Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\"", symbol)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } return proc; @@ -286,8 +287,9 @@ TclpTempFileNameForLibrary( Tcl_MutexLock(&dllDirectoryNameMutex); if (dllDirectoryName == NULL) { if (InitDLLDirectoryName() == TCL_ERROR) { - Tcl_AppendResult(interp, "couldn't create temporary directory: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create temporary directory: %s", + Tcl_PosixError(interp))); Tcl_MutexUnlock(&dllDirectoryNameMutex); return NULL; } -- cgit v0.12 From 26c44cb82bf68dc8c98700b4c5aca7da3d913877 Mon Sep 17 00:00:00 2001 From: stwo Date: Sat, 4 Aug 2012 18:54:45 +0000 Subject: Unbreak. --- unix/tclLoadDl.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 4f9c6b8..f8fe6d3 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -177,7 +177,7 @@ FindSymbol( Tcl_DStringFree(&ds); if (proc == NULL && interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "cannot find symbol \"%s\": %s", symbol, dlerror()); + "cannot find symbol \"%s\": %s", symbol, dlerror())); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } -- cgit v0.12 From 0f97712d765005441870b6e919297456e986be02 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 5 Aug 2012 12:09:12 +0000 Subject: Final part of result generation conversion (modulo any minor blunders) --- generic/tclIO.c | 125 +++++++++++++++++++++------------------- generic/tclIOCmd.c | 152 +++++++++++++++++++++++++------------------------ generic/tclIOGT.c | 4 +- generic/tclIORChan.c | 129 ++++++++++++++++++++++------------------- generic/tclIORTrans.c | 111 +++++++++++++++++++----------------- generic/tclIOSock.c | 36 ++++++------ generic/tclIOUtil.c | 102 ++++++++++++++++++--------------- macosx/tclMacOSXFCmd.c | 57 ++++++++++--------- unix/tclUnixChan.c | 75 ++++++++++++------------ unix/tclUnixFCmd.c | 81 +++++++++++++------------- unix/tclUnixFile.c | 13 ++--- unix/tclUnixPipe.c | 64 +++++++++++---------- unix/tclUnixSock.c | 146 +++++++++++++++++++++++++---------------------- win/tclWinChan.c | 16 +++--- win/tclWinDde.c | 7 ++- win/tclWinFCmd.c | 16 +++--- win/tclWinFile.c | 12 ++-- win/tclWinPipe.c | 37 ++++++------ win/tclWinReg.c | 33 +++++------ win/tclWinSerial.c | 143 ++++++++++++++++++++-------------------------- win/tclWinSock.c | 42 +++++++------- 21 files changed, 730 insertions(+), 671 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 2de8b53..4e24533 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1027,8 +1027,9 @@ Tcl_UnregisterChannel( if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp != NULL) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -1263,8 +1264,8 @@ Tcl_GetChannel( hTblPtr = GetChannelTable(interp); hPtr = Tcl_FindHashEntry(hTblPtr, name); if (hPtr == NULL) { - Tcl_AppendResult(interp, "can not find channel named \"", chanName, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can not find channel named \"%s\"", chanName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, NULL); return NULL; } @@ -1584,8 +1585,9 @@ Tcl_StackChannel( if (statePtr == NULL) { if (interp) { - Tcl_AppendResult(interp, "couldn't find state for channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find state for channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1605,9 +1607,9 @@ Tcl_StackChannel( if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { if (interp) { - Tcl_AppendResult(interp, - "reading and writing both disallowed for channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "reading and writing both disallowed for channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1630,8 +1632,9 @@ Tcl_StackChannel( statePtr->csPtrR = csPtrR; statePtr->csPtrW = csPtrW; if (interp) { - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName(prevChan), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not flush channel \"%s\"", + Tcl_GetChannelName(prevChan))); } return NULL; } @@ -1784,9 +1787,9 @@ Tcl_UnstackChannel( */ if (!TclChanCaughtErrorBypass(interp, chan) && interp) { - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not flush channel \"%s\"", + Tcl_GetChannelName((Tcl_Channel) chanPtr))); } return TCL_ERROR; } @@ -2318,8 +2321,8 @@ CheckForDeadChannel( Tcl_SetErrno(EINVAL); if (interp) { - Tcl_AppendResult(interp, "unable to access channel: invalid channel", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to access channel: invalid channel", -1)); } return 1; } @@ -3051,8 +3054,9 @@ Tcl_Close( if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -3210,8 +3214,9 @@ Tcl_CloseEx( */ if (!chanPtr->typePtr->close2Proc) { - Tcl_AppendResult(interp, "Half-close of channels not supported by ", - chanPtr->typePtr->typeName, "s", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "half-close of channels not supported by %ss", + chanPtr->typePtr->typeName)); return TCL_ERROR; } @@ -3220,9 +3225,8 @@ Tcl_CloseEx( */ if (chanPtr != statePtr->topChanPtr) { - Tcl_AppendResult(interp, - "Half-close not applicable to stack of transformations", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "half-close not applicable to stack of transformations", -1)); return TCL_ERROR; } @@ -3240,9 +3244,9 @@ Tcl_CloseEx( } else { msg = "write"; } - Tcl_AppendResult(interp, "Half-close of ", msg, - "-side not possible, side not opened or already closed", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened or" + " already closed", msg)); return TCL_ERROR; } @@ -3253,8 +3257,9 @@ Tcl_CloseEx( if (statePtr->flags & CHANNEL_INCLOSE) { if (interp) { - Tcl_AppendResult(interp, "Illegal recursive call to close " - "through close-handler of channel", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "illegal recursive call to close through close-handler" + " of channel", -1)); } return TCL_ERROR; } @@ -7547,6 +7552,7 @@ Tcl_BadChannelOption( const char **argv; int argc, i; Tcl_DString ds; + Tcl_Obj *errObj; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, genericopt, -1); @@ -7559,13 +7565,14 @@ Tcl_BadChannelOption( Tcl_Panic("malformed option list in channel driver"); } Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad option \"", optionName, - "\": should be one of ", NULL); + errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ", + optionName); argc--; for (i = 0; i < argc; i++) { - Tcl_AppendResult(interp, "-", argv[i], ", ", NULL); + Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]); } - Tcl_AppendResult(interp, "or -", argv[i], NULL); + Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]); + Tcl_SetObjResult(interp, errObj); Tcl_DStringFree(&ds); ckfree(argv); } @@ -7843,8 +7850,9 @@ Tcl_SetChannelOption( if (statePtr->csPtrR || statePtr->csPtrW) { if (interp) { - Tcl_AppendResult(interp, "unable to set channel options: " - "background copy in progress", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to set channel options: background copy in" + " progress", -1)); } return TCL_ERROR; } @@ -7893,8 +7901,9 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_LINEBUFFERED); SetFlag(statePtr, CHANNEL_UNBUFFERED); } else if (interp) { - Tcl_AppendResult(interp, "bad value for -buffering: " - "must be one of full, line, or none", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -buffering: must be one of" + " full, line, or none", -1)); return TCL_ERROR; } return TCL_OK; @@ -7949,8 +7958,9 @@ Tcl_SetChannelOption( if (inValue & 0x80 || outValue & 0x80) { if (interp) { - Tcl_AppendResult(interp, "bad value for -eofchar: ", - "must be non-NUL ASCII character", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -eofchar: must be non-NUL ASCII" + " character", -1)); } ckfree(argv); return TCL_ERROR; @@ -7963,9 +7973,9 @@ Tcl_SetChannelOption( } } else { if (interp) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: should be a list of zero," - " one, or two elements", NULL); + " one, or two elements", -1)); } ckfree(argv); return TCL_ERROR; @@ -7997,9 +8007,9 @@ Tcl_SetChannelOption( writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL; } else { if (interp) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be a one or two" - " element list", NULL); + " element list", -1)); } ckfree(argv); return TCL_ERROR; @@ -8027,10 +8037,9 @@ Tcl_SetChannelOption( translation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_AppendResult(interp, - "bad value for -translation: " - "must be one of auto, binary, cr, lf, crlf," - " or platform", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -translation: must be one of " + "auto, binary, cr, lf, crlf, or platform", -1)); } ckfree(argv); return TCL_ERROR; @@ -8078,10 +8087,9 @@ Tcl_SetChannelOption( statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_AppendResult(interp, - "bad value for -translation: " - "must be one of auto, binary, cr, lf, crlf," - " or platform", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -translation: must be one of " + "auto, binary, cr, lf, crlf, or platform", -1)); } ckfree(argv); return TCL_ERROR; @@ -8901,8 +8909,8 @@ Tcl_FileEventObjCmd( chanPtr = (Channel *) chan; statePtr = chanPtr->state; if ((statePtr->flags & mask) == 0) { - Tcl_AppendResult(interp, "channel is not ", - (mask == TCL_READABLE) ? "readable" : "writable", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s", + (mask == TCL_READABLE) ? "readable" : "writable")); return TCL_ERROR; } @@ -9023,15 +9031,15 @@ TclCopyChannel( if (BUSY_STATE(inStatePtr, TCL_READABLE)) { if (interp) { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(inChan), "\" is busy", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" is busy", Tcl_GetChannelName(inChan))); } return TCL_ERROR; } if (BUSY_STATE(outStatePtr, TCL_WRITABLE)) { if (interp) { - Tcl_AppendResult(interp, "channel \"", - Tcl_GetChannelName(outChan), "\" is busy", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" is busy", Tcl_GetChannelName(outChan))); } return TCL_ERROR; } @@ -10157,8 +10165,9 @@ SetBlockMode( */ if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) { - Tcl_AppendResult(interp, "error setting blocking mode: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error setting blocking mode: %s", + Tcl_PosixError(interp))); } } else { /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 59856d0..005713d 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -174,9 +174,10 @@ Tcl_PutsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -201,8 +202,8 @@ Tcl_PutsObjCmd( error: if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error writing \"", TclGetString(chanObjPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -244,9 +245,10 @@ Tcl_FlushObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -259,9 +261,9 @@ Tcl_FlushObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error flushing \"", - TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error flushing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -306,9 +308,10 @@ Tcl_GetsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } @@ -326,10 +329,9 @@ Tcl_GetsObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -411,9 +413,10 @@ Tcl_ReadObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } i++; /* Consumed channel name. */ @@ -436,11 +439,11 @@ Tcl_ReadObjCmd( if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { #endif - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected non-negative integer but got \"", - TclGetString(objv[i]), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected non-negative integer but got \"%s\"", + TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + return TCL_ERROR; #if TCL_MAJOR_VERSION < 9 } newline = 1; @@ -460,10 +463,9 @@ Tcl_ReadObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; @@ -552,9 +554,9 @@ Tcl_SeekObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error during seek on \"", - TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during seek on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -679,9 +681,9 @@ Tcl_CloseObjCmd( */ if (!(dir & Tcl_GetChannelMode(chan))) { - Tcl_AppendResult(interp, "Half-close of ", dirOptions[index], - "-side not possible, side not opened or already closed", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened" + " or already closed", dirOptions[index])); return TCL_ERROR; } @@ -977,9 +979,9 @@ Tcl_ExecObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading output from command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading output from command: %s", + Tcl_PosixError(interp))); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; @@ -1048,9 +1050,10 @@ Tcl_FblockedObjCmd( if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } @@ -1174,7 +1177,7 @@ Tcl_OpenObjCmd( return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1479,8 +1482,8 @@ Tcl_SocketObjCmd( switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } async = 1; @@ -1488,8 +1491,8 @@ Tcl_SocketObjCmd( case SKT_MYADDR: a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myaddr option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myaddr option", -1)); return TCL_ERROR; } myaddr = TclGetString(objv[a]); @@ -1499,8 +1502,8 @@ Tcl_SocketObjCmd( a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myport option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myport option", -1)); return TCL_ERROR; } myPortName = TclGetString(objv[a]); @@ -1511,15 +1514,15 @@ Tcl_SocketObjCmd( } case SKT_SERVER: if (async == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } server = 1; a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -server option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -server option", -1)); return TCL_ERROR; } script = TclGetString(objv[a]); @@ -1531,8 +1534,8 @@ Tcl_SocketObjCmd( if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { - Tcl_AppendResult(interp, "option -myport is not valid for servers", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -myport is not valid for servers", -1)); return TCL_ERROR; } } else if (a < objc) { @@ -1599,9 +1602,9 @@ Tcl_SocketObjCmd( return TCL_ERROR; } } - Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_RegisterChannel(interp, chan); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1651,17 +1654,19 @@ Tcl_FcopyObjCmd( if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(objv[2]))); return TCL_ERROR; } @@ -1745,14 +1750,14 @@ ChanPendingObjCmd( switch ((enum options) index) { case PENDING_INPUT: - if ((mode & TCL_READABLE) == 0) { + if (!(mode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); } break; case PENDING_OUTPUT: - if ((mode & TCL_WRITABLE) == 0) { + if (!(mode & TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); @@ -1806,8 +1811,8 @@ ChanTruncateObjCmd( return TCL_ERROR; } if (length < 0) { - Tcl_AppendResult(interp, - "cannot truncate to negative length of file", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot truncate to negative length of file", -1)); return TCL_ERROR; } } else { @@ -1817,18 +1822,17 @@ ChanTruncateObjCmd( length = Tcl_Tell(chan); if (length == Tcl_WideAsLong(-1)) { - Tcl_AppendResult(interp, - "could not determine current location in \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not determine current location in \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } } if (Tcl_TruncateChannel(chan, length) != TCL_OK) { - Tcl_AppendResult(interp, "error during truncate on \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during truncate on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 6f80c25..bfe6a10 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -284,8 +284,8 @@ TclChannelTransform( dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr, mode, chan); if (dataPtr->self == NULL) { - Tcl_AppendResult(interp, "\nfailed to stack channel \"", - Tcl_GetChannelName(chan), "\"", NULL); + Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), + "\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan)); Tcl_DecrRefCount(dataPtr->command); ResultClear(&dataPtr->result); ckfree(dataPtr); diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index eeb11f9..a354d60 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -404,25 +404,25 @@ static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ - if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ } #define PassReceivedErrorInterp(i,p) \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ FreeReceivedError(p) #define PassReceivedError(c,p) \ Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ FreeReceivedError(p) #define ForwardSetStaticError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ (p)->base.msgStr = (char *) (emsg) #define ForwardSetDynamicError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); @@ -775,13 +775,15 @@ TclChanCreateObjCmd( */ typedef struct ReflectEvent { - Tcl_Event header; - ReflectedChannel* rcPtr; - int events; + Tcl_Event header; + ReflectedChannel *rcPtr; + int events; } ReflectEvent; static int -ReflectEventRun (Tcl_Event* ev, int flags) +ReflectEventRun( + Tcl_Event *ev, + int flags) { /* OWNER thread * @@ -790,14 +792,16 @@ ReflectEventRun (Tcl_Event* ev, int flags) * accomplishing that. */ - ReflectEvent* e = (ReflectEvent*) ev; + ReflectEvent *e = (ReflectEvent *) ev; - Tcl_NotifyChannel (e->rcPtr->chan, e->events); + Tcl_NotifyChannel(e->rcPtr->chan, e->events); return 1; } static int -ReflectEventDelete (Tcl_Event* ev, ClientData cd) +ReflectEventDelete( + Tcl_Event *ev, + ClientData cd) { /* OWNER thread * @@ -806,11 +810,9 @@ ReflectEventDelete (Tcl_Event* ev, ClientData cd) * invalid channel. */ - ReflectEvent* e = (ReflectEvent*) ev; + ReflectEvent *e = (ReflectEvent *) ev; - if ((ev->proc != ReflectEventRun) || - ((cd != NULL) && - (cd != e->rcPtr))) { + if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) { return 0; } return 1; @@ -868,8 +870,8 @@ TclChanPostEventObjCmd( hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId); if (hPtr == NULL) { - Tcl_AppendResult(interp, "can not find reflected channel named \"", - chanId, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can not find reflected channel named \"%s\"", chanId)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL); return TCL_ERROR; } @@ -926,8 +928,9 @@ TclChanPostEventObjCmd( */ if (events & ~rcPtr->interest) { - Tcl_AppendResult(interp, "tried to post events channel \"", chanId, - "\" is not interested in", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "tried to post events channel \"%s\" is not interested in", + chanId)); return TCL_ERROR; } @@ -938,10 +941,11 @@ TclChanPostEventObjCmd( #ifdef TCL_THREADS if (rcPtr->owner == rcPtr->thread) { #endif - Tcl_NotifyChannel (chan, events); + Tcl_NotifyChannel(chan, events); #ifdef TCL_THREADS } else { - ReflectEvent* ev = ckalloc (sizeof (ReflectEvent)); + ReflectEvent *ev = ckalloc(sizeof(ReflectEvent)); + ev->header.proc = ReflectEventRun; ev->events = events; ev->rcPtr = rcPtr; @@ -958,7 +962,8 @@ TclChanPostEventObjCmd( * The teardown of unprocessed events is currently coupled to the * thread reflected channel map */ - (void) GetThreadReflectedChannelMap (); + + (void) GetThreadReflectedChannelMap(); /* XXX Race condition !! * XXX The destination thread may not exist anymore already. @@ -966,8 +971,9 @@ TclChanPostEventObjCmd( * XXX Can we detect this ? (check the validity of the owner threadid ?) * XXX Actually, in that case the channel should be dead also ! */ - Tcl_ThreadQueueEvent (rcPtr->owner, (Tcl_Event*) ev, TCL_QUEUE_TAIL); - Tcl_ThreadAlert (rcPtr->owner); + + Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL); + Tcl_ThreadAlert(rcPtr->owner); } #endif @@ -1157,8 +1163,11 @@ ReflectClose( ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* Now squash the pending reflection events for this channel. */ - Tcl_DeleteEvents (ReflectEventDelete, rcPtr); + /* + * Now squash the pending reflection events for this channel. + */ + + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); if (result != TCL_OK) { FreeReceivedError(&p); @@ -1166,7 +1175,7 @@ ReflectClose( } #endif - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1178,7 +1187,7 @@ ReflectClose( */ if (rcPtr->methods == 0) { - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1193,10 +1202,13 @@ ReflectClose( ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* Now squash the pending reflection events for this channel. */ - Tcl_DeleteEvents (ReflectEventDelete, rcPtr); + /* + * Now squash the pending reflection events for this channel. + */ - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); + + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -1241,7 +1253,7 @@ ReflectClose( } #endif - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); #ifdef TCL_THREADS } #endif @@ -1349,7 +1361,7 @@ ReflectInput( *errorCodePtr = EOK; if (bytec > 0) { - memcpy(buf, bytev, (size_t)bytec); + memcpy(buf, bytev, (size_t) bytec); } stop: @@ -1550,12 +1562,13 @@ ReflectSeekWide( Tcl_Preserve(rcPtr); offObj = Tcl_NewWideIntObj(offset); - baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" : - ((seekMode == SEEK_CUR) ? "current" : "end"), -1); + baseObj = Tcl_NewStringObj( + (seekMode == SEEK_SET) ? "start" : + (seekMode == SEEK_CUR) ? "current" : "end", -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } @@ -1773,7 +1786,7 @@ ReflectThread(ClientData clientData, int action) rcPtr->owner = NULL; break; default: - Tcl_Panic ("Unknown thread action code."); + Tcl_Panic("Unknown thread action code."); break; } } @@ -2047,7 +2060,8 @@ EncodeEventMask( } if (listc < 1) { - Tcl_AppendResult(interp, "bad ", objName, " list: is empty", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad %s list: is empty", objName)); return TCL_ERROR; } @@ -2808,7 +2822,7 @@ DeleteThreadReflectedChannelMap( * actually. */ - Tcl_DeleteEvents (ReflectEventDelete, NULL); + Tcl_DeleteEvents(ReflectEventDelete, NULL); /* * Get the map of all channels handled by the current thread. This is a @@ -2979,9 +2993,8 @@ ForwardProc( Tcl_Interp *interp = rcPtr->interp; ForwardParam *paramPtr = evPtr->param; Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ - ReflectedChannelMap *rcmPtr; - /* Map of reflected channels with handlers in - * this interp. */ + ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in + * this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ /* @@ -3024,12 +3037,12 @@ ForwardProc( rcmPtr = GetReflectedChannelMap(interp); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); FreeReflectedChannelArgs(rcPtr); @@ -3064,7 +3077,7 @@ ForwardProc( paramPtr->input.toRead = -1; } else { if (bytec > 0) { - memcpy(paramPtr->input.buf, bytev, (size_t)bytec); + memcpy(paramPtr->input.buf, bytev, (size_t) bytec); } paramPtr->input.toRead = bytec; } @@ -3076,7 +3089,7 @@ ForwardProc( case ForwardedOutput: { Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) - paramPtr->output.buf, paramPtr->output.toWrite); + paramPtr->output.buf, paramPtr->output.toWrite); Tcl_IncrRefCount(bufObj); Tcl_Preserve(rcPtr); @@ -3116,8 +3129,8 @@ ForwardProc( case ForwardedSeek: { Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset); Tcl_Obj *baseObj = Tcl_NewStringObj( - (paramPtr->seek.seekMode==SEEK_SET) ? "start" : - (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); + (paramPtr->seek.seekMode==SEEK_SET) ? "start" : + (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); @@ -3167,11 +3180,11 @@ ForwardProc( case ForwardedBlock: { Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking); - Tcl_IncrRefCount(blockObj); + Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); @@ -3187,7 +3200,7 @@ ForwardProc( Tcl_IncrRefCount(valueObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); @@ -3202,8 +3215,8 @@ ForwardProc( */ Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1); - Tcl_IncrRefCount(optionObj); + Tcl_IncrRefCount(optionObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 8f111b0..2b9efb9 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -363,33 +363,43 @@ static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ - if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ - } + do { \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ + } \ + } while (0) #define PassReceivedErrorInterp(i,p) \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ - FreeReceivedError(p) + do { \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ + FreeReceivedError(p); \ + } while (0) #define PassReceivedError(c,p) \ - Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ - FreeReceivedError(p) + do { \ + Tcl_SetChannelError((c), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + FreeReceivedError(p); \ + } while (0) #define ForwardSetStaticError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ - (p)->base.msgStr = (char *) (emsg) + do { \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ + (p)->base.msgStr = (char *) (emsg); \ + } while (0) #define ForwardSetDynamicError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ - (p)->base.msgStr = (char *) (emsg) + do { \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 1; \ + (p)->base.msgStr = (char *) (emsg); \ + } while (0) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); - static ReflectedTransformMap * GetThreadReflectedTransformMap(void); -static void DeleteThreadReflectedTransformMap(ClientData clientData); - +static void DeleteThreadReflectedTransformMap( + ClientData clientData); #endif /* TCL_THREADS */ #define SetChannelErrorStr(c,msgStr) \ @@ -513,7 +523,6 @@ TclChanPushObjCmd( int result; /* Result code for 'initialize' */ Tcl_Obj *resObj; /* Result data for 'initialize' */ int methods; /* Bitmask for supported methods. */ - Tcl_Obj *err; /* Error message */ ReflectedTransformMap *rtmPtr; /* Map of reflected transforms with handlers * in this interp. */ @@ -608,11 +617,10 @@ TclChanPushObjCmd( while (listc > 0) { if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, " initialize\" returned ", -1); - Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s initialize\" returned %s", + Tcl_GetString(cmdObj), + Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; } @@ -695,13 +703,14 @@ TclChanPushObjCmd( rtmPtr = GetThreadReflectedTransformMap(); hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); Tcl_SetHashValue(hPtr, rtPtr); -#endif +#endif /* TCL_THREADS */ /* * Return the channel as the result of the command. */ - Tcl_AppendResult(interp, Tcl_GetChannelName(rtPtr->chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_GetChannelName(rtPtr->chan), -1)); return TCL_OK; error: @@ -710,7 +719,7 @@ TclChanPushObjCmd( * structure. */ - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return TCL_ERROR; #undef CHAN @@ -913,9 +922,9 @@ ReflectClose( FreeReceivedError(&p); } } -#endif +#endif /* TCL_THREADS */ - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return EOK; } @@ -931,11 +940,11 @@ ReflectClose( if (!TransformDrain(rtPtr, &errorCode)) { #ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { - Tcl_EventuallyFree (rtPtr, + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; } -#endif +#endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; } @@ -945,11 +954,11 @@ ReflectClose( if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) { #ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { - Tcl_EventuallyFree (rtPtr, + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; } -#endif +#endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; } @@ -966,7 +975,7 @@ ReflectClose( ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); result = p.base.code; - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -974,7 +983,7 @@ ReflectClose( } return EOK; } -#endif +#endif /* TCL_THREADS */ /* * Do the actual invokation of "finalize" now; we're in the right thread. @@ -1022,7 +1031,7 @@ ReflectClose( if (hPtr) { Tcl_DeleteHashEntry(hPtr); } -#endif +#endif /* TCL_THREADS */ } Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); @@ -1348,7 +1357,7 @@ ReflectSeekWide( * transformation. */ - if ((rtPtr->methods & FLAG(METH_CLEAR))) { + if (rtPtr->methods & FLAG(METH_CLEAR)) { TransformClear(rtPtr); } @@ -2140,7 +2149,7 @@ DeleteReflectedTransformMap( ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; -#endif +#endif /* TCL_THREADS */ /* * Delete all entries. The channels may have been closed already, or will @@ -2232,8 +2241,7 @@ DeleteReflectedTransformMap( Tcl_ConditionNotify(&resultPtr->done); } Tcl_MutexUnlock(&rtForwardMutex); - -#endif +#endif /* TCL_THREADS */ } #ifdef TCL_THREADS @@ -2631,7 +2639,7 @@ ForwardProc( break; } - case ForwardedDrain: { + case ForwardedDrain: if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); paramPtr->transform.size = -1; @@ -2656,9 +2664,8 @@ ForwardProc( } } break; - } - case ForwardedFlush: { + case ForwardedFlush: if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); paramPtr->transform.size = -1; @@ -2684,12 +2691,10 @@ ForwardProc( } } break; - } - case ForwardedClear: { + case ForwardedClear: (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); break; - } case ForwardedLimit: if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) { @@ -2795,7 +2800,7 @@ ForwardSetObjError( ForwardSetDynamicError(paramPtr, ckalloc(len)); memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len); } -#endif +#endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- @@ -3092,7 +3097,7 @@ TransformRead( ckfree(p.transform.buf); return 1; } -#endif +#endif /* TCL_THREADS */ /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ @@ -3153,7 +3158,7 @@ TransformWrite( p.transform.size); ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */ /* ASSERT: rtPtr->mode & TCL_WRITABLE */ @@ -3215,7 +3220,7 @@ TransformDrain( ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3270,7 +3275,7 @@ TransformFlush( } ckfree(p.transform.buf); } else -#endif +#endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3311,7 +3316,7 @@ TransformClear( ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p); return; } -#endif +#endif /* TCL_THREADS */ /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 018f9f5..e603c91 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -64,8 +64,8 @@ TclSockGetPort( return TCL_ERROR; } if (*portPtr > 0xFFFF) { - Tcl_AppendResult(interp, "couldn't open socket: port number too high", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't open socket: port number too high", -1)); return TCL_ERROR; } return TCL_OK; @@ -100,16 +100,20 @@ TclSockMinimumBuffers( socklen_t len; len = sizeof(int); - getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); + getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, + (char *) ¤t, &len); if (current < size) { len = sizeof(int); - setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); + setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, + (char *) &size, len); } len = sizeof(int); - getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); + getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, + (char *) ¤t, &len); if (current < size) { len = sizeof(int); - setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); + setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, + (char *) &size, len); } return TCL_OK; } @@ -152,19 +156,18 @@ TclCreateSocketAddress( Tcl_DString ds; int result, i; - TclFormatInt(portstring, port); - if (host != NULL) { native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); } - + TclFormatInt(portstring, port); (void) memset(&hints, 0, sizeof(hints)); - hints.ai_family = AF_UNSPEC; + /* * Magic variable to enforce a certain address family - to be superseded * by a TIP that adds explicit switches to [socket] */ + if (interp != NULL) { family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0); if (family != NULL) { @@ -182,7 +185,7 @@ TclCreateSocketAddress( /* * We found some problems when using AI_ADDRCONFIG, e.g. on systems that * have no networking besides the loopback interface and want to resolve - * localhost. See bugs 3385024, 3382419, 3382431. As the advantage of + * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of * using AI_ADDRCONFIG in situations where it works, is probably low, * we'll leave it out for now. After all, it is just an optimisation. * @@ -206,12 +209,11 @@ TclCreateSocketAddress( } if (result != 0) { -#ifdef EAI_SYSTEM /* Doesn't exist on Windows */ - if (result == EAI_SYSTEM) - *errorMsgPtr = Tcl_PosixError(interp); - else -#endif - *errorMsgPtr = gai_strerror(result); + *errorMsgPtr = +#ifdef EAI_SYSTEM /* Doesn't exist on Windows */ + (result == EAI_SYSTEM) ? Tcl_PosixError(interp) : +#endif /* EAI_SYSTEM */ + gai_strerror(result); return 0; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index ebf34dc..115c132 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1573,8 +1573,8 @@ TclGetOpenModeEx( *seekFlagPtr = 0; *binaryPtr = 0; if (interp != NULL) { - Tcl_AppendResult(interp, "illegal access mode \"", modeString, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal access mode \"%s\"", modeString)); } return -1; } @@ -1623,8 +1623,9 @@ TclGetOpenModeEx( mode |= O_NOCTTY; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } ckfree(modeArgv); return -1; @@ -1635,8 +1636,9 @@ TclGetOpenModeEx( mode |= O_NONBLOCK; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } ckfree(modeArgv); return -1; @@ -1649,9 +1651,10 @@ TclGetOpenModeEx( } else { if (interp != NULL) { - Tcl_AppendResult(interp, "invalid access mode \"", flag, - "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " - "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid access mode \"%s\": must be RDONLY, WRONLY, " + "RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK," + " or TRUNC", flag)); } ckfree(modeArgv); return -1; @@ -1662,8 +1665,9 @@ TclGetOpenModeEx( if (!gotRW) { if (interp != NULL) { - Tcl_AppendResult(interp, "access mode must include either" - " RDONLY, WRONLY, or RDWR", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "access mode must include either RDONLY, WRONLY, or RDWR", + -1)); } return -1; } @@ -1722,15 +1726,16 @@ Tcl_FSEvalFileEx( if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } @@ -1764,8 +1769,9 @@ Tcl_FSEvalFileEx( if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } string = Tcl_GetString(objPtr); @@ -1778,8 +1784,9 @@ Tcl_FSEvalFileEx( if (Tcl_ReadChars(chan, objPtr, -1, memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } @@ -1853,15 +1860,16 @@ TclNREvalFile( if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1895,8 +1903,9 @@ TclNREvalFile( if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -1910,8 +1919,9 @@ TclNREvalFile( if (Tcl_ReadChars(chan, objPtr, -1, memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -2247,9 +2257,9 @@ Tcl_FSOpenFileChannel( if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END) < (Tcl_WideInt) 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not seek to end of file " - "while opening \"", Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not seek to end of file while opening \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } Tcl_Close(NULL, retVal); return NULL; @@ -2266,8 +2276,9 @@ Tcl_FSOpenFileChannel( Tcl_SetErrno(ENOENT); if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -2685,9 +2696,9 @@ Tcl_FSGetCwd( Disclaim(); goto cdDidNotChange; } else if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } } Disclaim(); @@ -2761,9 +2772,9 @@ Tcl_FSGetCwd( retCd = proc2(tsdPtr->cwdClientData); if (retCd == NULL && interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } if (retCd == tsdPtr->cwdClientData) { @@ -3153,8 +3164,9 @@ Tcl_LoadFile( */ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { - Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load library \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -3204,7 +3216,7 @@ Tcl_LoadFile( mustCopyToTempAnyway: Tcl_ResetResult(interp); -#endif +#endif /* TCL_LOAD_FROM_MEMORY */ /* * Get a temporary filename to use, first to copy the file into, and then @@ -3224,8 +3236,8 @@ Tcl_LoadFile( Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); - Tcl_AppendResult(interp, "couldn't load from current filesystem", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't load from current filesystem", -1)); return TCL_ERROR; } diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 9193c1a..f266443 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -148,8 +148,9 @@ TclMacOSXGetFileAttribute( result = TclpObjStat(fileName, &statBuf); if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -159,8 +160,8 @@ TclMacOSXGetFileAttribute( */ errno = EISDIR; - Tcl_AppendResult(interp, "invalid attribute: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid attribute: %s", Tcl_PosixError(interp))); return TCL_ERROR; } @@ -175,8 +176,9 @@ TclMacOSXGetFileAttribute( result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { - Tcl_AppendResult(interp, "could not read attributes of \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read attributes of \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -199,10 +201,11 @@ TclMacOSXGetFileAttribute( } return TCL_OK; #else - Tcl_AppendResult(interp, "Mac OS X file attributes not supported", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Mac OS X file attributes not supported", -1)); Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); return TCL_ERROR; -#endif +#endif /* HAVE_GETATTRLIST */ } /* @@ -241,8 +244,9 @@ TclMacOSXSetFileAttribute( result = TclpObjStat(fileName, &statBuf); if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -252,8 +256,8 @@ TclMacOSXSetFileAttribute( */ errno = EISDIR; - Tcl_AppendResult(interp, "invalid attribute: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid attribute: %s", Tcl_PosixError(interp))); return TCL_ERROR; } @@ -268,8 +272,9 @@ TclMacOSXSetFileAttribute( result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { - Tcl_AppendResult(interp, "could not read attributes of \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read attributes of \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -306,9 +311,9 @@ TclMacOSXSetFileAttribute( &finfo.data, sizeof(finfo.data), 0); if (result != 0) { - Tcl_AppendResult(interp, "could not set attributes of \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set attributes of \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } } else { @@ -328,8 +333,8 @@ TclMacOSXSetFileAttribute( */ if (newRsrcForkSize != 0) { - Tcl_AppendResult(interp, - "setting nonzero rsrclength not supported", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "setting nonzero rsrclength not supported", -1)); Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); return TCL_ERROR; } @@ -360,17 +365,17 @@ TclMacOSXSetFileAttribute( Tcl_DStringFree(&ds); if (result != 0) { - Tcl_AppendResult(interp, - "could not truncate resource fork of \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not truncate resource fork of \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); return TCL_ERROR; } } } return TCL_OK; #else - Tcl_AppendResult(interp, "Mac OS X file attributes not supported", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Mac OS X file attributes not supported", -1)); Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); return TCL_ERROR; #endif @@ -640,8 +645,8 @@ SetOSTypeFromAny( if (Tcl_DStringLength(&ds) > 4) { if (interp) { - Tcl_AppendResult(interp, "expected Macintosh OS type but got \"", - string, "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected Macintosh OS type but got \"%s\": ", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", NULL); } result = TCL_ERROR; diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 3845c44..9ee37f1 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -136,10 +136,10 @@ typedef struct TtyAttrs { #endif /* !SUPPORTS_TTY */ #define UNSUPPORTED_OPTION(detail) \ - if (interp) { \ - Tcl_AppendResult(interp, (detail), \ - " not supported for this platform", NULL); \ - Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ + "%s not supported for this platform", (detail))); \ + Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \ } /* @@ -697,9 +697,9 @@ TtySetOptionProc( return TCL_ERROR; } else { if (interp) { - Tcl_AppendResult(interp, "bad value for -handshake: " - "must be one of xonxoff, rtscts, dtrdsr or none", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -handshake: must be one of" + " xonxoff, rtscts, dtrdsr or none", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -720,8 +720,9 @@ TtySetOptionProc( return TCL_ERROR; } else if (argc != 2) { if (interp) { - Tcl_AppendResult(interp, "bad value for -xchar: " - "should be a list of two elements", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -xchar: should be a list of" + " two elements", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -773,8 +774,9 @@ TtySetOptionProc( } if ((argc % 2) == 1) { if (interp) { - Tcl_AppendResult(interp, "bad value for -ttycontrol: " - "should be a list of signal,value pairs", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -ttycontrol: should be a list of" + " signal,value pairs", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -822,9 +824,9 @@ TtySetOptionProc( #endif /* SETBREAK */ } else { if (interp) { - Tcl_AppendResult(interp, "bad signal \"", argv[i], - "\" for -ttycontrol: must be " - "DTR, RTS or BREAK", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad signal \"%s\" for -ttycontrol: must be" + " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -1388,8 +1390,8 @@ TtyParseMode( stopPtr, &end); if ((i != 4) || (mode[end] != '\0')) { if (interp != NULL) { - Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s: should be baud,parity,data,stop", bad)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; @@ -1412,13 +1414,14 @@ TtyParseMode( #endif /* PAREXT|USE_TERMIO */ == NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, bad, " parity: should be ", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s parity: should be %s", bad, #if defined(PAREXT) || defined(USE_TERMIO) - "n, o, e, m, or s", + "n, o, e, m, or s" #else - "n, o, or e", + "n, o, or e" #endif /* PAREXT|USE_TERMIO */ - NULL); + )); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; @@ -1426,15 +1429,16 @@ TtyParseMode( *parityPtr = parity; if ((*dataPtr < 5) || (*dataPtr > 8)) { if (interp != NULL) { - Tcl_AppendResult(interp, bad, " data: should be 5, 6, 7, or 8", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s data: should be 5, 6, 7, or 8", bad)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; } if ((*stopPtr < 0) || (*stopPtr > 2)) { if (interp != NULL) { - Tcl_AppendResult(interp, bad, " stop: should be 1 or 2", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s stop: should be 1 or 2", bad)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; @@ -1583,8 +1587,9 @@ TclpOpenFileChannel( if (fd < 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -1842,15 +1847,15 @@ Tcl_GetOpenFile( if (chan == NULL) { return TCL_ERROR; } - if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) { - Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for writing", - NULL); + if (forWriting && !(chanMode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" wasn't opened for writing", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_WRITABLE", NULL); return TCL_ERROR; - } else if ((!forWriting) && ((chanMode & TCL_READABLE) == 0)) { - Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for reading", - NULL); + } else if (!forWriting && !(chanMode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" wasn't opened for reading", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_READABLE", NULL); return TCL_ERROR; @@ -1881,8 +1886,8 @@ Tcl_GetOpenFile( f = fdopen(fd, (forWriting ? "w" : "r")); if (f == NULL) { - Tcl_AppendResult(interp, "cannot get a FILE * for \"", chanID, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot get a FILE * for \"%s\"", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "FILE_FAILURE", NULL); return TCL_ERROR; @@ -1892,8 +1897,8 @@ Tcl_GetOpenFile( } } - Tcl_AppendResult(interp, "\"", chanID, - "\" cannot be used to get a FILE *", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" cannot be used to get a FILE *", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR", NULL); return TCL_ERROR; diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index a695e9c..d3cc6bf 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -1320,9 +1320,9 @@ GetGroupAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1374,9 +1374,9 @@ GetOwnerAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1425,9 +1425,9 @@ GetPermissionsAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1478,9 +1478,10 @@ SetGroupAttribute( if (groupPtr == NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set group for file \"", - TclGetString(fileName), "\": group \"", string, - "\" does not exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set group for file \"%s\":" + " group \"%s\" does not exist", + TclGetString(fileName), string)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETGRP", "NO_GROUP", NULL); } @@ -1494,9 +1495,9 @@ SetGroupAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set group for file \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set group for file \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1544,9 +1545,10 @@ SetOwnerAttribute( if (pwPtr == NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set owner for file \"", - TclGetString(fileName), "\": user \"", string, - "\" does not exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set owner for file \"%s\":" + " user \"%s\" does not exist", + TclGetString(fileName), string)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETOWN", "NO_USER", NULL); } @@ -1560,9 +1562,9 @@ SetOwnerAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set owner for file \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set owner for file \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1630,9 +1632,9 @@ SetPermissionsAttribute( result = TclpObjStat(fileName, &buf); if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1640,8 +1642,9 @@ SetPermissionsAttribute( if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) { if (interp != NULL) { - Tcl_AppendResult(interp, "unknown permission string format \"", - modeStringPtr, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown permission string format \"%s\"", + modeStringPtr)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL); } return TCL_ERROR; @@ -1652,9 +1655,9 @@ SetPermissionsAttribute( result = chmod(native, newMode); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set permissions for file \"", - TclGetString(fileName), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set permissions for file \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2239,14 +2242,14 @@ GetReadOnlyAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } - *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags&UF_IMMUTABLE) != 0); + *attributePtrPtr = Tcl_NewBooleanObj(statBuf.st_flags&UF_IMMUTABLE); return TCL_OK; } @@ -2286,9 +2289,9 @@ SetReadOnlyAttribute( if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2303,9 +2306,9 @@ SetReadOnlyAttribute( result = chflags(native, statBuf.st_flags); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set flags for file \"", - TclGetString(fileName), "\": ", Tcl_PosixError(interp), - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not set flags for file \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index c213050..01fc6fe 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -310,10 +310,9 @@ TclpMatchInDirectory( if (d == NULL) { Tcl_DStringFree(&ds); if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(&dsOrig), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read directory \"%s\": %s", + Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); } Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); @@ -771,9 +770,9 @@ TclpGetCwd( #endif { if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } return NULL; } diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 377b84b..654c9d8 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -267,35 +267,34 @@ TclpTempFileName(void) } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------------- * * TclpTempFileNameForLibrary -- * - * Constructs a file name in the native file system where a - * dynamically loaded library may be placed. + * Constructs a file name in the native file system where a dynamically + * loaded library may be placed. * * Results: - * Returns the constructed file name. If an error occurs, - * returns NULL and leaves an error message in the interpreter - * result. + * Returns the constructed file name. If an error occurs, returns NULL + * and leaves an error message in the interpreter result. * - * On Unix, it works to load a shared object from a file of any - * name, so this function is merely a thin wrapper around - * TclpTempFileName(). + * On Unix, it works to load a shared object from a file of any name, so this + * function is merely a thin wrapper around TclpTempFileName(). * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------------- */ -Tcl_Obj* -TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_Obj* path) /* Path name of the library - * in the VFS */ +Tcl_Obj * +TclpTempFileNameForLibrary( + Tcl_Interp *interp, /* Tcl interpreter. */ + Tcl_Obj *path) /* Path name of the library in the VFS. */ { - Tcl_Obj* retval; - retval = TclpTempFileName(); + Tcl_Obj *retval = TclpTempFileName(); + if (retval == NULL) { - Tcl_AppendResult(interp, "couldn't create temporary file: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create temporary file: %s", + Tcl_PosixError(interp))); } return retval; } @@ -442,8 +441,8 @@ TclpCreateProcess( */ if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) { - Tcl_AppendResult(interp, "couldn't create pipe: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create pipe: %s", Tcl_PosixError(interp))); goto error; } @@ -463,8 +462,9 @@ TclpCreateProcess( /* * After vfork(), do not call code in the child that changes global state, * because it is using the parent's memory space at that point and writes - * might corrupt the parent: so ensure standard channels are initialized in - * the parent, otherwise SetupStdFile() might initialize them in the child. + * might corrupt the parent: so ensure standard channels are initialized + * in the parent, otherwise SetupStdFile() might initialize them in the + * child. */ if (!inputFile) { @@ -495,7 +495,7 @@ TclpCreateProcess( || (joinThisError && ((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) { sprintf(errSpace, - "%dforked process couldn't set up input/output: ", errno); + "%dforked process couldn't set up input/output", errno); len = strlen(errSpace); if (len != (size_t) write(fd, errSpace, len)) { Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut"); @@ -509,11 +509,11 @@ TclpCreateProcess( RestoreSignals(); execvp(newArgv[0], newArgv); /* INTL: Native. */ - sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]); + sprintf(errSpace, "%dcouldn't execute \"%.150s\"", errno, argv[0]); len = strlen(errSpace); - if (len != (size_t) write(fd, errSpace, len)) { + if (len != (size_t) write(fd, errSpace, len)) { Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut"); - } + } _exit(1); } @@ -528,8 +528,8 @@ TclpCreateProcess( TclStackFree(interp, dsArray); if (pid == -1) { - Tcl_AppendResult(interp, "couldn't fork child process: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't fork child process: %s", Tcl_PosixError(interp))); goto error; } @@ -546,9 +546,11 @@ TclpCreateProcess( count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); if (count > 0) { char *end; + errSpace[count] = 0; errno = strtol(errSpace, &end, 10); - Tcl_AppendResult(interp, end, Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s", + end, Tcl_PosixError(interp))); goto error; } @@ -832,8 +834,8 @@ Tcl_CreatePipe( int fileNums[2]; if (pipe(fileNums) < 0) { - Tcl_AppendResult(interp, "pipe creation failed: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("pipe creation failed: %s", + Tcl_PosixError(interp))); return TCL_ERROR; } diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 1e9d4eb..102c620 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -21,10 +21,10 @@ #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) /* "sock" + a pointer in hex + \0 */ -#define SOCK_CHAN_LENGTH 4 + sizeof(void*) * 2 + 1 -#define SOCK_TEMPLATE "sock%lx" +#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) +#define SOCK_TEMPLATE "sock%lx" -#undef SOCKET /* Possible conflict with win32 SOCKET */ +#undef SOCKET /* Possible conflict with win32 SOCKET */ /* * This is needed to comply with the strict aliasing rules of GCC, but it also @@ -58,19 +58,23 @@ struct TcpState { /* * Only needed for server sockets */ - Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ + + Tcl_TcpAcceptProc *acceptProc; + /* Proc to call on accept. */ + ClientData acceptProcData; /* The data for the accept proc. */ + /* * Only needed for client sockets */ - struct addrinfo *addrlist; /* addresses to connect to */ - struct addrinfo *addr; /* iterator over addrlist */ - struct addrinfo *myaddrlist; /* local address */ - struct addrinfo *myaddr; /* iterator over myaddrlist */ - int filehandlers; /* Caches FileHandlers that get set up while - * an async socket is not yet connected */ - int status; /* Cache status of async socket */ - int cachedBlocking; /* Cache blocking mode of async socket */ + + struct addrinfo *addrlist; /* Addresses to connect to. */ + struct addrinfo *addr; /* Iterator over addrlist. */ + struct addrinfo *myaddrlist;/* Local address. */ + struct addrinfo *myaddr; /* Iterator over myaddrlist. */ + int filehandlers; /* Caches FileHandlers that get set up while + * an async socket is not yet connected. */ + int status; /* Cache status of async socket. */ + int cachedBlocking; /* Cache blocking mode of async socket. */ }; /* @@ -90,9 +94,7 @@ struct TcpState { #ifndef SOMAXCONN # define SOMAXCONN 100 -#endif /* SOMAXCONN */ - -#if (SOMAXCONN < 100) +#elif (SOMAXCONN < 100) # undef SOMAXCONN # define SOMAXCONN 100 #endif /* SOMAXCONN < 100 */ @@ -217,7 +219,7 @@ InitializeHostName( if (native == NULL) { native = tclEmptyStringRep; } -#else +#else /* !NO_UNAME */ /* * Uname doesn't exist; try gethostname instead. * @@ -242,7 +244,7 @@ InitializeHostName( if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */ native = buffer; } -#endif +#endif /* NO_UNAME */ *encodingPtr = Tcl_GetEncoding(NULL, NULL); *lengthPtr = strlen(native); @@ -344,7 +346,7 @@ TcpBlockModeProc( * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; if (mode == TCL_MODE_BLOCKING) { CLEAR_BITS(statePtr->flags, TCP_ASYNC_SOCKET); @@ -443,7 +445,7 @@ TcpInputProc( * buffer? */ int *errorCodePtr) /* Where to store error code. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; int bytesRead; *errorCodePtr = 0; @@ -493,7 +495,7 @@ TcpOutputProc( int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; int written; *errorCodePtr = 0; @@ -532,7 +534,7 @@ TcpCloseProc( ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* For error reporting - unused. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; int errorCode = 0; TcpFdList *fds; @@ -593,7 +595,7 @@ TcpClose2Proc( Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; int errorCode = 0; int sd; @@ -610,8 +612,8 @@ TcpClose2Proc( break; default: if (interp) { - Tcl_AppendResult(interp, - "Socket close2proc called bidirectionally", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "socket close2proc called bidirectionally", -1)); } return TCL_ERROR; } @@ -653,7 +655,7 @@ TcpGetOptionProc( Tcl_DString *dsPtr) /* Where to store the computed value; * initialized by caller. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; char host[NI_MAXHOST], port[NI_MAXSERV]; size_t len = 0; int reverseDNS = 0; @@ -670,7 +672,7 @@ TcpGetOptionProc( if (statePtr->status == 0) { ret = getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, - (char *)&err, &optlen); + (char *) &err, &optlen); if (ret < 0) { err = errno; } @@ -688,9 +690,8 @@ TcpGetOptionProc( reverseDNS = NI_NUMERICHOST; } - if ((len == 0) || - ((len > 1) && (optionName[1] == 'p') && - (strncmp(optionName, "-peername", len) == 0))) { + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { address peername; socklen_t size = sizeof(peername); @@ -721,16 +722,16 @@ TcpGetOptionProc( if (len) { if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get peername: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } } } - if ((len == 0) || - ((len > 1) && (optionName[1] == 's') && + if ((len == 0) || ((len > 1) && (optionName[1] == 's') && (strncmp(optionName, "-sockname", len) == 0))) { TcpFdList *fds; address sockname; @@ -772,7 +773,7 @@ TcpGetOptionProc( sockname.sa6.sin6_addr.s6_addr[15] == 0)) { flags |= NI_NUMERICHOST; } -#endif +#endif /* NEED_FAKE_RFC2553 */ } getnameinfo(&sockname.sa, size, host, sizeof(host), port, sizeof(port), flags); @@ -787,8 +788,8 @@ TcpGetOptionProc( Tcl_DStringEndSublist(dsPtr); } else { if (interp) { - Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -825,7 +826,7 @@ TcpWatchProc( * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; if (statePtr->acceptProc != NULL) { /* @@ -842,8 +843,7 @@ TcpWatchProc( statePtr->filehandlers = mask; } else if (mask) { Tcl_CreateFileHandler(statePtr->fds.fd, mask, - (Tcl_FileProc *) Tcl_NotifyChannel, - (ClientData) statePtr->channel); + (Tcl_FileProc *) Tcl_NotifyChannel, statePtr->channel); } else { Tcl_DeleteFileHandler(statePtr->fds.fd); } @@ -874,7 +874,7 @@ TcpGetHandleProc( int direction, /* Not used. */ ClientData *handlePtr) /* Where to store the handle. */ { - TcpState *statePtr = (TcpState *) instanceData; + TcpState *statePtr = instanceData; *handlePtr = INT2PTR(statePtr->fds.fd); return TCL_OK; @@ -946,12 +946,11 @@ CreateClientSocket( } for (state->addr = state->addrlist; state->addr != NULL; - state->addr = state->addr->ai_next) { - + state->addr = state->addr->ai_next) { status = -1; for (state->myaddr = state->myaddrlist; state->myaddr != NULL; - state->myaddr = state->myaddr->ai_next) { + state->myaddr = state->myaddr->ai_next) { int reuseaddr; /* @@ -967,6 +966,7 @@ CreateClientSocket( * Close the socket if it is still open from the last unsuccessful * iteration. */ + if (state->fds.fd >= 0) { close(state->fds.fd); state->fds.fd = -1; @@ -991,7 +991,8 @@ CreateClientSocket( TclSockMinimumBuffers(INT2PTR(state->fds.fd), SOCKET_BUFSIZE); if (async) { - status = TclUnixSetBlockingMode(state->fds.fd, TCL_MODE_NONBLOCKING); + status = TclUnixSetBlockingMode(state->fds.fd, + TCL_MODE_NONBLOCKING); if (status < 0) { continue; } @@ -1001,7 +1002,7 @@ CreateClientSocket( (void) setsockopt(state->fds.fd, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); status = bind(state->fds.fd, state->myaddr->ai_addr, - state->myaddr->ai_addrlen); + state->myaddr->ai_addrlen); if (status < 0) { continue; } @@ -1014,24 +1015,25 @@ CreateClientSocket( */ status = connect(state->fds.fd, state->addr->ai_addr, - state->addr->ai_addrlen); + state->addr->ai_addrlen); if (status < 0 && errno == EINPROGRESS) { Tcl_CreateFileHandler(state->fds.fd, - TCL_WRITABLE | TCL_EXCEPTION, - TcpAsyncCallback, state); + TCL_WRITABLE|TCL_EXCEPTION, TcpAsyncCallback, state); return TCL_OK; reenter: Tcl_DeleteFileHandler(state->fds.fd); + /* * Read the error state from the socket to see if the async * connection has succeeded or failed. As this clears the * error condition, we cache the status in the socket state * struct for later retrieval by [fconfigure -error]. */ + optlen = sizeof(int); getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR, - (char *)&status, &optlen); + (char *) &status, &optlen); state->status = status; } if (status == 0) { @@ -1047,6 +1049,7 @@ out: /* * An asynchonous connection has finally succeeded or failed. */ + TcpWatchProc(state, state->filehandlers); TclUnixSetBlockingMode(state->fds.fd, state->cachedBlocking); @@ -1058,17 +1061,18 @@ out: * hurt that this is also called in the successful case and will save * the event mechanism one roundtrip through select(). */ - Tcl_NotifyChannel(state->channel, TCL_WRITABLE); + Tcl_NotifyChannel(state->channel, TCL_WRITABLE); } else if (status != 0) { /* * Failure for either a synchronous connection, or an async one that * failed before it could enter background mode, e.g. because an * invalid -myaddr was given. */ + if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1111,13 +1115,16 @@ Tcl_OpenTcpClient( /* * Do the name lookups for the local and remote addresses. */ - if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) || - !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, &errorMsg)) { + + if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) + || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, + &errorMsg)) { if (addrlist != NULL) { freeaddrinfo(addrlist); } if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", errorMsg, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", errorMsg)); } return NULL; } @@ -1141,10 +1148,10 @@ Tcl_OpenTcpClient( return NULL; } - sprintf(channelName, SOCK_TEMPLATE, (long)state); + sprintf(channelName, SOCK_TEMPLATE, (long) state); - state->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - state, (TCL_READABLE | TCL_WRITABLE)); + state->channel = Tcl_CreateChannel(&tcpChannelType, channelName, state, + (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(interp, state->channel, "-translation", "auto crlf") == TCL_ERROR) { Tcl_Close(NULL, state->channel); @@ -1257,6 +1264,7 @@ Tcl_OpenTcpServer( * Try to record and return the most meaningful error message, i.e. the * one from the first socket that went the farthest before it failed. */ + enum { LOOKUP, SOCKET, BIND, LISTEN } howfar = LOOKUP; int my_errno = 0; @@ -1267,7 +1275,7 @@ Tcl_OpenTcpServer( for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, - addrPtr->ai_protocol); + addrPtr->ai_protocol); if (sock == -1) { if (howfar < SOCKET) { howfar = SOCKET; @@ -1318,7 +1326,7 @@ Tcl_OpenTcpServer( (void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY, &v6only, sizeof(v6only)); } -#endif +#endif /* IPV6_V6ONLY */ status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen); if (status == -1) { @@ -1360,7 +1368,7 @@ Tcl_OpenTcpServer( memset(statePtr, 0, sizeof(TcpState)); statePtr->acceptProc = acceptProc; statePtr->acceptProcData = acceptProcData; - sprintf(channelName, SOCK_TEMPLATE, (long)statePtr); + sprintf(channelName, SOCK_TEMPLATE, (long) statePtr); newfds = &statePtr->fds; } else { newfds = ckalloc(sizeof(TcpFdList)); @@ -1389,13 +1397,15 @@ Tcl_OpenTcpServer( return statePtr->channel; } if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", NULL); + Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1); + if (errorMsg == NULL) { errno = my_errno; - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); + Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1); } else { - Tcl_AppendResult(interp, errorMsg, NULL); + Tcl_AppendToObj(errorObj, errorMsg, -1); } + Tcl_SetObjResult(interp, errorObj); } if (sock != -1) { close(sock); @@ -1434,7 +1444,7 @@ TcpAccept( char host[NI_MAXHOST], port[NI_MAXSERV]; len = sizeof(addr); - newsock = accept(fds->fd, &(addr.sa), &len); + newsock = accept(fds->fd, &addr.sa, &len); if (newsock < 0) { return; } @@ -1451,7 +1461,7 @@ TcpAccept( newSockState->flags = 0; newSockState->fds.fd = newsock; - sprintf(channelName, SOCK_TEMPLATE, (long)newSockState); + sprintf(channelName, SOCK_TEMPLATE, (long) newSockState); newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName, newSockState, (TCL_READABLE | TCL_WRITABLE)); @@ -1459,7 +1469,7 @@ TcpAccept( "auto crlf"); if (fds->statePtr->acceptProc != NULL) { - getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), + getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); fds->statePtr->acceptProc(fds->statePtr->acceptProcData, newSockState->channel, host, atoi(port)); diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 517aa20..bc233ea 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -940,8 +940,9 @@ TclpOpenFileChannel( } TclWinConvertError(err); if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + TclGetString(pathPtr),, Tcl_PosixError(interp))); } return NULL; } @@ -959,9 +960,9 @@ TclpOpenFileChannel( if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't reopen serial \"", - TclGetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't reopen serial \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -995,8 +996,9 @@ TclpOpenFileChannel( */ channel = NULL; - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": bad file type", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": bad file type", + TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE", NULL); break; diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 4d6e31b..e225989 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -157,7 +157,8 @@ Dde_Init( #ifdef UNICODE if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) { - Tcl_AppendResult(interp, "Win32s and Windows 9x are not supported platforms", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Win32s and Windows 9x are not supported platforms", -1)); return TCL_ERROR; } #endif @@ -947,8 +948,8 @@ MakeDdeConnection( if (ddeConv == (HCONV) NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, "no registered server named \"", - name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no registered server named \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); } return TCL_ERROR; diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 77a5b82..80fad3e 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1530,8 +1530,8 @@ StatError( * error. */ { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } /* @@ -1649,9 +1649,9 @@ ConvertFileNameFormat( if (splitPath == NULL || pathc == 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - Tcl_GetString(fileName), "\": no such file or directory", - (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": no such file or directory", + Tcl_GetString(fileName))); errno = ENOENT; Tcl_PosixError(interp); } @@ -1941,9 +1941,9 @@ CannotSetAttribute( Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { - Tcl_AppendResult(interp, "cannot set attribute \"", - tclpFileAttrStrings[objIndex], "\" for file \"", - Tcl_GetString(fileName), "\": attribute is readonly", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", + tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); errno = EINVAL; Tcl_PosixError(interp); return TCL_ERROR; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1f56060..a44a257 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1048,10 +1048,9 @@ TclpMatchInDirectory( TclWinConvertError(err); if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(&dsOrig), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read directory \"%s\": %s", + Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); } Tcl_DStringFree(&dsOrig); return TCL_ERROR; @@ -1866,8 +1865,9 @@ TclpGetCwd( if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); if (interp != NULL) { - Tcl_AppendResult(interp, "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } return NULL; } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index db462f8..36ae58a 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -1030,8 +1030,9 @@ TclpCreateProcess( } if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate input handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate input handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1065,8 +1066,9 @@ TclpCreateProcess( } if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate output handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate output handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1084,8 +1086,9 @@ TclpCreateProcess( } if (startInfo.hStdError == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate error handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate error handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1129,9 +1132,9 @@ TclpCreateProcess( } if (applType == APPL_DOS) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "DOS application process not supported on this platform", - (char *) NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP", NULL); goto end; @@ -1158,12 +1161,12 @@ TclpCreateProcess( BuildCommandLine(execPath, argc, argv, &cmdLine); - if (CreateProcess(NULL, - (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, - (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { + if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine), + NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, + &procInfo) == 0) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", argv[0], - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + argv[0], Tcl_PosixError(interp))); goto end; } @@ -1409,8 +1412,8 @@ ApplicationType( if (applType == APPL_NONE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", originalName, - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + originalName, Tcl_PosixError(interp))); return APPL_NONE; } @@ -1673,8 +1676,8 @@ Tcl_CreatePipe( if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "pipe creation failed: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "pipe creation failed: %s", Tcl_PosixError(interp))); return TCL_ERROR; } diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 9c08b0c..c4a89e6 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -172,7 +172,7 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } @@ -534,9 +534,9 @@ DeleteValue( result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to delete value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to delete value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -574,7 +574,8 @@ GetKeyNames( { const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH]; /* Buffer to hold the subkey name */ + TCHAR buffer[MAX_KEY_LENGTH]; + /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ char *name; /* Subkey name */ @@ -610,9 +611,9 @@ GetKeyNames( if (result == ERROR_NO_MORE_ITEMS) { result = TCL_OK; } else { - Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_AppendResult(interp, "unable to enumerate subkeys of \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to enumerate subkeys of \"%s\": ", + Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } @@ -693,9 +694,9 @@ GetType( RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get type of value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get type of value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); return TCL_ERROR; } @@ -787,9 +788,9 @@ GetValue( Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; @@ -1110,8 +1111,8 @@ ParseKeyName( rootName = name; } if (!rootName) { - Tcl_AppendResult(interp, "bad key \"", name, - "\": must start with a valid root", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad key \"%s\": must start with a valid root", name)); Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL); return TCL_ERROR; } diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 58a9eb4..fb7f69b 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1673,12 +1673,7 @@ SerialSetOptionProc( if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } native = Tcl_WinUtfToTChar(value, -1, &ds); result = BuildCommDCB(native, &dcb); @@ -1686,8 +1681,9 @@ SerialSetOptionProc( if (result == FALSE) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -mode: should be baud,parity,data,stop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -mode: should be baud,parity,data,stop", + value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; @@ -1703,12 +1699,7 @@ SerialSetOptionProc( dcb.fAbortOnError = FALSE; if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1719,12 +1710,7 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } /* @@ -1759,21 +1745,16 @@ SerialSetOptionProc( dcb.fDtrControl = DTR_CONTROL_HANDSHAKE; } else { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -handshake: must be one of xonxoff, rtscts, " - "dtrdsr or none", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -handshake: must be one of" + " xonxoff, rtscts, dtrdsr or none", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL); } return TCL_ERROR; } if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1784,12 +1765,7 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { @@ -1798,9 +1774,9 @@ SerialSetOptionProc( if (argc != 2) { badXchar: if (interp != NULL) { - Tcl_AppendResult(interp, "bad value for -xchar: should be " - "a list of two elements with each a single character", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -xchar: should be a list of" + " two elements with each a single character", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); } ckfree(argv); @@ -1837,12 +1813,7 @@ SerialSetOptionProc( ckfree(argv); if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1859,9 +1830,9 @@ SerialSetOptionProc( } if ((argc % 2) == 1) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -ttycontrol: should be a list of " - "signal,value pairs", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -ttycontrol: should be " + "a list of signal,value pairs", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL); } ckfree(argv); @@ -1877,7 +1848,8 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETDTR : CLRDTR))) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't set DTR signal", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set DTR signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1888,7 +1860,8 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETRTS : CLRRTS))) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't set RTS signal", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set RTS signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1899,7 +1872,8 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETBREAK : CLRBREAK))) { if (interp != NULL) { - Tcl_AppendResult(interp,"can't set BREAK signal",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set BREAK signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1908,9 +1882,9 @@ SerialSetOptionProc( } } else { if (interp != NULL) { - Tcl_AppendResult(interp, "bad signal name \"", argv[i], - "\" for -ttycontrol: must be DTR, RTS or BREAK", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad signal name \"%s\" for -ttycontrol: must be" + " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", NULL); } @@ -1949,9 +1923,9 @@ SerialSetOptionProc( if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -sysbuffer: should be a list of one or two " - "integers > 0", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -sysbuffer: should be " + "a list of one or two integers > 0", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL); } return TCL_ERROR; @@ -1960,8 +1934,9 @@ SerialSetOptionProc( if (!SetupComm(infoPtr->handle, inSize, outSize)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't setup comm buffers: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't setup comm buffers: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1974,22 +1949,12 @@ SerialSetOptionProc( */ if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2); dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4); if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -2020,8 +1985,9 @@ SerialSetOptionProc( if (!SetCommTimeouts(infoPtr->handle, &tout)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm timeouts: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't set comm timeouts: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2031,6 +1997,22 @@ SerialSetOptionProc( return Tcl_BadChannelOption(interp, optionName, "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); + + getStateFailed: + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: ", Tcl_PosixError(interp))); + } + return TCL_ERROR; + + setStateFailed: + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't set comm state: ", Tcl_PosixError(interp))); + } + return TCL_ERROR; } /* @@ -2089,8 +2071,8 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2159,8 +2141,8 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2237,8 +2219,8 @@ SerialGetOptionProc( if (!GetCommModemStatus(infoPtr->handle, &status)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get tty status: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get tty status: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2248,10 +2230,9 @@ SerialGetOptionProc( if (valid) { return TCL_OK; - } else { - return Tcl_BadChannelOption(interp, optionName, - "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } + return Tcl_BadChannelOption(interp, optionName, + "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 97b10a3..6986528 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -558,8 +558,8 @@ TclpHasSockets( return TCL_OK; } if (interp != NULL) { - Tcl_AppendResult(interp, "sockets are not available on this system", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "sockets are not available on this system", -1)); } return TCL_ERROR; } @@ -928,8 +928,8 @@ TcpClose2Proc( break; default: if (interp) { - Tcl_AppendResult(interp, - "Socket close2proc called bidirectionally", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Socket close2proc called bidirectionally", -1)); } return TCL_ERROR; } @@ -1280,12 +1280,9 @@ CreateSocket( } if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", NULL); - if (errorMsg == NULL) { - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); - } else { - Tcl_AppendResult(interp, errorMsg, NULL); - } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", + (errorMsg ? errorMsg : Tcl_PosixError(interp))); } if (sock != INVALID_SOCKET) { @@ -1929,7 +1926,8 @@ TcpSetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); } return TCL_ERROR; } @@ -1952,8 +1950,9 @@ TcpSetOptionProc( if (rtn != 0) { TclWinConvertError(WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1973,8 +1972,9 @@ TcpSetOptionProc( if (rtn != 0) { TclWinConvertError(WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2032,7 +2032,8 @@ TcpGetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); } return TCL_ERROR; } @@ -2099,8 +2100,9 @@ TcpGetOptionProc( if (len) { TclWinConvertError((DWORD) WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get peername: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2164,8 +2166,8 @@ TcpGetOptionProc( } else { if (interp) { TclWinConvertError((DWORD) WSAGetLastError()); - Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } -- cgit v0.12 From aa7ab9ce5eba66a61032dc91795617354ca8c05f Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 5 Aug 2012 20:34:57 +0000 Subject: Fixes to my previous commit, from Francois Vogel. (My thanks and apologies!) --- win/tclWinChan.c | 2 +- win/tclWinSock.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinChan.c b/win/tclWinChan.c index bc233ea..52b9e32 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -942,7 +942,7 @@ TclpOpenFileChannel( if (interp != (Tcl_Interp *) NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": %s", - TclGetString(pathPtr),, Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 6986528..7894920 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1282,7 +1282,7 @@ CreateSocket( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", - (errorMsg ? errorMsg : Tcl_PosixError(interp))); + (errorMsg ? errorMsg : Tcl_PosixError(interp)))); } if (sock != INVALID_SOCKET) { -- cgit v0.12 From bd99b30e349edc8d11ba6da32fbbd2050dbc671d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 6 Aug 2012 06:54:36 +0000 Subject: Reference to correct Bug #number --- ChangeLog | 2 +- generic/tclCmdAH.c | 2 +- generic/tclFCmd.c | 2 +- generic/tclIOUtil.c | 2 +- generic/tclTest.c | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index b92cc9b..77d483d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -335,7 +335,7 @@ 2011-11-22 Jan Nijtmans - * generic/tclCmdAH.c: [Bug 2935503] Windows: file mtime + * generic/tclCmdAH.c: [Bug 3354324] Windows: file mtime * generic/tclIOUtil.c: sets wrong time 2011-10-11 Jan Nijtmans diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 63d9111..45e138c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -13,7 +13,7 @@ */ #ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ +/* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 3d6a169..5ad7063 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -11,7 +11,7 @@ */ #ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ +/* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 94d0a6c..69b7e44 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -19,7 +19,7 @@ */ #ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ +/* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif diff --git a/generic/tclTest.c b/generic/tclTest.c index 3bf4b58..8256461 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -16,7 +16,7 @@ */ #ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ +/* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif -- cgit v0.12 From 1febf9e8972ab607090b31e5debd278e35c55bda Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 6 Aug 2012 08:48:57 +0000 Subject: fix two minor blunders, introduced by [1fb35ca910] Only define _USE_32BIT_TIME_T for Tcl build, and only once. --- generic/tclFCmd.c | 5 ----- generic/tclTest.c | 5 ----- win/tclWinPort.h | 2 +- win/tclWinSerial.c | 4 ++-- 4 files changed, 3 insertions(+), 13 deletions(-) diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 6611480..33c1496 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -10,11 +10,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef _WIN64 -/* See [Bug 3354324]: file mtime sets wrong time */ -# define _USE_32BIT_TIME_T -#endif - #include "tclInt.h" #include "tclFileSystem.h" diff --git a/generic/tclTest.c b/generic/tclTest.c index aa5a46d..5dc95f9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -15,11 +15,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef _WIN64 -/* See [Bug 3354324]: file mtime sets wrong time */ -# define _USE_32BIT_TIME_T -#endif - #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 23e79b0..c6ac2b7 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -14,7 +14,7 @@ #ifndef _TCLWINPORT #define _TCLWINPORT -#ifndef _WIN64 +#if !defined(_WIN64) && defined(BUILD_tcl) /* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index fb7f69b..9e9d1af 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -2002,7 +2002,7 @@ SerialSetOptionProc( if (interp != NULL) { TclWinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get comm state: ", Tcl_PosixError(interp))); + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; @@ -2010,7 +2010,7 @@ SerialSetOptionProc( if (interp != NULL) { TclWinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't set comm state: ", Tcl_PosixError(interp))); + "can't set comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } -- cgit v0.12 From 19e3b378a89091b1d0968a3db2b4f2ad493dc65a Mon Sep 17 00:00:00 2001 From: stwo Date: Mon, 6 Aug 2012 11:45:10 +0000 Subject: Installer consistency tweaks. --- unix/Makefile.in | 4 ++-- unix/configure.in | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 068cb12..0ede587 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -856,7 +856,7 @@ install-libraries: libraries @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; - @echo "Installing library encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; + @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \ done; @@ -867,7 +867,7 @@ install-libraries: libraries fi install-tzdata: ${NATIVE_TCLSH} - @echo "Installing time zone data" + @echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/" @${NATIVE_TCLSH} $(TOOL_DIR)/installData.tcl \ $(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata diff --git a/unix/configure.in b/unix/configure.in index c8f0bc6..dc0d543 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -841,8 +841,8 @@ if test "$FRAMEWORK_BUILD" = "1" ; then HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' - EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we -- cgit v0.12 From 12138ab3247620cd373014b9fc8047d9902c365e Mon Sep 17 00:00:00 2001 From: stwo Date: Tue, 7 Aug 2012 02:55:38 +0000 Subject: No need for install-sh to be executable. --- unix/Makefile.in | 1 - 1 file changed, 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 0ede587..c369f57 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1928,7 +1928,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M $(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in chmod 775 $(DISTDIR)/unix/ldAix - chmod +x $(DISTDIR)/unix/install-sh mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic -- cgit v0.12 From 98e448cf51f3baf3476bff4bd577f1cd8c4a5294 Mon Sep 17 00:00:00 2001 From: stwo Date: Tue, 7 Aug 2012 06:46:59 +0000 Subject: Installer improvements, like [226a993973]. --- unix/Makefile.in | 69 +++---- unix/configure | 4 +- unix/configure.in | 4 +- unix/install-sh | 580 +++++++++++++++++++++++++++++++++++++++++++++--------- 4 files changed, 526 insertions(+), 131 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index a527bf0..bdcbda0 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -151,10 +151,11 @@ SHELL = @MAKEFILE_SHELL@ INSTALL_STRIP_PROGRAM = -s INSTALL_STRIP_LIBRARY = -S -x -INSTALL = @srcdir@/../unix/install-sh -c +INSTALL = $(SHELL) $(UNIX_DIR)/install-sh -c INSTALL_PROGRAM = ${INSTALL} INSTALL_LIBRARY = ${INSTALL} INSTALL_DATA = ${INSTALL} -m 644 +INSTALL_DATA_DIR = ${INSTALL} -d -m 755 # TCL_EXE is the name of a tclsh executable that is available *BEFORE* running # make for the first time. Certain build targets (make genstubs) need it to be @@ -712,14 +713,10 @@ install-binaries: binaries do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; - @if test ! -x $(SRC_DIR)/../unix/install-sh; then \ - chmod +x $(SRC_DIR)/../unix/install-sh; \ - fi @echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/" @@INSTALL_LIB@ @chmod 555 "$(DLL_INSTALL_DIR)"/$(LIB_FILE) @@ -738,8 +735,7 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @@ -747,15 +743,11 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - mkdir -p "$(SCRIPT_INSTALL_DIR)"/$$i; \ - chmod 755 "$(SCRIPT_INSTALL_DIR)"/$$i; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ else true; \ fi; \ done; - @if test ! -x $(SRC_DIR)/../unix/install-sh; then \ - chmod +x $(SRC_DIR)/../unix/install-sh; \ - fi - @echo "Installing header files"; + @echo "Installing header files to $(INCLUDE_INSTALL_DIR)/"; @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ $(GENERIC_DIR)/tclPlatDecls.h \ $(GENERIC_DIR)/tclTomMath.h \ @@ -763,20 +755,20 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ $(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)"; \ done; - @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; + @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"; @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \ $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ done; - @echo "Installing library http1.0 directory"; + @echo "Installing package http1.0 files to $(SCRIPT_INSTALL_DIR)/http1.0/"; @for i in $(TOP_DIR)/library/http1.0/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; @echo "Installing package http 2.7.9 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/http-2.7.9.tm; - @echo "Installing library opt0.4 directory"; + @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ @@ -791,7 +783,7 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; - @echo "Installing library encoding directory"; + @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \ done; @@ -802,40 +794,44 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs fi install-tzdata: ${TCL_EXE} - @echo "Installing time zone data" + @echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/" @@LD_LIBRARY_PATH_VAR@="`pwd`:$${@LD_LIBRARY_PATH_VAR@}"; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./${TCL_EXE} $(TOOL_DIR)/installData.tcl \ $(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata -install-msgs: ${TCL_EXE} - @echo "Installing message catalogs" - @@LD_LIBRARY_PATH_VAR@="`pwd`:$${@LD_LIBRARY_PATH_VAR@}"; export @LD_LIBRARY_PATH_VAR@; \ - TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ - ./${TCL_EXE} $(TOOL_DIR)/installData.tcl \ - $(TOP_DIR)/library/msgs "$(SCRIPT_INSTALL_DIR)"/msgs +install-msgs: + @for i in msgs; \ + do \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ + else true; \ + fi; \ + done; + @echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/" + @for i in $(TOP_DIR)/library/msgs/*.msg ; do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/msgs; \ + done; install-doc: doc @for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)" ; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; - @echo "Installing and cross-linking top-level (.1) docs"; + @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.1; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \ done - - @echo "Installing and cross-linking C API (.3) docs"; + @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.3; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \ done - - @echo "Installing and cross-linking command (.n) docs"; + @echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.n; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ done @@ -846,15 +842,11 @@ install-private-headers: libraries do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - mkdir -p "$$i"; \ - chmod 755 "$$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; - @if test ! -x $(SRC_DIR)/../unix/install-sh; then \ - chmod +x $(SRC_DIR)/../unix/install-sh; \ - fi - @echo "Installing private header files"; + @echo "Installing private header files to $(PRIVATE_INCLUDE_INSTALL_DIR)/"; @for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \ $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \ $(UNIX_DIR)/tclUnixPort.h; \ @@ -1628,7 +1620,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure $(DISTDIR)/unix chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in chmod 775 $(DISTDIR)/unix/ldAix - chmod +x $(DISTDIR)/unix/install-sh mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic diff --git a/unix/configure b/unix/configure index 753f7c0..4a3a884 100755 --- a/unix/configure +++ b/unix/configure @@ -18989,8 +18989,8 @@ _ACEOF HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' - EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we diff --git a/unix/configure.in b/unix/configure.in index 8bab86e..1487752 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -803,8 +803,8 @@ if test "$FRAMEWORK_BUILD" = "1" ; then HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' - EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we diff --git a/unix/install-sh b/unix/install-sh index 8cff938..7c34c3f 100755 --- a/unix/install-sh +++ b/unix/install-sh @@ -1,124 +1,528 @@ #!/bin/sh +# install - install a program, script, or datafile + +scriptversion=2011-04-20.01; # UTC +# This originates from X11R5 (mit/util/scripts/install.sh), which was +# later released in X11R6 (xc/config/util/install.sh) with the +# following copyright and license. # -# install - install a program, script, or datafile -# This comes from X11R5; it is not part of GNU. +# Copyright (C) 1994 X Consortium +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +# +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. +# +# +# FSF changes to this file are in the public domain. # -# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. -# +nl=' +' +IFS=" "" $nl" # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" +doit=${DOITPROG-} +if test -z "$doit"; then + doit_exec=exec +else + doit_exec=$doit +fi + +# Put in absolute file names if you don't have them in your path; +# or use environment vars. +chgrpprog=${CHGRPPROG-chgrp} +chmodprog=${CHMODPROG-chmod} +chownprog=${CHOWNPROG-chown} +cmpprog=${CMPPROG-cmp} +cpprog=${CPPROG-cp} +mkdirprog=${MKDIRPROG-mkdir} +mvprog=${MVPROG-mv} +rmprog=${RMPROG-rm} +stripprog=${STRIPPROG-strip} -# put in absolute paths if you don't have them in your path; or use env. vars. +posix_glob='?' +initialize_posix_glob=' + test "$posix_glob" != "?" || { + if (set -f) 2>/dev/null; then + posix_glob= + else + posix_glob=: + fi + } +' -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" +posix_mkdir= -instcmd="$mvprog" -chmodcmd="" -chowncmd="" -chgrpcmd="" -stripcmd="" +# Desired mode of installed file. +mode=0755 + +chgrpcmd= +chmodcmd=$chmodprog +chowncmd= +mvcmd=$mvprog rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - -S) stripcmd="$stripprog $2" - shift - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - dst=$1 - fi - shift - continue;; - esac +stripcmd= + +src= +dst= +dir_arg= +dst_arg= + +copy_on_change=false +no_target_directory= + +usage="\ +Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE + or: $0 [OPTION]... SRCFILES... DIRECTORY + or: $0 [OPTION]... -t DIRECTORY SRCFILES... + or: $0 [OPTION]... -d DIRECTORIES... + +In the 1st form, copy SRCFILE to DSTFILE. +In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. +In the 4th, create DIRECTORIES. + +Options: + --help display this help and exit. + --version display version info and exit. + + -c (ignored) + -C install only if different (preserve the last data modification time) + -d create directories instead of installing files. + -g GROUP $chgrpprog installed files to GROUP. + -m MODE $chmodprog installed files to MODE. + -o USER $chownprog installed files to USER. + -s $stripprog installed files. + -S $stripprog installed files. + -t DIRECTORY install into DIRECTORY. + -T report an error if DSTFILE is a directory. + +Environment variables override the default commands: + CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG + RMPROG STRIPPROG +" + +while test $# -ne 0; do + case $1 in + -c) ;; + + -C) copy_on_change=true;; + + -d) dir_arg=true;; + + -g) chgrpcmd="$chgrpprog $2" + shift;; + + --help) echo "$usage"; exit $?;; + + -m) mode=$2 + case $mode in + *' '* | *' '* | *' +'* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; + + -o) chowncmd="$chownprog $2" + shift;; + + -s) stripcmd=$stripprog;; + + -S) stripcmd="$stripprog $2" + shift;; + + -t) dst_arg=$2 + shift;; + + -T) no_target_directory=true;; + + --version) echo "$0 $scriptversion"; exit $?;; + + --) shift + break;; + + -*) echo "$0: invalid option: $1" >&2 + exit 1;; + + *) break;; + esac + shift done -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 +if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then + # When -d is used, all remaining arguments are directories to create. + # When -t is used, the destination is already specified. + # Otherwise, the last argument is the destination. Remove it from $@. + for arg + do + if test -n "$dst_arg"; then + # $@ is not empty: it contains at least $arg. + set fnord "$@" "$dst_arg" + shift # fnord + fi + shift # arg + dst_arg=$arg + done fi -if [ x"$dst" = x ] -then - echo "install: no destination specified" - exit 1 +if test $# -eq 0; then + if test -z "$dir_arg"; then + echo "$0: no input file specified." >&2 + exit 1 + fi + # It's OK to call `install-sh -d' without argument. + # This can happen when creating conditional directories. + exit 0 fi +if test -z "$dir_arg"; then + do_exit='(exit $ret); exit $ret' + trap "ret=129; $do_exit" 1 + trap "ret=130; $do_exit" 2 + trap "ret=141; $do_exit" 13 + trap "ret=143; $do_exit" 15 -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic + # Set umask so as not to create temps with too-generous modes. + # However, 'strip' requires both read and write access to temps. + case $mode in + # Optimize common cases. + *644) cp_umask=133;; + *755) cp_umask=22;; -if [ -d "$dst" ] -then - dst="$dst/`basename "$src"`" + *[0-7]) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw='% 200' + fi + cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; + *) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw=,u+rw + fi + cp_umask=$mode$u_plus_rw;; + esac fi -# Make a temp file name in the proper directory. +for src +do + # Protect names starting with `-'. + case $src in + -*) src=./$src;; + esac + + if test -n "$dir_arg"; then + dst=$src + dstdir=$dst + test -d "$dstdir" + dstdir_status=$? + else + + # Waiting for this to be detected by the "$cpprog $src $dsttmp" command + # might cause directories to be created, which would be especially bad + # if $src (and thus $dsttmp) contains '*'. + if test ! -f "$src" && test ! -d "$src"; then + echo "$0: $src does not exist." >&2 + exit 1 + fi + + if test -z "$dst_arg"; then + echo "$0: no destination specified." >&2 + exit 1 + fi + + dst=$dst_arg + # Protect names starting with `-'. + case $dst in + -*) dst=./$dst;; + esac + + # If destination is a directory, append the input filename; won't work + # if double slashes aren't ignored. + if test -d "$dst"; then + if test -n "$no_target_directory"; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 + fi + dstdir=$dst + dst=$dstdir/`basename "$src"` + dstdir_status=0 + else + # Prefer dirname, but fall back on a substitute if dirname fails. + dstdir=` + (dirname "$dst") 2>/dev/null || + expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$dst" : 'X\(//\)[^/]' \| \ + X"$dst" : 'X\(//\)$' \| \ + X"$dst" : 'X\(/\)' \| . 2>/dev/null || + echo X"$dst" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q' + ` + + test -d "$dstdir" + dstdir_status=$? + fi + fi + + obsolete_mkdir_used=false + + if test $dstdir_status != 0; then + case $posix_mkdir in + '') + # Create intermediate dirs using mode 755 as modified by the umask. + # This is like FreeBSD 'install' as of 1997-10-28. + umask=`umask` + case $stripcmd.$umask in + # Optimize common cases. + *[2367][2367]) mkdir_umask=$umask;; + .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; + + *[0-7]) + mkdir_umask=`expr $umask + 22 \ + - $umask % 100 % 40 + $umask % 20 \ + - $umask % 10 % 4 + $umask % 2 + `;; + *) mkdir_umask=$umask,go-w;; + esac + + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + case $umask in + *[123567][0-7][0-7]) + # POSIX mkdir -p sets u+wx bits regardless of umask, which + # is incompatible with FreeBSD 'install' when (umask & 300) != 0. + ;; + *) + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 -dstdir="`dirname "$dst"`" -dsttmp="$dstdir"/#inst.$$# + if (umask $mkdir_umask && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writeable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + ls_ld_tmpdir=`ls -ld "$tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/d" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null + fi + trap '' 0;; + esac;; + esac + + if + $posix_mkdir && ( + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + ) + then : + else + + # The umask is ridiculous, or mkdir does not conform to POSIX, + # or it failed possibly due to a race condition. Create the + # directory the slow way, step by step, checking for races as we go. + + case $dstdir in + /*) prefix='/';; + -*) prefix='./';; + *) prefix='';; + esac + + eval "$initialize_posix_glob" + + oIFS=$IFS + IFS=/ + $posix_glob set -f + set fnord $dstdir + shift + $posix_glob set +f + IFS=$oIFS -# Move or copy the file name to the temp name + prefixes= -$doit $instcmd "$src" "$dsttmp" + for d + do + test -z "$d" && continue -# and set any options; do chmod last to preserve setuid bits + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask=$mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ + done -if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dsttmp"; fi -if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dsttmp"; fi -if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dsttmp"; fi -if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dsttmp"; fi + if test -n "$prefixes"; then + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true + fi + fi + fi -# Now rename the file to the real destination. + if test -n "$dir_arg"; then + { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && + { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || + test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 + else -$doit $rmcmd "$dst" -$doit $mvcmd "$dsttmp" "$dst" + # Make a couple of temp file names in the proper directory. + dsttmp=$dstdir/_inst.$$_ + rmtmp=$dstdir/_rm.$$_ + # Trap to clean up those temp files at exit. + trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 + + # Copy the file name to the temp name. + (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && + + # and set any options; do chmod last to preserve setuid bits. + # + # If any of these fail, we abort the whole thing. If we want to + # ignore errors from any of these, just make sure not to ignore + # errors from the above "$doit $cpprog $src $dsttmp" command. + # + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && + { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && + { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && + + # If -C, don't bother to copy if it wouldn't change the file. + if $copy_on_change && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + + eval "$initialize_posix_glob" && + $posix_glob set -f && + set X $old && old=:$2:$4:$5:$6 && + set X $new && new=:$2:$4:$5:$6 && + $posix_glob set +f && + + test "$old" = "$new" && + $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 + then + rm -f "$dsttmp" + else + # Rename the file to the real destination. + $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || + + # The rename failed, perhaps because mv can't rename something else + # to itself, or perhaps because mv is so ancient that it does not + # support -f. + { + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd -f "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" + } + fi || exit 1 + + trap '' 0 + fi +done -exit 0 +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC" +# time-stamp-end: "; # UTC" +# End: -- cgit v0.12 From de3dd1a56602c61a4d1d2f8583ebaddd68207f43 Mon Sep 17 00:00:00 2001 From: stwo Date: Tue, 7 Aug 2012 07:19:27 +0000 Subject: A little more installer consistency tweaking. --- unix/Makefile.in | 6 +++--- unix/configure | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index c369f57..4d5595d 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -894,17 +894,17 @@ install-doc: doc else true; \ fi; \ done; - @echo "Installing and cross-linking top-level (.1) docs"; + @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.1; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \ done - @echo "Installing and cross-linking C API (.3) docs"; + @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.3; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \ done - @echo "Installing and cross-linking command (.n) docs"; + @echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.n; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ done diff --git a/unix/configure b/unix/configure index 2e36ad2..18611f0 100755 --- a/unix/configure +++ b/unix/configure @@ -19437,8 +19437,8 @@ _ACEOF HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' - EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we -- cgit v0.12 From 04049103c8d246d5dbc6c6d62e12b2f462208abb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Aug 2012 14:58:34 +0000 Subject: add 3 testcases for "dde poke", only active with --enable-symbols (we need a "dde poke" server for that, which is now built into tcldde14g.dll, but not in tcldde14.dll) --- tests/winDde.test | 21 +++++++++++++++++++++ win/tclWinDde.c | 55 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 75 insertions(+), 1 deletion(-) diff --git a/tests/winDde.test b/tests/winDde.test index 8befa3c..8d9bd12 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -15,6 +15,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +testConstraint debug [::tcl::pkgconfig get debug] testConstraint dde 0 if {[testConstraint win]} { if {![catch { @@ -166,6 +167,16 @@ test winDde-3.7 {DDE request binary} -constraints dde -body { dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00] scan [set \xe1] %c } -result 196 +test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke TclEval self \xe1 \xc4 + dde request TclEval self \xe1 +} -result \xc4 +test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke -binary TclEval self \xe1 \xc3\x84\x00 + dde request TclEval self \xe1 +} -result \xc4 # ------------------------------------------------------------------------- @@ -207,6 +218,16 @@ test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body { update set \xe1 } -result foo +test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body { + set \xe1 "" + set name ch\xEDld-4.5 + set child [createChildProcess $name] + dde poke TclEval $name \xe1 foo + set \xe1 [dde request TclEval $name \xe1] + dde execute TclEval $name {set done 1} + update + set \xe1 +} -result foo # ------------------------------------------------------------------------- diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 7b9fbf4..23b3a8e 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -17,7 +17,13 @@ #include #include -#ifndef UNICODE +#ifdef UNICODE +# if !defined(NDEBUG) + /* test POKE server Implemented for UNICODE in debug mode only */ +# undef CBF_FAIL_POKES +# define CBF_FAIL_POKES 0 +# endif +#else # undef CP_WINUNICODE # define CP_WINUNICODE CP_WINANSI # undef Tcl_WinTCharToUtf @@ -786,6 +792,53 @@ DdeServerProc( } return ddeReturn; +#if !CBF_FAIL_POKES + case XTYP_POKE: + /* + * This is a poke for a Tcl variable, only implemented in + * debug/UNICODE mode. + */ + ddeReturn = DDE_FNOTPROCESSED; + + if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { + return ddeReturn; + } + + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { + Tcl_DString ds; + Tcl_Obj *variableObjPtr; + + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + CP_WINUNICODE); + Tcl_WinTCharToUtf(utilString, -1, &ds); + utilString = (TCHAR *) DdeAccessData(hData, &dlen); + if (uFmt == CF_TEXT) { + variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); + } else { + variableObjPtr = Tcl_NewUnicodeObj(utilString, -1); + } + + Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + variableObjPtr, TCL_GLOBAL_ONLY); + + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dString); + ddeReturn = (HDDEDATA) DDE_FACK; + } + return ddeReturn; + +#endif case XTYP_EXECUTE: { /* * Execute this script. The results will be saved into a list object -- cgit v0.12 From fa8578631ca16ef4a01ce48b5c7b27d5dad66e54 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 7 Aug 2012 15:23:27 +0000 Subject: 3554250 Overlooked one field of cleanup in the thread exit handler for the filesystem subsystem. --- ChangeLog | 5 +++++ generic/tclIOUtil.c | 1 + 2 files changed, 6 insertions(+) diff --git a/ChangeLog b/ChangeLog index 7a3b39f..9423c98 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-07 Don Porter + + * generic/tclIOUtil.c: [Bug 3554250] Overlooked one field of + cleanup in the thread exit handler for the filesystem subsystem. + 2012-07-31 Jan Nijtmans * win/nmakehlp.c: Backport from Tcl 8.6, but add -Q option from diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6cf87ad..348e7bf 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -520,6 +520,7 @@ FsThrExitProc( ckfree((char *)fsRecPtr); fsRecPtr = tmpFsRecPtr; } + tsdPtr->filesystemList = NULL; tsdPtr->initialized = 0; } -- cgit v0.12 From 0fe2d45ae44323638f143bf320c77a5cb6df2a01 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 7 Aug 2012 20:57:08 +0000 Subject: Minor changes to improve style (C89 declarations, consistent indentation, clarification of #endifs, reduction of unnecessary casts, use of array syntax for reading array elements, etc.) --- generic/tclCkalloc.c | 12 +- generic/tclIORChan.c | 4 +- generic/tclIOUtil.c | 9 +- generic/tclMain.c | 98 ++++--- generic/tclResult.c | 57 ++-- generic/tclUtil.c | 803 ++++++++++++++++++++++++++++++--------------------- unix/tclLoadOSF.c | 14 +- unix/tclLoadShl.c | 17 +- unix/tclUnixFile.c | 51 ++-- unix/tclUnixNotfy.c | 175 ++++++----- win/tclWinReg.c | 48 ++- 11 files changed, 746 insertions(+), 542 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 6443975..ab977cb 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -170,11 +170,15 @@ TclInitDbCkalloc(void) */ int -TclDumpMemoryInfo(ClientData clientData, int flags) +TclDumpMemoryInfo( + ClientData clientData, + int flags) { char buf[1024]; - if (clientData == NULL) { return 0; } + if (clientData == NULL) { + return 0; + } sprintf(buf, "total mallocs %10d\n" "total frees %10d\n" @@ -1255,7 +1259,9 @@ Tcl_ValidateAllMemory( } int -TclDumpMemoryInfo(ClientData clientData, int flags) +TclDumpMemoryInfo( + ClientData clientData, + int flags) { return 1; } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index a354d60..cb0282a 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1774,7 +1774,9 @@ ReflectBlock( */ static void -ReflectThread(ClientData clientData, int action) +ReflectThread( + ClientData clientData, + int action) { ReflectedChannel *rcPtr = clientData; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 4df7f36..2d6d898 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -648,23 +648,26 @@ TclFSEpochOk( } static void -Claim() +Claim(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + tsdPtr->claims++; } static void -Disclaim() +Disclaim(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + tsdPtr->claims--; } int -TclFSEpoch() +TclFSEpoch(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + return tsdPtr->filesystemEpoch; } diff --git a/generic/tclMain.c b/generic/tclMain.c index 88b4e51..14139ec 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -16,11 +16,12 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -/** - * On Windows, this file needs to be compiled twice, once with - * TCL_ASCII_MAIN defined. This way both Tcl_Main and Tcl_MainExW - * can be implemented, sharing the same source code. +/* + * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN + * defined. This way both Tcl_Main and Tcl_MainExW can be implemented, sharing + * the same source code. */ + #if defined(TCL_ASCII_MAIN) # ifdef UNICODE # undef UNICODE @@ -40,12 +41,12 @@ #define DEFAULT_PRIMARY_PROMPT "% " /* - * This file can be compiled on Windows in UNICODE mode, as well as - * on all other platforms using the native encoding. This is done - * by using the normal Windows functions like _tcscmp, but on - * platforms which don't have we have to translate that - * to strcmp here. + * This file can be compiled on Windows in UNICODE mode, as well as on all + * other platforms using the native encoding. This is done by using the normal + * Windows functions like _tcscmp, but on platforms which don't have + * we have to translate that to strcmp here. */ + #ifndef __WIN32__ # define TCHAR char # define TEXT(arg) arg @@ -128,10 +129,11 @@ typedef struct InteractiveState { MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); -static void FreeMainInterp(ClientData clientData); +static void FreeMainInterp(ClientData clientData); #ifndef TCL_ASCII_MAIN static Tcl_ThreadDataKey dataKey; + /* *---------------------------------------------------------------------- * @@ -333,8 +335,9 @@ Tcl_MainEx( if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && (TEXT('-') != argv[3][0])) { - Tcl_Obj *value = NewNativeObj(argv[2], -1); - Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value)); + Tcl_Obj *value = NewNativeObj(argv[2], -1); + Tcl_SetStartupScript(NewNativeObj(argv[3], -1), + Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; @@ -395,8 +398,9 @@ Tcl_MainEx( /* * Arrange for final deletion of the main interp */ - /* ARGH Munchhausen effect */ - Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp); + + /* ARGH Munchhausen effect */ + Tcl_CreateExitHandler(FreeMainInterp, interp); } /* @@ -458,6 +462,7 @@ Tcl_MainEx( mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { int length; + if (is.tty) { Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { @@ -523,7 +528,8 @@ Tcl_MainEx( Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); - code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); + code = Tcl_RecordAndEvalObj(interp, is.commandPtr, + TCL_EVAL_GLOBAL); is.input = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_NewObj(); @@ -557,7 +563,8 @@ Tcl_MainEx( Prompt(interp, &is); } - Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is); + Tcl_CreateChannelHandler(is.input, TCL_READABLE, + StdinProc, &is); } mainLoopProc(); @@ -568,24 +575,23 @@ Tcl_MainEx( } is.input = Tcl_GetStdChannel(TCL_STDIN); } -#ifdef TCL_MEM_DEBUG /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ +#ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { Tcl_SetMainLoop(NULL); Tcl_DeleteInterp(interp); } -#endif +#endif /* TCL_MEM_DEBUG */ } done: mainLoopProc = TclGetMainLoop(); - if ((exitCode == 0) && (mainLoopProc != NULL) - && !Tcl_LimitExceeded(interp)) { + if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at @@ -605,21 +611,21 @@ Tcl_MainEx( * exit. The Tcl_EvalObjEx call should never return. */ - if (!Tcl_InterpDeleted(interp)) { - if (!Tcl_LimitExceeded(interp)) { - Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); + if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { + Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); - Tcl_IncrRefCount(cmd); - Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmd); - } + Tcl_IncrRefCount(cmd); + Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmd); } - /* - * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual - * is happening. Maybe interp has been deleted; maybe [exit] was - * redefined, maybe we've blown up because of an exceeded limit. We - * still want to cleanup and exit. - */ + + /* + * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is + * happening. Maybe interp has been deleted; maybe [exit] was redefined, + * maybe we've blown up because of an exceeded limit. We still want to + * cleanup and exit. + */ + Tcl_Exit(exitCode); } @@ -637,7 +643,7 @@ Tcl_Main( Tcl_FindExecutable(argv[0]); Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); } -#endif +#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ #ifndef TCL_ASCII_MAIN @@ -711,6 +717,7 @@ TclGetMainLoop(void) * *---------------------------------------------------------------------- */ + MODULE_SCOPE int TclFullFinalizationRequested(void) { @@ -727,7 +734,7 @@ TclFullFinalizationRequested(void) Tcl_DStringFree(&ds); } return finalize; -#endif +#endif /* PURIFY */ } #endif /* !TCL_ASCII_MAIN */ @@ -866,9 +873,8 @@ StdinProc( static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ - InteractiveState *isPtr) /* InteractiveState. Filled - * with PROMPT_NONE after a prompt is - * printed. */ + InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE + * after a prompt is printed. */ { Tcl_Obj *promptCmdPtr; int code; @@ -879,7 +885,7 @@ Prompt( } promptCmdPtr = Tcl_GetVar2Ex(interp, - ((isPtr->prompt == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), + (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { @@ -920,8 +926,8 @@ Prompt( * * FreeMainInterp -- * - * Exit handler used to cleanup the main interpreter and ancillary startup - * script storage at exit. + * Exit handler used to cleanup the main interpreter and ancillary + * startup script storage at exit. * *---------------------------------------------------------------------- */ @@ -930,13 +936,13 @@ static void FreeMainInterp( ClientData clientData) { - Tcl_Interp *interp = (Tcl_Interp *) clientData; + Tcl_Interp *interp = clientData; - /*if (TclInExit()) return;*/ + /*if (TclInExit()) return;*/ - if (!Tcl_InterpDeleted(interp)) { - Tcl_DeleteInterp(interp); - } + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } Tcl_SetStartupScript(NULL, NULL); Tcl_Release(interp); } diff --git a/generic/tclResult.c b/generic/tclResult.c index 17aac74..9707f20 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -380,12 +380,10 @@ Tcl_DiscardResult( if (statePtr->result == statePtr->appendResult) { ckfree(statePtr->appendResult); + } else if (statePtr->freeProc == TCL_DYNAMIC) { + ckfree(statePtr->result); } else if (statePtr->freeProc) { - if (statePtr->freeProc == TCL_DYNAMIC) { - ckfree(statePtr->result); - } else { - statePtr->freeProc(statePtr->result); - } + statePtr->freeProc(statePtr->result); } } @@ -585,7 +583,7 @@ Tcl_GetObjResult( * result, then reset the string result. */ - if (*(iPtr->result) != 0) { + if (iPtr->result[0] != 0) { ResetObjResult(iPtr); objResultPtr = iPtr->objResultPtr; @@ -601,7 +599,7 @@ Tcl_GetObjResult( iPtr->freeProc = 0; } iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; + iPtr->result[0] = 0; } return iPtr->objResultPtr; } @@ -1106,9 +1104,7 @@ Tcl_SetObjErrorCode( * * Tcl_GetErrorLine -- * - * Results: - * - * Side effects: + * Returns the line number associated with the current error. * *---------------------------------------------------------------------- */ @@ -1125,9 +1121,7 @@ Tcl_GetErrorLine( * * Tcl_SetErrorLine -- * - * Results: - * - * Side effects: + * Sets the line number associated with the current error. * *---------------------------------------------------------------------- */ @@ -1274,7 +1268,8 @@ TclProcessReturn( Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], + &valuePtr); if (valuePtr != NULL) { int infoLen; @@ -1285,7 +1280,8 @@ TclProcessReturn( iPtr->flags |= ERR_ALREADY_LOGGED; } } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], + &valuePtr); if (valuePtr != NULL) { int len, valueObjc; Tcl_Obj **valueObjv; @@ -1298,26 +1294,36 @@ TclProcessReturn( Tcl_IncrRefCount(newObj); iPtr->errorStack = newObj; } + /* * List extraction done after duplication to avoid moving the rug * if someone does [return -errorstack [info errorstack]] */ - if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { + + if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, + &valueObjv) == TCL_ERROR) { return TCL_ERROR; } iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* reset while keeping the list intrep as much as possible */ - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, + valueObjv); } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], + &valuePtr); if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { Tcl_SetErrorCode(interp, "NONE", NULL); } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], + &valuePtr); if (valuePtr != NULL) { TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine); } @@ -1421,7 +1427,8 @@ TclMergeReturnOptions( Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); if (valuePtr != NULL) { - if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, valuePtr, &code)) { + if (TclGetCompletionCodeFromObj(interp, valuePtr, + &code) == TCL_ERROR) { goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); @@ -1599,7 +1606,8 @@ Tcl_GetReturnOptions( * * TclNoErrorStack -- * - * Removes the -errorstack entry from an options dict to avoid reference cycles + * Removes the -errorstack entry from an options dict to avoid reference + * cycles. * * Results: * The (unshared) argument options dict, modified in -place. @@ -1608,12 +1616,13 @@ Tcl_GetReturnOptions( */ Tcl_Obj * -TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options) +TclNoErrorStack( + Tcl_Interp *interp, + Tcl_Obj *options) { Tcl_Obj **keys = GetKeys(); Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]); - return options; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 6d42080..13e54ec 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -26,9 +26,9 @@ static ProcessGlobalValue executableName = { }; /* - * The following values are used in the flags arguments of Tcl*Scan*Element and - * Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and TCL_DONT_QUOTE_HASH - * are defined in tcl.h, like so: + * The following values are used in the flags arguments of Tcl*Scan*Element + * and Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and + * TCL_DONT_QUOTE_HASH are defined in tcl.h, like so: * #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 @@ -54,8 +54,8 @@ static ProcessGlobalValue executableName = { * conversion is most appropriate for Tcl*Convert*Element() to perform, and * sets two bits of the flags value to indicate the mode selected. * - * CONVERT_NONE The element needs no quoting. Its literal string - * is suitable as is. + * CONVERT_NONE The element needs no quoting. Its literal string is + * suitable as is. * CONVERT_BRACE The conversion should be enclosing the literal string * in braces. * CONVERT_ESCAPE The conversion should be using backslashes to escape @@ -63,19 +63,19 @@ static ProcessGlobalValue executableName = { * CONVERT_MASK A mask value used to extract the conversion mode from * the flags argument. * Also indicates a strange conversion mode where all - * special characters are escaped with backslashes - * *except for braces*. This is a strange and unnecessary + * special characters are escaped with backslashes + * *except for braces*. This is a strange and unnecessary * case, but it's part of the historical way in which - * lists have been formatted in Tcl. To experiment with + * lists have been formatted in Tcl. To experiment with * removing this case, set the value of COMPAT to 0. * - * One last flag value is used only by callers of TclScanElement(). The flag + * One last flag value is used only by callers of TclScanElement(). The flag * value produced by a call to Tcl*Scan*Element() will never leave this bit * set. * - * CONVERT_ANY The caller of TclScanElement() declares it can make - * no promise about what public flags will be passed to - * the matching call of TclConvertElement(). As such, + * CONVERT_ANY The caller of TclScanElement() declares it can make no + * promise about what public flags will be passed to the + * matching call of TclConvertElement(). As such, * TclScanElement() has to determine the worst case * destination buffer length over all possibilities, and * in other cases this means an overestimate of the @@ -129,17 +129,17 @@ const Tcl_ObjType tclEndOffsetType = { /* * * STRING REPRESENTATION OF LISTS * * * * - * The next several routines implement the conversions of strings to and - * from Tcl lists. To understand their operation, the rules of parsing - * and generating the string representation of lists must be known. Here - * we describe them in one place. + * The next several routines implement the conversions of strings to and from + * Tcl lists. To understand their operation, the rules of parsing and + * generating the string representation of lists must be known. Here we + * describe them in one place. * - * A list is made up of zero or more elements. Any string is a list if - * it is made up of alternating substrings of element-separating ASCII - * whitespace and properly formatted elements. + * A list is made up of zero or more elements. Any string is a list if it is + * made up of alternating substrings of element-separating ASCII whitespace + * and properly formatted elements. * - * The ASCII characters which can make up the whitespace between list - * elements are: + * The ASCII characters which can make up the whitespace between list elements + * are: * * \u0009 \t TAB * \u000A \n NEWLINE @@ -158,69 +158,68 @@ const Tcl_ObjType tclEndOffsetType = { * * Unlike command parsing, the BACKSLASH NEWLINE sequence is not * considered to be a whitespace character. * - * * Other Unicode whitespace characters (recognized by - * [string is space] or Tcl_UniCharIsSpace()) do not play any role - * as element separators in Tcl lists. + * * Other Unicode whitespace characters (recognized by [string is space] + * or Tcl_UniCharIsSpace()) do not play any role as element separators + * in Tcl lists. * * * The NUL byte ought not appear, as it is not in strings properly * encoded for Tcl, but if it is present, it is not treated as - * separating whitespace, or a string terminator. It is just - * another character in a list element. - * - * The interpretaton of a formatted substring as a list element follows - * rules similar to the parsing of the words of a command in a Tcl script. - * Backslash substitution plays a key role, and is defined exactly as it is - * in command parsing. The same routine, TclParseBackslash() is used in both - * command parsing and list parsing. - * - * NOTE: This means that if and when backslash substitution rules ever - * change for command parsing, the interpretation of strings as lists also - * changes. + * separating whitespace, or a string terminator. It is just another + * character in a list element. + * + * The interpretaton of a formatted substring as a list element follows rules + * similar to the parsing of the words of a command in a Tcl script. Backslash + * substitution plays a key role, and is defined exactly as it is in command + * parsing. The same routine, TclParseBackslash() is used in both command + * parsing and list parsing. + * + * NOTE: This means that if and when backslash substitution rules ever change + * for command parsing, the interpretation of strings as lists also changes. * * Backslash substitution replaces an "escape sequence" of one or more * characters starting with * \u005c \ BACKSLASH - * with a single character. The one character escape sequent case happens - * only when BACKSLASH is the last character in the string. In all other - * cases, the escape sequence is at least two characters long. + * with a single character. The one character escape sequent case happens only + * when BACKSLASH is the last character in the string. In all other cases, the + * escape sequence is at least two characters long. * - * The formatted substrings are interpreted as element values according to - * the following cases: + * The formatted substrings are interpreted as element values according to the + * following cases: * * * If the first character of a formatted substring is * \u007b { OPEN BRACE * then the end of the substring is the matching * \u007d } CLOSE BRACE - * character, where matching is determined by counting nesting levels, - * and not including any brace characters that are contained within a - * backslash escape sequence in the nesting count. Having found the - * matching brace, all characters between the braces are the string - * value of the element. If no matching close brace is found before the - * end of the string, the string is not a Tcl list. If the character - * following the close brace is not an element separating whitespace - * character, or the end of the string, then the string is not a Tcl list. - * - * NOTE: this differs from a brace-quoted word in the parsing of a - * Tcl command only in its treatment of the backslash-newline sequence. - * In a list element, the literal characters in the backslash-newline - * sequence become part of the element value. In a script word, - * conversion to a single SPACE character is done. + * character, where matching is determined by counting nesting levels, and + * not including any brace characters that are contained within a backslash + * escape sequence in the nesting count. Having found the matching brace, + * all characters between the braces are the string value of the element. + * If no matching close brace is found before the end of the string, the + * string is not a Tcl list. If the character following the close brace is + * not an element separating whitespace character, or the end of the string, + * then the string is not a Tcl list. + * + * NOTE: this differs from a brace-quoted word in the parsing of a Tcl + * command only in its treatment of the backslash-newline sequence. In a + * list element, the literal characters in the backslash-newline sequence + * become part of the element value. In a script word, conversion to a + * single SPACE character is done. * * NOTE: Most list element values can be represented by a formatted - * substring using brace quoting. The exceptions are any element value - * that includes an unbalanced brace not in a backslash escape sequence, - * and any value that ends with a backslash not itself in a backslash - * escape sequence. + * substring using brace quoting. The exceptions are any element value that + * includes an unbalanced brace not in a backslash escape sequence, and any + * value that ends with a backslash not itself in a backslash escape + * sequence. * * * If the first character of a formatted substring is * \u0022 " QUOTE * then the end of the substring is the next QUOTE character, not counting * any QUOTE characters that are contained within a backslash escape - * sequence. If no next QUOTE is found before the end of the string, the - * string is not a Tcl list. If the character following the closing QUOTE - * is not an element separating whitespace character, or the end of the - * string, then the string is not a Tcl list. Having found the limits - * of the substring, the element value is produced by performing backslash + * sequence. If no next QUOTE is found before the end of the string, the + * string is not a Tcl list. If the character following the closing QUOTE is + * not an element separating whitespace character, or the end of the string, + * then the string is not a Tcl list. Having found the limits of the + * substring, the element value is produced by performing backslash * substitution on the character sequence between the open and close QUOTEs. * * NOTE: Any element value can be represented by this style of formatting, @@ -231,7 +230,7 @@ const Tcl_ObjType tclEndOffsetType = { * of the substring, the element value is produced by performing backslash * substitution on it. * - * NOTE: Any element value can be represented by this style of formatting, + * NOTE: Any element value can be represented by this style of formatting, * given suitable choice of backslash escape sequences, with one exception. * The empty string cannot be represented as a list element without the use * of either braces or quotes to delimit it. @@ -239,32 +238,32 @@ const Tcl_ObjType tclEndOffsetType = { * This collection of parsing rules is implemented in the routine * TclFindElement(). * - * In order to produce lists that can be parsed by these rules, we need - * the ability to distinguish between characters that are part of a list - * element value from characters providing syntax that define the structure - * of the list. This means that our code that generates lists must at a - * minimum be able to produce escape sequences for the 10 characters - * identified above that have significance to a list parser. + * In order to produce lists that can be parsed by these rules, we need the + * ability to distinguish between characters that are part of a list element + * value from characters providing syntax that define the structure of the + * list. This means that our code that generates lists must at a minimum be + * able to produce escape sequences for the 10 characters identified above + * that have significance to a list parser. * - * * * CANONICAL LISTS * * * * * + * * * CANONICAL LISTS * * * * * * * In addition to the basic rules for parsing strings into Tcl lists, there * are additional properties to be met by the set of list values that are * generated by Tcl. Such list values are often said to be in "canonical * form": * - * * When any canonical list is evaluated as a Tcl script, it is a script - * of either zero commands (an empty list) or exactly one command. The - * command word is exactly the first element of the list, and each argument - * word is exactly one of the following elements of the list. This means - * that any characters that have special meaning during script evaluation - * need special treatment when canonical lists are produced: + * * When any canonical list is evaluated as a Tcl script, it is a script of + * either zero commands (an empty list) or exactly one command. The command + * word is exactly the first element of the list, and each argument word is + * exactly one of the following elements of the list. This means that any + * characters that have special meaning during script evaluation need + * special treatment when canonical lists are produced: * * * Whitespace between elements may not include NEWLINE. * * The command terminating character, * \u003b ; SEMICOLON - * must be BRACEd, QUOTEd, or escaped so that it does not terminate - * the command prematurely. + * must be BRACEd, QUOTEd, or escaped so that it does not terminate the + * command prematurely. * * Any of the characters that begin substitutions in scripts, * \u0024 $ DOLLAR * \u005b [ OPEN BRACKET @@ -274,11 +273,10 @@ const Tcl_ObjType tclEndOffsetType = { * \u0023 # HASH * that HASH character must be BRACEd, QUOTEd, or escaped so that it * does not convert the command into a comment. - * * Any list element that contains the character sequence - * BACKSLASH NEWLINE cannot be formatted with BRACEs. The - * BACKSLASH character must be represented by an escape - * sequence, and unless QUOTEs are used, the NEWLINE must - * be as well. + * * Any list element that contains the character sequence BACKSLASH + * NEWLINE cannot be formatted with BRACEs. The BACKSLASH character + * must be represented by an escape sequence, and unless QUOTEs are + * used, the NEWLINE must be as well. * * * It is also guaranteed that one can use a canonical list as a building * block of a larger script within command substitution, as in this example: @@ -289,66 +287,66 @@ const Tcl_ObjType tclEndOffsetType = { * * * Finally it is guaranteed that enclosing a canonical list in braces * produces a new value that is also a canonical list. This new list has - * length 1, and its only element is the original canonical list. This - * same guarantee also makes it possible to construct scripts where an - * argument word is given a list value by enclosing the canonical form - * of that list in braces: + * length 1, and its only element is the original canonical list. This same + * guarantee also makes it possible to construct scripts where an argument + * word is given a list value by enclosing the canonical form of that list + * in braces: * set script "puts {[list $one $two $three]}"; eval $script * This sort of coding was once fairly common, though it's become more * idiomatic to see the following instead: * set script [list puts [list $one $two $three]]; eval $script - * In order to support this guarantee, every canonical list must have + * In order to support this guarantee, every canonical list must have * balance when counting those braces that are not in escape sequences. * * Within these constraints, the canonical list generation routines - * TclScanElement() and TclConvertElement() attempt to generate the string - * for any list that is easiest to read. When an element value is itself + * TclScanElement() and TclConvertElement() attempt to generate the string for + * any list that is easiest to read. When an element value is itself * acceptable as the formatted substring, it is usually used (CONVERT_NONE). - * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) - * is usually preferred over the use of escape sequences (CONVERT_ESCAPE). - * There are some exceptions to both of these preferences for reasons of - * code simplicity, efficiency, and continuation of historical habits. - * Canonical lists never use the QUOTE formatting to delimit their elements - * because that form of quoting does not nest, which makes construction of - * nested lists far too much trouble. Canonical lists always use only a - * single SPACE character for element-separating whitespace. + * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) is + * usually preferred over the use of escape sequences (CONVERT_ESCAPE). There + * are some exceptions to both of these preferences for reasons of code + * simplicity, efficiency, and continuation of historical habits. Canonical + * lists never use the QUOTE formatting to delimit their elements because that + * form of quoting does not nest, which makes construction of nested lists far + * too much trouble. Canonical lists always use only a single SPACE character + * for element-separating whitespace. * * * * FUTURE CONSIDERATIONS * * * * * When a list element requires quoting or escaping due to a CLOSE BRACKET * character or an internal QUOTE character, a strange formatting mode is - * recommended. For example, if the value "a{b]c}d" is converted by the - * usual modes: + * recommended. For example, if the value "a{b]c}d" is converted by the usual + * modes: * * CONVERT_BRACE: a{b]c}d => {a{b]c}d} * CONVERT_ESCAPE: a{b]c}d => a\{b\]c\}d * - * we get perfectly usable formatted list elements. However, this is not - * what Tcl releases have been producing. Instead, we have: + * we get perfectly usable formatted list elements. However, this is not what + * Tcl releases have been producing. Instead, we have: * * CONVERT_MASK: a{b]c}d => a{b\]c}d * - * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same - * effect can be seen replacing ] with " in this example. There does not - * appear to be any functional or aesthetic purpose for this strange - * additional mode. The sole purpose I can see for preserving it is to - * keep generating the same formatted lists programmers have become accustomed - * to, and perhaps written tests to expect. That is, compatibility only. - * The additional code complexity required to support this mode is significant. - * The lines of code supporting it are delimited in the routines below with - * #if COMPAT directives. This makes it easy to experiment with eliminating - * this formatting mode simply with "#define COMPAT 0" above. I believe - * this is worth considering. + * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same effect + * can be seen replacing ] with " in this example. There does not appear to be + * any functional or aesthetic purpose for this strange additional mode. The + * sole purpose I can see for preserving it is to keep generating the same + * formatted lists programmers have become accustomed to, and perhaps written + * tests to expect. That is, compatibility only. The additional code + * complexity required to support this mode is significant. The lines of code + * supporting it are delimited in the routines below with #if COMPAT + * directives. This makes it easy to experiment with eliminating this + * formatting mode simply with "#define COMPAT 0" above. I believe this is + * worth considering. * - * Another consideration is the treatment of QUOTE characters in list elements. - * TclConvertElement() must have the ability to produce the escape sequence - * \" so that when a list element begins with a QUOTE we do not confuse - * that first character with a QUOTE used as list syntax to define list - * structure. However, that is the only place where QUOTE characters need - * quoting. In this way, handling QUOTE could really be much more like - * the way we handle HASH which also needs quoting and escaping only in - * particular situations. Following up this could increase the set of - * list elements that can use the CONVERT_NONE formatting mode. + * Another consideration is the treatment of QUOTE characters in list + * elements. TclConvertElement() must have the ability to produce the escape + * sequence \" so that when a list element begins with a QUOTE we do not + * confuse that first character with a QUOTE used as list syntax to define + * list structure. However, that is the only place where QUOTE characters need + * quoting. In this way, handling QUOTE could really be much more like the way + * we handle HASH which also needs quoting and escaping only in particular + * situations. Following up this could increase the set of list elements that + * can use the CONVERT_NONE formatting mode. * * More speculative is that the demands of canonical list form require brace * balance for the list as a whole, while the current implementation achieves @@ -366,15 +364,15 @@ const Tcl_ObjType tclEndOffsetType = { * * Given 'bytes' pointing to 'numBytes' bytes, scan through them and * count the number of whitespace runs that could be list element - * separators. If 'numBytes' is -1, scan to the terminating '\0'. - * Not a full list parser. Typically used to get a quick and dirty - * overestimate of length size in order to allocate space for an - * actual list parser to operate with. + * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a + * full list parser. Typically used to get a quick and dirty overestimate + * of length size in order to allocate space for an actual list parser to + * operate with. * * Results: - * Returns the largest number of list elements that could possibly - * be in this string, interpreted as a Tcl list. If 'endPtr' is not - * NULL, writes a pointer to the end of the string scanned there. + * Returns the largest number of list elements that could possibly be in + * this string, interpreted as a Tcl list. If 'endPtr' is not NULL, + * writes a pointer to the end of the string scanned there. * * Side effects: * None. @@ -395,16 +393,25 @@ TclMaxListLength( goto done; } - /* No list element before leading white space */ + /* + * No list element before leading white space. + */ + count += 1 - TclIsSpaceProc(*bytes); - /* Count white space runs as potential element separators */ + /* + * Count white space runs as potential element separators. + */ + while (numBytes) { if ((numBytes == -1) && (*bytes == '\0')) { break; } if (TclIsSpaceProc(*bytes)) { - /* Space run started; bump count */ + /* + * Space run started; bump count. + */ + count++; do { bytes++; @@ -413,16 +420,22 @@ TclMaxListLength( if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { break; } - /* (*bytes) is non-space; return to counting state */ + + /* + * (*bytes) is non-space; return to counting state. + */ } bytes++; numBytes -= (numBytes != -1); } - /* No list element following trailing white space */ + /* + * No list element following trailing white space. + */ + count -= TclIsSpaceProc(bytes[-1]); - done: + done: if (endPtr) { *endPtr = bytes; } @@ -449,18 +462,18 @@ TclMaxListLength( * that's part of the element. If this is the last argument in the list, * then *nextPtr will point just after the last character in the list * (i.e., at the character at list+listLength). If sizePtr is non-NULL, - * *sizePtr is filled in with the number of bytes in the element. If - * the element is in braces, then *elementPtr will point to the character + * *sizePtr is filled in with the number of bytes in the element. If the + * element is in braces, then *elementPtr will point to the character * after the opening brace and *sizePtr will not include either of the * braces. If there isn't an element in the list, *sizePtr will be zero, * and both *elementPtr and *nextPtr will point just after the last * character in the list. If literalPtr is non-NULL, *literalPtr is set - * to a boolean value indicating whether the substring returned as - * the values of **elementPtr and *sizePtr is the literal value of - * a list element. If not, a call to TclCopyAndCollapse() is needed - * to produce the actual value of the list element. Note: this function - * does NOT collapse backslash sequences, but uses *literalPtr to tell - * callers when it is required for them to do so. + * to a boolean value indicating whether the substring returned as the + * values of **elementPtr and *sizePtr is the literal value of a list + * element. If not, a call to TclCopyAndCollapse() is needed to produce + * the actual value of the list element. Note: this function does NOT + * collapse backslash sequences, but uses *literalPtr to tell callers + * when it is required for them to do so. * * Side effects: * None. @@ -587,9 +600,10 @@ TclFindElement( /* * A backslash sequence not within a brace quoted element * means the value of the element is different from the - * substring we are parsing. A call to TclCopyAndCollapse() - * is needed to produce the element value. Inform the caller. + * substring we are parsing. A call to TclCopyAndCollapse() is + * needed to produce the element value. Inform the caller. */ + literal = 0; } TclParseBackslash(p, limit - p, &numChars, NULL); @@ -697,9 +711,9 @@ TclFindElement( * * Results: * Count bytes get copied from src to dst. Along the way, backslash - * sequences are substituted in the copy. After scanning count bytes - * from src, a null character is placed at the end of dst. Returns - * the number of bytes that got written to dst. + * sequences are substituted in the copy. After scanning count bytes from + * src, a null character is placed at the end of dst. Returns the number + * of bytes that got written to dst. * * Side effects: * None. @@ -717,6 +731,7 @@ TclCopyAndCollapse( while (count > 0) { char c = *src; + if (c == '\\') { int numRead; int backslashCount = TclParseBackslash(src, count, &numRead, dst); @@ -780,12 +795,11 @@ Tcl_SplitList( int length, size, i, result, elSize; /* - * Allocate enough space to work in. A (const char *) for each - * (possible) list element plus one more for terminating NULL, - * plus as many bytes as in the original string value, plus one - * more for a terminating '\0'. Space used to hold element separating - * white space in the original string gets re-purposed to hold '\0' - * characters in the argv array. + * Allocate enough space to work in. A (const char *) for each (possible) + * list element plus one more for terminating NULL, plus as many bytes as + * in the original string value, plus one more for a terminating '\0'. + * Space used to hold element separating white space in the original + * string gets re-purposed to hold '\0' characters in the argv array. */ size = TclMaxListLength(list, -1, &end) + 1; @@ -844,9 +858,9 @@ Tcl_SplitList( * enclosing braces) to make the string into a valid Tcl list element. * * Results: - * The return value is an overestimate of the number of bytes that - * will be needed by Tcl_ConvertElement to produce a valid list element - * from src. The word at *flagPtr is filled in with a value needed by + * The return value is an overestimate of the number of bytes that will + * be needed by Tcl_ConvertElement to produce a valid list element from + * src. The word at *flagPtr is filled in with a value needed by * Tcl_ConvertElement when doing the actual conversion. * * Side effects: @@ -876,10 +890,10 @@ Tcl_ScanElement( * to the first null byte. * * Results: - * The return value is an overestimate of the number of bytes that - * will be needed by Tcl_ConvertCountedElement to produce a valid list - * element from src. The word at *flagPtr is filled in with a value - * needed by Tcl_ConvertCountedElement when doing the actual conversion. + * The return value is an overestimate of the number of bytes that will + * be needed by Tcl_ConvertCountedElement to produce a valid list element + * from src. The word at *flagPtr is filled in with a value needed by + * Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: * None. @@ -906,24 +920,24 @@ Tcl_ScanCountedElement( * * TclScanElement -- * - * This function is a companion function to TclConvertElement. It - * scans a string to see what needs to be done to it (e.g. add - * backslashes or enclosing braces) to make the string into a valid Tcl - * list element. If length is -1, then the string is scanned from src up - * to the first null byte. A NULL value for src is treated as an - * empty string. The incoming value of *flagPtr is a report from the - * caller what additional flags it will pass to TclConvertElement(). + * This function is a companion function to TclConvertElement. It scans a + * string to see what needs to be done to it (e.g. add backslashes or + * enclosing braces) to make the string into a valid Tcl list element. If + * length is -1, then the string is scanned from src up to the first null + * byte. A NULL value for src is treated as an empty string. The incoming + * value of *flagPtr is a report from the caller what additional flags it + * will pass to TclConvertElement(). * * Results: - * The recommended formatting mode for the element is determined and - * a value is written to *flagPtr indicating that recommendation. This + * The recommended formatting mode for the element is determined and a + * value is written to *flagPtr indicating that recommendation. This * recommendation is combined with the incoming flag values in *flagPtr * set by the caller to determine how many bytes will be needed by * TclConvertElement() in which to write the formatted element following - * the recommendation modified by the flag values. This number of bytes - * is the return value of the routine. In some situations it may be - * an overestimate, but so long as the caller passes the same flags - * to TclConvertElement(), it will be large enough. + * the recommendation modified by the flag values. This number of bytes + * is the return value of the routine. In some situations it may be an + * overestimate, but so long as the caller passes the same flags to + * TclConvertElement(), it will be large enough. * * Side effects: * None. @@ -941,7 +955,7 @@ TclScanElement( const char *p = src; int nestingLevel = 0; /* Brace nesting count */ int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something - needs protection or escape. */ + * needs protection or escape. */ int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some * reason bare or brace-quoted form fails. */ int extra = 0; /* Count of number of extra bytes needed for @@ -953,10 +967,13 @@ TclScanElement( int preferEscape = 0; /* Use preferences to track whether to use */ int preferBrace = 0; /* CONVERT_MASK mode. */ int braceCount = 0; /* Count of all braces '{' '}' seen. */ -#endif +#endif /* COMPAT */ if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { - /* Empty string element must be brace quoted. */ + /* + * Empty string element must be brace quoted. + */ + *flagPtr = CONVERT_BRACE; return 2; } @@ -966,10 +983,11 @@ TclScanElement( * Must escape or protect so leading character of value is not * misinterpreted as list element delimiting syntax. */ + forbidNone = 1; #if COMPAT preferBrace = 1; -#endif +#endif /* COMPAT */ } while (length) { @@ -978,18 +996,21 @@ TclScanElement( case '{': /* TYPE_BRACE */ #if COMPAT braceCount++; -#endif +#endif /* COMPAT */ extra++; /* Escape '{' => '\{' */ nestingLevel++; break; case '}': /* TYPE_BRACE */ #if COMPAT braceCount++; -#endif +#endif /* COMPAT */ extra++; /* Escape '}' => '\}' */ nestingLevel--; if (nestingLevel < 0) { - /* Unbalanced braces! Cannot format with brace quoting. */ + /* + * Unbalanced braces! Cannot format with brace quoting. + */ + requireEscape = 1; } break; @@ -1002,7 +1023,7 @@ TclScanElement( break; #else /* FLOW THROUGH */ -#endif +#endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ case ';': /* TYPE_COMMAND_END */ @@ -1016,18 +1037,25 @@ TclScanElement( extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; -#endif +#endif /* COMPAT */ break; case '\\': /* TYPE_SUBS */ extra++; /* Escape '\' => '\\' */ if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { - /* Final backslash. Cannot format with brace quoting. */ + /* + * Final backslash. Cannot format with brace quoting. + */ + requireEscape = 1; break; } if (p[1] == '\n') { extra++; /* Escape newline => '\n', one byte longer */ - /* Backslash newline sequence. Brace quoting not permitted. */ + + /* + * Backslash newline sequence. Brace quoting not permitted. + */ + requireEscape = 1; length -= (length > 0); p++; @@ -1041,7 +1069,7 @@ TclScanElement( forbidNone = 1; #if COMPAT preferBrace = 1; -#endif +#endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ if (length == -1) { @@ -1055,22 +1083,33 @@ TclScanElement( p++; } - endOfString: + endOfString: if (nestingLevel != 0) { - /* Unbalanced braces! Cannot format with brace quoting. */ + /* + * Unbalanced braces! Cannot format with brace quoting. + */ + requireEscape = 1; } - /* We need at least as many bytes as are in the element value... */ + /* + * We need at least as many bytes as are in the element value... + */ + bytesNeeded = p - src; if (requireEscape) { /* - * We must use escape sequences. Add all the extra bytes needed - * to have room to create them. + * We must use escape sequences. Add all the extra bytes needed to + * have room to create them. */ + bytesNeeded += extra; - /* Make room to escape leading #, if needed. */ + + /* + * Make room to escape leading #, if needed. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } @@ -1080,12 +1119,13 @@ TclScanElement( if (*flagPtr & CONVERT_ANY) { /* * The caller has not let us know what flags it will pass to - * TclConvertElement() so compute the max size we might need for - * any possible choice. Normally the formatting using escape - * sequences is the longer one, and a minimum "extra" value of 2 - * makes sure we don't request too small a buffer in those edge - * cases where that's not true. + * TclConvertElement() so compute the max size we might need for any + * possible choice. Normally the formatting using escape sequences is + * the longer one, and a minimum "extra" value of 2 makes sure we + * don't request too small a buffer in those edge cases where that's + * not true. */ + if (extra < 2) { extra = 2; } @@ -1093,59 +1133,78 @@ TclScanElement( *flagPtr |= TCL_DONT_USE_BRACES; } if (forbidNone) { - /* We must request some form of quoting of escaping... */ + /* + * We must request some form of quoting of escaping... + */ + #if COMPAT if (preferEscape && !preferBrace) { /* - * If we are quoting solely due to ] or internal " characters - * use the CONVERT_MASK mode where we escape all special - * characters except for braces. "extra" counted space needed - * to escape braces too, so substract "braceCount" to get our - * actual needs. + * If we are quoting solely due to ] or internal " characters use + * the CONVERT_MASK mode where we escape all special characters + * except for braces. "extra" counted space needed to escape + * braces too, so substract "braceCount" to get our actual needs. */ + bytesNeeded += (extra - braceCount); /* Make room to escape leading #, if needed. */ if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } + /* * If the caller reports it will direct TclConvertElement() to * use full escapes on the element, add back the bytes needed to * escape the braces. */ + if (*flagPtr & TCL_DONT_USE_BRACES) { bytesNeeded += braceCount; } *flagPtr = CONVERT_MASK; goto overflowCheck; } -#endif +#endif /* COMPAT */ if (*flagPtr & TCL_DONT_USE_BRACES) { /* * If the caller reports it will direct TclConvertElement() to * use escapes, add the extra bytes needed to have room for them. */ + bytesNeeded += extra; - /* Make room to escape leading #, if needed. */ + + /* + * Make room to escape leading #, if needed. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } } else { - /* Add 2 bytes for room for the enclosing braces. */ + /* + * Add 2 bytes for room for the enclosing braces. + */ + bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; goto overflowCheck; } - /* So far, no need to quote or escape anything. */ + /* + * So far, no need to quote or escape anything. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { - /* If we need to quote a leading #, make room to enclose in braces. */ + /* + * If we need to quote a leading #, make room to enclose in braces. + */ + bytesNeeded += 2; } *flagPtr = CONVERT_NONE; - overflowCheck: + overflowCheck: if (bytesNeeded < 0) { Tcl_Panic("TclScanElement: string length overflow"); } @@ -1220,9 +1279,9 @@ Tcl_ConvertCountedElement( * * TclConvertElement -- * - * This is a companion function to TclScanElement. Given the - * information produced by TclScanElement, this function converts - * a string to a list element equal to that string. + * This is a companion function to TclScanElement. Given the information + * produced by TclScanElement, this function converts a string to a list + * element equal to that string. * * Results: * Information is copied to *dst in the form of a list element identical @@ -1236,7 +1295,8 @@ Tcl_ConvertCountedElement( *---------------------------------------------------------------------- */ -int TclConvertElement( +int +TclConvertElement( register const char *src, /* Source information for list element. */ int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ @@ -1245,19 +1305,28 @@ int TclConvertElement( int conversion = flags & CONVERT_MASK; char *p = dst; - /* Let the caller demand we use escape sequences rather than braces. */ + /* + * Let the caller demand we use escape sequences rather than braces. + */ + if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) { conversion = CONVERT_ESCAPE; } - /* No matter what the caller demands, empty string must be braced! */ - if ((src == NULL) || (length == 0) || ((*src == '\0') && (length == -1))) { + /* + * No matter what the caller demands, empty string must be braced! + */ + + if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { src = tclEmptyStringRep; length = 0; conversion = CONVERT_BRACE; } - /* Escape leading hash as needed and requested. */ + /* + * Escape leading hash as needed and requested. + */ + if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { if (conversion == CONVERT_ESCAPE) { p[0] = '\\'; @@ -1270,7 +1339,10 @@ int TclConvertElement( } } - /* No escape or quoting needed. Copy the literal string value. */ + /* + * No escape or quoting needed. Copy the literal string value. + */ + if (conversion == CONVERT_NONE) { if (length == -1) { /* TODO: INT_MAX overflow? */ @@ -1284,7 +1356,10 @@ int TclConvertElement( } } - /* Formatted string is original string enclosed in braces. */ + /* + * Formatted string is original string enclosed in braces. + */ + if (conversion == CONVERT_BRACE) { *p = '{'; p++; @@ -1304,7 +1379,10 @@ int TclConvertElement( /* conversion == CONVERT_ESCAPE or CONVERT_MASK */ - /* Formatted string is original string converted to escape sequences. */ + /* + * Formatted string is original string converted to escape sequences. + */ + for ( ; length; src++, length -= (length > 0)) { switch (*src) { case ']': @@ -1320,13 +1398,12 @@ int TclConvertElement( case '{': case '}': #if COMPAT - if (conversion == CONVERT_ESCAPE) { -#endif + if (conversion == CONVERT_ESCAPE) +#endif /* COMPAT */ + { *p = '\\'; p++; -#if COMPAT } -#endif break; case '\f': *p = '\\'; @@ -1362,13 +1439,15 @@ int TclConvertElement( if (length == -1) { return p - dst; } + /* - * If we reach this point, there's an embedded NULL in the - * string range being processed, which should not happen when - * the encoding rules for Tcl strings are properly followed. - * If the day ever comes when we stop tolerating such things, - * this is where to put the Tcl_Panic(). + * If we reach this point, there's an embedded NULL in the string + * range being processed, which should not happen when the + * encoding rules for Tcl strings are properly followed. If the + * day ever comes when we stop tolerating such things, this is + * where to put the Tcl_Panic(). */ + break; } *p = *src; @@ -1402,17 +1481,18 @@ Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -# define LOCAL_SIZE 20 +#define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; int i, bytesNeeded = 0; char *result, *dst; const int maxFlags = UINT_MAX / sizeof(int); + /* + * Handle empty list case first, so logic of the general case can be + * simpler. + */ + if (argc == 0) { - /* - * Handle empty list case first, so logic of the general case - * can be simpler. - */ result = ckalloc(1); result[0] = '\0'; return result; @@ -1426,17 +1506,17 @@ Tcl_Merge( flagPtr = localFlags; } else if (argc > maxFlags) { /* - * We cannot allocate a large enough flag array to format this - * list in one pass. We could imagine converting this routine - * to a multi-pass implementation, but for sizeof(int) == 4, - * the limit is a max of 2^30 list elements and since each element - * is at least one byte formatted, and requires one byte space - * between it and the next one, that a minimum space requirement - * of 2^31 bytes, which is already INT_MAX. If we tried to format - * a list of > maxFlags elements, we're just going to overflow - * the size limits on the formatted string anyway, so just issue - * that same panic early. + * We cannot allocate a large enough flag array to format this list in + * one pass. We could imagine converting this routine to a multi-pass + * implementation, but for sizeof(int) == 4, the limit is a max of + * 2^30 list elements and since each element is at least one byte + * formatted, and requires one byte space between it and the next one, + * that a minimum space requirement of 2^31 bytes, which is already + * INT_MAX. If we tried to format a list of > maxFlags elements, we're + * just going to overflow the size limits on the formatted string + * anyway, so just issue that same panic early. */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { flagPtr = ckalloc(argc * sizeof(int)); @@ -1511,9 +1591,10 @@ Tcl_Backslash( *---------------------------------------------------------------------- * * TclTrimRight -- - * Takes two counted strings in the Tcl encoding which must both be - * null terminated. Conceptually trims from the right side of the - * first string all characters found in the second string. + * + * Takes two counted strings in the Tcl encoding which must both be null + * terminated. Conceptually trims from the right side of the first string + * all characters found in the second string. * * Results: * The number of bytes to be removed from the end of the string. @@ -1526,10 +1607,10 @@ Tcl_Backslash( int TclTrimRight( - const char *bytes, /* String to be trimmed... */ - int numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - int numTrim) /* ...and its length in bytes */ + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ { const char *p = bytes + numBytes; int pInc; @@ -1538,12 +1619,18 @@ TclTrimRight( Tcl_Panic("TclTrimRight works only on null-terminated strings"); } - /* Empty strings -> nothing to do */ + /* + * Empty strings -> nothing to do. + */ + if ((numBytes == 0) || (numTrim == 0)) { return 0; } - /* Outer loop: iterate over string to be trimmed */ + /* + * Outer loop: iterate over string to be trimmed. + */ + do { Tcl_UniChar ch1; const char *q = trim; @@ -1552,7 +1639,10 @@ TclTrimRight( p = Tcl_UtfPrev(p, bytes); pInc = TclUtfToUniChar(p, &ch1); - /* Inner loop: scan trim string for match to current character */ + /* + * Inner loop: scan trim string for match to current character. + */ + do { Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); @@ -1566,7 +1656,10 @@ TclTrimRight( } while (bytesLeft); if (bytesLeft == 0) { - /* No match; trim task done; *p is last non-trimmed char */ + /* + * No match; trim task done; *p is last non-trimmed char. + */ + p += pInc; break; } @@ -1579,9 +1672,10 @@ TclTrimRight( *---------------------------------------------------------------------- * * TclTrimLeft -- - * Takes two counted strings in the Tcl encoding which must both be - * null terminated. Conceptually trims from the left side of the - * first string all characters found in the second string. + * + * Takes two counted strings in the Tcl encoding which must both be null + * terminated. Conceptually trims from the left side of the first string + * all characters found in the second string. * * Results: * The number of bytes to be removed from the start of the string. @@ -1594,10 +1688,10 @@ TclTrimRight( int TclTrimLeft( - const char *bytes, /* String to be trimmed... */ - int numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - int numTrim) /* ...and its length in bytes */ + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ { const char *p = bytes; @@ -1605,19 +1699,28 @@ TclTrimLeft( Tcl_Panic("TclTrimLeft works only on null-terminated strings"); } - /* Empty strings -> nothing to do */ + /* + * Empty strings -> nothing to do. + */ + if ((numBytes == 0) || (numTrim == 0)) { return 0; } - /* Outer loop: iterate over string to be trimmed */ + /* + * Outer loop: iterate over string to be trimmed. + */ + do { Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; - /* Inner loop: scan trim string for match to current character */ + /* + * Inner loop: scan trim string for match to current character. + */ + do { Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); @@ -1631,7 +1734,10 @@ TclTrimLeft( } while (bytesLeft); if (bytesLeft == 0) { - /* No match; trim task done; *p is first non-trimmed char */ + /* + * No match; trim task done; *p is first non-trimmed char. + */ + break; } @@ -1673,14 +1779,20 @@ Tcl_Concat( int i, needSpace = 0, bytesNeeded = 0; char *result, *p; - /* Dispose of the empty result corner case first to simplify later code */ + /* + * Dispose of the empty result corner case first to simplify later code. + */ + if (argc == 0) { result = (char *) ckalloc(1); result[0] = '\0'; return result; } - /* First allocate the result buffer at the size required */ + /* + * First allocate the result buffer at the size required. + */ + for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); if (bytesNeeded < 0) { @@ -1689,13 +1801,18 @@ Tcl_Concat( } if (bytesNeeded + argc - 1 < 0) { /* - * Panic test could be tighter, but not going to bother for - * this legacy routine. + * Panic test could be tighter, but not going to bother for this + * legacy routine. */ + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } - /* All element bytes + (argc - 1) spaces + 1 terminating NULL */ - result = (char *) ckalloc((unsigned) (bytesNeeded + argc)); + + /* + * All element bytes + (argc - 1) spaces + 1 terminating NULL. + */ + + result = ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { int trim, elemLength; @@ -1704,26 +1821,35 @@ Tcl_Concat( element = argv[i]; elemLength = strlen(argv[i]); - /* Trim away the leading whitespace */ + /* + * Trim away the leading whitespace. + */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); element += trim; elemLength -= trim; /* - * Trim away the trailing whitespace. Do not permit trimming - * to expose a final backslash character. + * Trim away the trailing whitespace. Do not permit trimming to expose + * a final backslash character. */ trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; - /* If we're left with empty element after trimming, do nothing */ + /* + * If we're left with empty element after trimming, do nothing. + */ + if (elemLength == 0) { continue; } - /* Append to the result with space if needed */ + /* + * Append to the result with space if needed. + */ + if (needSpace) { *p++ = ' '; } @@ -1802,9 +1928,10 @@ Tcl_ConcatObj( /* * Something cannot be determined to be safe, so build the concatenation * the slow way, using the string representations. + * + * First try to pre-allocate the size required. */ - /* First try to pre-allocate the size required */ for (i = 0; i < objc; i++) { element = TclGetStringFromObj(objv[i], &elemLength); bytesNeeded += elemLength; @@ -1812,11 +1939,13 @@ Tcl_ConcatObj( break; } } + /* - * Does not matter if this fails, will simply try later to build up - * the string with each Append reallocating as needed with the usual - * string append algorithm. When that fails it will report the error. + * Does not matter if this fails, will simply try later to build up the + * string with each Append reallocating as needed with the usual string + * append algorithm. When that fails it will report the error. */ + TclNewObj(resPtr); Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); Tcl_SetObjLength(resPtr, 0); @@ -1826,26 +1955,35 @@ Tcl_ConcatObj( element = TclGetStringFromObj(objv[i], &elemLength); - /* Trim away the leading whitespace */ + /* + * Trim away the leading whitespace. + */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); element += trim; elemLength -= trim; /* - * Trim away the trailing whitespace. Do not permit trimming - * to expose a final backslash character. + * Trim away the trailing whitespace. Do not permit trimming to expose + * a final backslash character. */ trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; - /* If we're left with empty element after trimming, do nothing */ + /* + * If we're left with empty element after trimming, do nothing. + */ + if (elemLength == 0) { continue; } - /* Append to the result with space if needed */ + /* + * Append to the result with space if needed. + */ + if (needSpace) { Tcl_AppendToObj(resPtr, " ", 1); } @@ -2249,6 +2387,7 @@ TclByteArrayMatch( /* * Matches ranges of form [a-z] or [z-a]. */ + break; } } else if (startChar == ch1) { @@ -2295,9 +2434,9 @@ TclByteArrayMatch( * * TclStringMatchObj -- * - * See if a particular string matches a particular pattern. - * Allows case insensitivity. This is the generic multi-type handler - * for the various matching algorithms. + * See if a particular string matches a particular pattern. Allows case + * insensitivity. This is the generic multi-type handler for the various + * matching algorithms. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The @@ -2657,24 +2796,8 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Interp *iPtr = (Interp *) interp; - Tcl_ResetResult(interp); - - if (dsPtr->string != dsPtr->staticSpace) { - iPtr->result = dsPtr->string; - iPtr->freeProc = TCL_DYNAMIC; - } else if (dsPtr->length < TCL_RESULT_SIZE) { - iPtr->result = iPtr->resultSpace; - memcpy(iPtr->result, dsPtr->string, dsPtr->length + 1); - } else { - Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); - } - - dsPtr->string = dsPtr->staticSpace; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = '\0'; + Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } /* @@ -2710,6 +2833,39 @@ Tcl_DStringGetResult( } /* + * Do more efficient transfer when we know the result is a Tcl_Obj. When + * there's no st`ring result, we only have to deal with two cases: + * + * 1. When the string rep is the empty string, when we don't copy but + * instead use the staticSpace in the DString to hold an empty string. + + * 2. When the string rep is not there or there's a real string rep, when + * we use Tcl_GetString to fetch (or generate) the string rep - which + * we know to have been allocated with ckalloc() - and use it to + * populate the DString space. Then, we free the internal rep. and set + * the object's string representation back to the canonical empty + * string. + */ + + if (!iPtr->result[0] && iPtr->objResultPtr + && !Tcl_IsShared(iPtr->objResultPtr)) { + if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->string[0] = 0; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = Tcl_GetString(iPtr->objResultPtr); + dsPtr->length = iPtr->objResultPtr->length; + dsPtr->spaceAvl = dsPtr->length + 1; + TclFreeIntRep(iPtr->objResultPtr); + iPtr->objResultPtr->bytes = tclEmptyStringRep; + iPtr->objResultPtr->length = 0; + } + return; + } + + /* * If the string result is empty, move the object result to the string * result, then reset the object result. */ @@ -2947,12 +3103,12 @@ Tcl_PrintDouble( * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: * - * % expr 0.1 - * 0.10000000000000001 - * % expr 0.01 - * 0.01 - * % expr 1e-7 - * 9.9999999999999995e-08 + * % expr 0.1 + * 0.10000000000000001 + * % expr 0.01 + * 0.01 + * % expr 1e-7 + * 9.9999999999999995e-08 * * For human readability, it appears better to choose the second rule, * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer @@ -2965,8 +3121,8 @@ Tcl_PrintDouble( */ digits = TclDoubleDigits(value, *precisionPtr, - TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, - &exponent, &signum, &end); + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, + &exponent, &signum, &end); } if (signum) { *dst++ = '-'; @@ -3222,10 +3378,10 @@ TclNeedSpace( */ int -TclFormatInt(buffer, n) - char *buffer; /* Points to the storage into which the +TclFormatInt( + char *buffer, /* Points to the storage into which the * formatted characters are written. */ - long n; /* The integer to format. */ + long n) /* The integer to format. */ { long intVal; int i; @@ -3243,9 +3399,9 @@ TclFormatInt(buffer, n) } /* - * Check whether "n" is the maximum negative value. This is - * -2^(m-1) for an m-bit word, and has no positive equivalent; - * negating it produces the same value. + * Check whether "n" is the maximum negative value. This is -2^(m-1) for + * an m-bit word, and has no positive equivalent; negating it produces the + * same value. */ intVal = -n; /* [Bug 3390638] Workaround for*/ @@ -3277,6 +3433,7 @@ TclFormatInt(buffer, n) for (j = 0; j < i; j++, i--) { char tmp = buffer[i]; + buffer[i] = buffer[j]; buffer[j] = tmp; } @@ -3742,7 +3899,7 @@ TclSetProcessGlobalValue( if (NULL != pgvPtr->value) { ckfree(pgvPtr->value); } else { - Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); + Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index 6515b89..6e76b55 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -35,12 +35,14 @@ #include "tclInt.h" #include #include - -/* Static functions defined within this file */ -static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, - const char* symbol); -static void UnloadFile(Tcl_LoadHandle handle); +/* + * Static functions defined within this file. + */ + +static void * FindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, const char* symbol); +static void UnloadFile(Tcl_LoadHandle handle); /* *---------------------------------------------------------------------- @@ -105,7 +107,7 @@ TclpDlopen( if (lm == LDR_NULL_MODULE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load file \"%s\": %s", - fileName, Tcl_PosixError(interp)); + fileName, Tcl_PosixError(interp))); return TCL_ERROR; } diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index 968f232..7b80bcc 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -22,14 +22,14 @@ #endif #include "tclInt.h" - -/* Static functions defined within this file */ -static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, - const char* symbol); -static void -UnloadFile(Tcl_LoadHandle handle); +/* + * Static functions defined within this file. + */ +static void * FindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, const char *symbol); +static void UnloadFile(Tcl_LoadHandle handle); /* *---------------------------------------------------------------------- @@ -137,7 +137,7 @@ FindSymbol( { Tcl_DString newName; Tcl_PackageInitProc *proc = NULL; - shl_t handle = (shl_t)(loadHandle->clientData); + shl_t handle = (shl_t) loadHandle->clientData; /* * Some versions of the HP system software still use "_" at the beginning @@ -187,9 +187,8 @@ UnloadFile( * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - shl_t handle; + shl_t handle = (shl_t) loadHandle->clientData; - handle = (shl_t) (loadHandle -> clientData); shl_unload(handle); ckfree(loadHandle); } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 01fc6fe..38504d9 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -470,7 +470,7 @@ NativeMatchType( #ifndef MAC_OSX_TCL || ((types->perm & TCL_GLOB_PERM_HIDDEN) && (*nativeName != '.')) -#endif +#endif /* MAC_OSX_TCL */ ) { return 0; } @@ -488,12 +488,10 @@ NativeMatchType( * check that here: */ - if (types->type & TCL_GLOB_TYPE_LINK) { - if (TclOSlstat(nativeEntry, &buf) == 0) { - if (S_ISLNK(buf.st_mode)) { - return 1; - } - } + if ((types->type & TCL_GLOB_TYPE_LINK) + && (TclOSlstat(nativeEntry, &buf) == 0) + && S_ISLNK(buf.st_mode)) { + return 1; } return 0; } @@ -516,12 +514,10 @@ NativeMatchType( */ } else { #ifdef S_ISLNK - if (types->type & TCL_GLOB_TYPE_LINK) { - if (TclOSlstat(nativeEntry, &buf) == 0) { - if (S_ISLNK(buf.st_mode)) { - goto filetypeOK; - } - } + if ((types->type & TCL_GLOB_TYPE_LINK) + && (TclOSlstat(nativeEntry, &buf) == 0) + && S_ISLNK(buf.st_mode)) { + goto filetypeOK; } #endif /* S_ISLNK */ return 0; @@ -717,9 +713,9 @@ TclpGetNativeCwd( if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */ return NULL; } -#endif +#endif /* USEGETWD */ - if ((clientData == NULL) || strcmp(buffer, (const char*)clientData)) { + if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) { char *newCd = ckalloc(strlen(buffer) + 1); strcpy(newCd, buffer); @@ -767,7 +763,7 @@ TclpGetCwd( if (getwd(buffer) == NULL) /* INTL: Native. */ #else if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */ -#endif +#endif /* USEGETWD */ { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -823,7 +819,7 @@ TclpReadlink( return Tcl_DStringValue(linkPtr); #else return NULL; -#endif +#endif /* !DJGPP */ } /* @@ -857,7 +853,7 @@ TclpObjStat( #ifdef S_IFLNK -Tcl_Obj* +Tcl_Obj * TclpObjLink( Tcl_Obj *pathPtr, Tcl_Obj *toPtr, @@ -1179,10 +1175,17 @@ TclpUtime( { return utime(Tcl_FSGetNativePath(pathPtr), tval); } + #ifdef __CYGWIN__ -int TclOSstat(const char *name, Tcl_StatBuf *statBuf) { + +int +TclOSstat( + const char *name, + Tcl_StatBuf *statBuf) +{ struct stat buf; int result = stat(name, &buf); + statBuf->st_mode = buf.st_mode; statBuf->st_ino = buf.st_ino; statBuf->st_dev = buf.st_dev; @@ -1196,9 +1199,15 @@ int TclOSstat(const char *name, Tcl_StatBuf *statBuf) { statBuf->st_ctime = buf.st_ctime; return result; } -int TclOSlstat(const char *name, Tcl_StatBuf *statBuf) { + +int +TclOSlstat( + const char *name, + Tcl_StatBuf *statBuf) +{ struct stat buf; int result = lstat(name, &buf); + statBuf->st_mode = buf.st_mode; statBuf->st_ino = buf.st_ino; statBuf->st_dev = buf.st_dev; @@ -1212,7 +1221,7 @@ int TclOSlstat(const char *name, Tcl_StatBuf *statBuf) { statBuf->st_ctime = buf.st_ctime; return result; } -#endif +#endif /* CYGWIN */ /* * Local Variables: diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index ca95f40..b87af1b 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -96,7 +96,7 @@ typedef struct ThreadSpecificData { * that an event is ready to be processed * by sending this event. */ void *hwnd; /* Messaging window. */ -#else /* !__CYGWIN__ */ +#else Tcl_Condition waitCV; /* Any other thread alerts a notifier that an * event is ready to be processed by signaling * this condition variable. */ @@ -104,7 +104,7 @@ typedef struct ThreadSpecificData { int eventReady; /* True if an event is ready to be processed. * Used as condition flag together with waitCV * above. */ -#endif +#endif /* TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -187,25 +187,12 @@ static Tcl_ThreadId notifierThread; static void NotifierThreadProc(ClientData clientData); #endif static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); - + /* - *---------------------------------------------------------------------- - * - * Tcl_InitNotifier -- - * - * Initializes the platform specific notifier state. - * - * Results: - * Returns a handle to the notifier state for this thread. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- + * Import of Windows API when building threaded with Cygwin. */ #if defined(TCL_THREADS) && defined(__CYGWIN__) - typedef struct { void *hwnd; unsigned int *message; @@ -217,34 +204,60 @@ typedef struct { } MSG; typedef struct { - unsigned int style; - void *lpfnWndProc; - int cbClsExtra; - int cbWndExtra; - void *hInstance; - void *hIcon; - void *hCursor; - void *hbrBackground; - void *lpszMenuName; - void *lpszClassName; + unsigned int style; + void *lpfnWndProc; + int cbClsExtra; + int cbWndExtra; + void *hInstance; + void *hIcon; + void *hCursor; + void *hbrBackground; + void *lpszMenuName; + void *lpszClassName; } WNDCLASS; -extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int); -extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int); -extern unsigned char __stdcall TranslateMessage(const MSG *); -extern int __stdcall DispatchMessageW(const MSG *); -extern void __stdcall PostQuitMessage(int); -extern void * __stdcall CreateWindowExW(void *, void *, void *, DWORD, int, int, int, int, void *, void *, void *, void *); -extern unsigned char __stdcall DestroyWindow(void *); -extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *, void *); -extern void *__stdcall RegisterClassW(const WNDCLASS *); -extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *); -extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, void *); -extern void __stdcall CloseHandle(void *); -extern void __stdcall MsgWaitForMultipleObjects(DWORD, void *, unsigned char, DWORD, DWORD); -extern unsigned char __stdcall ResetEvent(void *); +extern void __stdcall CloseHandle(void *); +extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, + void *); +extern void * __stdcall CreateWindowExW(void *, void *, void *, DWORD, int, + int, int, int, void *, void *, void *, void *); +extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *); +extern unsigned char __stdcall DestroyWindow(void *); +extern int __stdcall DispatchMessageW(const MSG *); +extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int); +extern void __stdcall MsgWaitForMultipleObjects(DWORD, void *, + unsigned char, DWORD, DWORD); +extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int); +extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *, + void *); +extern void __stdcall PostQuitMessage(int); +extern void *__stdcall RegisterClassW(const WNDCLASS *); +extern unsigned char __stdcall ResetEvent(void *); +extern unsigned char __stdcall TranslateMessage(const MSG *); -#endif +/* + * Threaded-cygwin specific functions in this file: + */ + +static DWORD __stdcall NotifierProc(void *hwnd, unsigned int message, + void *wParam, void *lParam); +#endif /* TCL_THREADS && __CYGWIN__ */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitNotifier -- + * + * Initializes the platform specific notifier state. + * + * Results: + * Returns a handle to the notifier state for this thread. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ ClientData Tcl_InitNotifier(void) @@ -403,11 +416,11 @@ Tcl_AlertNotifier( Tcl_MutexLock(¬ifierMutex); tsdPtr->eventReady = 1; -#ifdef __CYGWIN__ +# ifdef __CYGWIN__ PostMessageW(tsdPtr->hwnd, 1024, 0, 0); -#else +# else Tcl_ConditionNotify(&tsdPtr->waitCV); -#endif +# endif /* __CYGWIN__ */ Tcl_MutexUnlock(¬ifierMutex); #endif /* TCL_THREADS */ } @@ -732,12 +745,12 @@ NotifierProc( * Process all of the runnable events. */ - tsdPtr->eventReady = 1; + tsdPtr->eventReady = 1; Tcl_ServiceAll(); return 0; } -#endif /* __CYGWIN__ */ - +#endif /* TCL_THREADS && __CYGWIN__ */ + /* *---------------------------------------------------------------------- * @@ -768,9 +781,9 @@ Tcl_WaitForEvent( Tcl_Time vTime; #ifdef TCL_THREADS int waitForFiles; -# ifdef __CYGWIN__ - MSG msg; -# endif +# ifdef __CYGWIN__ + MSG msg; +# endif /* __CYGWIN__ */ #else /* * Impl. notes: timeout & timeoutPtr are used if, and only if threads @@ -792,8 +805,8 @@ Tcl_WaitForEvent( if (timePtr != NULL) { /* * TIP #233 (Virtualized Time). Is virtual time in effect? And do - * we actually have something to scale? If yes to both then we call - * the handler to do this scaling. + * we actually have something to scale? If yes to both then we + * call the handler to do this scaling. */ if (timePtr->sec != 0 || timePtr->usec != 0) { @@ -807,17 +820,17 @@ Tcl_WaitForEvent( timeoutPtr = &timeout; } else if (tsdPtr->numFdBits == 0) { /* - * If there are no threads, no timeout, and no fds registered, then - * there are no events possible and we must avoid deadlock. Note - * that this is not entirely correct because there might be a - * signal that could interrupt the select call, but we don't handle - * that case if we aren't using threads. + * If there are no threads, no timeout, and no fds registered, + * then there are no events possible and we must avoid deadlock. + * Note that this is not entirely correct because there might be a + * signal that could interrupt the select call, but we don't + * handle that case if we aren't using threads. */ return -1; } else { timeoutPtr = NULL; -#endif /* TCL_THREADS */ +#endif /* !TCL_THREADS */ } #ifdef TCL_THREADS @@ -828,7 +841,7 @@ Tcl_WaitForEvent( #ifdef __CYGWIN__ if (!tsdPtr->hwnd) { - WNDCLASS class; + WNDCLASS class; class.style = 0; class.cbClsExtra = 0; @@ -842,24 +855,24 @@ Tcl_WaitForEvent( class.hCursor = NULL; RegisterClassW(&class); - tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName, class.lpszClassName, - 0, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); + tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName, + class.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL, + TclWinGetTclInstance(), NULL); tsdPtr->event = CreateEventW(NULL, 1 /* manual */, 0 /* !signaled */, NULL); - } - -#endif + } +#endif /* __CYGWIN */ Tcl_MutexLock(¬ifierMutex); if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0 #if defined(__APPLE__) && defined(__LP64__) /* - * On 64-bit Darwin, pthread_cond_timedwait() appears to have a - * bug that causes it to wait forever when passed an absolute - * time which has already been exceeded by the system time; as - * a workaround, when given a very brief timeout, just do a - * poll. [Bug 1457797] + * On 64-bit Darwin, pthread_cond_timedwait() appears to have + * a bug that causes it to wait forever when passed an + * absolute time which has already been exceeded by the system + * time; as a workaround, when given a very brief timeout, + * just do a poll. [Bug 1457797] */ || timePtr->usec < 10 #endif /* __APPLE__ && __LP64__ */ @@ -883,8 +896,8 @@ Tcl_WaitForEvent( if (waitForFiles) { /* * Add the ThreadSpecificData structure of this thread to the list - * of ThreadSpecificData structures of all threads that are waiting - * on file events. + * of ThreadSpecificData structures of all threads that are + * waiting on file events. */ tsdPtr->nextPtr = waitingListPtr; @@ -909,6 +922,7 @@ Tcl_WaitForEvent( #ifdef __CYGWIN__ if (!PeekMessageW(&msg, NULL, 0, 0, 0)) { DWORD timeout; + if (timePtr) { timeout = timePtr->sec * 1000 + timePtr->usec / 1000; } else { @@ -920,7 +934,7 @@ Tcl_WaitForEvent( } #else Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr); -#endif +#endif /* __CYGWIN__ */ } tsdPtr->eventReady = 0; @@ -929,17 +943,20 @@ Tcl_WaitForEvent( /* * Retrieve and dispatch the message. */ + DWORD result = GetMessageW(&msg, NULL, 0, 0); + if (result == 0) { PostQuitMessage(msg.wParam); /* What to do here? */ - } else if (result != (DWORD)-1) { + } else if (result != (DWORD) -1) { TranslateMessage(&msg); DispatchMessageW(&msg); } } ResetEvent(tsdPtr->event); -#endif +#endif /* __CYGWIN__ */ + if (waitForFiles && tsdPtr->onList) { /* * Remove the ThreadSpecificData structure of this thread from the @@ -1211,9 +1228,9 @@ NotifierThreadProc( tsdPtr->pollState = 0; } #ifdef __CYGWIN__ - PostMessageW(tsdPtr->hwnd, 1024, 0, 0); -#else /* __CYGWIN__ */ - Tcl_ConditionNotify(&tsdPtr->waitCV); + PostMessageW(tsdPtr->hwnd, 1024, 0, 0); +#else + Tcl_ConditionNotify(&tsdPtr->waitCV); #endif /* __CYGWIN__ */ } } @@ -1255,7 +1272,7 @@ NotifierThreadProc( } #endif /* TCL_THREADS */ -#endif /* HAVE_COREFOUNDATION */ +#endif /* !HAVE_COREFOUNDATION */ /* * Local Variables: diff --git a/win/tclWinReg.c b/win/tclWinReg.c index c4a89e6..6ac5caf 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -15,6 +15,7 @@ #undef STATIC_BUILD #undef USE_TCL_STUBS #define USE_TCL_STUBS + #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") @@ -23,20 +24,20 @@ #ifndef UNICODE # undef Tcl_WinTCharToUtf -# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) +# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) # undef Tcl_WinUtfToTChar -# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) -#endif +# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) +#endif /* !UNICODE */ /* * Ensure that we can say which registry is being accessed. */ #ifndef KEY_WOW64_64KEY -#define KEY_WOW64_64KEY (0x0100) +# define KEY_WOW64_64KEY (0x0100) #endif #ifndef KEY_WOW64_32KEY -#define KEY_WOW64_32KEY (0x0200) +# define KEY_WOW64_32KEY (0x0200) #endif /* @@ -44,7 +45,7 @@ */ #ifndef MAX_KEY_LENGTH -#define MAX_KEY_LENGTH 256 +# define MAX_KEY_LENGTH 256 #endif /* @@ -57,14 +58,6 @@ #define TCL_STORAGE_CLASS DLLEXPORT /* - * The maximum length of a sub-key name. - */ - -#ifndef MAX_KEY_LENGTH -#define MAX_KEY_LENGTH 256 -#endif - -/* * The following macros convert between different endian ints. */ @@ -817,16 +810,16 @@ GetValue( * we get bogus data. */ - while ((p < end) - && (*((Tcl_UniChar *) p)) != 0) { + while ((p < end) && *((Tcl_UniChar *) p) != 0) { Tcl_UniChar *up; + Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); up = (Tcl_UniChar *) p; - while (*up++ != 0) {} + while (*up++ != 0) {/* empty body */} p = (char *) up; Tcl_DStringFree(&buf); } @@ -1226,8 +1219,8 @@ RecursiveDeleteKey( } break; } else if (result == ERROR_SUCCESS) { - result = RecursiveDeleteKey(hKey, (const TCHAR *) Tcl_DStringValue(&subkey), - mode); + result = RecursiveDeleteKey(hKey, + (const TCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); @@ -1294,8 +1287,8 @@ SetValue( return TCL_ERROR; } - value = ConvertDWORD((DWORD)type, (DWORD)value); - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + value = ConvertDWORD((DWORD) type, (DWORD) value); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; @@ -1329,7 +1322,7 @@ SetValue( Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); @@ -1338,7 +1331,7 @@ SetValue( Tcl_DString buf; const char *data = Tcl_GetStringFromObj(dataObj, &length); - data = (char *)Tcl_WinUtfToTChar(data, length, &buf); + data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* * Include the null in the length, padding if needed for Unicode. @@ -1347,7 +1340,7 @@ SetValue( Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); length = Tcl_DStringLength(&buf) + 1; - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) length); Tcl_DStringFree(&buf); } else { @@ -1358,7 +1351,7 @@ SetValue( */ data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length); - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, data, (DWORD) length); } @@ -1529,14 +1522,15 @@ ConvertDWORD( DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ DWORD value) /* The value to be converted. */ { - DWORD order = 1; + const DWORD order = 1; DWORD localType; /* * Check to see if the low bit is in the first byte. */ - localType = (*((char *) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; + localType = (*((const char *) &order) == 1) + ? REG_DWORD : REG_DWORD_BIG_ENDIAN; return (type != localType) ? (DWORD) SWAPLONG(value) : value; } -- cgit v0.12 From c31f309b59260de32048173493f3463dbdaa51f7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Aug 2012 09:25:29 +0000 Subject: [Bug #1536227]: Cygwin network pathname supoort --- ChangeLog | 5 ++ generic/tclFileName.c | 241 ++++++++++++++++++++------------------------------ tests/fileName.test | 6 +- 3 files changed, 104 insertions(+), 148 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9423c98..d6499d7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-08 Jan Nijtmans + + * generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname + * tests/fileName.test: support + 2012-08-07 Don Porter * generic/tclIOUtil.c: [Bug 3554250] Overlooked one field of diff --git a/generic/tclFileName.c b/generic/tclFileName.c index a6bb932..07757d9 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -32,8 +32,8 @@ static const char * ExtractWinRoot(const char *path, Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr); static int SkipToChar(char **stringPtr, int match); -static Tcl_Obj* SplitWinPath(const char *path); -static Tcl_Obj* SplitUnixPath(const char *path); +static Tcl_Obj * SplitWinPath(const char *path); +static Tcl_Obj * SplitUnixPath(const char *path); static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr, const char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types); @@ -199,7 +199,7 @@ ExtractWinRoot( Tcl_DStringAppend(resultPtr, path, 2); return &path[2]; } else { - char *tail = (char*)&path[3]; + const char *tail = &path[3]; /* * Skip separators. @@ -377,7 +377,7 @@ TclpGetNativePathType( { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; - char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* @@ -386,7 +386,7 @@ TclpGetNativePathType( */ if (driveNameLengthPtr != NULL) { - char *end = path + 1; + const char *end = path + 1; while ((*end != '\0') && (*end != '/')) { end++; } @@ -395,31 +395,34 @@ TclpGetNativePathType( } else { switch (tclPlatform) { case TCL_PLATFORM_UNIX: { - char *origPath = path; + const char *origPath = path; /* * Paths that begin with / are absolute. */ -#ifdef __QNX__ - /* - * Check for QNX // prefix - */ - if (*path && (pathLen > 3) && (path[0] == '/') - && (path[1] == '/') && isdigit(UCHAR(path[2]))) { - path += 3; - while (isdigit(UCHAR(*path))) { - ++path; - } - } -#endif if (path[0] == '/') { -#ifdef __CYGWIN__ + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) /* - * Check for Cygwin // network path prefix + * Check for "//" network path prefix */ - if (path[1] == '/') { - path++; + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } #endif if (driveNameLengthPtr != NULL) { @@ -427,7 +430,7 @@ TclpGetNativePathType( * We need this addition in case the QNX or Cygwin code was used. */ - *driveNameLengthPtr = (1 + path - origPath); + *driveNameLengthPtr = (path - origPath); } } else { type = TCL_PATH_RELATIVE; @@ -546,7 +549,8 @@ Tcl_SplitPath( Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; int i, size, len; - char *p, *str; + char *p; + const char *str; /* * Perform the splitting, using objectified, vfs-aware code. @@ -631,40 +635,43 @@ SplitUnixPath( const char *path) /* Pointer to string containing a path. */ { int length; - const char *p, *elementStart; + const char *origPath = path, *elementStart; Tcl_Obj *result = Tcl_NewObj(); /* * Deal with the root directory as a special case. */ -#ifdef __QNX__ - /* - * Check for QNX // prefix - */ - if ((path[0] == '/') && (path[1] == '/') - && isdigit(UCHAR(path[2]))) { /* INTL: digit */ - path += 3; - while (isdigit(UCHAR(*path))) { /* INTL: digit */ - ++path; - } - } -#endif - - p = path; - if (*p == '/') { - Tcl_Obj *rootElt = Tcl_NewStringObj("/", 1); - p++; -#ifdef __CYGWIN__ + if (*path == '/') { + Tcl_Obj *rootElt; + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) /* - * Check for Cygwin // network path prefix + * Check for "//" network path prefix */ - if (*p == '/') { - Tcl_AppendToObj(rootElt, "/", 1); - p++; + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } #endif + rootElt = Tcl_NewStringObj(origPath, path - origPath); Tcl_ListObjAppendElement(NULL, result, rootElt); + while (*path == '/') { + ++path; + } } /* @@ -673,14 +680,14 @@ SplitUnixPath( */ for (;;) { - elementStart = p; - while ((*p != '\0') && (*p != '/')) { - p++; + elementStart = path; + while ((*path != '\0') && (*path != '/')) { + path++; } - length = p - elementStart; + length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart[0] == '~') && (elementStart != path)) { + if ((elementStart[0] == '~') && (elementStart != origPath)) { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { @@ -688,7 +695,7 @@ SplitUnixPath( } Tcl_ListObjAppendElement(NULL, result, nextElt); } - if (*p++ == '\0') { + if (*path++ == '\0') { break; } } @@ -843,8 +850,9 @@ TclpNativeJoinPath( const char *joining) { int length, needsSep; + char *dest; const char *p; - char *dest, *start; + const char *start; start = Tcl_GetStringFromObj(prefix, &length); @@ -968,7 +976,7 @@ Tcl_JoinPath( int i, len; Tcl_Obj *listObj = Tcl_NewObj(); Tcl_Obj *resultObj; - char *resultStr; + const char *resultStr; /* * Build the list of paths. @@ -1338,8 +1346,8 @@ Tcl_GlobObjCmd( if (dir == PATH_GENERAL) { int pathlength; - char *last; - char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); + const char *last; + const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path @@ -1440,7 +1448,7 @@ Tcl_GlobObjCmd( while (--length >= 0) { int len; - char *str; + const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); str = Tcl_GetStringFromObj(look, &len); @@ -1496,10 +1504,10 @@ Tcl_GlobObjCmd( Tcl_IncrRefCount(look); } else { - Tcl_Obj* item; + Tcl_Obj *item; - if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) && - (len == 3)) { + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) + && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); @@ -1831,7 +1839,7 @@ TclGlob( if (tail[0] == '/') { tail++; } else { - tail+=2; + tail += 2; } Tcl_IncrRefCount(pathPrefix); break; @@ -1902,27 +1910,29 @@ TclGlob( if (*tail == '\0' && pathPrefix != NULL) { /* - * An empty pattern. This means 'pathPrefix' is actually - * a full path of a file/directory we want to simply check - * for existence and type. + * An empty pattern. This means 'pathPrefix' is actually a full path + * of a file/directory we want to simply check for existence and type. */ + if (types == NULL) { /* - * We just want to check for existence. In this case we - * make it easy on Tcl_FSMatchInDirectory and its - * sub-implementations by not bothering them (even though - * they should support this situation) and we just use the - * simple existence check with Tcl_FSAccess. + * We just want to check for existence. In this case we make it + * easy on Tcl_FSMatchInDirectory and its sub-implementations by + * not bothering them (even though they should support this + * situation) and we just use the simple existence check with + * Tcl_FSAccess. */ + if (Tcl_FSAccess(pathPrefix, F_OK) == 0) { Tcl_ListObjAppendElement(interp, filenamesObj, pathPrefix); } result = TCL_OK; } else { /* - * We want to check for the correct type. Tcl_FSMatchInDirectory + * We want to check for the correct type. Tcl_FSMatchInDirectory * is documented to do this for us, if we give it a NULL pattern. */ + result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix, NULL, types); } @@ -1987,20 +1997,20 @@ TclGlob( Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; - char *oldStr = Tcl_GetStringFromObj(objv[i], &len); - Tcl_Obj* elems[1]; + const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); + Tcl_Obj *elem; if (len == prefixLen) { if ((pattern[0] == '\0') || (strchr(separators, pattern[0]) == NULL)) { - TclNewLiteralStringObj(elems[0], "."); + TclNewLiteralStringObj(elem, "."); } else { - TclNewLiteralStringObj(elems[0], "/"); + TclNewLiteralStringObj(elem, "/"); } } else { - elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen); + elem = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen); } - Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems); + Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, &elem); } } @@ -2115,7 +2125,7 @@ DoGlob( * resulting filenames. Caller allocates and * deallocates; DoGlob must not touch the * refCount of this object. */ - const char *separators, /* String containing separator characters that + const char *separators, /* String containing separator characters that * should be used to identify globbing * boundaries. */ Tcl_Obj *pathPtr, /* Completely expanded prefix. */ @@ -2159,67 +2169,6 @@ DoGlob( } /* - * This block of code is not exercised by the Tcl test suite as of Tcl - * 8.5a0. Simplifications to the calling paths suggest it may not be - * necessary any more, since path separators are handled elsewhere. It is - * left in place in case new bugs are reported. - */ - -#if 0 /* PROBABLY_OBSOLETE */ - /* - * Deal with path separators. - */ - - if (pathPtr == NULL) { - /* - * Length used to be the length of the prefix, and lastChar the - * lastChar of the prefix. But, none of this is used any more. - */ - - int length = 0; - char lastChar = 0; - - switch (tclPlatform) { - case TCL_PLATFORM_WINDOWS: - /* - * If this is a drive relative path, add the colon and the - * trailing slash if needed. Otherwise add the slash if this is - * the first absolute element, or a later relative element. Add an - * extra slash if this is a UNC path. - */ - - if (*name == ':') { - Tcl_DStringAppend(&append, ":", 1); - if (count > 1) { - Tcl_DStringAppend(&append, "/", 1); - } - } else if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - if ((length == 0) && (count > 1)) { - Tcl_DStringAppend(&append, "/", 1); - } - } - - break; - case TCL_PLATFORM_UNIX: - /* - * Add a separator if this is the first absolute element, or a - * later relative element. - */ - - if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - } - break; - } - } -#endif /* PROBABLY_OBSOLETE */ - - /* * Look for the first matching pair of braces or the first directory * separator that is not inside a pair of braces. */ @@ -2273,8 +2222,8 @@ DoGlob( if (openBrace != NULL) { char *element; - Tcl_DString newName; + Tcl_DStringInit(&newName); /* @@ -2323,12 +2272,13 @@ DoGlob( */ if (*p != '\0') { + char savedChar = *p; + /* * Note that we are modifying the string in place. This won't work if * the string is a static. */ - char savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(pattern, "*[]?\\"); *p = savedChar; @@ -2347,7 +2297,7 @@ DoGlob( TCL_GLOB_TYPE_DIR, 0, NULL, NULL }; char save = *p; - Tcl_Obj* subdirsPtr; + Tcl_Obj *subdirsPtr; if (*p == '\0') { return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr, @@ -2393,6 +2343,7 @@ DoGlob( const char *bytes; int numBytes; Tcl_Obj *fixme, *newObj; + Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); bytes = Tcl_GetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); @@ -2413,6 +2364,9 @@ DoGlob( */ if (*p == '\0') { + int length; + Tcl_DString append; + /* * This is the code path reached by a command like 'glob foo'. * @@ -2425,9 +2379,6 @@ DoGlob( * approach). */ - int length; - Tcl_DString append; - Tcl_DStringInit(&append); Tcl_DStringAppend(&append, pattern, p-pattern); diff --git a/tests/fileName.test b/tests/fileName.test index a91f4b3..68c5592 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -189,7 +189,7 @@ test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} { test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split //foo -} "[file split //] foo" +} "/ foo" test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo//bar @@ -429,11 +429,11 @@ test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b -} "[file split //]a/b" +} "/a/b" test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /// a b -} "[file split //]a/b" +} "/a/b" test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { -- cgit v0.12 From 540f62b18de23e912d85b8b0fe9ea4f35dda0d2b Mon Sep 17 00:00:00 2001 From: twylite Date: Wed, 8 Aug 2012 15:28:09 +0000 Subject: Back-out 'foreacha' implementation but leave code cleanup of 'mapeach' and 'dict map'. --- generic/tclBasic.c | 1 - generic/tclCmdAH.c | 58 ++++++++++----------------------------------------- generic/tclCompCmds.c | 23 ++------------------ generic/tclCompile.h | 1 - generic/tclExecute.c | 17 +++------------ generic/tclInt.h | 10 --------- 6 files changed, 16 insertions(+), 94 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fe8fa5a..a35da29 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -219,7 +219,6 @@ static const CmdInfo builtInCmds[] = { {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, - {"foreacha", Tcl_ForeachaObjCmd, TclCompileForeachaCmd, TclNRForeachaCmd, 1}, {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 333946a..a10646c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -45,7 +45,7 @@ static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, - struct ForeachState *statePtr, int collect); + struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, struct ForeachState *statePtr); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -2619,26 +2619,6 @@ TclNRMapeachCmd( } int -Tcl_ForeachaObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRForeachaCmd, dummy, objc, objv); -} - -int -TclNRForeachaCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_ACCUM); -} - -int TclNREachloopCmd( ClientData dummy, Tcl_Interp *interp, @@ -2720,13 +2700,9 @@ TclNREachloopCmd( TclListObjGetElements(NULL, statePtr->aCopyList[i], &statePtr->argcList[i], &statePtr->argvList[i]); - j = (i == 0) && (collect == TCL_EACH_ACCUM); /* Accumulator present? */ - /* If accumulator is only var in list, then we iterate j=1 times */ - if (statePtr->varcList[i] > j) { - /* We need listLen/numVars round up = ((listLen+numVars-1)/numVars) - * When accum is present we need (listLen-1)/(numVars-1) round up */ - j = (statePtr->argcList[i] - j + statePtr->varcList[i] - j - 1) - / (statePtr->varcList[i] - j); + j = statePtr->argcList[i] / statePtr->varcList[i]; + if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { + j++; } if (j > statePtr->maxj) { statePtr->maxj = j; @@ -2739,7 +2715,7 @@ TclNREachloopCmd( */ if (statePtr->maxj > 0) { - result = ForeachAssignments(interp, statePtr, collect); + result = ForeachAssignments(interp, statePtr); if (result == TCL_ERROR) { goto done; } @@ -2803,7 +2779,7 @@ ForeachLoopStep( */ if (statePtr->maxj > ++statePtr->j) { - result = ForeachAssignments(interp, statePtr, collect); + result = ForeachAssignments(interp, statePtr); if (result == TCL_ERROR) { goto done; } @@ -2816,18 +2792,9 @@ ForeachLoopStep( /* * We're done. Tidy up our work space and finish off. */ -finish: - if (collect == TCL_EACH_ACCUM) { - Tcl_Obj* valueObj = Tcl_ObjGetVar2(interp, statePtr->varvList[0][0], - NULL, TCL_LEAVE_ERR_MSG); - if (valueObj == NULL) { - goto done; - } - Tcl_SetObjResult(interp, valueObj); - } else { - Tcl_SetObjResult(interp, statePtr->resultList); - statePtr->resultList = NULL; /* Don't clean it up */ - } + finish: + Tcl_SetObjResult(interp, statePtr->resultList); + statePtr->resultList = NULL; /* Don't clean it up */ done: ForeachCleanup(interp, statePtr); return result; @@ -2840,16 +2807,13 @@ finish: static inline int ForeachAssignments( Tcl_Interp *interp, - struct ForeachState *statePtr, - int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ + struct ForeachState *statePtr) { int i, v, k; Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { - /* Don't modify the accumulator except on the first iteration */ - v = ((i == 0) && (collect == TCL_EACH_ACCUM) && (statePtr->index[i] > 0)); - for (; vvarcList[i] ; v++) { + for (v=0 ; vvarcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 07a5eea..395a0f8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1911,9 +1911,9 @@ TclCompileForCmd( /* *---------------------------------------------------------------------- * - * TclCompileForeachCmd, TclCompileForeachaCmd -- + * TclCompileForeachCmd -- * - * Procedure called to compile the "foreach" and "foreacha" commands. + * Procedure called to compile the "foreach" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -1937,18 +1937,6 @@ TclCompileForeachCmd( { return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 0); } - -int -TclCompileForeachaCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 2); -} /* *---------------------------------------------------------------------- @@ -2136,7 +2124,6 @@ TclCompileEachloopCmd( infoPtr->numLists = numLists; infoPtr->firstValueTemp = firstValueTemp; infoPtr->loopCtTemp = loopCtTemp; - infoPtr->collect = collect; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; @@ -2150,9 +2137,6 @@ TclCompileEachloopCmd( varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, nameChars, /*create*/ 1, envPtr); - if ((collect == TCL_EACH_ACCUM) && ((loopIndex + j) == 0)) { - collectTemp = varListPtr->varIndexes[j]; - } } infoPtr->varLists[loopIndex] = varListPtr; } @@ -2344,7 +2328,6 @@ DupForeachInfo( dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; - dupPtr->collect = srcPtr->collect; for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; @@ -2435,8 +2418,6 @@ PrintForeachInfo( } Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", (unsigned) infoPtr->loopCtTemp); - Tcl_AppendPrintfToObj(appendObj, "], collect=%%v%u", - (unsigned) infoPtr->collect); for (i=0 ; inumLists ; i++) { if (i) { Tcl_AppendToObj(appendObj, ",", -1); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 7a41bb1..ba78c36 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -807,7 +807,6 @@ typedef struct ForeachInfo { * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ - int collect; /* Selected collecting or accumulating mode. */ ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 952eb32..e402634 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5492,15 +5492,7 @@ TEBCresume( opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); goto gotError; } - - /* If the accumulator is the only variable then this list gets - * just one iteration. Otherwise we must keep going until the - * list is exhausted by non-accumulator loop vars */ - j = ((i == 0) && (iterNum > 0) - && (infoPtr->collect == TCL_EACH_ACCUM)); - /* j is 1 if the accumulator is present but does not consume - * an element, or 0 otherwise (consuming or not-present). */ - if ((numVars > j) && (listLen > (iterNum * (numVars - j) + j))) { + if (listLen > iterNum * numVars) { continueLoop = 1; } listTmpIndex++; @@ -5525,11 +5517,8 @@ TEBCresume( listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); TclListObjGetElements(interp, listPtr, &listLen, &elements); - /* Don't modify the accumulator except on the first iteration */ - j = ((i == 0) && (iterNum > 0) - && (infoPtr->collect == TCL_EACH_ACCUM)); - valIndex = (iterNum * (numVars - j) + j); - for (; j < numVars; j++) { + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { if (valIndex >= listLen) { TclNewObj(valuePtr); } else { diff --git a/generic/tclInt.h b/generic/tclInt.h index 6600dd9..4fc265f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2773,7 +2773,6 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachaCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRMapeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; @@ -2865,9 +2864,6 @@ struct Tcl_LoadHandle_ { #define TCL_EACH_COLLECT 1 /* Collect iteration result like [mapeach] */ -#define TCL_EACH_ACCUM 2 - /* First loop var is accumulator like [foreacha] */ - /* *---------------------------------------------------------------- @@ -3314,9 +3310,6 @@ MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForeachaObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3549,9 +3542,6 @@ MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileForeachaCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From dadccca81c83f99bae348c4caecf3a90270e7e6a Mon Sep 17 00:00:00 2001 From: twylite Date: Wed, 8 Aug 2012 15:34:13 +0000 Subject: Rename 'mapeach' to 'lmap' per preferred alternative in TIP #405. --- generic/tclBasic.c | 2 +- generic/tclCmdAH.c | 6 +- generic/tclCompCmds.c | 10 +- generic/tclInt.h | 16 +- tests/lmap.test | 493 ++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 510 insertions(+), 17 deletions(-) create mode 100644 tests/lmap.test diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a35da29..36e777a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -230,6 +230,7 @@ static const CmdInfo builtInCmds[] = { {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, + {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1}, @@ -237,7 +238,6 @@ static const CmdInfo builtInCmds[] = { {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, - {"mapeach", Tcl_MapeachObjCmd, TclCompileMapeachCmd, TclNRMapeachCmd, 1}, {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index a10646c..9ebdf21 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2599,17 +2599,17 @@ TclNRForeachCmd( } int -Tcl_MapeachObjCmd( +Tcl_LmapObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRMapeachCmd, dummy, objc, objv); + return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv); } int -TclNRMapeachCmd( +TclNRLmapCmd( ClientData dummy, Tcl_Interp *interp, int objc, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 395a0f8..4d015ec 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1943,7 +1943,7 @@ TclCompileForeachCmd( * * TclCompileEachloopCmd -- * - * Procedure called to compile the "foreach" and "mapeach" commands. + * Procedure called to compile the "foreach" and "lmap" commands. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -3832,23 +3832,23 @@ TclCompileLsetCmd( /* *---------------------------------------------------------------------- * - * TclCompileMapeachCmd -- + * TclCompileLmapCmd -- * - * Procedure called to compile the "mapeach" command. + * Procedure called to compile the "lmap" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "mapeach" command at + * Instructions are added to envPtr to execute the "lmap" command at * runtime. * *---------------------------------------------------------------------- */ int -TclCompileMapeachCmd( +TclCompileLmapCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 4fc265f..f1a6fce 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2774,7 +2774,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRMapeachCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; @@ -2862,7 +2862,7 @@ struct Tcl_LoadHandle_ { /* Discard iteration result like [foreach] */ #define TCL_EACH_COLLECT 1 - /* Collect iteration result like [mapeach] */ + /* Collect iteration result like [lmap] */ /* @@ -3353,6 +3353,9 @@ MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3377,9 +3380,6 @@ MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_MapeachObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy, Tcl_Interp *interp, int objc, @@ -3569,6 +3569,9 @@ MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3578,9 +3581,6 @@ MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileMapeachCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/lmap.test b/tests/lmap.test new file mode 100644 index 0000000..dc5053f --- /dev/null +++ b/tests/lmap.test @@ -0,0 +1,493 @@ +# Commands covered: lmap, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 2011 Trevor Davel +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +catch {unset a} +catch {unset i} +catch {unset x} + +# ----- Non-compiled operation ------------------------------------------------- + + +# Basic "lmap" operation (non-compiled) + +test lmap-1.1 {basic lmap tests} { + set a {} + lmap i {a b c d} { + set a [concat $a $i] + } +} {a {a b} {a b c} {a b c d}} +test lmap-1.2 {basic lmap tests} { + lmap i {a b {{c d} e} {123 {{x}}}} { + set i + } +} {a b {{c d} e} {123 {{x}}}} +test lmap-1.2a {basic lmap tests} { + lmap i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } +} {a b {{c d} e} {123 {{x}}}} +test lmap-1.3 {basic lmap tests} {catch {lmap} msg} 1 +test lmap-1.4 {basic lmap tests} { + catch {lmap} msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.5 {basic lmap tests} {catch {lmap i} msg} 1 +test lmap-1.6 {basic lmap tests} { + catch {lmap i} msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.7 {basic lmap tests} {catch {lmap i j} msg} 1 +test lmap-1.8 {basic lmap tests} { + catch {lmap i j} msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.9 {basic lmap tests} {catch {lmap i j k l} msg} 1 +test lmap-1.10 {basic lmap tests} { + catch {lmap i j k l} msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.11 {basic lmap tests} { + lmap i {} { + set i + } +} {} +test lmap-1.12 {basic lmap tests} { + lmap i {} { + return -level 0 x + } +} {} +test lmap-1.13 {lmap errors} { + list [catch {lmap {{a}{b}} {1 2 3} {}} msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test lmap-1.14 {lmap errors} { + list [catch {lmap a {{1 2}3} {}} msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test lmap-1.15 {lmap errors} { + catch {unset a} + set a(0) 44 + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo +} {1 {can't set "a": variable is array} {can't set "a": variable is array + (setting foreach loop variable "a") + invoked from within +"lmap a {1 2 3} {}"}} +test lmap-1.16 {lmap errors} { + list [catch {lmap {} {} {}} msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + + +# Parallel "lmap" operation (non-compiled) + +test lmap-2.1 {parallel lmap tests} { + lmap {a b} {1 2 3 4} { + list $b $a + } +} {{2 1} {4 3}} +test lmap-2.2 {parallel lmap tests} { + lmap {a b} {1 2 3 4 5} { + list $b $a + } +} {{2 1} {4 3} {{} 5}} +test lmap-2.3 {parallel lmap tests} { + lmap a {1 2 3} b {4 5 6} { + list $b $a + } +} {{4 1} {5 2} {6 3}} +test lmap-2.4 {parallel lmap tests} { + lmap a {1 2 3} b {4 5 6 7 8} { + list $b $a + } +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test lmap-2.5 {parallel lmap tests} { + lmap {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test lmap-2.6 {parallel lmap tests} { + lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } +} {11111 22222 33333} +test lmap-2.7 {parallel lmap tests} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } +} {{1111 2} 222 33 4} +test lmap-2.8 {parallel lmap tests} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test lmap-2.9 {lmap only sets vars if repeating loop} { + namespace eval ::lmap_test { + set rgb {65535 0 0} + lmap {r g b} [set rgb] {} + set ::x "r=$r, g=$g, b=$b" + } + namespace delete ::lmap_test + set x +} {r=65535, g=0, b=0} +test lmap-2.10 {lmap only supports local scalar variables} { + catch { unset a } + lmap {a(3)} {1 2 3 4} {set {a(3)}} +} {1 2 3 4} +catch { unset a } + + +# "lmap" with "continue" and "break" (non-compiled) + +test lmap-3.1 {continue tests} { + lmap i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } +} {a c d} +test lmap-3.2 {continue tests} { + set x 0 + list [lmap i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x +} {b 4} +test lmap-3.3 {break tests} { + set x 0 + list [lmap i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x +} {{a b} 3} +# Check for bug similar to #406709 +test lmap-3.4 {break tests} { + set a 1 + lmap b b {list [concat a; break]; incr a} + incr a +} {2} + + +# ----- Compiled operation ------------------------------------------------------ + +# Basic "lmap" operation (compiled) + +test lmap-4.1 {basic lmap tests} { + apply {{} { + set a {} + lmap i {a b c d} { + set a [concat $a $i] + } + }} +} {a {a b} {a b c} {a b c d}} +test lmap-4.2 {basic lmap tests} { + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + set i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test lmap-4.2a {basic lmap tests} { + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test lmap-4.3 {basic lmap tests} {catch { apply {{} { lmap }} } msg} 1 +test lmap-4.4 {basic lmap tests} { + catch { apply {{} { lmap }} } msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.5 {basic lmap tests} {catch { apply {{} { lmap i }} } msg} 1 +test lmap-4.6 {basic lmap tests} { + catch { apply {{} { lmap i }} } msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.7 {basic lmap tests} {catch { apply {{} { lmap i j }} } msg} 1 +test lmap-4.8 {basic lmap tests} { + catch { apply {{} { lmap i j }} } msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.9 {basic lmap tests} {catch { apply {{} { lmap i j k l }} } msg} 1 +test lmap-4.10 {basic lmap tests} { + catch { apply {{} { lmap i j k l }} } msg + set msg +} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.11 {basic lmap tests} { + apply {{} { lmap i {} { set i } }} +} {} +test lmap-4.12 {basic lmap tests} { + apply {{} { lmap i {} { return -level 0 x } }} +} {} +test lmap-4.13 {lmap errors} { + list [catch { apply {{} { lmap {{a}{b}} {1 2 3} {} }} } msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test lmap-4.14 {lmap errors} { + list [catch { apply {{} { lmap a {{1 2}3} {} }} } msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test lmap-4.15 {lmap errors} { + apply {{} { + set a(0) 44 + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo + }} +} {1 {can't set "a": variable is array} {can't set "a": variable is array + while executing +"lmap a {1 2 3} {}"}} +test lmap-4.16 {lmap errors} { + list [catch { apply {{} { lmap {} {} {} }} } msg] $msg +} {1 {foreach varlist is empty}} +catch {unset a} + + +# Parallel "lmap" operation (compiled) + +test lmap-5.1 {parallel lmap tests} { + apply {{} { + lmap {a b} {1 2 3 4} { + list $b $a + } + }} +} {{2 1} {4 3}} +test lmap-5.2 {parallel lmap tests} { + apply {{} { + lmap {a b} {1 2 3 4 5} { + list $b $a + } + }} +} {{2 1} {4 3} {{} 5}} +test lmap-5.3 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {4 5 6} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3}} +test lmap-5.4 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {4 5 6 7 8} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test lmap-5.5 {parallel lmap tests} { + apply {{} { + lmap {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } + }} +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test lmap-5.6 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } + }} +} {11111 22222 33333} +test lmap-5.7 {parallel lmap tests} { + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } + }} +} {{1111 2} 222 33 4} +test lmap-5.8 {parallel lmap tests} { + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } + }} +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test lmap-5.9 {lmap only sets vars if repeating loop} { + apply {{} { + set rgb {65535 0 0} + lmap {r g b} [set rgb] {} + return "r=$r, g=$g, b=$b" + }} +} {r=65535, g=0, b=0} +test lmap-5.10 {lmap only supports local scalar variables} { + apply {{} { + lmap {a(3)} {1 2 3 4} {set {a(3)}} + }} +} {1 2 3 4} + + +# "lmap" with "continue" and "break" (compiled) + +test lmap-6.1 {continue tests} { + apply {{} { + lmap i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } + }} +} {a c d} +test lmap-6.2 {continue tests} { + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x + }} +} {b 4} +test lmap-6.3 {break tests} { + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x + }} +} {{a b} 3} +# Check for bug similar to #406709 +test lmap-6.4 {break tests} { + apply {{} { + set a 1 + lmap b b {list [concat a; break]; incr a} + incr a + }} +} {2} + + + +# ----- Special cases and bugs ------------------------------------------------- + + +test lmap-7.1 {compiled lmap backward jump works correctly} { + catch {unset x} + array set x {0 zero 1 one 2 two 3 three} + lsort [apply {{arrayName} { + upvar 1 $arrayName a + lmap member [array names a] { + list $member [set a($member)] + } + }} x] +} [lsort {{0 zero} {1 one} {2 two} {3 three}}] + +test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} { + catch {unset x} + lmap {12.0} {a b c} { + set x 12.0 + set x [expr $x + 1] + } +} {13.0 13.0 13.0} + +# Test for incorrect "double evaluation" semantics +test lmap-7.3 {delayed substitution of body} { + apply {{} { + set a 0 + lmap a [list 1 2 3] " + set x $a + " + set x + }} +} {0} + +# Related to "foreach" test for [Bug 1189274]; crash on failure +test lmap-7.4 {empty list handling} { + proc crash {} { + rename crash {} + set a "x y z" + set b "" + lmap aa $a bb $b { set x "aa = $aa bb = $bb" } + } + crash +} {{aa = x bb = } {aa = y bb = } {aa = z bb = }} + +# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled version +test lmap-7.5 {compiled empty var list} { + proc foo {} { + lmap {} x { + error "reached body" + } + } + list [catch { foo } msg] $msg +} {1 {foreach varlist is empty}} + +test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup { + proc demo {} { + set vals {1 2 3 4} + trace add variable x write {string length $vals ;# } + lmap {x y} $vals {format $y} + } +} -body { + demo +} -cleanup { + rename demo {} +} -result {2 4} + +# Huge lists must not overflow the bytecode interpreter (development bug) +test lmap-7.7 {huge list non-compiled} { + set x [lmap a [lrepeat 1000000 x] { set b y$a }] + list $b [llength $x] [string length $x] +} {yx 1000000 2999999} + +test lmap-7.8 {huge list compiled} { + set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000] + list $b [llength $x] [string length $x] +} {yx 1000000 2999999} + +test lmap-7.9 {error then dereference loop var (dev bug)} { + catch { lmap a 0 b {1 2 3} { error x } } + set a +} 0 +test lmap-7.9a {error then dereference loop var (dev bug)} { + catch { lmap a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + +# ----- Coroutines ------------------------------------------------------------- + +test lmap-8.1 {lmap non-compiled with coroutines} { + coroutine coro apply {{} { + set values [yield [info coroutine]] + eval lmap i [list $values] {{ yield $i }} + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} {{1 2 3 4 5 6} {}} + +test lmap-8.2 {lmap compiled with coroutines} { + coroutine coro apply {{} { + set values [yield [info coroutine]] + lmap i $values { yield $i } + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} {{1 2 3 4 5 6} {}} + + +# cleanup +catch {unset a} +catch {unset x} +catch {rename foo {}} +::tcltest::cleanupTests +return -- cgit v0.12 From 25925f6f8e072a0bc3cf719c7684eff79f96ed8f Mon Sep 17 00:00:00 2001 From: twylite Date: Wed, 8 Aug 2012 16:00:10 +0000 Subject: Man page updates for command rename from 'mapeach' to 'lmap'. --- doc/lmap.n | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) create mode 100644 doc/lmap.n diff --git a/doc/lmap.n b/doc/lmap.n new file mode 100644 index 0000000..7deb7f9 --- /dev/null +++ b/doc/lmap.n @@ -0,0 +1,91 @@ +'\" +'\" Copyright (c) 2012 Trevor Davel +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.so man.macros +.TH lmap n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lmap \- Iterate over all elements in one or more lists and collect results +.SH SYNOPSIS +\fBlmap \fIvarname list body\fR +.br +\fBlmap \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR +.BE + +.SH DESCRIPTION +.PP +The \fBlmap\fR command implements a loop where the loop +variable(s) take on values from one or more lists, and the loop returns a list +of results collected from each iteration. +.PP +In the simplest case there is one loop variable, \fIvarname\fR, +and one list, \fIlist\fR, that is a list of values to assign to \fIvarname\fR. +The \fIbody\fR argument is a Tcl script. +For each element of \fIlist\fR (in order +from first to last), \fBlmap\fR assigns the contents of the +element to \fIvarname\fR as if the \fBlindex\fR command had been used +to extract the element, then calls the Tcl interpreter to execute +\fIbody\fR. If execution of the body completes normally then the result of the +body is appended to an accumulator list. \fBlmap\fR returns the accumulator +list. + +.PP +In the general case there can be more than one value list +(e.g., \fIlist1\fR and \fIlist2\fR), +and each value list can be associated with a list of loop variables +(e.g., \fIvarlist1\fR and \fIvarlist2\fR). +During each iteration of the loop +the variables of each \fIvarlist\fR are assigned +consecutive values from the corresponding \fIlist\fR. +Values in each \fIlist\fR are used in order from first to last, +and each value is used exactly once. +The total number of loop iterations is large enough to use +up all the values from all the value lists. +If a value list does not contain enough +elements for each of its loop variables in each iteration, +empty values are used for the missing elements. +.PP +The \fBbreak\fR and \fBcontinue\fR statements may be +invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR +and \fBforeach\fR commands. In these cases the body does not complete normally +and the result is not appended to the accumulator list. +.SH EXAMPLES +.PP +Zip lists together: +.PP +.CS +'\" Maintainers: notice the tab hacking below! +.ta 3i +set list1 {a b c d} +set list2 {1 2 3 4} +set zipped [\fBlmap\fR a $list1 b $list2 {list $a $b}] +# The value of zipped is "{a 1} {b 2} {c 3} {d 4}" +.CE +.PP +Filter a list: +.PP +.CS +set values {1 2 3 4 5 6 7 8} +proc isGood {n} { expr { ($n % 2) == 0 } } +set goodOnes [\fBlmap\fR x $values {expr {[isGood $x] ? $x : [continue]}}] +# The value of goodOnes is "2 4 6 8" +.CE +.PP +Take a prefix from a list: +.PP +.CS +set values {8 7 6 5 4 3 2 1} +proc isGood {n} { expr { $n > 3 } } +set prefix [\fBlmap\fR x $values {expr {[isGood $x] ? $x : [break]}}] +# The value of prefix is "8 7 6 5 4" +.CE + +.SH "SEE ALSO" +for(n), while(n), break(n), continue(n), foreach(n) + +.SH KEYWORDS +foreach, iteration, list, loop, map -- cgit v0.12 From 0062f8538fd9dc925e8b8e00b9ede5ff39022623 Mon Sep 17 00:00:00 2001 From: stwo Date: Wed, 8 Aug 2012 23:07:27 +0000 Subject: Change one '#ifdef' to '#if defined()' for improved consistency within the file. --- ChangeLog | 5 +++++ unix/tclUnixCompat.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index cbbfea1..95a67b9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2010-08-08 Stuart Cassoff + + * unix/tclUnixCompat.c: Change one '#ifdef' to '#if defined()' for + improved consistency within the file. + 2012-08-08 Jan Nijtmans * generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 3818121..359e253 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -364,7 +364,7 @@ TclpGetGrNam( #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); -#ifdef HAVE_GETGRNAM_R_5 +#if defined(HAVE_GETGRNAM_R_5) struct group *grPtr = NULL; /* -- cgit v0.12 From ff7f9ca57976adcf0bd2d12b434e250cbcbbf765 Mon Sep 17 00:00:00 2001 From: max Date: Thu, 9 Aug 2012 14:26:04 +0000 Subject: Fix http-3.29 for machines without IPv6 support. --- ChangeLog | 4 ++++ tests/http.test | 16 ++++++++++++---- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 95a67b9..3d6e6d7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2012-08-09 Reinhard Max + + * tests/http.test: Fix http-3.29 for machines without IPv6 support. + 2010-08-08 Stuart Cassoff * unix/tclUnixCompat.c: Change one '#ifdef' to '#if defined()' for diff --git a/tests/http.test b/tests/http.test index fe44b47..bde5795 100644 --- a/tests/http.test +++ b/tests/http.test @@ -392,11 +392,19 @@ Content-Type {text/plain;charset=utf-8} Accept-Encoding .* Content-Length 5} test http-3.29 "http::geturl $ipv6url" -body { - set token [http::geturl $ipv6url -validate 1] - http::code $token + # We only want to see if the URL gets parsed correctly. This is + # the case if http::geturl succeeds or returns a socket related + # error. If the parsing is wrong, we'll get a parse error. + # It'd be better to separate the URL parser from http::geturl, so + # that it can be tested without also trying to make a connection. + set error [catch {http::geturl $ipv6url -validate 1} token] + if {$error && [string match "couldn't open socket: *" $token]} { + set error 0 + } + set error } -cleanup { - http::cleanup $token -} -result "HTTP/1.0 200 OK" + catch { http::cleanup $token } +} -result 0 test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12 From 6c8d57ffe3737a001786e0838daaf1a6e9f246c1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Aug 2012 04:42:33 +0000 Subject: minor fix --- doc/dde.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/dde.n b/doc/dde.n index e4b51b7..0acceac 100644 --- a/doc/dde.n +++ b/doc/dde.n @@ -88,7 +88,7 @@ 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 ?\fB\-binary\fR? \fIservice topic item data\fR +\fBdde poke\fR ?\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, -- cgit v0.12 From 948410d3929a4818d0fe0c6b7dfd918e4a98f35f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 13 Aug 2012 10:05:16 +0000 Subject: tinkering with the documentation --- doc/zlib.n | 43 +++++++++++++++++++++++++++++++------------ 1 file changed, 31 insertions(+), 12 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index 0233ba8..2610527 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -170,6 +170,13 @@ the .QW "\fIoptions ...\fR" to the \fBzlib push\fR command: .TP +\fB\-dictionary\fI binData\fR +.VS "TIP 400" +Sets the compression dictionary to use when working with compressing or +decompressing the data to be \fIbinData\fR. Not valid for transformations that +work with gzip-format data. +.VE +.TP \fB\-header\fI dictionary\fR . Passes a description of the gzip header to create, in the same format that @@ -198,6 +205,15 @@ the compression engine has seen so far. It is valid for both compressing and decompressing transforms, but not for the raw inflate and deflate formats. The compression algorithm depends on what format is being produced or consumed. .TP +\fB\-dictionary\fI binData\fR +.VS "TIP 400" +This read-write options gets or sets the compression dictionary to use when +working with compressing or decompressing the data to be \fIbinData\fR. It is +not valid for transformations that work with gzip-format data, and should not +normally be set on compressing transformations other than at the point where +the transformation is stacked. +.VE +.TP \fB\-flush\fI type\fR . This write-only operation flushes the current state of the compressor to the @@ -223,12 +239,12 @@ is non-blocking. .RE .SS "STREAMING SUBCOMMAND" .TP -\fBzlib stream\fI mode\fR ?\fIlevel\fR? +\fBzlib stream\fI mode\fR ?\fIoptions\fR? . Creates a streaming compression or decompression command based on the \fImode\fR, and return the name of the command. For a description of how that command works, see \fBSTREAMING INSTANCE COMMAND\fR below. The following modes -are supported: +and \fIoptions\fR are supported: .RS .TP \fBzlib stream compress\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? @@ -236,7 +252,7 @@ are supported: The stream will be a compressing stream that produces zlib-format output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, -.VS +.VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). .VE .TP @@ -244,7 +260,7 @@ and the compression dictionary \fIbindata\fR (if specified). . The stream will be a decompressing stream that takes zlib-format input and produces uncompressed output. -.VS +.VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use if required. .VE @@ -254,13 +270,13 @@ required. The stream will be a compressing stream that produces raw output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, -.VS +.VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). Note that the raw compressed data includes no metadata about what compression dictionary was used, if any; that is a feature of the zlib-format data. .VE .TP -\fBzlib stream gunzip\fR ?\fIlevel\fR? +\fBzlib stream gunzip\fR . The stream will be a decompressing stream that takes gzip-format input and produces uncompressed output. @@ -275,9 +291,12 @@ for keys see \fBzlib gzip\fR). \fBzlib stream inflate\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes raw compressed input and -produces uncompressed output. If \fIbindata\fR is supplied, it is a -compression dictionary to use. Note that there are no checks in place -to determine whether the compression dictionary is correct. +produces uncompressed output. +.VS "TIP 400" +If \fIbindata\fR is supplied, it is a compression dictionary to use. Note that +there are no checks in place to determine whether the compression dictionary +is correct. +.VE .RE .SS "CHECKSUMMING SUBCOMMANDS" .TP @@ -356,10 +375,10 @@ supported (or an unambiguous prefix of them), which are used to modify the way in which the transformation is applied: .RS .TP -\fB\-dictionary\fI compressionDictionary\fR +\fB\-dictionary\fI binData\fR .VS "TIP 400" -Sets a compression dictionary to use when working with compressing or -decompressing the data. +Sets the compression dictionary to use when working with compressing or +decompressing the data to be \fIbinData\fR. .VE .TP \fB\-finalize\fR -- cgit v0.12 From c5e721806345e37d192fc329af24785b5490c08a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Aug 2012 13:58:25 +0000 Subject: Add 64-bit build of zlib1.dll, and use it for the dynamic mingw-w64 build --- ChangeLog | 8 ++++++++ compat/zlib/win64/zdll.lib | Bin 0 -> 45650 bytes compat/zlib/win64/zlib1.dll | Bin 0 -> 112640 bytes win/Makefile.in | 8 ++++++-- win/configure | 14 ++++++++++++-- win/configure.in | 8 ++++++-- 6 files changed, 32 insertions(+), 6 deletions(-) create mode 100644 compat/zlib/win64/zdll.lib create mode 100644 compat/zlib/win64/zlib1.dll diff --git a/ChangeLog b/ChangeLog index 4391648..e1eb9b8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-08-13 Jan Nijtmans + + * compat/zlib/win64/zlib1.dll: Add 64-bit build of zlib1.dll, and use it + * compat/zlib/win64/zdll.lib: for the dynamic mingw-w64 build. + * win/Makefile.in + * win/configure.in + * win/configure + 2012-08-09 Reinhard Max * tests/http.test: Fix http-3.29 for machines without IPv6 support. diff --git a/compat/zlib/win64/zdll.lib b/compat/zlib/win64/zdll.lib new file mode 100644 index 0000000..084dbff Binary files /dev/null and b/compat/zlib/win64/zdll.lib differ diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll new file mode 100644 index 0000000..631439b Binary files /dev/null and b/compat/zlib/win64/zlib1.dll differ diff --git a/win/Makefile.in b/win/Makefile.in index 84dcaf7..fbc9274 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -456,8 +456,12 @@ ${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE} @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) # use pre-built zlib1.dll -${ZLIB_DLL_FILE}: $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} - @$(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE} +${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} + if test "@ZLIB_LIBS@set" == "${ZLIB_DIR}/win64/zdll.libset" ; then \ + $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ + else \ + $(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ + fi; # Add the object extension to the implicit rules. By default .obj is not # automatically added. diff --git a/win/configure b/win/configure index f5a23fe..5cf1513 100755 --- a/win/configure +++ b/win/configure @@ -4344,7 +4344,7 @@ esac # as we just assume that the platform hasn't got a usable z.lib #------------------------------------------------------------------------ -if test "$do64bit" = "yes"; then +if test "$do64bit" = "yes" && test "$GCC" != "yes"; then tcl_ok=no @@ -4368,7 +4368,17 @@ if test "$tcl_ok" = "yes"; then ZLIB_DLL_FILE=\${ZLIB_DLL_FILE} - ZLIB_LIBS=\${ZLIB_DIR}/win32/zdll.lib + if test "$do64bit" = "yes"; then + + ZLIB_LIBS=\${ZLIB_DIR}/win64/zdll.lib + + +else + + ZLIB_LIBS=\${ZLIB_DIR}/win32/zdll.lib + + +fi else diff --git a/win/configure.in b/win/configure.in index d17f815..de56bf7 100644 --- a/win/configure.in +++ b/win/configure.in @@ -120,7 +120,7 @@ esac # as we just assume that the platform hasn't got a usable z.lib #------------------------------------------------------------------------ -AS_IF([test "$do64bit" = "yes"], [ +AS_IF([test "$do64bit" = "yes" && test "$GCC" != "yes"], [ tcl_ok=no ], [ AS_IF([test "${enable_shared+set}" = "set"], [ @@ -132,7 +132,11 @@ AS_IF([test "${enable_shared+set}" = "set"], [ ]) AS_IF([test "$tcl_ok" = "yes"], [ AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win32/zdll.lib]) + AS_IF([test "$do64bit" = "yes"], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win64/zdll.lib]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win32/zdll.lib]) + ]) ], [ AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) AC_DEFINE_UNQUOTED(NO_VIZ, 1) -- cgit v0.12 From 026db9973900d03ebaf3e280f8300e3916fe0aaa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Aug 2012 14:02:23 +0000 Subject: .... but be less verbose --- win/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/Makefile.in b/win/Makefile.in index fbc9274..392bd7a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -457,7 +457,7 @@ ${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE} # use pre-built zlib1.dll ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} - if test "@ZLIB_LIBS@set" == "${ZLIB_DIR}/win64/zdll.libset" ; then \ + @if test "@ZLIB_LIBS@set" == "${ZLIB_DIR}/win64/zdll.libset" ; then \ $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ else \ $(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ -- cgit v0.12 From 263ace8ece084001464b1b3f8cdf0bfff4ec8538 Mon Sep 17 00:00:00 2001 From: stwo Date: Mon, 13 Aug 2012 14:18:55 +0000 Subject: [Bug 3555454] Rearrange a bit to quash 'declared but never defined' compiler warnings. --- ChangeLog | 5 +++++ unix/tclUnixCompat.c | 16 ++++++++++------ 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/ChangeLog b/ChangeLog index e1eb9b8..cc70f44 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2010-08-13 Stuart Cassoff + + * unix/tclUnixCompat.c: [Bug 3555454] Rearrange a bit + to quash 'declared but never defined' compiler warnings. + 2012-08-13 Jan Nijtmans * compat/zlib/win64/zlib1.dll: Add 64-bit build of zlib1.dll, and use it diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 359e253..e201018 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -99,12 +99,20 @@ static Tcl_Mutex compatLock; #undef NEED_COPYPWD #undef NEED_COPYSTRING +#if !defined(HAVE_GETGRNAM_R_5) && !defined(HAVE_GETGRNAM_R_4) +#define NEED_COPYGRP 1 +static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); +#endif + +#if !defined(HAVE_GETPWNAM_R_5) && !defined(HAVE_GETPWNAM_R_4) +#define NEED_COPYPWD 1 +static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); +#endif + static int CopyArray(char **src, int elsize, char *buf, int buflen); -static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); -static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif @@ -214,7 +222,6 @@ TclpGetPwNam( return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); #else -#define NEED_COPYPWD 1 struct passwd *pwPtr; Tcl_MutexLock(&compatLock); @@ -295,7 +302,6 @@ TclpGetPwUid( return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); #else -#define NEED_COPYPWD 1 struct passwd *pwPtr; Tcl_MutexLock(&compatLock); @@ -399,7 +405,6 @@ TclpGetGrNam( return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); #else -#define NEED_COPYGRP 1 struct group *grPtr; Tcl_MutexLock(&compatLock); @@ -480,7 +485,6 @@ TclpGetGrGid( return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); #else -#define NEED_COPYGRP 1 struct group *grPtr; Tcl_MutexLock(&compatLock); -- cgit v0.12 From 15741b0a0f7182f52283a7c3cac4513b14af1359 Mon Sep 17 00:00:00 2001 From: stwo Date: Mon, 13 Aug 2012 22:27:14 +0000 Subject: [Bug 3555454] Rearrange a bit to quash 'declared but never defined' compiler warnings. --- ChangeLog | 5 +++++ unix/tclUnixCompat.c | 16 ++++++++++------ 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/ChangeLog b/ChangeLog index d6499d7..5374478 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2010-08-13 Stuart Cassoff + + * unix/tclUnixCompat.c: [Bug 3555454] Rearrange a bit + to quash 'declared but never defined' compiler warnings. + 2012-08-08 Jan Nijtmans * generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 8b067af..06c19b9 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -99,12 +99,20 @@ static Tcl_Mutex compatLock; #undef NEED_COPYPWD #undef NEED_COPYSTRING +#if !defined(HAVE_GETGRNAM_R_5) && !defined(HAVE_GETGRNAM_R_4) +#define NEED_COPYGRP 1 +static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); +#endif + +#if !defined(HAVE_GETPWNAM_R_5) && !defined(HAVE_GETPWNAM_R_4) +#define NEED_COPYPWD 1 +static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); +#endif + static int CopyArray(char **src, int elsize, char *buf, int buflen); -static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); -static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif @@ -214,7 +222,6 @@ TclpGetPwNam( return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); #else -#define NEED_COPYPWD 1 struct passwd *pwPtr; Tcl_MutexLock(&compatLock); @@ -295,7 +302,6 @@ TclpGetPwUid( return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); #else -#define NEED_COPYPWD 1 struct passwd *pwPtr; Tcl_MutexLock(&compatLock); @@ -399,7 +405,6 @@ TclpGetGrNam( return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); #else -#define NEED_COPYGRP 1 struct group *grPtr; Tcl_MutexLock(&compatLock); @@ -480,7 +485,6 @@ TclpGetGrGid( return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); #else -#define NEED_COPYGRP 1 struct group *grPtr; Tcl_MutexLock(&compatLock); -- cgit v0.12 From 9dbf0547c43ef5ce4b301582d9e950dbe2b70a97 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Aug 2012 08:12:39 +0000 Subject: Only build the threaded builds by default. Backport some improvements from Tcl 8.6 --- ChangeLog | 6 +++ win/buildall.vc.bat | 68 +++++++++-------------- win/makefile.vc | 153 +++++++++++++++++++++++++++++++++++----------------- win/rules.vc | 63 ++++++++++++++-------- 4 files changed, 175 insertions(+), 115 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5374478..9956dd0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-08-15 Jan Nijtmans + + * win/buildall.vc.bat: Only build the threaded builds by default + * win/rules.vc: Backport some improvements from Tcl 8.6 + * win/makefile.vc: + 2010-08-13 Stuart Cassoff * unix/tclUnixCompat.c: [Bug 3555454] Rearrange a bit diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index 55b29ae..0c9b3ac 100644 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -1,4 +1,5 @@ @echo off + :: This is an example batchfile for building everything. Please :: edit this (or make your own) for your needs and wants using :: the instructions for calling makefile.vc found in makefile.vc @@ -22,17 +23,25 @@ goto OPTIONS_DONE :: reset errorlevel cd > nul +:: You might have installed your developer studio to add itself to the +:: path or have already run vcvars32.bat. Testing these envars proves +:: cl.exe and friends are in your path. +:: +if defined VCINSTALLDIR (goto :startBuilding) +if defined MSDEVDIR (goto :startBuilding) +if defined MSVCDIR (goto :startBuilding) +if defined MSSDK (goto :startBuilding) +if defined WINDOWSSDKDIR (goto :startBuilding) + :: We need to run the development environment batch script that comes -:: with developer studio (v4,5,6,7,etc...) All have it. These paths -:: might not be correct. You may need to edit these. +:: with developer studio (v4,5,6,7,etc...) All have it. This path +:: might not be correct. You should call it yourself prior to running +:: this batchfile. :: -if not defined MSDevDir ( - call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat" - ::call "C:\Program Files\Microsoft Developer Studio\vc\bin\vcvars32.bat" - ::call c:\dev\devstudio60\vc98\bin\vcvars32.bat - if errorlevel 1 goto no_vcvars -) +call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat" +if errorlevel 1 (goto no_vcvars) +:startBuilding echo. echo Sit back and have a cup of coffee while this grinds through ;) @@ -50,45 +59,16 @@ if "%INSTALLDIR%" == "" set INSTALLDIR=C:\Program Files\Tcl :: Build the normal stuff along with the help file. :: -set OPTS=none -if not %SYMBOLS%.==. set OPTS=symbols -nmake -nologo -f makefile.vc release winhelp OPTS=%OPTS% %1 -if errorlevel 1 goto error - -:: Build the static core, dlls and shell. -:: -set OPTS=static -if not %SYMBOLS%.==. set OPTS=symbols,static -nmake -nologo -f makefile.vc release OPTS=%OPTS% %1 -if errorlevel 1 goto error - -:: Build the special static libraries that use the dynamic runtime. -:: -set OPTS=static,msvcrt -if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt -nmake -nologo -f makefile.vc core dlls OPTS=%OPTS% %1 -if errorlevel 1 goto error - -:: Build the core and shell for thread support. -:: set OPTS=threads if not %SYMBOLS%.==. set OPTS=symbols,threads -nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1 -if errorlevel 1 goto error - -:: Build a static, thread support core library with a shell. -:: -set OPTS=static,threads -if not %SYMBOLS%.==. set OPTS=symbols,static,threads -nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1 +nmake -nologo -f makefile.vc release winhelp OPTS=%OPTS% %1 if errorlevel 1 goto error -:: Build the special static libraries that use the dynamic runtime, -:: but now with thread support. +:: Build the static core and shell. :: set OPTS=static,msvcrt,threads if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt,threads -nmake -nologo -f makefile.vc core dlls OPTS=%OPTS% %1 +nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1 if errorlevel 1 goto error set OPTS= @@ -100,15 +80,15 @@ echo *** BOOM! *** goto end :no_vcvars -echo vcvars32.bat not found. You'll need to edit this batch script. +echo vcvars32.bat was not run prior to this batchfile, nor are the MS tools in your path. goto out :help title buildall.vc.bat help message echo usage: -echo %0 : builds Tcl for all build types (do this first) -echo %0 install : installs all the release builds (do this second) -echo %0 symbols : builds Tcl for all debugging build types +echo %0 : builds Tcl for all build types (do this first) +echo %0 install : installs all the release builds (do this second) +echo %0 symbols : builds Tcl for all debugging build types echo %0 symbols install : install all the debug builds. echo. goto out diff --git a/win/makefile.vc b/win/makefile.vc index 5db8143..3d17331 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -5,7 +5,7 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# +# # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. @@ -58,67 +58,72 @@ the build instructions. # makefile. Helpful to avoid problems when the sources are # refreshed and you rebuild, but can "overbuild" when common # headers like tclInt.h just get small changes. +# htmlhelp -- Builds a Windows .chm help file for Tcl and Tk from the +# troff manual pages found in $(ROOT)\doc. You need to +# have installed the HTML Help Compiler package from Microsoft +# to produce the .chm file. # winhelp -- Builds the windows .hlp file for Tcl from the troff man -# files found in $(ROOT)\doc . +# files found in $(ROOT)\doc. # # 4) Macros usable on the commandline: # INSTALLDIR= # Sets where to install Tcl from the built binaries. # C:\Progra~1\Tcl is assumed when not specified. # -# OPTS=static,msvcrt,staticpkg,threads,symbols,profile,loimpact,unchecked,none +# OPTS=loimpact,msvcrt,static,staticpkg,symbols,threads,profile,unchecked,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. # -# static = Builds a static library of the core instead of a -# dll. The shell will be static (and large), as well. -# msvcrt = Affects the static option only to switch it from +# loimpact = Adds a flag for how NT treats the heap to keep memory +# in use, low. This is said to impact alloc performance. +# msvcrt = Affects the static option only to switch it from # using libcmt(d) as the C runtime [by default] to # msvcrt(d). This is useful for static embedding # support. -# staticpkg = Affects the static option only to switch +# static = Builds a static library of the core instead of a +# dll. The shell will be static (and large), as well. +# staticpkg= Affects the static option only to switch # tclshXX.exe to have the dde and reg extension linked # inside it. -# threads = Turns on full multithreading support. +# threads = Turns on full multithreading support. # thrdalloc = Use the thread allocator (shared global free pool). # thrdstorage = Use the generic thread storage support. # symbols = Adds symbols for step debugging. # profile = Adds profiling hooks. Map file is assumed. -# loimpact = Adds a flag for how NT treats the heap to keep memory -# in use, low. This is said to impact alloc performance. # unchecked = Allows a symbols build to not use the debug # enabled runtime (msvcrt.dll not msvcrtd.dll # or libcmt.lib not libcmtd.lib). # -# STATS=memdbg,compdbg,none +# STATS=compdbg,memdbg,none # Sets optional memory and bytecode compiler debugging code added # to the core. The default is for none. Any combination of the # above may be used (comma separated). 'none' will over-ride # everything to nothing. # -# memdbg = Enables the debugging memory allocator. # compdbg = Enables byte compilation logging. +# memdbg = Enables the debugging memory allocator. # -# CHECKS=nodep,fullwarn,64bit,none +# CHECKS=64bit,fullwarn,nodep,none # Sets special macros for checking compatability. # -# nodep = Turns off compatability macros to ensure the core -# isn't being built with deprecated functions. +# 64bit = Enable 64bit portability warnings (if available) # fullwarn = Builds with full compiler and link warnings enabled. # Very verbose. -# 64bit = Enable 64bit portability warnings (if available) +# nodep = Turns off compatability macros to ensure the core +# isn't being built with deprecated functions. # -# MACHINE=(IX86|IA64|AMD64|ALPHA) +# MACHINE=(ALPHA|AMD64|IA64|IX86) # Set the machine type used for the compiler, linker, and # resource compiler. This hook is needed to tell the tools # when alternate platforms are requested. IX86 is the default -# when not specified. +# when not specified. If the CPU environment variable has been +# set (ie: recent Platform SDK) then MACHINE is set from CPU. # # TMP_DIR= # OUT_DIR= # Hooks to allow the intermediate and output directories to be -# changed. $(OUT_DIR) is assumed to be +# changed. $(OUT_DIR) is assumed to be # $(BINROOT)\(Release|Debug) based on if symbols are requested. # $(TMP_DIR) will de $(OUT_DIR)\ by default. # @@ -170,7 +175,7 @@ Please `cd` to its location first. !error $(MSG) !endif -PROJECT = tcl +PROJECT = tcl !include "rules.vc" STUBPREFIX = $(PROJECT)stub @@ -397,7 +402,8 @@ TCLOBJS = \ $(TMP_DIR)\tcl.res !endif -TCLSTUBOBJS = $(TMP_DIR)\tclStubLib.obj +TCLSTUBOBJS = \ + $(TMP_DIR)\tclStubLib.obj ### The following paths CANNOT have spaces in them. COMPATDIR = $(ROOT)\compat @@ -407,7 +413,6 @@ TOMMATHDIR = $(ROOT)\libtommath TOOLSDIR = $(ROOT)\tools WINDIR = $(ROOT)\win - #--------------------------------------------------------------------- # Compile flags #--------------------------------------------------------------------- @@ -452,8 +457,7 @@ TCL_DEFINES = -DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" -DTCL_TOMMATH -DMP_PREC=4 -Di BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) $(TCL_DEFINES) CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) -### Stubs files should not be compiled with -GL -STUB_CFLAGS = $(cflags) $(cdebug:-GL=) $(OPTDEFINES) +STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) #--------------------------------------------------------------------- @@ -522,17 +526,17 @@ all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) tcltest: setup $(TCLTEST) dlls $(CAT32) install: install-binaries install-libraries install-docs - -test: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT)/library +test: test-core +test-core: setup $(TCLTEST) dlls $(CAT32) + set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" - $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile << + $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.2.2 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... - $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log + $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.2.2 "$(TCLREGLIB:\=/)" registry] << @@ -540,8 +544,12 @@ test: setup $(TCLTEST) dlls $(CAT32) !endif runtest: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT)/library - $(DEBUGGER) $(TCLTEST) + set TCL_LIBRARY=$(ROOT:\=/)/library + $(DEBUGGER) $(TCLTEST) $(SCRIPT) + +runshell: setup $(TCLSH) dlls + set TCL_LIBRARY=$(ROOT:\=/)/library + $(DEBUGGER) $(TCLSH) $(SCRIPT) setup: @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) @@ -553,7 +561,7 @@ $(TCLIMPLIB): $(TCLLIB) $(TCLLIB): $(TCLOBJS) !if $(STATIC_BUILD) - $(lib32) -nologo -out:$@ @<< + $(lib32) -nologo $(LINKERFLAGS) -out:$@ @<< $** << !else @@ -566,13 +574,13 @@ $** !endif $(TCLSTUBLIB): $(TCLSTUBOBJS) - $(lib32) -nologo -out:$@ $(TCLSTUBOBJS) + $(lib32) -nologo $(LINKERFLAGS) -out:$@ $(TCLSTUBOBJS) -$(TCLSH): $(TCLSHOBJS) $(TCLIMPLIB) +$(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** $(_VC_MANIFEST_EMBED_EXE) -$(TCLTEST): $(TCLTESTOBJS) $(TCLIMPLIB) +$(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** $(_VC_MANIFEST_EMBED_EXE) @@ -583,7 +591,7 @@ $(TCLPIPEDLL): $(WINDIR)\stub16.c !if $(STATIC_BUILD) $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj - $(lib32) -nologo -out:$@ $** + $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** !else $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \ @@ -595,7 +603,7 @@ $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) !if $(STATIC_BUILD) $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj - $(lib32) -nologo -out:$@ $** + $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** !else $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \ @@ -641,9 +649,49 @@ gentommath_h: !endif #--------------------------------------------------------------------- -# Build the windows help file. +# Build the Windows HTML help file. #--------------------------------------------------------------------- +# NOTE: you can define HHC on the command-line to override this +!ifndef HHC +HHC=""%ProgramFiles%\HTML Help Workshop\hhc.exe"" +!endif +HTMLDIR=$(ROOT)\html +HTMLBASE=TclTk$(VERSION) +HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp +CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm + +htmlhelp: chmsetup $(CHMFILE) + +$(CHMFILE): $(DOCDIR)\* + @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl + @echo Compiling HTML help project + @$(HHC) <<$(HHPFILE) >NUL +[OPTIONS] +Compatibility=1.1 or later +Compiled file=$(HTMLBASE).chm +Display compile progress=no +Error log file=$(HTMLBASE).log +Language=0x409 English (United States) +Title=Tcl/Tk $(DOT_VERSION) Help +[FILES] +contents.htm +docs.css +Keywords +TclCmd +TclLib +TkCmd +TkLib +UserCmd +<< + +chmsetup: + @if not exist $(HTMLDIR)\nul mkdir $(HTMLDIR) + +#------------------------------------------------------------------------- +# Build the old-style Windows .hlp file +#------------------------------------------------------------------------- + TCLHLPBASE = $(PROJECT)$(VERSION) HELPFILE = $(OUT_DIR)\$(TCLHLPBASE).hlp HELPCNT = $(OUT_DIR)\$(TCLHLPBASE).cnt @@ -701,7 +749,12 @@ $(HELPRTF): $(MAN2TCL) $(MAN2HELP) $(MAN2HELP2) $(INDEX) $(DOCDIR)\* $(TCLSH) $(MAN2HELP) -bitmap $(BMP_NOPATH) $(PROJECT) $(VERSION) $(DOCDIR:\=/) install-docs: -!if exist($(HELPFILE)) +!if exist("$(CHMFILE)") + @echo Installing compiled HTML help + @$(CPY) "$(CHMFILE)" "$(DOC_INSTALL_DIR)\" +!endif +!if exist("$(HELPFILE)") + @echo Installing Windows help @$(CPY) "$(HELPFILE)" "$(DOC_INSTALL_DIR)\" @$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\" !endif @@ -732,8 +785,8 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in @LIBS@ $(baselibs) @prefix@ $(_INSTALLDIR) @exec_prefix@ $(BIN_INSTALL_DIR) -@SHLIB_CFLAGS@ -@STLIB_CFLAGS@ +@SHLIB_CFLAGS@ +@STLIB_CFLAGS@ @CFLAGS_WARNING@ -W3 @EXTRA_CFLAGS@ -YX @SHLIB_LD@ $(link32) $(dlllflags) @@ -751,7 +804,7 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in @TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) @TCL_LIB_VERSIONS_OK@ @TCL_SRC_DIR@ $(ROOT) -@TCL_PACKAGE_PATH@ +@TCL_PACKAGE_PATH@ @TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) @@ -771,7 +824,7 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in #--------------------------------------------------------------------- -# The following target generates the file generic/tclDate.c +# The following target generates the file generic/tclDate.c # from the yacc grammar found in generic/tclGetDate.y. This is # only run by hand as yacc is not available in all environments. # The name of the .c file is different than the name of the .y file @@ -1023,15 +1076,15 @@ install-libraries: tclConfig install-msgs install-tzdata install-tzdata: @echo Installing time zone data - @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ - "$(ROOT)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" install-msgs: @echo Installing message catalogs - @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ - "$(ROOT)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" #--------------------------------------------------------------------- # Clean up @@ -1069,6 +1122,8 @@ clean: @echo Cleaning $(WINDIR)\versions.vc ... @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc +realclean: hose + hose: @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) diff --git a/win/rules.vc b/win/rules.vc index 20c967a..bbf7485 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -6,9 +6,9 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# +# # Copyright (c) 2001-2003 David Gravereaux. -# Copyright (c) 2003-2007 Patrick Thoyts +# Copyright (c) 2003-2008 Patrick Thoyts #------------------------------------------------------------------------------ !ifndef _RULES_VC @@ -217,7 +217,8 @@ TCL_THREADS = 0 DEBUG = 0 SYMBOLS = 0 PROFILE = 0 -MSVCRT = 0 +PGO = 0 +MSVCRT = 1 LOIMPACT = 0 TCL_USE_STATIC_PACKAGES = 0 USE_THREAD_ALLOC = 0 @@ -233,9 +234,13 @@ STATIC_BUILD = 0 !message *** Doing msvcrt MSVCRT = 1 !else +!if !$(STATIC_BUILD) +MSVCRT = 1 +!else MSVCRT = 0 !endif -!if [nmakehlp -f $(OPTS) "staticpkg"] +!endif +!if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !else @@ -244,8 +249,10 @@ TCL_USE_STATIC_PACKAGES = 0 !if [nmakehlp -f $(OPTS) "threads"] !message *** Doing threads TCL_THREADS = 1 +USE_THREAD_ALLOC = 1 !else TCL_THREADS = 0 +USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols @@ -265,6 +272,15 @@ PROFILE = 1 !else PROFILE = 0 !endif +!if [nmakehlp -f $(OPTS) "pgi"] +!message *** Doing profile guided optimization instrumentation +PGO = 1 +!elseif [nmakehlp -f $(OPTS) "pgo"] +!message *** Doing profile guided optimization +PGO = 2 +!else +PGO = 0 +!endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Doing loimpact LOIMPACT = 1 @@ -274,7 +290,9 @@ LOIMPACT = 0 !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 -!else +!endif +!if [nmakehlp -f $(OPTS) "tclalloc"] +!message *** Doing tclalloc USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] @@ -285,15 +303,6 @@ UNCHECKED = 0 !endif !endif - -!if !$(STATIC_BUILD) -# Make sure we don't build overly fat DLLs. -MSVCRT = 1 -# We shouldn't statically put the extensions inside the shell when dynamic. -TCL_USE_STATIC_PACKAGES = 0 -!endif - - #---------------------------------------------------------- # Figure-out how to name our intermediate and output directories. # We wouldn't want different builds to use the same .obj files @@ -335,10 +344,8 @@ TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX TMP_DIRFULL = $(TMP_DIRFULL:Static=) SUFX = $(SUFX:s=) EXT = dll -!if $(MSVCRT) TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) -!endif !else TMP_DIRFULL = $(TMP_DIRFULL:Dynamic=) EXT = lib @@ -417,6 +424,24 @@ WARNINGS = $(WARNINGS) -Wp64 !endif !endif +!if $(PGO) > 1 +!if [nmakehlp -l -ltcg:pgoptimize] +LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pgoptimize +!else +MSG=^ +This compiler does not support profile guided optimization. +!error $(MSG) +!endif +!elseif $(PGO) > 0 +!if [nmakehlp -l -ltcg:pginstrument] +LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pginstrument +!else +MSG=^ +This compiler does not support profile guided optimization. +!error $(MSG) +!endif +!endif + #---------------------------------------------------------- # Set our defines now armed with our options. #---------------------------------------------------------- @@ -552,12 +577,6 @@ Failed to find tcl.h. The TCLDIR macro does not appear correct. TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) -!if $(TCL_VERSION) < 81 -TCL_DOES_STUBS = 0 -!else -TCL_DOES_STUBS = 1 -!endif - !if $(TCLINSTALL) TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe" !if !exist($(TCLSH)) && $(TCL_THREADS) -- cgit v0.12 From 50d80bc71893acbc27ec158d7fc0607e1c8e50b6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Aug 2012 08:41:03 +0000 Subject: build htmlhelp, not winhelp by default --- win/buildall.vc.bat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index fed5e64..e4f0a30 100755 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -61,7 +61,7 @@ if "%INSTALLDIR%" == "" set INSTALLDIR=C:\Program Files\Tcl :: set OPTS=none if not %SYMBOLS%.==. set OPTS=symbols -nmake -nologo -f makefile.vc release winhelp OPTS=%OPTS% %1 +nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1 if errorlevel 1 goto error :: Build the static core and shell. -- cgit v0.12 From 7c1018370361dd17edaa31c3baac76a615d73059 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Aug 2012 07:15:31 +0000 Subject: nmakehlp: Add "-V" option, in order to be able to detect partial version numbers. --- win/nmakehlp.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/win/nmakehlp.c b/win/nmakehlp.c index 2868857..d0edcf0 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -47,7 +47,7 @@ static int CheckForLinkerFeature(const char *option); static int IsIn(const char *string, const char *substring); static int SubstituteFile(const char *substs, const char *filename); static int QualifyPath(const char *path); -static const char *GetVersionFromFile(const char *filename, const char *match); +static const char *GetVersionFromFile(const char *filename, const char *match, int numdots); static DWORD WINAPI ReadFromPipe(LPVOID args); /* globals */ @@ -153,7 +153,7 @@ main( &dwWritten, NULL); return 0; } - printf("%s\n", GetVersionFromFile(argv[2], argv[3])); + printf("%s\n", GetVersionFromFile(argv[2], argv[3], *(argv[1]+2) - '0')); return 0; case 'Q': if (argc != 3) { @@ -479,7 +479,8 @@ IsIn( static const char * GetVersionFromFile( const char *filename, - const char *match) + const char *match, + int numdots) { size_t cbBuffer = 100; static char szBuffer[100]; @@ -509,7 +510,8 @@ GetVersionFromFile( */ q = p; - while (*q && (isalnum(*q) || *q == '.')) { + while (*q && (strchr("0123456789.ab", *q)) && ((!strchr(".ab", *q) + && (!strchr("ab", q[-1])) || --numdots))) { ++q; } -- cgit v0.12 From 087231e55e5ff1f00a7c61f88faac65f8155f504 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Aug 2012 07:16:25 +0000 Subject: nmakehlp: Add "-V" option, in order to be able to detect partial version numbers. --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 77d483d..b8b9f2b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-17 Jan Nijtmans + + * win/nmakehlp.c: Add "-V" option, in order to be able + to detect partial version numbers. + 2012-07-31 Jan Nijtmans * win/nmakehlp.c: Backport from Tcl 8.6, but add -Q option from -- cgit v0.12 From 45f8aafc9099cb3ee0ae65d68f59d57ba5cec4d9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Aug 2012 08:59:36 +0000 Subject: Remove wrapper macro for ntohs(): unnecessary, because it doesn't require an initialized winsock_2 library --- generic/tclStubInit.c | 7 +------ win/tclWinPort.h | 1 - win/tclWinSock.c | 22 ++-------------------- 3 files changed, 3 insertions(+), 27 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7b73ee3..3be6b45 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -74,6 +74,7 @@ MODULE_SCOPE TclIntPlatStubs tclIntPlatStubs; MODULE_SCOPE TclPlatStubs tclPlatStubs; MODULE_SCOPE TclStubs tclStubs; MODULE_SCOPE TclTomMathStubs tclTomMathStubs; +#define TclWinNToHS ntohs #ifdef __WIN32__ # define TclUnixWaitForFile 0 @@ -112,12 +113,6 @@ void *TclWinGetTclInstance() return hInstance; } -unsigned short -TclWinNToHS(unsigned short ns) -{ - return ntohs(ns); -} - int TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 4f9e8b8..f58014c 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -457,7 +457,6 @@ typedef DWORD_PTR * PDWORD_PTR; #define getservbyname TclWinGetServByName #define getsockopt TclWinGetSockOpt -#define ntohs TclWinNToHS #define setsockopt TclWinSetSockOpt /* This type is not defined in the Windows headers */ #define socklen_t int diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 63f166d..8f2028d 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -65,7 +65,6 @@ #undef getservbyname #undef getsockopt -#undef ntohs #undef setsockopt /* @@ -131,7 +130,7 @@ typedef struct SocketInfo { * socket event occurs. */ -typedef struct SocketEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ SOCKET socket; /* Socket descriptor that is ready. Used to @@ -159,7 +158,7 @@ typedef struct SocketEvent { #define SOCKET_PENDING (1<<3) /* A message has been sent for this * socket */ -typedef struct ThreadSpecificData { +typedef struct { HWND hwnd; /* Handle to window for socket messages. */ HANDLE socketThread; /* Thread handling the window */ Tcl_ThreadId threadId; /* Parent thread. */ @@ -2508,23 +2507,6 @@ TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, return setsockopt(s, level, optname, optval, optlen); } -unsigned short -TclWinNToHS(unsigned short netshort) -{ - /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. - */ - - if (!SocketsEnabled()) { - return (unsigned short) -1; - } - - return ntohs(netshort); -} - char * TclpInetNtoa(struct in_addr addr) { -- cgit v0.12 From ac385804788ee5d3a9ee7929a7df56b930b6b8d7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Aug 2012 09:01:08 +0000 Subject: ... and don't forget ChangeLog entry --- ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ChangeLog b/ChangeLog index 3dfcc09..d5e6345 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-08-20 Jan Nijtmans + + * win/tclWinPort.h: Remove wrapper macro for ntohs(): unnecessary, + because it doesn't require an initialized winsock_2 library. See: + + * win/tclWinSock.c + * generic/tclStubInit.c + 2012-08-17 Jan Nijtmans * win/nmakehlp.c: Add "-V" option, in order to be able -- cgit v0.12 From 843b8497d3c972540e5b12b26ae3055d9df4bf77 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 20 Aug 2012 23:45:25 +0000 Subject: 3559678 Fix bad filename normalization when the last component is the empty string. --- ChangeLog | 5 +++++ generic/tclPathObj.c | 9 +++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index d5e6345..b1c9079 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-20 Don Porter + + * generic/tclPathObj.c: [Bug 3559678] Fix bad filename normalization + when the last component is the empty string. + 2012-08-20 Jan Nijtmans * win/tclWinPort.h: Remove wrapper macro for ntohs(): unnecessary, diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index ac9df3a..c9b3b8e 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1831,7 +1831,7 @@ Tcl_FSGetNormalizedPath( */ Tcl_Obj *dir, *copy; - int cwdLen, pathType; + int tailLen, cwdLen, pathType; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); @@ -1843,7 +1843,12 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } - copy = AppendPath(dir, fsPathPtr->normPathPtr); + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + if (tailLen) { + copy = AppendPath(dir, fsPathPtr->normPathPtr); + } else { + copy = Tcl_DuplicateObj(dir); + } Tcl_IncrRefCount(dir); Tcl_IncrRefCount(copy); -- cgit v0.12 From 77e356e2cee812b76dd325d0f34ad239eb75f82a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Aug 2012 12:07:22 +0000 Subject: [Bug 3496014] Protect Tcl_SetByteArrayObj for invalid values (Backported from Tcl 8.6) --- ChangeLog | 5 +++++ generic/tclBinary.c | 7 ++++++- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index b1c9079..74ff19b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-23 Jan Nijtmans + + * generic/tclBinary.c: [Bug 3496014] (Backport from Tcl 8.6) Protect + Tcl_SetByteArrayObj for invalid values. + 2012-08-20 Don Porter * generic/tclPathObj.c: [Bug 3559678] Fix bad filename normalization diff --git a/generic/tclBinary.c b/generic/tclBinary.c index f321b28..8c95305 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -273,10 +273,15 @@ Tcl_SetByteArrayObj( TclFreeIntRep(objPtr); Tcl_InvalidateStringRep(objPtr); + if (length < 0) { + length = 0; + } byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - memcpy(byteArrayPtr->bytes, bytes, (size_t) length); + if (length && bytes) { + memcpy(byteArrayPtr->bytes, bytes, (size_t) length); + } objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); -- cgit v0.12 From b02e97a2b368aa22f4d35a51ab1d3efdf197352b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Aug 2012 20:06:18 +0000 Subject: small wrapper for TclWinNToHs, for change in calling convention --- generic/tclStubInit.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 3be6b45..6a3207b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -74,7 +74,12 @@ MODULE_SCOPE TclIntPlatStubs tclIntPlatStubs; MODULE_SCOPE TclPlatStubs tclPlatStubs; MODULE_SCOPE TclStubs tclStubs; MODULE_SCOPE TclTomMathStubs tclTomMathStubs; -#define TclWinNToHS ntohs + +#if defined(_WIN32) || defined(__CYGWIN__) +unsigned short TclWinNToHS(unsigned short ns) { + return ntohs(ns); +} +#endif #ifdef __WIN32__ # define TclUnixWaitForFile 0 -- cgit v0.12 From a204742a21724c1f5404afff35e6450941ee13ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Aug 2012 06:29:44 +0000 Subject: make sure that extensions which might still use TclWinNToHS, now use ntohs directly. --- generic/tclIntPlatDecls.h | 5 ++++- generic/tclStubInit.c | 1 + 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 34a23a4..1e68c9c 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -845,7 +845,10 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpLocaltime_unix #undef TclpGmtime_unix -#if !defined(__WIN32__) && !defined(__CYGWIN__) +#if defined(__WIN32__) || defined(__CYGWIN__) +# undef TclWinNToHS +# define TclWinNToHS ntohs +#else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) #endif diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6a3207b..d06e174 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -76,6 +76,7 @@ MODULE_SCOPE TclStubs tclStubs; MODULE_SCOPE TclTomMathStubs tclTomMathStubs; #if defined(_WIN32) || defined(__CYGWIN__) +#undef TclWinNToHS unsigned short TclWinNToHS(unsigned short ns) { return ntohs(ns); } -- cgit v0.12 From 5acd6ce01a27ac62f458af4a93a97939fc8f9dd6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 Aug 2012 10:07:16 +0000 Subject: [Bug 3561330]: Use the correct full name of March in Ukrainian. --- ChangeLog | 5 +++++ library/msgs/uk.msg | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 74ff19b..b8776c9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-08-25 Donal K. Fellows + + * library/msgs/uk.msg: [Bug 3561330]: Use the correct full name of + March in Ukrainian. Thanks to Mikhail Teterin for reporting. + 2012-08-23 Jan Nijtmans * generic/tclBinary.c: [Bug 3496014] (Backport from Tcl 8.6) Protect diff --git a/library/msgs/uk.msg b/library/msgs/uk.msg index 3e24f86..7d4c64a 100755 --- a/library/msgs/uk.msg +++ b/library/msgs/uk.msg @@ -33,7 +33,7 @@ namespace eval ::tcl::clock { ::msgcat::mcset uk MONTHS_FULL [list \ "\u0441\u0456\u0447\u043d\u044f"\ "\u043b\u044e\u0442\u043e\u0433\u043e"\ - "\u0431\u0435\u0440\u0435\u0436\u043d\u044f"\ + "\u0431\u0435\u0440\u0435\u0437\u043d\u044f"\ "\u043a\u0432\u0456\u0442\u043d\u044f"\ "\u0442\u0440\u0430\u0432\u043d\u044f"\ "\u0447\u0435\u0440\u0432\u043d\u044f"\ -- cgit v0.12 From fe97a8d7c3a50b23fe6136f9034f16769304d1df Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 Aug 2012 16:39:25 +0000 Subject: minor: tidy up formatting --- ChangeLog | 137 ++++++++++++++++++++++++++++++++------------------------------ 1 file changed, 71 insertions(+), 66 deletions(-) diff --git a/ChangeLog b/ChangeLog index b8776c9..18cdf37 100644 --- a/ChangeLog +++ b/ChangeLog @@ -5,12 +5,12 @@ 2012-08-23 Jan Nijtmans - * generic/tclBinary.c: [Bug 3496014] (Backport from Tcl 8.6) Protect + * generic/tclBinary.c: [Bug 3496014]: (Backport from Tcl 8.6) Protect Tcl_SetByteArrayObj for invalid values. 2012-08-20 Don Porter - * generic/tclPathObj.c: [Bug 3559678] Fix bad filename normalization + * generic/tclPathObj.c: [Bug 3559678]: Fix bad filename normalization when the last component is the empty string. 2012-08-20 Jan Nijtmans @@ -34,8 +34,8 @@ 2010-08-13 Stuart Cassoff - * unix/tclUnixCompat.c: [Bug 3555454] Rearrange a bit - to quash 'declared but never defined' compiler warnings. + * unix/tclUnixCompat.c: [Bug 3555454]: Rearrange a bit to quash + 'declared but never defined' compiler warnings. 2012-08-08 Jan Nijtmans @@ -44,8 +44,8 @@ 2012-08-07 Don Porter - * generic/tclIOUtil.c: [Bug 3554250] Overlooked one field of - cleanup in the thread exit handler for the filesystem subsystem. + * generic/tclIOUtil.c: [Bug 3554250]: Overlooked one field of cleanup + in the thread exit handler for the filesystem subsystem. 2012-07-31 Jan Nijtmans @@ -54,8 +54,8 @@ 2012-07-28 Jan Nijtmans - * tests/clock.test: [Bug 3549770] Multiple test failures running tcltest - * tests/registry.test: outside build tree + * tests/clock.test: [Bug 3549770]: Multiple test failures running + * tests/registry.test: tcltest outside build tree * tests/winDde.test: 2012-07-27 Jan Nijtmans @@ -112,7 +112,8 @@ 2012-07-10 Jan Nijtmans - * unix/tclUnixNotfy.c: [Bug 3541646] Don't panic on triggerPipe overrun + * unix/tclUnixNotfy.c: [Bug 3541646]: Don't panic on triggerPipe + overrun. 2012-07-10 Donal K. Fellows @@ -123,7 +124,7 @@ 2012-07-05 Don Porter - * unix/tclUnixPipe.c: [Bug 1189293] Make "<<" binary safe. + * unix/tclUnixPipe.c: [Bug 1189293]: Make "<<" binary safe. * win/tclWinPipe.c: 2012-06-29 Jan Nijtmans @@ -132,10 +133,10 @@ 2012-06-29 Harald Oehlmann - * library/msgcat/msgcat.tcl: [Bug 3536888] Locale guessing of msgcat - * library/msgcat/pkgIndex.tcl: fails on (some) Windows 7. Bump to 1.4.5 - * unix/Makefile.in - * win/Makefile.in + * library/msgcat/msgcat.tcl: [Bug 3536888]: Locale guessing of + * library/msgcat/pkgIndex.tcl: msgcat fails on (some) Windows 7. Bump + * unix/Makefile.in: to 1.4.5 + * win/Makefile.in: 2012-06-29 Donal K. Fellows @@ -147,7 +148,7 @@ 2012-06-25 Don Porter - * generic/tclFileSystem.h: [Bug 3024359] Make sure that the + * generic/tclFileSystem.h: [Bug 3024359]: Make sure that the * generic/tclIOUtil.c: per-thread cache of the list of file systems * generic/tclPathObj.c: currently registered is only updated at times when no active loops are traversing it. Also reduce the amount of @@ -176,10 +177,10 @@ 2012-06-11 Don Porter - * generic/tclBasic.c: [Bug 3532959] Make sure the lifetime management - * generic/tclProc.c: of entries in the linePBodyPtr hash table can - * tests/proc.test: tolerate either order of teardown, interp first, - or Proc first. + * generic/tclBasic.c: [Bug 3532959]: Make sure the lifetime + * generic/tclProc.c: management of entries in the linePBodyPtr + * tests/proc.test: hash table can tolerate either order of + teardown, interp first, or Proc first. 2012-06-08 Don Porter @@ -187,7 +188,7 @@ * unix/tclUnixPort.h: Thanks Joe English. * unix/configure: autoconf 2.13 - * unix/tclUnixPort.h: [Bug 3530533] Centralize #include + * unix/tclUnixPort.h: [Bug 3530533]: Centralize #include * unix/tclUnixThrd.c: in the tclUnixPort.h header so that old unix systems that need inclusion in all compilation units are supported. @@ -214,7 +215,7 @@ 2012-05-25 Jan Nijtmans - * win/tclWinDde.c: [Bug 473946] special characters not correctly + * win/tclWinDde.c: [Bug 473946]: special characters not correctly * win/Makefile.in: sent, now for XTYP_EXECUTE as well as XTYP_REQUEST. Fix "make genstubs" when cross-compiling on UNIX @@ -271,7 +272,7 @@ 2012-05-10 Jan Nijtmans - * win/tclWinDde.c: [Bug 473946] special characters not + * win/tclWinDde.c: [Bug 473946]: Special characters not * library/dde/pkgIndex.tcl: correctly sent. Bump to 1.3.3 2012-05-02 Jan Nijtmans @@ -305,10 +306,10 @@ 2012-04-24 Jan Nijtmans - * generic/tclInt.decls: [Bug 3508771] load tclreg.dll in cygwin - * generic/tclIntPlatDecls.h: tclsh Implement TclWinGetSockOpt, - * generic/tclStubInit.c: TclWinGetServByName and TclWinCPUID - * generic/tclUnixCompat.c: for Cygwin. + * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in + * generic/tclIntPlatDecls.h: cygwin tclsh. Implement + * generic/tclStubInit.c: TclWinGetSockOpt, TclWinGetServByName + * generic/tclUnixCompat.c: and TclWinCPUID for Cygwin. * unix/configure.in: * unix/configure: * unix/tclUnixCompat.c: @@ -330,7 +331,7 @@ 2012-04-11 Jan Nijtmans - * win/tclWinInit.c: [Bug 3448512] [clock scan 1958-01-01] fails + * win/tclWinInit.c: [Bug 3448512]: [clock scan 1958-01-01] fails * win/tcl.m4: in debug compilation. * win/configure: * unix/tcl.m4: Use NDEBUG consistantly meaning: no debugging. @@ -338,7 +339,7 @@ 2012-04-04 Jan Nijtmans - * win/tclWinSock.c: [Bug 510001] TclSockMinimumBuffers needs + * win/tclWinSock.c: [Bug 510001]: TclSockMinimumBuffers needs * generic/tclIOSock.c: platform implementation. * generic/tclInt.decls: * generic/tclIntDecls.h: @@ -353,15 +354,16 @@ 2012-03-30 Jan Nijtmans - * generic/tclInt.decls: [Bug 3508771] load tclreg.dll in cygwin - * generic/tclIntPlatDecls.h: tclsh. Implement TclWinGetTclInstance, - * generic/tclStubInit.c: TclpGetTZName, and various more - win32-specific internal functions for Cygwin, so win32 extensions - using those can be loaded in the cygwin version of tclsh. + * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in + * generic/tclIntPlatDecls.h: cygwin tclsh. Implement + * generic/tclStubInit.c: TclWinGetTclInstance, TclpGetTZName, + and various more win32-specific internal functions for Cygwin, so + win32 extensions using those can be loaded in the cygwin version of + tclsh. 2012-03-30 Jan Nijtmans - * unix/tcl.m4: [Bug 3511806] Compiler checks too early + * unix/tcl.m4: [Bug 3511806]: Compiler checks too early * unix/configure.in: This change allows to build the cygwin * unix/tclUnixPort.h: and mingw32 ports of Tcl/Tk to build * win/tcl.m4: out-of-the-box using a native or cross- @@ -370,19 +372,20 @@ 2012-03-27 Jan Nijtmans - * generic/tcl.h: [Bug 3508771] Wrong Tcl_StatBuf used on MinGW - * generic/tclFCmd.c: [Bug 2015723] duplicate inodes from file stat + * generic/tcl.h: [Bug 3508771]: Wrong Tcl_StatBuf used on MinGW + * generic/tclFCmd.c: [Bug 2015723]: duplicate inodes from file stat on windows (but now for cygwin as well) 2012-03-25 Jan Nijtmans - * generic/tclInt.decls: [Bug 3508771] load tclreg.dll in cygwin - * generic/tclIntPlatDecls.h: tclsh. Implement TclWinConvertError, - * generic/tclStubInit.c: TclWinConvertWSAError, and various more - * unix/Makefile.in: win32-specific internal functions for - * unix/tcl.m4: Cygwin, so win32 extensions using those - * unix/configure: can be loaded in the cygwin version - * win/tclWinError.c: of tclsh. + * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in + * generic/tclIntPlatDecls.h: cygwin tclsh. Implement + * generic/tclStubInit.c: TclWinConvertError, + * unix/Makefile.in: TclWinConvertWSAError, and various + * unix/tcl.m4: more win32-specific internal functions + * unix/configure: for Cygwin, so win32 extensions using + * win/tclWinError.c: those can be loaded in the cygwin + version of tclsh. 2012-03-23 Jan Nijtmans @@ -398,12 +401,13 @@ 2012-03-20 Jan Nijtmans - * generic/tcl.decls: [Bug 3508771] load tclreg.dll in cygwin - * generic/tclInt.decls: tclsh. Implement TclWinGetPlatformId, - * generic/tclIntPlatDecls.h: Tcl_WinUtfToTChar, Tcl_WinTCharToUtf - * generic/tclPlatDecls.h: (and a dummy TclWinCPUID) for Cygwin, - * generic/tclStubInit.c: so win32 extensions using those can be - * unix/tclUnixCompat.c: loaded in the cygwin version of tclsh. + * generic/tcl.decls: [Bug 3508771]: load tclreg.dll in + * generic/tclInt.decls: cygwin tclsh. Implement + * generic/tclIntPlatDecls.h: TclWinGetPlatformId,Tcl_WinUtfToTChar, + * generic/tclPlatDecls.h: Tcl_WinTCharToUtf (and a dummy + * generic/tclStubInit.c: TclWinCPUID) for Cygwin, so win32 + * unix/tclUnixCompat.c: extensions using those can be loaded + in the cygwin version of tclsh. 2012-03-19 Venkat Iyer @@ -437,7 +441,7 @@ 2012-03-15 Jan Nijtmans - * generic/tcl.h: [Bug 3288345] Wrong Tcl_StatBuf used on Cygwin + * generic/tcl.h: [Bug 3288345]: Wrong Tcl_StatBuf used on Cygwin * unix/tclUnixFile.c * unix/tclUnixPort.h * win/cat.c: Remove cygwin stuff no longer needed @@ -446,7 +450,7 @@ 2012-03-12 Jan Nijtmans - * win/tclWinFile.c: [Bug 3388350] mingw64 compiler warnings + * win/tclWinFile.c: [Bug 3388350]: mingw64 compiler warnings 2012-03-07 Andreas Kupries @@ -468,7 +472,7 @@ 2012-02-29 Jan Nijtmans - * generic/tclIOUtil.c: [Bug 3466099] BOM in Unicode + * generic/tclIOUtil.c: [Bug 3466099]: BOM in Unicode * generic/tclEncoding.c: * tests/source.test @@ -603,7 +607,7 @@ 2011-12-23 Jan Nijtmans - * generic/tclUtf.c: [Bug 3464428] string is graph \u0120 is wrong + * generic/tclUtf.c: [Bug 3464428]: string is graph \u0120 is wrong * generic/tclUniData.c: * generic/regc_locale.c: * tests/utf.test: @@ -617,7 +621,7 @@ 2011-12-07 Jan Nijtmans - * tools/uniParse.tcl: [Bug 3444754] string tolower \u01c5 is wrong + * tools/uniParse.tcl: [Bug 3444754]: string tolower \u01c5 is wrong * generic/tclUniData.c: * tests/utf.test: @@ -636,7 +640,7 @@ 2011-11-22 Jan Nijtmans - * win/tclWinPort.h: [Bug 3354324] Windows: file mtime + * win/tclWinPort.h: [Bug 3354324]: Windows: file mtime * win/tclWinFile.c: sets wrong time (VS2005+ only) * generic/tclTest.c: @@ -680,15 +684,15 @@ 2011-10-11 Jan Nijtmans - * win/tclWinFile.c: [Bug 2935503] Incorrect mode field + * win/tclWinFile.c: [Bug 2935503]: Incorrect mode field returned by file stat command 2011-10-07 Jan Nijtmans - * generic/tclIORChan.c: Fix gcc warning - (discovered with latest mingw, based on gcc 4.6.1) - * tests/env.test: Fix env.test, when running - under wine 1.3 (partly backported from Tcl 8.6) + * generic/tclIORChan.c: Fix gcc warning (discovered with latest + mingw, based on gcc 4.6.1) + * tests/env.test: Fix env.test running under wine 1.3 (partly + backported from Tcl 8.6) 2011-10-03 Venkat Iyer @@ -723,20 +727,20 @@ 2011-09-13 Don Porter - * generic/tclUtil.c: [Bug 3390638] Workaround broken solaris + * generic/tclUtil.c: [Bug 3390638]: Workaround broken solaris studio cc optimizer. Thanks to Wolfgang S. Kechel. - * generic/tclDTrace.d: [Bug 3405652] Portability workaround for + * generic/tclDTrace.d: [Bug 3405652]: Portability workaround for broken system DTrace support. Thanks to Dagobert Michelson. 2011-09-12 Jan Nijtmans - * win/tclWinPort.h: [Bug 3407070] tclPosixStr.c won't build with + * win/tclWinPort.h: [Bug 3407070]: tclPosixStr.c won't build with EOVERFLOW==E2BIG 2011-09-07 Don Porter - * generic/tclCompExpr.c: [Bug 3401704] Allow function names like + * generic/tclCompExpr.c: [Bug 3401704]: Allow function names like * tests/parseExpr.test: influence(), nanobot(), and 99bottles() that have been parsed as missing operator syntax errors before with the form NUMBER + FUNCTION. @@ -755,7 +759,7 @@ 2011-09-01 Don Porter - * generic/tclStrToD.c: [Bug 3402540] Corrections to TclParseNumber() + * generic/tclStrToD.c: [Bug 3402540]: Corrections to TclParseNumber() * tests/binary.test: to make it reject invalid Nan(Hex) strings. * tests/scan.test: [scan Inf %g] is portable; remove constraint. @@ -933,7 +937,8 @@ 2011-06-13 Don Porter - * generic/tclStrToD.c: [Bug 3315098] Mem leak fix from Gustaf Neumann. + * generic/tclStrToD.c: [Bug 3315098]: Mem leak fix from Gustaf + Neumann. 2011-06-02 Don Porter -- cgit v0.12 From e7975ff335f51d429c79b128209d33f7808f3782 Mon Sep 17 00:00:00 2001 From: andreask Date: Mon, 27 Aug 2012 17:12:06 +0000 Subject: Followup to [6325d5dbeac6f91d28d6]. dlerror() may return NULL. Fixed the code which wasn't prepared to deal with that. --- unix/tclLoadDl.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index f8fe6d3..a48aa23 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -176,8 +176,14 @@ FindSymbol( } Tcl_DStringFree(&ds); if (proc == NULL && interp != NULL) { + const char *errorStr = dlerror(); + + if (!errorStr) { + errorStr = "unknown"; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "cannot find symbol \"%s\": %s", symbol, dlerror())); + "cannot find symbol \"%s\": %s", symbol, errorStr)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } -- cgit v0.12 From 43f16074cb838b5bb19f3504fc9e6c66458fbdf9 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 27 Aug 2012 17:24:55 +0000 Subject: Commit of Harald Oehlmann's TIP 404 patch without TIP 399 pieces and with some added documentation. No tests for new functionality yet. --- doc/msgcat.n | 28 +++++++++++++++- library/msgcat/msgcat.tcl | 78 +++++++++++++++++++++++++++++++++++++++++++-- library/msgcat/pkgIndex.tcl | 2 +- 3 files changed, 103 insertions(+), 5 deletions(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index 595c85f..d65563a 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -13,7 +13,7 @@ msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.5\fR .sp -\fBpackage require msgcat 1.4.5\fR +\fBpackage require msgcat 1.5.0\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp @@ -29,6 +29,12 @@ msgcat \- Tcl message catalog .sp \fB::msgcat::mcmset \fIlocale src-trans-list\fR .sp +.VS "TIP 404" +\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +.sp +\fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VE "TIP 404" +.sp \fB::msgcat::mcunknown \fIlocale src-string\fR .BE .SH DESCRIPTION @@ -131,6 +137,26 @@ translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly faster than multiple invocations of \fB::msgcat::mcset\fR. The function returns the number of translations set. .TP +\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +.VS "TIP 404" +Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the the +current namespace for the locale implied by the name of the message catalog +being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not +specified, \fIsrc-string\fR is used for both. The function returns +\fItranslate-string\fR. +.VE "TIP 404" +.TP +\fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VS "TIP 404" +Sets the translation for multiple source strings in \fIsrc-trans-list\fR in +the current namespace for the locale implied by the name of the message +catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must +have an even number of elements and is in the form {\fIsrc-string +translate-string\fR ?\fIsrc-string translate-string ...\fR?} +\fB::msgcat::mcmset\fR can be significantly faster than multiple invocations +of \fB::msgcat::mcset\fR. The function returns the number of translations set. +.VE "TIP 404" +.TP \fB::msgcat::mcunknown \fIlocale src-string\fR . This routine is called by \fB::msgcat::mc\fR in the case when diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 3377b47..6dd44d2 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -13,11 +13,11 @@ package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.4.5 +package provide msgcat 1.5.0 namespace eval msgcat { namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ - mcunknown + mcunknown mcflset mcflmset # Records the current locale as passed to mclocale variable Locale "" @@ -25,6 +25,12 @@ namespace eval msgcat { # Records the list of locales to search variable Loclist {} + # Records the locale of the currently sourced message catalogue file; this + # would be problematic if anyone were to recursively load a message + # catalog for a different locale from inside a catalog, but that's not a + # case that we really need to worry about. + variable FileLocale + # Records the mapping between source strings and translated strings. The # dict key is of the form " ", where locale and # namespace should be themselves dict values and the value is @@ -277,6 +283,7 @@ proc msgcat::mcpreferences {} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { + variable FileLocale set x 0 foreach p [mcpreferences] { if { $p eq {} } { @@ -285,7 +292,12 @@ proc msgcat::mcload {langdir} { set langfile [file join $langdir $p.msg] if {[file exists $langfile]} { incr x + set FileLocale [string tolower [file tail [file rootname $langfile]]] + if {"root" eq $FileLocale} { + set FileLocale "" + } uplevel 1 [list ::source -encoding utf-8 $langfile] + unset FileLocale } } return $x @@ -318,6 +330,35 @@ proc msgcat::mcset {locale src {dest ""}} { return $dest } +# msgcat::mcflset -- +# +# Set the translation for a given string in the current file locale. +# +# Arguments: +# src The source string. +# dest (Optional) The translated string. If omitted, +# the source string is used. +# +# Results: +# Returns the new locale. + +proc msgcat::mcflset {src {dest ""}} { + variable FileLocale + variable Msgs + + if {![info exists FileLocale]} { + return -code error \ + "must only be used inside a message catalog loaded with ::msgcat::mcload" + } + if {[llength [info level 0]] == 2} { ;# dest not specified + set dest $src + } + + set ns [uplevel 1 [list ::namespace current]] + dict set Msgs $FileLocale $ns $src $dest + return $dest +} + # msgcat::mcmset -- # # Set the translation for multiple strings in a specified locale. @@ -345,7 +386,38 @@ proc msgcat::mcmset {locale pairs } { dict set Msgs $locale $ns $src $dest } - return $length + return [expr {$length / 2}] +} + +# msgcat::mcflmset -- +# +# Set the translation for multiple strings in the mc file locale. +# +# Arguments: +# pairs One or more src/dest pairs (must be even length) +# +# Results: +# Returns the number of pairs processed + +proc msgcat::mcflmset {pairs} { + variable FileLocale + variable Msgs + + if {![info exists FileLocale]} { + return -code error \ + "must only be used inside a message catalog loaded with ::msgcat::mcload" + } + set length [llength $pairs] + if {$length % 2} { + return -code error "bad translation list:\ + should be \"[lindex [info level 0] 0] locale {src dest ...}\"" + } + + set ns [uplevel 1 [list ::namespace current]] + foreach {src dest} $pairs { + dict set Msgs $FileLocale $ns $src $dest + } + return [expr {$length / 2}] } # msgcat::mcunknown -- diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 60c2d3c..832bf81 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded msgcat 1.4.5 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.5.0 [list source [file join $dir msgcat.tcl]] -- cgit v0.12 From cf8f67a2316359b6e0e563c51d2d6cda34f9cec6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Aug 2012 18:46:27 +0000 Subject: Update changes for 8.6b3 --- changes | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/changes b/changes index 1430f8c..a69a544 100644 --- a/changes +++ b/changes @@ -8023,8 +8023,6 @@ like "nano()" instead of parsing as "nan o()" with missing op (duquette,porter) 2012-02-02 (bug fix)[2974459,2879351,1951574,1852572,1661378,1613456] Fix problems where [file *able] would return false results on Win/Samba (porter) -2012-02-02 (update)[3464401] Support Unicode 6.1 (nijtmans) - 2012-02-06 (bug fix)[3484621] bump bytecode epoch on exec traces (kuhn,sofer) 2012-02-15 (bug fix)[3487626] crash compiling [dict for] (fellows) @@ -8105,6 +8103,14 @@ and Tcl_FSMountsChanged(). (porter) 2012-07-25 (bug fix)[3546275] [auto_execok] search match [exec] (danckaert) +2012-07-27 (update)[3464401] Support Unicode 6.2 (nijtmans) + +2012-08-20 (bug fix)[3559678] [file normalize] EIAS failure (phao,dgp) + +2012-08-25 (bug fix)[3561330] Ukranian translation of "March" (teterin) + Many revisions to better support a Cygwin environment (nijtmans) +Dropped support for OS X versions less than 10.4 (Tiger) (fellows) + --- Released 8.6b3, July 30, 2012 --- See ChangeLog for details --- -- cgit v0.12 From 4c8d436cd9e92ed6a304fed697f233ecb7996635 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Aug 2012 18:49:11 +0000 Subject: ...and the date too. --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index a69a544..06b2db1 100644 --- a/changes +++ b/changes @@ -8113,4 +8113,4 @@ Many revisions to better support a Cygwin environment (nijtmans) Dropped support for OS X versions less than 10.4 (Tiger) (fellows) ---- Released 8.6b3, July 30, 2012 --- See ChangeLog for details --- +--- Released 8.6b3, September 7, 2012 --- See ChangeLog for details --- -- cgit v0.12 From 96b1a87503f1da17ec4626ba78ef7a04030e98ce Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Sep 2012 09:37:10 +0000 Subject: Minor clarification of description; all traces use a command prefix for their callbacks. --- doc/trace.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/trace.n b/doc/trace.n index 9d40123..c928856 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -138,7 +138,7 @@ error will occur. .PP For \fBleave\fR and \fBleavestep\fR operations: .CS -\fIcommand command-string code result op\fR +\fIcommandPrefix command-string code result op\fR .CE \fICommand-string\fR gives the complete current command being executed (the traced command for a \fBenter\fR operation, an -- cgit v0.12 From 41d7976a599beb50796eb6a1316080825fb79047 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Sep 2012 19:01:32 +0000 Subject: 3564735 Protection against namespace var resolvers that unexpectedly return a pointer to Var while Tcl expects pointer to VarInHash. This may not be the total solution to Bug 3564735 (Itcl may be misbehaving), but this will prevent memory corruption. --- generic/tclInt.h | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index e1ce6d5..cca9938 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -693,13 +693,17 @@ typedef struct VarInHash { #define TclSetVarNamespaceVar(varPtr) \ if (!TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags |= VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount++;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount++;\ + }\ } #define TclClearVarNamespaceVar(varPtr) \ if (TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount--;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount--;\ + }\ } /* -- cgit v0.12 From edd591e8fbb5a6def7fbe9ca0d8e3f22c0e9cd56 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Fri, 7 Sep 2012 14:44:46 +0000 Subject: Backport of 2008-12-12 8.6 commit: Fix missing CLOEXEC on internal pipes [2417695] --- ChangeLog | 5 +++++ unix/tclUnixNotfy.c | 6 ++++++ win/buildall.vc.bat | 0 3 files changed, 11 insertions(+) mode change 100644 => 100755 win/buildall.vc.bat diff --git a/ChangeLog b/ChangeLog index 18cdf37..b0fed83 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-09-07 Alexandre Ferrieux + + * unix/tclUnixNotfy.c Backport of 2008-12-12 8.6 commit: Fix + missing CLOEXEC on internal pipes [2417695] + 2012-08-25 Donal K. Fellows * library/msgs/uk.msg: [Bug 3561330]: Use the correct full name of diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index 42cc7be..51f0b1f 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -1057,6 +1057,12 @@ NotifierThreadProc( if (TclUnixSetBlockingMode(fds[1], TCL_MODE_NONBLOCKING) < 0) { Tcl_Panic("NotifierThreadProc: could not make trigger pipe non blocking"); } + if (fcntl(receivePipe, F_SETFD, FD_CLOEXEC) < 0) { + Tcl_Panic("NotifierThreadProc: could not make receive pipe close-on-exec"); + } + if (fcntl(fds[1], F_SETFD, FD_CLOEXEC) < 0) { + Tcl_Panic("NotifierThreadProc: could not make trigger pipe close-on-exec"); + } /* * Install the write end of the pipe into the global variable. diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat old mode 100644 new mode 100755 -- cgit v0.12 From ec48c37cfcfbbd45233696741ce5c7b44b8e43bf Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 7 Sep 2012 15:32:15 +0000 Subject: Reentrant mcfl(m)set command, test, document mcflset as recommended for message files --- doc/msgcat.n | 12 ++++++------ library/msgcat/msgcat.tcl | 12 ++++++++---- tests/msgcat.test | 44 ++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 56 insertions(+), 12 deletions(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index d65563a..af6be7f 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -139,7 +139,7 @@ returns the number of translations set. .TP \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? .VS "TIP 404" -Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the the +Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the current namespace for the locale implied by the name of the message catalog being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not specified, \fIsrc-string\fR is used for both. The function returns @@ -153,8 +153,8 @@ the current namespace for the locale implied by the name of the message catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must have an even number of elements and is in the form {\fIsrc-string translate-string\fR ?\fIsrc-string translate-string ...\fR?} -\fB::msgcat::mcmset\fR can be significantly faster than multiple invocations -of \fB::msgcat::mcset\fR. The function returns the number of translations set. +\fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations +of \fB::msgcat::mcflset\fR. The function returns the number of translations set. .VE "TIP 404" .TP \fB::msgcat::mcunknown \fIlocale src-string\fR @@ -312,15 +312,15 @@ cause peculiar behavior, such as marking the message file as .QW hidden on Unix file systems. .IP [3] -The file contains a series of calls to \fBmcset\fR and -\fBmcmset\fR, setting the necessary translation strings +The file contains a series of calls to \fBmcflset\fR and +\fBmcflmset\fR, setting the necessary translation strings for the language, likely enclosed in a \fBnamespace eval\fR so that all source strings are tied to the namespace of the package. For example, a short \fBes.msg\fR might contain: .PP .CS namespace eval ::mypackage { - \fB::msgcat::mcset\fR es "Free Beer!" "Cerveza Gracias!" + \fB::msgcat::mcflset\fR "Free Beer!" "Cerveza Gracias!" } .CE .SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES" diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 6dd44d2..112507a 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -25,10 +25,7 @@ namespace eval msgcat { # Records the list of locales to search variable Loclist {} - # Records the locale of the currently sourced message catalogue file; this - # would be problematic if anyone were to recursively load a message - # catalog for a different locale from inside a catalog, but that's not a - # case that we really need to worry about. + # Records the locale of the currently sourced message catalogue file variable FileLocale # Records the mapping between source strings and translated strings. The @@ -284,6 +281,10 @@ proc msgcat::mcpreferences {} { proc msgcat::mcload {langdir} { variable FileLocale + # Save the file locale if we are recursively called + if {[info exists FileLocale]} { + set nestedFileLocale $FileLocale + } set x 0 foreach p [mcpreferences] { if { $p eq {} } { @@ -300,6 +301,9 @@ proc msgcat::mcload {langdir} { unset FileLocale } } + if {[info exists nestedFileLocale]} { + set FileLocale $nestedFileLocale + } return $x } diff --git a/tests/msgcat.test b/tests/msgcat.test index bbcd023..d75bf8e 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -17,8 +17,8 @@ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } -if {[catch {package require msgcat 1.4.5}]} { - puts stderr "Skipping tests in [info script]. No msgcat 1.4.5 found to test." +if {[catch {package require msgcat 1.5.0}]} { + puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test." return } @@ -611,6 +611,46 @@ namespace eval ::msgcat::test { mc "this is a %s" "good test" } -result "this is a good test" + # Tests msgcat-8.*: [mcflset] + + set msgdir1 [makeDirectory msgdir1] + makeFile {::msgcat::mcflset k1 v1} l1.msg $msgdir1 + + test msgcat-8.1 {mcflset} -setup { + variable locale [mclocale] + mclocale l1 + mcload $msgdir1 + } -cleanup { + mclocale $locale + } -body { + mc k1 + } -result v1 + + removeFile l1.msg $msgdir1 + removeDirectory msgdir1 + + set msgdir2 [makeDirectory msgdir2] + set msgdir3 [makeDirectory msgdir3] + makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\ + l2.msg $msgdir2 + makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3 + + # chained mcload + test msgcat-8.2 {mcflset} -setup { + variable locale [mclocale] + mclocale l2 + mcload $msgdir2 + } -cleanup { + mclocale $locale + } -body { + return [mc k2][mc k3] + } -result v2v3 + + removeFile l2.msg $msgdir2 + removeDirectory msgdir2 + removeFile l3.msg $msgdir3 + removeDirectory msgdir3 + cleanupTests } namespace delete ::msgcat::test -- cgit v0.12 From 260678675728634c7eea51913b9227aaf67892df Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 7 Sep 2012 17:22:53 +0000 Subject: ChangeLog entry added --- ChangeLog | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 68f2441..036cd21 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-09-07 Harald Oehlmann + + IMPLEMENTATION OF TIP#404. + + * library/msgcat.tcl: [FRQ 3544988]: add commands + [mcflset] and [mcflmset] to set mc entries with implicit message file + locale. Package version is now 1.5.0. + 2012-08-25 Donal K. Fellows * library/msgs/uk.msg: [Bug 3561330]: Use the correct full name of @@ -186,7 +194,7 @@ * library/msgcat/msgcat.tcl: Add tn, ro_MO and ru_MO to msgcat. -2012-06-29 Harald Oehlmann +2012-06-29 Harald Oehlmann * library/msgcat/msgcat.tcl: [Bug 3536888]: Locale guessing of * library/msgcat/pkgIndex.tcl: msgcat fails on (some) Windows 7. Bump -- cgit v0.12 From aafb8f260959dba7316e70f8dfd6afcd1a9248d0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Sep 2012 21:01:14 +0000 Subject: removed leftover from failed attempt to unify stub tables. --- generic/tclStubInit.c | 8 -------- 1 file changed, 8 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0fc35d5..a8d74ee 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -169,14 +169,6 @@ Tcl_WinTCharToUtf( string, len, dsPtr); } -#define TclMacOSXGetFileAttribute (int (*) (Tcl_Interp *, \ - int, Tcl_Obj *, Tcl_Obj **)) TclpCreateProcess -#define TclMacOSXMatchType (int (*) (Tcl_Interp *, const char *, \ - const char *, Tcl_StatBuf *, Tcl_GlobTypeData *)) TclpMakeFile -#define TclMacOSXNotifierAddRunLoopMode (void (*) (const void *)) TclpOpenFile -#define TclpLocaltime_unix (struct tm *(*) (const time_t *)) TclGetAndDetachPids -#define TclpGmtime_unix (struct tm *(*) (const time_t *)) TclpCloseFile - #else /* UNIX and MAC */ # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime -- cgit v0.12 From d925e8a8f0a6b7903e5183742422097f0789d210 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Sep 2012 21:58:56 +0000 Subject: Experiment: MSVC build now links with 64-bit zlib1.dll --- compat/zlib/win32/zdll.lib | Bin 13438 -> 15256 bytes compat/zlib/win64/zdll.lib | Bin 45650 -> 14896 bytes win/configure | 9 --------- win/configure.in | 4 ---- 4 files changed, 13 deletions(-) diff --git a/compat/zlib/win32/zdll.lib b/compat/zlib/win32/zdll.lib index 4e53491..669b186 100644 Binary files a/compat/zlib/win32/zdll.lib and b/compat/zlib/win32/zdll.lib differ diff --git a/compat/zlib/win64/zdll.lib b/compat/zlib/win64/zdll.lib index 084dbff..d7dfb09 100644 Binary files a/compat/zlib/win64/zdll.lib and b/compat/zlib/win64/zdll.lib differ diff --git a/win/configure b/win/configure index 5cf1513..3e08d5d 100755 --- a/win/configure +++ b/win/configure @@ -4344,12 +4344,6 @@ esac # as we just assume that the platform hasn't got a usable z.lib #------------------------------------------------------------------------ -if test "$do64bit" = "yes" && test "$GCC" != "yes"; then - - tcl_ok=no - -else - if test "${enable_shared+set}" = "set"; then enableval="$enable_shared" @@ -4361,9 +4355,6 @@ else fi - -fi - if test "$tcl_ok" = "yes"; then ZLIB_DLL_FILE=\${ZLIB_DLL_FILE} diff --git a/win/configure.in b/win/configure.in index de56bf7..cd6088e 100644 --- a/win/configure.in +++ b/win/configure.in @@ -120,16 +120,12 @@ esac # as we just assume that the platform hasn't got a usable z.lib #------------------------------------------------------------------------ -AS_IF([test "$do64bit" = "yes" && test "$GCC" != "yes"], [ - tcl_ok=no -], [ AS_IF([test "${enable_shared+set}" = "set"], [ enableval="$enable_shared" tcl_ok=$enableval ], [ tcl_ok=yes ]) -]) AS_IF([test "$tcl_ok" = "yes"], [ AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) AS_IF([test "$do64bit" = "yes"], [ -- cgit v0.12 From df2aa14a4b12e5a43e8e757268e95e153cc31fdb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Sep 2012 13:24:22 +0000 Subject: fix running package-tests on Windows, correct TCLSH_PROG in this case --- win/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/Makefile.in b/win/Makefile.in index 392bd7a..4dbdbbd 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -786,7 +786,7 @@ test-packages: tcltest packages pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ echo "Testing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) "LD_LIBRARY_PATH=$$builddir:${LD_LIBRARY_PATH}" "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" "TCLLIBPATH=$$builddir/pkgs" test "TCLSH_PROG=$$builddir/tcltest"; ) \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) "LD_LIBRARY_PATH=$$builddir:${LD_LIBRARY_PATH}" "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" "TCLLIBPATH=$$builddir/pkgs" test "TCLSH_PROG=$$builddir/${TCLSH}"; ) \ fi; \ fi; \ done; \ -- cgit v0.12 From 3110959c6f9095d249c2991f9f41fb27fa900c1a Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Sep 2012 14:07:27 +0000 Subject: 3564735 Protect against mem corruption when var resolvers misbehave. --- generic/tclInt.h | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 53a88d6..6c6e664 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -801,13 +801,17 @@ typedef struct VarInHash { #define TclSetVarNamespaceVar(varPtr) \ if (!TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags |= VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount++;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount++;\ + }\ } #define TclClearVarNamespaceVar(varPtr) \ if (TclIsVarNamespaceVar(varPtr)) {\ (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\ - ((VarInHash *)(varPtr))->refCount--;\ + if (TclIsVarInHash(varPtr)) {\ + ((VarInHash *)(varPtr))->refCount--;\ + }\ } /* -- cgit v0.12 From 4dbba767c34ef9df1449908d3b71e130ebf74dc5 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 12 Sep 2012 17:42:59 +0000 Subject: tip#404 file locale mcset: mc(fl)(m)set backport from 8.6 --- ChangeLog | 8 ++++ doc/msgcat.n | 91 ++++++++++++++++++++++++++++++++++++--------- library/msgcat/msgcat.tcl | 82 ++++++++++++++++++++++++++++++++++++++-- library/msgcat/pkgIndex.tcl | 2 +- tests/msgcat.test | 44 +++++++++++++++++++++- 5 files changed, 203 insertions(+), 24 deletions(-) diff --git a/ChangeLog b/ChangeLog index b0fed83..4d2d296 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-09-07 Harald Oehlmann + + IMPLEMENTATION OF TIP#404. + + * library/msgcat.tcl: [FRQ 3544988] (Backport from tcl8.6): add commands + [mcflset] and [mcflmset] to set mc entries with implicit message file + locale. Package version is now 1.5.0. + 2012-09-07 Alexandre Ferrieux * unix/tclUnixNotfy.c Backport of 2008-12-12 8.6 commit: Fix diff --git a/doc/msgcat.n b/doc/msgcat.n index c2c0abd..af6be7f 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -13,7 +13,7 @@ msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.5\fR .sp -\fBpackage require msgcat 1.4.5\fR +\fBpackage require msgcat 1.5.0\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp @@ -29,6 +29,12 @@ msgcat \- Tcl message catalog .sp \fB::msgcat::mcmset \fIlocale src-trans-list\fR .sp +.VS "TIP 404" +\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +.sp +\fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VE "TIP 404" +.sp \fB::msgcat::mcunknown \fIlocale src-string\fR .BE .SH DESCRIPTION @@ -49,6 +55,7 @@ wishes to be enabled for multi-lingual applications. .SH COMMANDS .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? +. Returns a translation of \fIsrc-string\fR according to the user's current locale. If additional arguments past \fIsrc-string\fR are given, the \fBformat\fR command is used to substitute the @@ -71,12 +78,14 @@ later simply by defining new message catalog entries. .RE .TP \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? +. Given several source strings, \fB::msgcat::mcmax\fR returns the length of the longest translated string. This is useful when designing localized GUIs, which may require that all buttons, for example, be a fixed width (which will be the width of the widest button). .TP -\fB::msgcat::mclocale \fR?\fInewLocale\fR? +\fB::msgcat::mclocale \fR?\fInewLocale\fR? +. This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale is set to \fInewLocale\fR. msgcat stores and compares the locale in a @@ -86,6 +95,7 @@ the user's environment. See \fBLOCALE SPECIFICATION\fR below for a description of the locale string format. .TP \fB::msgcat::mcpreferences\fR +. Returns an ordered list of the locales preferred by the user, based on the user's language specification. The list is ordered from most specific to least @@ -93,11 +103,10 @@ preference. The list is derived from the current locale set in msgcat by \fB::msgcat::mclocale\fR, and cannot be set independently. For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR -.VS 1.4 returns \fB{en_US_funky en_US en {}}\fR. -.VE 1.4 .TP \fB::msgcat::mcload \fIdirname\fR +. Searches the specified directory for files that match the language specifications returned by \fB::msgcat::mcpreferences\fR (note that these are all lowercase), extended by the file extension @@ -111,12 +120,14 @@ evaluation. The number of message files which matched the specification and were loaded is returned. .TP \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? +. Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the specified \fIlocale\fR and the current namespace. If \fItranslate-string\fR is not specified, \fIsrc-string\fR is used for both. The function returns \fItranslate-string\fR. .TP \fB::msgcat::mcmset \fIlocale src-trans-list\fR +. Sets the translation for multiple source strings in \fIsrc-trans-list\fR in the specified \fIlocale\fR and the current namespace. @@ -126,7 +137,28 @@ translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly faster than multiple invocations of \fB::msgcat::mcset\fR. The function returns the number of translations set. .TP +\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +.VS "TIP 404" +Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the +current namespace for the locale implied by the name of the message catalog +being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not +specified, \fIsrc-string\fR is used for both. The function returns +\fItranslate-string\fR. +.VE "TIP 404" +.TP +\fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VS "TIP 404" +Sets the translation for multiple source strings in \fIsrc-trans-list\fR in +the current namespace for the locale implied by the name of the message +catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must +have an even number of elements and is in the form {\fIsrc-string +translate-string\fR ?\fIsrc-string translate-string ...\fR?} +\fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations +of \fB::msgcat::mcflset\fR. The function returns the number of translations set. +.VE "TIP 404" +.TP \fB::msgcat::mcunknown \fIlocale src-string\fR +. This routine is called by \fB::msgcat::mc\fR in the case when a translation for \fIsrc-string\fR is not defined in the current locale. The default action is to return @@ -157,14 +189,18 @@ according to the user's environment. The variables \fBenv(LC_ALL)\fR, \fBenv(LC_MESSAGES)\fR, and \fBenv(LANG)\fR are examined in order. The first of them to have a non-empty value is used to determine the initial locale. The value is parsed according to the XPG4 pattern +.PP .CS language[_country][.codeset][@modifier] .CE +.PP to extract its parts. The initial locale is then set by calling \fB::msgcat::mclocale\fR with the argument +.PP .CS language[_country][_modifier] .CE +.PP On Windows and Cygwin, if none of those environment variables is set, msgcat will attempt to extract locale information from the registry. From Windows Vista on, the RFC4747 locale name "lang-script-country-options" @@ -179,7 +215,6 @@ When a locale is specified by the user, a .QW "best match" search is performed during string translation. For example, if a user specifies -.VS 1.4 en_GB_Funky, the locales .QW en_GB_Funky , .QW en_GB , @@ -187,7 +222,6 @@ en_GB_Funky, the locales and .MT (the empty string) -.VE 1.4 are searched in order until a matching translation string is found. If no translation string is available, then \fB::msgcat::mcunknown\fR is called. @@ -201,15 +235,18 @@ source string to be shorter and less prone to typographical error. .PP For example, executing the code +.PP .CS \fB::msgcat::mcset\fR en hello "hello from ::" namespace eval foo { - \fB::msgcat::mcset\fR en hello "hello from ::foo" + \fB::msgcat::mcset\fR en hello "hello from ::foo" } puts [\fB::msgcat::mc\fR hello] namespace eval foo {puts [\fB::msgcat::mc\fR hello]} .CE +.PP will print +.PP .CS hello from :: hello from ::foo @@ -225,23 +262,26 @@ messages from their parent namespace. For example, executing (in the .QW en locale) the code +.PP .CS \fB::msgcat::mcset\fR en m1 ":: message1" \fB::msgcat::mcset\fR en m2 ":: message2" \fB::msgcat::mcset\fR en m3 ":: message3" namespace eval ::foo { - \fB::msgcat::mcset\fR en m2 "::foo message2" - \fB::msgcat::mcset\fR en m3 "::foo message3" + \fB::msgcat::mcset\fR en m2 "::foo message2" + \fB::msgcat::mcset\fR en m3 "::foo message3" } namespace eval ::foo::bar { - \fB::msgcat::mcset\fR en m3 "::foo::bar message3" + \fB::msgcat::mcset\fR en m3 "::foo::bar message3" } namespace import \fB::msgcat::mc\fR puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]" namespace eval ::foo {puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"} namespace eval ::foo::bar {puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"} .CE +.PP will print +.PP .CS :: message1; :: message2; :: message3 :: message1; ::foo message2; ::foo message3 @@ -257,11 +297,12 @@ All message files for a package are in the same directory. The message file name is a msgcat locale specifier (all lowercase) followed by .QW .msg . For example: +.PP .CS es.msg \(em spanish en_gb.msg \(em United Kingdom English .CE -.VS 1.4 +.PP \fIException:\fR The message file for the root locale .MT is called @@ -270,16 +311,16 @@ This exception is made so as not to cause peculiar behavior, such as marking the message file as .QW hidden on Unix file systems. -.VE 1.4 .IP [3] -The file contains a series of calls to \fBmcset\fR and -\fBmcmset\fR, setting the necessary translation strings +The file contains a series of calls to \fBmcflset\fR and +\fBmcflmset\fR, setting the necessary translation strings for the language, likely enclosed in a \fBnamespace eval\fR so that all source strings are tied to the namespace of the package. For example, a short \fBes.msg\fR might contain: +.PP .CS namespace eval ::mypackage { - \fB::msgcat::mcset\fR es "Free Beer!" "Cerveza Gracias!" + \fB::msgcat::mcflset\fR "Free Beer!" "Cerveza Gracias!" } .CE .SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES" @@ -293,8 +334,8 @@ During package installation, create a subdirectory .IP [2] Copy your *.msg files into that directory. .IP [3] - Add the following command to your package -initialization script: +Add the following command to your package initialization script: +.PP .CS # load language files, stored in msgs subdirectory \fB::msgcat::mcload\fR [file join [file dirname [info script]] msgs] @@ -306,6 +347,7 @@ to \fBformat\fR might have positionally dependent parameters that might need to be repositioned. For example, it might be syntactically desirable to rearrange the sentence structure while translating. +.PP .CS format "We produced %d units in location %s" $num $city format "In location %s we produced %d units" $city $num @@ -313,13 +355,23 @@ format "In location %s we produced %d units" $city $num .PP This can be handled by using the positional parameters: +.PP .CS format "We produced %1\e$d units in location %2\e$s" $num $city format "In location %2\e$s we produced %1\e$d units" $num $city .CE .PP Similarly, positional parameters can be used with \fBscan\fR to -extract values from internationalized strings. +extract values from internationalized strings. Note that it is not +necessary to pass the output of \fB::msgcat::mc\fR to \fBformat\fR +directly; by passing the values to substitute in as arguments, the +formatting substitution is done directly. +.PP +.CS +\fBmsgcat::mc\fR {Produced %1$d at %2$s} $num $city +# ... where that key is mapped to one of the +# human-oriented versions by \fBmsgcat::mcset\fR +.CE .SH CREDITS .PP The message catalog code was developed by Mark Harrison. @@ -327,3 +379,6 @@ The message catalog code was developed by Mark Harrison. format(n), scan(n), namespace(n), package(n) .SH KEYWORDS internationalization, i18n, localization, l10n, message, text, translation +.\" Local Variables: +.\" mode: nroff +.\" End: diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 3377b47..112507a 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -13,11 +13,11 @@ package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.4.5 +package provide msgcat 1.5.0 namespace eval msgcat { namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ - mcunknown + mcunknown mcflset mcflmset # Records the current locale as passed to mclocale variable Locale "" @@ -25,6 +25,9 @@ namespace eval msgcat { # Records the list of locales to search variable Loclist {} + # Records the locale of the currently sourced message catalogue file + variable FileLocale + # Records the mapping between source strings and translated strings. The # dict key is of the form " ", where locale and # namespace should be themselves dict values and the value is @@ -277,6 +280,11 @@ proc msgcat::mcpreferences {} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { + variable FileLocale + # Save the file locale if we are recursively called + if {[info exists FileLocale]} { + set nestedFileLocale $FileLocale + } set x 0 foreach p [mcpreferences] { if { $p eq {} } { @@ -285,9 +293,17 @@ proc msgcat::mcload {langdir} { set langfile [file join $langdir $p.msg] if {[file exists $langfile]} { incr x + set FileLocale [string tolower [file tail [file rootname $langfile]]] + if {"root" eq $FileLocale} { + set FileLocale "" + } uplevel 1 [list ::source -encoding utf-8 $langfile] + unset FileLocale } } + if {[info exists nestedFileLocale]} { + set FileLocale $nestedFileLocale + } return $x } @@ -318,6 +334,35 @@ proc msgcat::mcset {locale src {dest ""}} { return $dest } +# msgcat::mcflset -- +# +# Set the translation for a given string in the current file locale. +# +# Arguments: +# src The source string. +# dest (Optional) The translated string. If omitted, +# the source string is used. +# +# Results: +# Returns the new locale. + +proc msgcat::mcflset {src {dest ""}} { + variable FileLocale + variable Msgs + + if {![info exists FileLocale]} { + return -code error \ + "must only be used inside a message catalog loaded with ::msgcat::mcload" + } + if {[llength [info level 0]] == 2} { ;# dest not specified + set dest $src + } + + set ns [uplevel 1 [list ::namespace current]] + dict set Msgs $FileLocale $ns $src $dest + return $dest +} + # msgcat::mcmset -- # # Set the translation for multiple strings in a specified locale. @@ -345,7 +390,38 @@ proc msgcat::mcmset {locale pairs } { dict set Msgs $locale $ns $src $dest } - return $length + return [expr {$length / 2}] +} + +# msgcat::mcflmset -- +# +# Set the translation for multiple strings in the mc file locale. +# +# Arguments: +# pairs One or more src/dest pairs (must be even length) +# +# Results: +# Returns the number of pairs processed + +proc msgcat::mcflmset {pairs} { + variable FileLocale + variable Msgs + + if {![info exists FileLocale]} { + return -code error \ + "must only be used inside a message catalog loaded with ::msgcat::mcload" + } + set length [llength $pairs] + if {$length % 2} { + return -code error "bad translation list:\ + should be \"[lindex [info level 0] 0] locale {src dest ...}\"" + } + + set ns [uplevel 1 [list ::namespace current]] + foreach {src dest} $pairs { + dict set Msgs $FileLocale $ns $src $dest + } + return [expr {$length / 2}] } # msgcat::mcunknown -- diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 60c2d3c..832bf81 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded msgcat 1.4.5 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.5.0 [list source [file join $dir msgcat.tcl]] diff --git a/tests/msgcat.test b/tests/msgcat.test index bbcd023..d75bf8e 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -17,8 +17,8 @@ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } -if {[catch {package require msgcat 1.4.5}]} { - puts stderr "Skipping tests in [info script]. No msgcat 1.4.5 found to test." +if {[catch {package require msgcat 1.5.0}]} { + puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test." return } @@ -611,6 +611,46 @@ namespace eval ::msgcat::test { mc "this is a %s" "good test" } -result "this is a good test" + # Tests msgcat-8.*: [mcflset] + + set msgdir1 [makeDirectory msgdir1] + makeFile {::msgcat::mcflset k1 v1} l1.msg $msgdir1 + + test msgcat-8.1 {mcflset} -setup { + variable locale [mclocale] + mclocale l1 + mcload $msgdir1 + } -cleanup { + mclocale $locale + } -body { + mc k1 + } -result v1 + + removeFile l1.msg $msgdir1 + removeDirectory msgdir1 + + set msgdir2 [makeDirectory msgdir2] + set msgdir3 [makeDirectory msgdir3] + makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\ + l2.msg $msgdir2 + makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3 + + # chained mcload + test msgcat-8.2 {mcflset} -setup { + variable locale [mclocale] + mclocale l2 + mcload $msgdir2 + } -cleanup { + mclocale $locale + } -body { + return [mc k2][mc k3] + } -result v2v3 + + removeFile l2.msg $msgdir2 + removeDirectory msgdir2 + removeFile l3.msg $msgdir3 + removeDirectory msgdir3 + cleanupTests } namespace delete ::msgcat::test -- cgit v0.12 From a7d4de2c279b775e84ac115f7b1450a31d5cd213 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 12 Sep 2012 19:11:29 +0000 Subject: finish the TIP 404 implementation. --- ChangeLog | 7 ++++--- changes | 6 ++++-- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index 036cd21..d2017d4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,9 +2,10 @@ IMPLEMENTATION OF TIP#404. - * library/msgcat.tcl: [FRQ 3544988]: add commands - [mcflset] and [mcflmset] to set mc entries with implicit message file - locale. Package version is now 1.5.0. + * library/msgcat/msgcat.tcl: [FRQ 3544988]: New commands [mcflset] + * library/msgcat/pkgIndex.tcl: and [mcflmset] to set mc entries with + * unix/Makefile.in: implicit message file locale. + * win/Makefile.in: Bump to 1.5.0. 2012-08-25 Donal K. Fellows diff --git a/changes b/changes index 06b2db1..b902445 100644 --- a/changes +++ b/changes @@ -8092,7 +8092,6 @@ problems where [file *able] would return false results on Win/Samba (porter) and Tcl_FSMountsChanged(). (porter) 2012-06-29 (bug fix)[3536888] fix locale guessing (oehlmann,nijtmans) -=> msgcat 1.4.5 2012-07-05 (bug fix)[1189293] make "<<" redirect binary safe (porter) @@ -8109,8 +8108,11 @@ and Tcl_FSMountsChanged(). (porter) 2012-08-25 (bug fix)[3561330] Ukranian translation of "March" (teterin) +2012-09-12 (TIP 404) New msgcat commands [mcflset], [mcflmset] (oehlmann) +=> msgcat 1.5.0 + Many revisions to better support a Cygwin environment (nijtmans) Dropped support for OS X versions less than 10.4 (Tiger) (fellows) ---- Released 8.6b3, September 7, 2012 --- See ChangeLog for details --- +--- Released 8.6b3, September 18, 2012 --- See ChangeLog for details --- diff --git a/unix/Makefile.in b/unix/Makefile.in index 4d5595d..9ac84f7 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -846,8 +846,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.4.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.5.tm; + @echo "Installing package msgcat 1.5.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.4.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 4dbdbbd..bef71c0 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -647,8 +647,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.4.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.5.tm; + @echo "Installing package msgcat 1.5.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.4.tm; @echo "Installing package platform 1.0.10 as a Tcl Module"; -- cgit v0.12 From fa34cf0e225eb594debfdac2da4f6dd6df451418 Mon Sep 17 00:00:00 2001 From: twylite Date: Thu, 13 Sep 2012 09:02:52 +0000 Subject: 3549770 fix filesystem-7.1.x tests: loaddll constraint setup and path for filesystem-7.1.1 --- tests/fileSystem.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 38ecbee..b098f35 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -27,7 +27,7 @@ catch { set ::ddelib [lindex [package ifneeded dde $::ddever] 1] set ::regver [package require registry] set ::reglib [lindex [package ifneeded registry $::regver] 1] - testConstraint loaddll 0 + testConstraint loaddll 1 } # Test for commands defined in Tcltest executable @@ -514,7 +514,7 @@ test filesystem-7.1.1 {load from vfs} -setup { set dir [pwd] } -constraints {win testsimplefilesystem loaddll} -body { # This may cause a crash on exit - cd [file dirname $::reglib] + cd [file dirname $::ddelib] testsimplefilesystem 1 # This loads dde via a complex copy-to-temp operation load simplefs:/[file tail $::ddelib] dde -- cgit v0.12 From 98237732ef4cd07a63f32adcdbcdb4d0b9099773 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 12:34:37 +0000 Subject: 3566106 Solaris9/x86 support. Thanks Dagobert and others. --- unix/tcl.m4 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index a142baf..b13fddd 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1968,7 +1968,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AS_IF([test "$GCC" = yes],[use_sunmath=no],[ arch=`isainfo` AC_MSG_CHECKING([whether to use -lsunmath for fp rounding control]) - AS_IF([test "$arch" = "amd64 i386"], [ + AS_IF([test "$arch" = "amd64 i386" -o "$arch" = "i386"], [ AC_MSG_RESULT([yes]) MATH_LIBS="-lsunmath $MATH_LIBS" AC_CHECK_HEADER(sunmath.h) @@ -2001,7 +2001,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ], [ AS_IF([test "$use_sunmath" = yes], [textmode=textoff],[textmode=text]) case $system in - SunOS-5.[[1-9]][[0-9]]*) + SunOS-5.[[1-9]][[0-9]]*|SunOS-5.[[7-9]]) SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";; *) SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";; -- cgit v0.12 From 5b68c7d62cf67a00bd6c5e97f1da7d7fd194ef00 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Sep 2012 13:09:17 +0000 Subject: Fix msgcat-0.7 when running tests outside of the build tree (part of Bug #3549770) --- tests/msgcat.test | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/msgcat.test b/tests/msgcat.test index d75bf8e..0edb1d2 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -56,6 +56,13 @@ namespace eval ::msgcat::test { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { + if {([info sharedlibextension] == ".dll") + && ![catch {package require registry}]} { + # Windows and Cygwin have other ways to determine the + # locale when the environment variables are missing + # and the registry package is present + continue + } set result c } } -- cgit v0.12 From 8514777f826612d38687d5c42e5a4283930ea9a3 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 14:17:18 +0000 Subject: Revert committed debugging configuration. --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index a0629c6..6c6e664 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4640,7 +4640,7 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); *---------------------------------------------------------------- */ -#define NRE_USE_SMALL_ALLOC 0 /* Only turn off for debugging purposes. */ +#define NRE_USE_SMALL_ALLOC 1 /* Only turn off for debugging purposes. */ #define NRE_ENABLE_ASSERTS 1 /* -- cgit v0.12 From 6222630e1575db9c7d632eac2ac4587292ef94f1 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 15:34:11 +0000 Subject: First draft of tcl/pkgs/README bundling instructions. --- pkgs/README | 58 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 57 insertions(+), 1 deletion(-) diff --git a/pkgs/README b/pkgs/README index e2b33f5..01c6f43 100644 --- a/pkgs/README +++ b/pkgs/README @@ -1 +1,57 @@ -Add notes here about bundling packages with Tcl. + +The 'pkgs' subdirectory of the Tcl source code distribution is meant to be +a place where the source code distribution of Tcl packages may be placed so +that they are built, installed, and tested along with Tcl. As originally +distributed, Tcl re-distributes a number of packages in this location. The +build systems for Tcl are written so that additional packages may be added, +or the original packages removed in any number and still have all packages +present get built, installed, and tested along with Tcl. + +In order for a package to work properly under the pkgs subdirectory, it +needs to conform to the following conventions. + + All files of the package need to be contained in (subdirs of ...) a + single subdirectory of the "pkgs" directrory. + + In that subdirectory of "pkgs" there must be an executable file named + "configure". When the program "configure" is run, it should generate + a file "Makefile" in the current working directory. The "configure" + program should be able to accept as command line arguments all the + arguments that can be passed to the master unix/configure program. It + should also accept the --with-tcl= and --with-tclinclude= options in + the conventional way. + + The generated "Makefile" must be one suitable for controlling the operations + of a `make` program. The following targets must be defined: + + : Perform a build of the runtime components of the + package from sources. + + install: Copy the runtime components of the package into their + installed location. Must respect the DESTDIR variable + for determining the installation location. + + test: Run the test suite of the package. Must respect the + TCLSH_PROG, TESTFLAGS variables. + + clean: Delete all files generated by the default build target. + + distclean: Delete all generated files. + + dist: Produce a copy of the package's source code distribution. + Must respect the DIST_ROOT variable determing where to + write the generated directory. + +Packages that are written to make use of the Tcl Extension Architecture (TEA) +and that make use of the tclconfig collection of support files, should +conform to these conventions without further efforts. + +These conventions are subject to revision and refinement over time to +better support the needs of the build system. Efforts will be made to +keep the TEA support scripts consistent with the demands of this system. + +In addition, it is requested that packages also support building with +Microsoft Visual Studio tools. This means the file win/makefile.vc +should be included, suitable for use by the nmake program, defining the +targets , install, test, and clean. + -- cgit v0.12 From 158e7897249b7ff3ac5bba76020895f7d5d90d8e Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 15:54:52 +0000 Subject: autoconf-2.59 --- unix/configure | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index 18611f0..3e247c7 100755 --- a/unix/configure +++ b/unix/configure @@ -8757,7 +8757,7 @@ else arch=`isainfo` echo "$as_me:$LINENO: checking whether to use -lsunmath for fp rounding control" >&5 echo $ECHO_N "checking whether to use -lsunmath for fp rounding control... $ECHO_C" >&6 - if test "$arch" = "amd64 i386"; then + if test "$arch" = "amd64 i386" -o "$arch" = "i386"; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 @@ -8956,7 +8956,7 @@ else fi case $system in - SunOS-5.[1-9][0-9]*) + SunOS-5.[1-9][0-9]*|SunOS-5.[7-9]) SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";; *) SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";; -- cgit v0.12 From e684cc19d11b76f4bbe0b3540577963563f3e948 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Sep 2012 16:19:19 +0000 Subject: Safer stale config fix for review. --- unix/configure | 5 ++++- unix/configure.in | 5 ++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index 0958d3d..cbb10b4 100755 --- a/unix/configure +++ b/unix/configure @@ -1355,7 +1355,10 @@ fi #------------------------------------------------------------------------ # Empty slate for bundled packages, to avoid stale configuration #------------------------------------------------------------------------ -rm -Rf pkgs +#rm -Rf pkgs +if test -f Makefile; then + make distclean-packages +fi #------------------------------------------------------------------------ # Handle the --prefix=... option diff --git a/unix/configure.in b/unix/configure.in index 420cdc2..f4b695d 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -45,7 +45,10 @@ fi #------------------------------------------------------------------------ # Empty slate for bundled packages, to avoid stale configuration #------------------------------------------------------------------------ -rm -Rf pkgs +#rm -Rf pkgs +if test -f Makefile; then + make distclean-packages +fi #------------------------------------------------------------------------ # Handle the --prefix=... option -- cgit v0.12 From d097d2d5afb8aac0a3913ad7f4af6726025c6dc2 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 14 Sep 2012 18:15:54 +0000 Subject: Missing test cleanup. --- tests/ioTrans.test | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/ioTrans.test b/tests/ioTrans.test index db9a2cb..7027ec1 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -283,6 +283,8 @@ test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} lappend res [catch {close $c} msg] $msg lappend res [file channels file*] lappend res [file channels rt*] +} -cleanup { + tempdone } -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}} test iortrans-3.2 {chan finalize, for close} -setup { set res {} @@ -300,6 +302,7 @@ test iortrans-3.2 {chan finalize, for close} -setup { lappend res [info command foo] } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} test iortrans-3.3 {chan finalize, for close, error, close error} -setup { set res {} @@ -315,6 +318,7 @@ test iortrans-3.3 {chan finalize, for close, error, close error} -setup { lappend res [file channels rt*] } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} test iortrans-3.4 {chan finalize, for close, error, close error} -setup { set res {} @@ -328,6 +332,7 @@ test iortrans-3.4 {chan finalize, for close, error, close error} -setup { lappend res [catch {close $c} msg] $msg $::errorInfo } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO *"close $c"}} test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { @@ -342,6 +347,7 @@ test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} test iortrans-3.6 {chan finalize, for close, break, close error} -setup { set res {} @@ -355,6 +361,7 @@ test iortrans-3.6 {chan finalize, for close, break, close error} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { set res {} @@ -368,6 +375,7 @@ test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { set res {} @@ -381,6 +389,7 @@ test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { set res {} @@ -395,6 +404,7 @@ test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { noteOpts $opt } -match glob -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} # --- === *** ########################### @@ -1036,6 +1046,8 @@ test iortrans-11.2 {delete interp of reflected transform} -setup { chan event $c readable no-op } interp delete slave +} -cleanup { + tempdone } -result {} # ### ### ### ######### ######### ######### -- cgit v0.12 From 18b6945d86ecf2b58a0d39e7f17885f692f19a87 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 14 Sep 2012 18:20:36 +0000 Subject: Mistaken cleanup command. --- tests/msgcat.test | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/msgcat.test b/tests/msgcat.test index 0edb1d2..1522354 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -655,7 +655,6 @@ namespace eval ::msgcat::test { removeFile l2.msg $msgdir2 removeDirectory msgdir2 - removeFile l3.msg $msgdir3 removeDirectory msgdir3 cleanupTests -- cgit v0.12 From 0807baacce4a33e3515110feb33689c90b397f80 Mon Sep 17 00:00:00 2001 From: stwo Date: Sun, 16 Sep 2012 15:51:55 +0000 Subject: Nicer style test. --- generic/tclBinary.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 4953e27..cbd9b02 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -309,10 +309,10 @@ Tcl_SetByteArrayObj( byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if (length && bytes) { + + if ((length != NULL) && (bytes > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); } -- cgit v0.12 From 4cbd189c26149481fffd935920221b8e3a0c7b2e Mon Sep 17 00:00:00 2001 From: stwo Date: Sun, 16 Sep 2012 15:56:02 +0000 Subject: Nicer style test. --- generic/tclBinary.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 8c95305..d3b11d3 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -279,10 +279,10 @@ Tcl_SetByteArrayObj( byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if (length && bytes) { + + if ((length != NULL) && (bytes > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); } -- cgit v0.12 From fd70297b820fcad022629bfd4d0ff5e1a550aaaa Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 17 Sep 2012 06:42:02 +0000 Subject: Correct build version and backported 973091ef75 --- ChangeLog | 8 +++++--- changes | 3 +++ tests/msgcat.test | 7 +++++++ unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 19 insertions(+), 7 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4d2d296..9f63bc1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,9 +2,11 @@ IMPLEMENTATION OF TIP#404. - * library/msgcat.tcl: [FRQ 3544988] (Backport from tcl8.6): add commands - [mcflset] and [mcflmset] to set mc entries with implicit message file - locale. Package version is now 1.5.0. + * library/msgcat/msgcat.tcl: [FRQ 3544988]: (Backport from Tcl 8.6) + * library/msgcat/pkgIndex.tcl: New commands [mcflset] and [mcflmset] + * unix/Makefile.in: to set mc entries with implicit message + * win/Makefile.in: file locale. Bump to 1.5.0. + * tests/msgcat.test: 2012-09-07 Alexandre Ferrieux diff --git a/changes b/changes index 6709726..3221846 100644 --- a/changes +++ b/changes @@ -7655,6 +7655,9 @@ and Tcl_FSMountsChanged(). (porter) 2012-07-25 (bug fix)[3546275] [auto_execok] search match [exec] (danckaert) +2012-09-12 (TIP 404) New msgcat commands [mcflset], [mcflmset] (oehlmann) +=> msgcat 1.5.0 + Many revisions to better support a Cygwin environment (nijtmans) --- Released 8.5.12, July 27, 2011 --- See ChangeLog for details --- diff --git a/tests/msgcat.test b/tests/msgcat.test index d75bf8e..0edb1d2 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -56,6 +56,13 @@ namespace eval ::msgcat::test { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { + if {([info sharedlibextension] == ".dll") + && ![catch {package require registry}]} { + # Windows and Cygwin have other ways to determine the + # locale when the environment variables are missing + # and the registry package is present + continue + } set result c } } diff --git a/unix/Makefile.in b/unix/Makefile.in index bdcbda0..a2d89aa 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -773,8 +773,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.4.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.5.tm; + @echo "Installing package msgcat 1.5.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.4.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 8e01818..b0bdec8 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -644,8 +644,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.4.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.5.tm; + @echo "Installing package msgcat 1.5.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.4.tm; @echo "Installing package platform 1.0.10 as a Tcl Module"; -- cgit v0.12 From f0b29ca5582f739d333f185cf4cd0be2432025b5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Sep 2012 10:45:47 +0000 Subject: eliminate compiler warning in previous commit --- generic/tclBinary.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index d3b11d3..9ba06ee 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -280,7 +280,7 @@ Tcl_SetByteArrayObj( byteArrayPtr->used = length; byteArrayPtr->allocated = length; - if ((length != NULL) && (bytes > 0)) { + if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } objPtr->typePtr = &tclByteArrayType; -- cgit v0.12 From 08483415eb549c433b52c30f5b7c5b3166549bbd Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 17 Sep 2012 12:56:32 +0000 Subject: Tag Tcl 8.6b3 for release. --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index d2017d4..2360718 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,7 @@ 2012-09-07 Harald Oehlmann + *** 8.6b3 TAGGED FOR RELEASE *** + IMPLEMENTATION OF TIP#404. * library/msgcat/msgcat.tcl: [FRQ 3544988]: New commands [mcflset] -- cgit v0.12 From 87baa038943501504fc76d2f330ad6987b384602 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Sep 2012 09:50:25 +0000 Subject: Make Tcl_Interp a fully opaque structure if TCL_NO_DEPRECATED is set (TIP 330 and 336). --- ChangeLog | 5 +++++ generic/tcl.h | 14 +++++++++----- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2360718..b6addcc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-09-19 Jan Nijtmans + + * generic/tcl.h: make Tcl_Interp a fully opaque structure + if TCL_NO_DEPRECATED is set (TIP 330 and 336). + 2012-09-07 Harald Oehlmann *** 8.6b3 TAGGED FOR RELEASE *** diff --git a/generic/tcl.h b/generic/tcl.h index 32d8e1e..3f9f06a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -500,7 +500,9 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ -typedef struct Tcl_Interp { +typedef struct Tcl_Interp +#ifndef TCL_NO_DEPRECATED +{ /* TIP #330: Strongly discourage extensions from using the string * result. */ #ifdef USE_INTERP_RESULT @@ -517,8 +519,8 @@ typedef struct Tcl_Interp { * Tcl_Eval must free it before executing next * command. */ #else - char *unused3 TCL_DEPRECATED_API("bad field access"); - void (*unused4) (char *) TCL_DEPRECATED_API("bad field access"); + char *resultDontUse; /* Don't use in extensions! */ + void (*freeProcDontUse) (char *); /* Don't use in extensions! */ #endif #ifdef USE_INTERP_ERRORLINE int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); @@ -526,9 +528,11 @@ typedef struct Tcl_Interp { * line number within the command where the * error occurred (1 if first line). */ #else - int unused5 TCL_DEPRECATED_API("bad field access"); + int errorLineDontUse; /* Don't use in extensions! */ #endif -} Tcl_Interp; +} +#endif /* TCL_NO_DEPRECATED */ +Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; -- cgit v0.12 From 562176ad5a881a5f92f2985feab5401c375d559a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Sep 2012 12:33:25 +0000 Subject: Let "nmakehlp -V" start searching digits after the found match (suggested by Harald Oehlmann) --- ChangeLog | 4 +++- win/nmakehlp.c | 9 +++++---- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index b6addcc..9a17845 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,9 @@ 2012-09-19 Jan Nijtmans - * generic/tcl.h: make Tcl_Interp a fully opaque structure + * generic/tcl.h: make Tcl_Interp a fully opaque structure if TCL_NO_DEPRECATED is set (TIP 330 and 336). + * win/nmakehlp.c: Let "nmakehlp -V" start searching digits + after the found match (suggested by Harald Oehlmann) 2012-09-07 Harald Oehlmann diff --git a/win/nmakehlp.c b/win/nmakehlp.c index d0edcf0..b1a1517 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -498,9 +498,10 @@ GetVersionFromFile( p = strstr(szBuffer, match); if (p != NULL) { /* - * Skip to first digit. + * Skip to first digit after the match. */ + p += strlen(match); while (*p && !isdigit(*p)) { ++p; } @@ -630,11 +631,11 @@ SubstituteFile( } } #endif - + /* * Run the substitutions over each line of the input */ - + while (fgets(szBuffer, cbBuffer, fp) != NULL) { list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr) { @@ -654,7 +655,7 @@ SubstituteFile( } printf(szBuffer); } - + list_free(&substPtr); } fclose(fp); -- cgit v0.12 From 772953aa7f24fe39a87d949c789344bed284d75c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Sep 2012 20:29:45 +0000 Subject: eliminate unnecessary TEXT() macros --- generic/tclMain.c | 4 ++-- win/tclAppInit.c | 30 +++++++++++++++--------------- win/tclWinFCmd.c | 4 ++-- win/tclWinFile.c | 2 +- 4 files changed, 20 insertions(+), 20 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index 14139ec..f445383 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -334,14 +334,14 @@ Tcl_MainEx( */ if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) - && (TEXT('-') != argv[3][0])) { + && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2], -1); Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; - } else if ((argc > 1) && (TEXT('-') != argv[1][0])) { + } else if ((argc > 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); argc--; argv++; diff --git a/win/tclAppInit.c b/win/tclAppInit.c index d6da500..56f45a0 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -109,9 +109,9 @@ _tmain( * Forward slashes substituted for backslashes. */ - for (p = argv[0]; *p != TEXT('\0'); p++) { - if (*p == TEXT('\\')) { - *p = TEXT('/'); + for (p = argv[0]; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; } } @@ -242,13 +242,13 @@ setargv( */ size = 2; - for (p = cmdLine; *p != TEXT('\0'); p++) { - if ((*p == TEXT(' ')) || (*p == TEXT('\t'))) { /* INTL: ISO space. */ + for (p = cmdLine; *p != '\0'; p++) { + if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ size++; - while ((*p == TEXT(' ')) || (*p == TEXT('\t'))) { /* INTL: ISO space. */ + while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ p++; } - if (*p == TEXT('\0')) { + if (*p == '\0') { break; } } @@ -267,10 +267,10 @@ setargv( p = cmdLine; for (argc = 0; argc < size; argc++) { argv[argc] = arg = argSpace; - while ((*p == TEXT(' ')) || (*p == TEXT('\t'))) { /* INTL: ISO space. */ + while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ p++; } - if (*p == TEXT('\0')) { + if (*p == '\0') { break; } @@ -278,14 +278,14 @@ setargv( slashes = 0; while (1) { copy = 1; - while (*p == TEXT('\\')) { + while (*p == '\\') { slashes++; p++; } - if (*p == TEXT('"')) { + if (*p == '"') { if ((slashes & 1) == 0) { copy = 0; - if ((inquote) && (p[1] == TEXT('"'))) { + if ((inquote) && (p[1] == '"')) { p++; copy = 1; } else { @@ -296,13 +296,13 @@ setargv( } while (slashes) { - *arg = TEXT('\\'); + *arg = '\\'; arg++; slashes--; } - if ((*p == TEXT('\0')) || (!inquote && - ((*p == TEXT(' ')) || (*p == TEXT('\t'))))) { /* INTL: ISO space. */ + if ((*p == '\0') || (!inquote && + ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ break; } if (copy != 0) { diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 80fad3e..ac88861 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1738,11 +1738,11 @@ ConvertFileNameFormat( } nativeName = data.cAlternateFileName; if (longShort) { - if (data.cFileName[0] != TEXT('\0')) { + if (data.cFileName[0] != '\0') { nativeName = data.cFileName; } } else { - if (data.cAlternateFileName[0] == TEXT('\0')) { + if (data.cAlternateFileName[0] == '\0') { nativeName = (TCHAR *) data.cFileName; } } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index a44a257..a1189f5 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1784,7 +1784,7 @@ NativeIsExec( return 0; } - if (path[len-4] != TEXT('.')) { + if (path[len-4] != '.') { return 0; } -- cgit v0.12 From 301282088d6b7961c502f111c171db6e6a341ab9 Mon Sep 17 00:00:00 2001 From: max Date: Wed, 26 Sep 2012 21:02:33 +0000 Subject: Workaround for [socket -server foo -myaddr localhost 0] failure on OSX. --- ChangeLog | 6 ++++++ generic/tclIOSock.c | 15 +++++++++++++-- 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6d18242..9f10890 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-09-26 Reinhard Max + + * generic/tclIOSock.c (TclCreateSocketAddress): Work around a bug + in getaddrinfo() on OSX that caused name resolution to fail for + [socket -server foo -myaddr localhost 0]. + 2012-09-20 Jan Nijtmans * win/configure.in: New import libraries for zlib 1.2.7, diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index e603c91..694501f 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -151,7 +151,7 @@ TclCreateSocketAddress( struct addrinfo *p; struct addrinfo *v4head = NULL, *v4ptr = NULL; struct addrinfo *v6head = NULL, *v6ptr = NULL; - char *native = NULL, portstring[TCL_INTEGER_SPACE]; + char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring; const char *family = NULL; Tcl_DString ds; int result, i; @@ -159,7 +159,18 @@ TclCreateSocketAddress( if (host != NULL) { native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); } - TclFormatInt(portstring, port); + + /* + * Workaround for OSX's apparent inability to resolve "localhost", "0" + * when the loopback device is the only available network interface. + */ + if (host != NULL && port == 0) { + portstring = NULL; + } else { + TclFormatInt(portbuf, port); + portstring = portbuf; + } + (void) memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; -- cgit v0.12 From 309512eff1f0750be76d3bbd487dd734f8eea65b Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 2 Oct 2012 16:08:42 +0000 Subject: Fix for core bug yet to be named/numbered. --- generic/tclIO.c | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4e24533..0cb9fa9 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -879,19 +879,25 @@ CheckForStdChannelsBeingClosed( ChannelState *statePtr = ((Channel *) chan)->state; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if ((chan == tsdPtr->stdinChannel) && tsdPtr->stdinInitialized) { + if (tsdPtr->stdinInitialized + && tsdPtr->stdinChannel != NULL + && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdinChannel = NULL; return; } - } else if ((chan == tsdPtr->stdoutChannel) && tsdPtr->stdoutInitialized) { + } else if (tsdPtr->stdoutInitialized + && tsdPtr->stdoutChannel != NULL + && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdoutChannel = NULL; return; } - } else if ((chan == tsdPtr->stderrChannel) && tsdPtr->stderrInitialized) { + } else if (tsdPtr->stderrInitialized + && tsdPtr->stderrChannel != NULL + && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stderrChannel = NULL; -- cgit v0.12 From e8194c6b432919103ad3c5f472e4c05ce1a2b037 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 3 Oct 2012 09:38:50 +0000 Subject: documented new C API; corrected type signature of no-zlib fallback function --- doc/TclZlib.3 | 30 +++++++++++++++++++++++++++++- generic/tclZlib.c | 9 +++------ 2 files changed, 32 insertions(+), 7 deletions(-) diff --git a/doc/TclZlib.3 b/doc/TclZlib.3 index 1b5e892..ebd294b 100644 --- a/doc/TclZlib.3 +++ b/doc/TclZlib.3 @@ -49,9 +49,11 @@ int .sp int \fBTcl_ZlibStreamGet\fR(\fIzshandle, dataObj, count\fR) +.sp +\fBTcl_ZlibStreamSetCompressionDictionary\fR(\fIzshandle, compDict\fR) .fi .SH ARGUMENTS -.AS Tcl_ZlibStream *zshandlePtr out +.AS Tcl_ZlibStream zshandle in .AP Tcl_Interp *interp in The interpreter to store resulting compressed or uncompressed data in. Also where any error messages are written. For \fBTcl_ZlibStreamInit\fR, this can @@ -108,6 +110,13 @@ trailer demanded by the format is written. .AP int count in The maximum number of bytes to get from the stream, or -1 to get all remaining bytes from the stream's buffers. +.AP Tcl_Obj *compDict in +A byte array object that is the compression dictionary to use with the stream. +Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this +only ever be used with streams that were created with their \fIformat\fR set +to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to +indicate whether a compression dictionary was present other than to fail on +decompression. .BE .SH DESCRIPTION These functions form the interface from the Tcl library to the Zlib @@ -172,6 +181,25 @@ uncompressed data according to the format, and \fBTcl_ZlibStreamEof\fR returns a boolean value indicating whether the end of the uncompressed data has been reached. .PP +\fBTcl_ZlibStreamSetCompressionDictionary\fR is used to control the +compression dictionary used with the stream, a compression dictionary being an +array of bytes (such as might be created with \fBTcl_NewByteArrayObj\fR) that +is used to initialize the compression engine rather than leaving it to create +it on the fly from the data being compressed. Setting a compression dictionary +allows for more efficient compression in the case where the start of the data +is highly regular, but it does require both the compressor and the +decompressor to agreee on the value to use. Compression dictionaries are only +fully supported for zlib-format data; on compression, they must be set before +any data is sent in with \fBTcl_ZlibStreamPut\fR, and on decompression they +should be set when \fBTcl_ZlibStreamGet\fR produces an \fBerror\fR with its +\fB\-errorcode\fR set to +.QW "\fBZLIB NEED_DICT\fI code\fR" ; +the \fIcode\fR will be the Adler-32 checksum (see \fBTcl_ZlibAdler32\fR) of +the compression dictionary sought. (Note that this is only true for +zlib-format streams; gzip streams ignore compression dictionaries as the +format specification doesn't permit them, and raw streams just produce a data +error if the compression dictionary is missing or incorrect.) +.PP If you wish to clear a stream and reuse it for a new compression or decompression action, \fBTcl_ZlibStreamReset\fR will do this and return a normal Tcl result code to indicate whether it was successful; if the stream is diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 20130d1..2054b15 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3974,15 +3974,12 @@ Tcl_ZlibAdler32( return 0; } -int +void Tcl_ZlibStreamSetCompressionDictionary( - Tcl_Interp *interp, - Tcl_ZlibStream zhandle, + Tcl_ZlibStream zshandle, Tcl_Obj *compressionDictionaryObj) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); - Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); - return TCL_ERROR; + /* Do nothing. */ } #endif /* HAVE_ZLIB */ -- cgit v0.12 From 570d1f597600fd4e019636e74fc5d1a74bc0b53e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 3 Oct 2012 15:22:15 +0000 Subject: When checking for std channels being closed, compare the channel state, not the channel itself so that stacked channels do not cause trouble. --- ChangeLog | 6 ++++++ generic/tclIO.c | 44 ++++++++++++++++++++++++-------------------- 2 files changed, 30 insertions(+), 20 deletions(-) diff --git a/ChangeLog b/ChangeLog index b8b9f2b..6f84707 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-10-03 Don Porter + + * generic/tclIO.c: When checking for std channels being closed, + compare the channel state, not the channel itself so that stacked + channels do not cause trouble. + 2012-08-17 Jan Nijtmans * win/nmakehlp.c: Add "-V" option, in order to be able diff --git a/generic/tclIO.c b/generic/tclIO.c index b9cd30c..eace472 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -697,26 +697,30 @@ CheckForStdChannelsBeingClosed(chan) ChannelState *statePtr = ((Channel *) chan)->state; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if ((chan == tsdPtr->stdinChannel) && (tsdPtr->stdinInitialized)) { - if (statePtr->refCount < 2) { - statePtr->refCount = 0; - tsdPtr->stdinChannel = NULL; - return; - } - } else if ((chan == tsdPtr->stdoutChannel) - && (tsdPtr->stdoutInitialized)) { - if (statePtr->refCount < 2) { - statePtr->refCount = 0; - tsdPtr->stdoutChannel = NULL; - return; - } - } else if ((chan == tsdPtr->stderrChannel) - && (tsdPtr->stderrInitialized)) { - if (statePtr->refCount < 2) { - statePtr->refCount = 0; - tsdPtr->stderrChannel = NULL; - return; - } + if (tsdPtr->stdinInitialized + && tsdPtr->stdinChannel != NULL + && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { + if (statePtr->refCount < 2) { + statePtr->refCount = 0; + tsdPtr->stdinChannel = NULL; + return; + } + } else if (tsdPtr->stdoutInitialized + && tsdPtr->stdoutChannel != NULL + && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) { + if (statePtr->refCount < 2) { + statePtr->refCount = 0; + tsdPtr->stdoutChannel = NULL; + return; + } + } else if (tsdPtr->stderrInitialized + && tsdPtr->stderrChannel != NULL + && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) { + if (statePtr->refCount < 2) { + statePtr->refCount = 0; + tsdPtr->stderrChannel = NULL; + return; + } } } -- cgit v0.12 From 26529fbec2cc37660e2f376993a1098b4d95404a Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Oct 2012 08:24:05 +0000 Subject: clean up some of the code to remove warnings and uselessly-settable things --- generic/tclZlib.c | 58 +++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 43 insertions(+), 15 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 2054b15..11490f1 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -288,21 +288,27 @@ ConvertError( codeStr2 = codeStrBuf; sprintf(codeStrBuf, "%lu", adler); break; - default: - codeStr = "unknown"; - codeStr2 = codeStrBuf; - sprintf(codeStrBuf, "%d", code); - break; /* - * Finally, these should _not_ happen! This function is for dealing - * with error cases, not non-errors! + * These should _not_ happen! This function is for dealing with error + * cases, not non-errors! */ case Z_OK: Tcl_Panic("unexpected zlib result in error handler: Z_OK"); case Z_STREAM_END: Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); + + /* + * Anything else is bad news; it's unexpected. Convert to generic + * error. + */ + + default: + codeStr = "UNKNOWN"; + codeStr2 = codeStrBuf; + sprintf(codeStrBuf, "%d", code); + break; } Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); @@ -364,7 +370,7 @@ ConvertErrorToList( */ default: - TclNewLiteralStringObj(objv[2], "unknown"); + TclNewLiteralStringObj(objv[2], "UNKNOWN"); TclNewIntObj(objv[3], code); return Tcl_NewListObj(4, objv); } @@ -1984,12 +1990,27 @@ ZlibCmd( NULL); case CMD_GZIP: /* gzip data ?level? * -> gzippedCompressedData */ + headerDictObj = NULL; + + /* + * Legacy argument format support. + */ + + if (objc == 4 + && Tcl_GetIntFromObj(interp, objv[3], &level) == TCL_OK) { + if (level < 0 || level > 9) { + extraInfoStr = "\n (in -level option)"; + goto badLevel; + } + return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], + level, NULL); + } + if (objc < 3 || objc > 7 || ((objc & 1) == 0)) { Tcl_WrongNumArgs(interp, 2, objv, "data ?-level level? ?-header header?"); return TCL_ERROR; } - headerDictObj = NULL; for (i=3 ; i 65535) { + } else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "-limit must be between 1 and 65535", -1)); + "-limit must be between 1 and 65536", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL); return TCL_ERROR; } -- cgit v0.12 From 90506922cb9a702695c821faa7cfee16ce8e3915 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Oct 2012 08:17:22 +0000 Subject: tuning up the documentation --- doc/dict.n | 39 ++++++++++++++++++------------ doc/lmap.n | 82 +++++++++++++++++++++++++++++--------------------------------- 2 files changed, 61 insertions(+), 60 deletions(-) diff --git a/doc/dict.n b/doc/dict.n index b9b4767..3bd5530 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -147,23 +147,30 @@ keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the value that the key maps to to not be representable as a list. .TP -\fBdict map {\fIkeyVar valueVar\fB} \fIdictionaryValue body\fR +\fBdict map \fR{\fIkeyVar valueVar\fR} \fIdictionaryValue body\fR . -This command takes three arguments, the first a two-element list of -variable names (for the key and value respectively of each mapping in -the dictionary), the second the dictionary value to iterate across, -and the third a script to be evaluated for each mapping with the key -and value variables set appropriately (in the manner of \fBmapeach\fR.) -In an iteration where the evaluated script completes normally -(\fBTCL_OK\fR) the script result is appended to an accumulator list. -The result of the \fBdict map\fB command is the accumulator list. -If any evaluation of the body generates a \fBTCL_BREAK\fR result, no -further pairs from the dictionary will be iterated over and the -\fBdict map\fR command will terminate successfully immediately. If any -evaluation of the body generates a \fBTCL_CONTINUE\fR result, the -current iteration is aborted and the accumulator list is not modified. -The order of iteration is the order in which the keys were inserted into -the dictionary. +This command applies a transformation to each element of a dictionary, +returning a new dictionary. It takes three arguments: the first is a +two-element list of variable names (for the key and value respectively of each +mapping in the dictionary), the second the dictionary value to iterate across, +and the third a script to be evaluated for each mapping with the key and value +variables set appropriately (in the manner of \fBlmap\fR). In an iteration +where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an +\fBerror\fR, etc.) the result of the script is put into an accumulator +dictionary using the key that is the current contents of the \fIkeyVar\fR +variable at that point. The result of the \fBdict map\fB command is the +accumulator dictionary after all keys have been iterated over. +.RS +.PP +If the evaluation of the body for any particular step generates a \fBbreak\fR, +no further pairs from the dictionary will be iterated over and the \fBdict +map\fR command will terminate successfully immediately. If the evaluation of +the body for a particular step generates a \fBcontinue\fR result, the current +iteration is aborted and the accumulator dictionary is not modified. The order +of iteration is the natural order of the dictionary (typically the order in +which the keys were added to the dictionary; the order is the same as that +used in \fBdict for\fR). +.RE .TP \fBdict merge \fR?\fIdictionaryValue ...\fR? . diff --git a/doc/lmap.n b/doc/lmap.n index 7deb7f9..880b05a 100644 --- a/doc/lmap.n +++ b/doc/lmap.n @@ -15,77 +15,71 @@ lmap \- Iterate over all elements in one or more lists and collect results .br \fBlmap \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR .BE - .SH DESCRIPTION .PP -The \fBlmap\fR command implements a loop where the loop -variable(s) take on values from one or more lists, and the loop returns a list -of results collected from each iteration. +The \fBlmap\fR command implements a loop where the loop variable(s) take on +values from one or more lists, and the loop returns a list of results +collected from each iteration. .PP -In the simplest case there is one loop variable, \fIvarname\fR, -and one list, \fIlist\fR, that is a list of values to assign to \fIvarname\fR. -The \fIbody\fR argument is a Tcl script. -For each element of \fIlist\fR (in order -from first to last), \fBlmap\fR assigns the contents of the -element to \fIvarname\fR as if the \fBlindex\fR command had been used -to extract the element, then calls the Tcl interpreter to execute -\fIbody\fR. If execution of the body completes normally then the result of the -body is appended to an accumulator list. \fBlmap\fR returns the accumulator -list. - +In the simplest case there is one loop variable, \fIvarname\fR, and one list, +\fIlist\fR, that is a list of values to assign to \fIvarname\fR. The +\fIbody\fR argument is a Tcl script. For each element of \fIlist\fR (in order +from first to last), \fBlmap\fR assigns the contents of the element to +\fIvarname\fR as if the \fBlindex\fR command had been used to extract the +element, then calls the Tcl interpreter to execute \fIbody\fR. If execution of +the body completes normally then the result of the body is appended to an +accumulator list. \fBlmap\fR returns the accumulator list. .PP -In the general case there can be more than one value list -(e.g., \fIlist1\fR and \fIlist2\fR), -and each value list can be associated with a list of loop variables -(e.g., \fIvarlist1\fR and \fIvarlist2\fR). -During each iteration of the loop -the variables of each \fIvarlist\fR are assigned -consecutive values from the corresponding \fIlist\fR. -Values in each \fIlist\fR are used in order from first to last, -and each value is used exactly once. -The total number of loop iterations is large enough to use -up all the values from all the value lists. -If a value list does not contain enough -elements for each of its loop variables in each iteration, -empty values are used for the missing elements. +In the general case there can be more than one value list (e.g., \fIlist1\fR +and \fIlist2\fR), and each value list can be associated with a list of loop +variables (e.g., \fIvarlist1\fR and \fIvarlist2\fR). During each iteration of +the loop the variables of each \fIvarlist\fR are assigned consecutive values +from the corresponding \fIlist\fR. Values in each \fIlist\fR are used in order +from first to last, and each value is used exactly once. The total number of +loop iterations is large enough to use up all the values from all the value +lists. If a value list does not contain enough elements for each of its loop +variables in each iteration, empty values are used for the missing elements. .PP -The \fBbreak\fR and \fBcontinue\fR statements may be -invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR -and \fBforeach\fR commands. In these cases the body does not complete normally -and the result is not appended to the accumulator list. +The \fBbreak\fR and \fBcontinue\fR statements may be invoked inside +\fIbody\fR, with the same effect as in the \fBfor\fR and \fBforeach\fR +commands. In these cases the body does not complete normally and the result is +not appended to the accumulator list. .SH EXAMPLES .PP Zip lists together: .PP .CS -'\" Maintainers: notice the tab hacking below! -.ta 3i set list1 {a b c d} set list2 {1 2 3 4} set zipped [\fBlmap\fR a $list1 b $list2 {list $a $b}] # The value of zipped is "{a 1} {b 2} {c 3} {d 4}" .CE .PP -Filter a list: +Filter a list to remove odd values: .PP .CS set values {1 2 3 4 5 6 7 8} -proc isGood {n} { expr { ($n % 2) == 0 } } -set goodOnes [\fBlmap\fR x $values {expr {[isGood $x] ? $x : [continue]}}] +proc isEven {n} {expr {($n % 2) == 0}} +set goodOnes [\fBlmap\fR x $values {expr { + [isEven $x] ? $x : [continue] +}}] # The value of goodOnes is "2 4 6 8" .CE .PP -Take a prefix from a list: +Take a prefix from a list based on the contents of the list: .PP .CS set values {8 7 6 5 4 3 2 1} -proc isGood {n} { expr { $n > 3 } } -set prefix [\fBlmap\fR x $values {expr {[isGood $x] ? $x : [break]}}] +proc isGood {counter} {expr {$n > 3}} +set prefix [\fBlmap\fR x $values {expr { + [isGood $x] ? $x : [break] +}}] # The value of prefix is "8 7 6 5 4" .CE - .SH "SEE ALSO" -for(n), while(n), break(n), continue(n), foreach(n) - +break(n), continue(n), for(n), foreach(n), while(n) .SH KEYWORDS foreach, iteration, list, loop, map +'\" Local Variables: +'\" mode: nroff +'\" End: -- cgit v0.12 From cee5b1c1de27f36c538c9b653ce8f2c1c69ea569 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Oct 2012 08:55:35 +0000 Subject: adjusted non-compiled implementation of [dict map] to match TIP --- generic/tcl.h | 1 - generic/tclDictObj.c | 306 +++++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 247 insertions(+), 60 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 5f4a77a..3f9f06a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1363,7 +1363,6 @@ typedef struct { int epoch; /* Epoch marker for dictionary being searched, * or -1 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ - Tcl_Obj *resultList; /* List of result values from the loop body. */ } Tcl_DictSearch; /* diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 56baf1f..dac4cbe 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -76,13 +76,12 @@ static int FinalizeDictWith(ClientData data[], Tcl_Interp *interp, int result); static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); -static int DictEachNRCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv, int collect); -static int DictEachLoopCallback(ClientData data[], +static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictForLoopCallback(ClientData data[], + Tcl_Interp *interp, int result); +static int DictMapLoopCallback(ClientData data[], Tcl_Interp *interp, int result); - /* * Table of dict subcommand names and implementations. @@ -186,6 +185,23 @@ static const Tcl_HashKeyType chainHashType = { AllocChainEntry, TclFreeObjEntry }; + +/* + * Structure used in implementation of 'dict map' to hold the state that gets + * passed between parts of the implementation. + */ + +typedef struct { + Tcl_Obj *keyVarObj; /* The name of the variable that will have + * keys assigned to it. */ + Tcl_Obj *valueVarObj; /* The name of the variable that will have + * values assigned to it. */ + Tcl_DictSearch search; /* The dictionary search structure. */ + Tcl_Obj *scriptObj; /* The script to evaluate each time through + * the loop. */ + Tcl_Obj *accumulatorObj; /* The dictionary used to accumulate the + * results. */ +} DictMapStorage; /***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/ @@ -2338,11 +2354,11 @@ DictAppendCmd( /* *---------------------------------------------------------------------- * - * DictForNRCmd, DictMapNRCmd, DictEachNRCmd -- + * DictForNRCmd -- * - * These functions implement the "dict for" and "dict map" Tcl commands. - * See the user documentation for details on what it does, and TIP#111 - * and TIP#405 for the formal specification. + * These functions implement the "dict for" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2360,27 +2376,6 @@ DictForNRCmd( int objc, Tcl_Obj *const *objv) { - return DictEachNRCmd(dummy, interp, objc, objv, 0); -} - -static int -DictMapNRCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - return DictEachNRCmd(dummy, interp, objc, objv, 1); -} - -static int -DictEachNRCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv, - int collect) /* Flag == 1 to collect and return loop body result. */ -{ Interp *iPtr = (Interp *) interp; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; @@ -2406,7 +2401,6 @@ DictEachNRCmd( return TCL_ERROR; } searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); - searchPtr->resultList = (collect ? Tcl_NewListObj(0, NULL) : NULL ); if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj, &done) != TCL_OK) { TclStackFree(interp, searchPtr); @@ -2450,7 +2444,7 @@ DictEachNRCmd( * Run the script. */ - TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj, + TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj, valueVarObj, scriptObj); return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); @@ -2468,7 +2462,7 @@ DictEachNRCmd( } static int -DictEachLoopCallback( +DictForLoopCallback( ClientData data[], Tcl_Interp *interp, int result) @@ -2493,34 +2487,19 @@ DictEachLoopCallback( result = TCL_OK; } else if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - ((searchPtr->resultList == NULL) ? - "\n (\"dict for\" body line %d)" : - "\n (\"dict map\" body line %d)"), + "\n (\"dict for\" body line %d)", Tcl_GetErrorLine(interp))); } goto done; } /* - * Capture result if collecting. - */ - - if (searchPtr->resultList != NULL) { - Tcl_ListObjAppendElement(interp, searchPtr->resultList, Tcl_GetObjResult(interp)); - } - - /* * Get the next mapping from the dictionary. */ Tcl_DictObjNext(searchPtr, &keyObj, &valueObj, &done); if (done) { - if (searchPtr->resultList != NULL) { - Tcl_SetObjResult(interp, searchPtr->resultList); - searchPtr->resultList = NULL; /* Don't clean it up */ - } else { - Tcl_ResetResult(interp); - } + Tcl_ResetResult(interp); goto done; } @@ -2530,13 +2509,15 @@ DictEachLoopCallback( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); result = TCL_ERROR; goto done; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; goto done; } @@ -2545,7 +2526,7 @@ DictEachLoopCallback( * Run the script. */ - TclNRAddCallback(interp, DictEachLoopCallback, searchPtr, keyVarObj, + TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj, valueVarObj, scriptObj); return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); @@ -2553,12 +2534,9 @@ DictEachLoopCallback( * For unwinding everything once the iterating is done. */ -done: + done: TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); - if (searchPtr->resultList != NULL) { - TclDecrRefCount(searchPtr->resultList); - } TclDecrRefCount(scriptObj); Tcl_DictObjDone(searchPtr); TclStackFree(interp, searchPtr); @@ -2568,6 +2546,216 @@ done: /* *---------------------------------------------------------------------- * + * DictMapNRCmd -- + * + * These functions implement the "dict map" Tcl command. See the user + * documentation for details on what it does, and TIP#405 for the formal + * specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictMapNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj **varv, *keyObj, *valueObj; + DictMapStorage *storagePtr; + int varc, done; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "{keyVar valueVar} dictionary script"); + return TCL_ERROR; + } + + /* + * Parse arguments. + */ + + if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + return TCL_ERROR; + } + if (varc != 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have exactly two variable names", -1)); + return TCL_ERROR; + } + storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage)); + if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj, + &valueObj, &done) != TCL_OK) { + TclStackFree(interp, storagePtr); + return TCL_ERROR; + } + if (done) { + /* + * Note that this exit leaves an empty value in the result (due to + * command calling conventions) but that is OK since an empty value is + * an empty dictionary. + */ + + TclStackFree(interp, storagePtr); + return TCL_OK; + } + TclNewObj(storagePtr->accumulatorObj); + TclListObjGetElements(NULL, objv[1], &varc, &varv); + storagePtr->keyVarObj = varv[0]; + storagePtr->valueVarObj = varv[1]; + storagePtr->scriptObj = objv[3]; + + /* + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. Note that the dictionary internal rep is locked + * internally so that updates, shimmering, etc are not a problem. + */ + + Tcl_IncrRefCount(storagePtr->keyVarObj); + Tcl_IncrRefCount(storagePtr->valueVarObj); + Tcl_IncrRefCount(storagePtr->scriptObj); + + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ + + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + goto error; + } + if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + goto error; + } + TclDecrRefCount(valueObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); + return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, + iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything on error. + */ + + error: + TclDecrRefCount(storagePtr->keyVarObj); + TclDecrRefCount(storagePtr->valueVarObj); + TclDecrRefCount(storagePtr->scriptObj); + TclDecrRefCount(storagePtr->accumulatorObj); + Tcl_DictObjDone(&storagePtr->search); + TclStackFree(interp, storagePtr); + return TCL_ERROR; +} + +static int +DictMapLoopCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + DictMapStorage *storagePtr = data[0]; + Tcl_Obj *keyObj, *valueObj; + int done; + + /* + * Process the result from the previous execution of the script body. + */ + + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result != TCL_OK) { + if (result == TCL_BREAK) { + Tcl_ResetResult(interp); + result = TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"dict map\" body line %d)", + Tcl_GetErrorLine(interp))); + } + goto done; + } else { + keyObj = Tcl_ObjGetVar2(interp, storagePtr->keyVarObj, NULL, + TCL_LEAVE_ERR_MSG); + if (keyObj == NULL) { + result = TCL_ERROR; + goto done; + } + Tcl_DictObjPut(NULL, storagePtr->accumulatorObj, keyObj, + Tcl_GetObjResult(interp)); + } + + /* + * Get the next mapping from the dictionary. + */ + + Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done); + if (done) { + Tcl_ResetResult(interp); + goto done; + } + + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ + + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + result = TCL_ERROR; + goto done; + } + if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + TclDecrRefCount(valueObj); + result = TCL_ERROR; + goto done; + } + TclDecrRefCount(valueObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); + return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, + iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything once the iterating is done. + */ + + done: + TclDecrRefCount(storagePtr->keyVarObj); + TclDecrRefCount(storagePtr->valueVarObj); + TclDecrRefCount(storagePtr->scriptObj); + TclDecrRefCount(storagePtr->accumulatorObj); + Tcl_DictObjDone(&storagePtr->search); + TclStackFree(interp, storagePtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * * DictSetCmd -- * * This function implements the "dict set" Tcl command. See the user @@ -3490,7 +3678,7 @@ TclInitDictCmd( { return TclMakeEnsemble(interp, "dict", implementationMap); } - + /* * Local Variables: * mode: c -- cgit v0.12 From a41520cafc3a8bda98fb4c37256ad2b7c56f0b6a Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Oct 2012 13:05:55 +0000 Subject: compilation code adjusted --- generic/tclCmdAH.c | 73 ++++++++++++++++---------- generic/tclCompCmds.c | 142 ++++++++++++++++++++++++++------------------------ generic/tclInt.h | 18 +++---- 3 files changed, 126 insertions(+), 107 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index d7872ef..14951e4 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -32,7 +32,9 @@ struct ForeachState { int *argcList; /* Array of value list sizes. */ Tcl_Obj ***argvList; /* Array of value lists. */ Tcl_Obj **aCopyList; /* Copies of value list arguments. */ - Tcl_Obj *resultList; /* List of result values from the loop body. */ + Tcl_Obj *resultList; /* List of result values from the loop body, + * or NULL if we're not collecting them + * ([lmap] vs [foreach]). */ }; /* @@ -53,8 +55,8 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); -static int TclNREachloopCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[], int collect); +static inline int EachloopCmd(Tcl_Interp *interp, int collect, + int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ExprCallback; static Tcl_NRPostProc ForSetupCallback; @@ -2568,7 +2570,7 @@ ForPostNextCallback( /* *---------------------------------------------------------------------- * - * Tcl_ForeachObjCmd, TclNRForeachCmd, TclNREachloopCmd -- + * Tcl_ForeachObjCmd, TclNRForeachCmd, EachloopCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. @@ -2600,7 +2602,7 @@ TclNRForeachCmd( int objc, Tcl_Obj *const objv[]) { - return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_KEEP_NONE); + return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv); } int @@ -2620,18 +2622,18 @@ TclNRLmapCmd( int objc, Tcl_Obj *const objv[]) { - return TclNREachloopCmd(dummy, interp, objc, objv, TCL_EACH_COLLECT); + return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv); } -int -TclNREachloopCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[], - int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ +static inline int +EachloopCmd( + Tcl_Interp *interp, /* Our context for variables and script + * evaluation. */ + int collect, /* Select collecting or accumulating mode + * (TCL_EACH_*) */ + int objc, /* The arguments being passed in... */ + Tcl_Obj *const objv[]) { - int numLists = (objc-2) / 2; register struct ForeachState *statePtr; int i, j, result; @@ -2675,7 +2677,11 @@ TclNREachloopCmd( statePtr->bodyPtr = objv[objc - 1]; statePtr->bodyIdx = objc - 1; - statePtr->resultList = Tcl_NewListObj(0, NULL); + if (collect == TCL_EACH_COLLECT) { + statePtr->resultList = Tcl_NewListObj(0, NULL); + } else { + statePtr->resultList = NULL; + } /* * Break up the value lists and variable lists into elements. @@ -2690,9 +2696,11 @@ TclNREachloopCmd( TclListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "foreach varlist is empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FOREACH", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s varlist is empty", + (statePtr->resultList != NULL ? "lmap" : "foreach"))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), "NEEDVARS", NULL); result = TCL_ERROR; goto done; @@ -2726,7 +2734,7 @@ TclNREachloopCmd( goto done; } - TclNRAddCallback(interp, ForeachLoopStep, statePtr, collect, NULL, NULL); + TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); return TclNREvalObjEx(interp, objv[objc-1], 0, ((Interp *) interp)->cmdFramePtr, objc-1); } @@ -2753,7 +2761,6 @@ ForeachLoopStep( int result) { register struct ForeachState *statePtr = data[0]; - int collect = (int)data[1]; /* Selected collecting or accumulating mode. */ /* * Process the result code from this run of the [foreach] body. Note that @@ -2765,8 +2772,9 @@ ForeachLoopStep( result = TCL_OK; break; case TCL_OK: - if (collect == TCL_EACH_COLLECT) { - Tcl_ListObjAppendElement(interp, statePtr->resultList, Tcl_GetObjResult(interp)); + if (statePtr->resultList != NULL) { + Tcl_ListObjAppendElement(interp, statePtr->resultList, + Tcl_GetObjResult(interp)); } break; case TCL_BREAK: @@ -2774,7 +2782,9 @@ ForeachLoopStep( goto finish; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"foreach\" body line %d)", Tcl_GetErrorLine(interp))); + "\n (\"%s\" body line %d)", + (statePtr->resultList != NULL ? "lmap" : "foreach"), + Tcl_GetErrorLine(interp))); default: goto done; } @@ -2790,7 +2800,7 @@ ForeachLoopStep( goto done; } - TclNRAddCallback(interp, ForeachLoopStep, statePtr, collect, NULL, NULL); + TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); return TclNREvalObjEx(interp, statePtr->bodyPtr, 0, ((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx); } @@ -2798,9 +2808,15 @@ ForeachLoopStep( /* * We're done. Tidy up our work space and finish off. */ + finish: - Tcl_SetObjResult(interp, statePtr->resultList); - statePtr->resultList = NULL; /* Don't clean it up */ + if (statePtr->resultList == NULL) { + Tcl_ResetResult(interp); + } else { + Tcl_SetObjResult(interp, statePtr->resultList); + statePtr->resultList = NULL; /* Don't clean it up */ + } + done: ForeachCleanup(interp, statePtr); return result; @@ -2833,7 +2849,8 @@ ForeachAssignments( if (varValuePtr == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (setting foreach loop variable \"%s\")", + "\n (setting %s loop variable \"%s\")", + (statePtr->resultList != NULL ? "lmap" : "foreach"), TclGetString(statePtr->varvList[i][v]))); return TCL_ERROR; } @@ -2862,7 +2879,7 @@ ForeachCleanup( TclDecrRefCount(statePtr->aCopyList[i]); } } - if (statePtr->resultList) { + if (statePtr->resultList != NULL) { TclDecrRefCount(statePtr->resultList); } TclStackFree(interp, statePtr); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 4d015ec..13f479d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -40,10 +40,10 @@ static int PushVarName(Tcl_Interp *interp, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line, int *clNext); -static int TclCompileEachloopCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, - int collect); -static int TclCompileDictEachCmd(Tcl_Interp *interp, +static int CompileEachloopCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + CompileEnv *envPtr, int collect); +static int CompileDictEachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr, int collect); @@ -795,37 +795,42 @@ TclCompileDictForCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - return TclCompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, 0); + return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_KEEP_NONE); } int TclCompileDictMapCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ { - return TclCompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, 1); + return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_COLLECT); } int -TclCompileDictEachCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int collect) /* Flag == 1 to collect and return loop body result. */ +CompileDictEachCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int collect) /* Flag == TCL_EACH_COLLECT to collect and + * construct a new dictionary with the loop + * body result. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; int numVars, endTargetOffset; - int collectTemp; /* Index of temp var holding the result list. */ + int collectVar = -1; /* Index of temp var holding the result + * dict. */ int savedStackDepth = envPtr->currStackDepth; /* Needed because jumps confuse the stack * space calculator. */ @@ -901,16 +906,12 @@ TclCompileDictEachCmd( * Create temporary variable to capture return values from loop body. */ - if (collect == 1) { - collectTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, envPtr); - - PushLiteral(envPtr, "", 0); - if (collectTemp <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, collectTemp, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, collectTemp, envPtr); + if (collect == TCL_EACH_COLLECT) { + collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, + envPtr); + if (collectVar < 0) { + return TCL_ERROR; } - TclEmitOpcode(INST_POP, envPtr); } /* @@ -927,6 +928,16 @@ TclCompileDictEachCmd( TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); /* + * Initialize the accumulator dictionary, if needed. + */ + + if (collect == TCL_EACH_COLLECT) { + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + /* * Now we catch errors from here on so that we can finalize the search * started by Tcl_DictObjFirst above. */ @@ -958,12 +969,12 @@ TclCompileDictEachCmd( SetLineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); - if (collect == 1) { - if (collectTemp <= 255) { - TclEmitInstInt1(INST_LAPPEND_SCALAR1, collectTemp, envPtr); - } else { - TclEmitInstInt4(INST_LAPPEND_SCALAR4, collectTemp, envPtr); - } + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_DICT_SET, 1, envPtr); + TclEmitInt4( collectVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); } TclEmitOpcode( INST_POP, envPtr); @@ -1039,12 +1050,8 @@ TclCompileDictEachCmd( jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, envPtr->codeStart + endTargetOffset); - if (collect == 1) { - if (collectTemp <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, collectTemp, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, collectTemp, envPtr); - } + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); } else { PushLiteral(envPtr, "", 0); } @@ -1935,13 +1942,14 @@ TclCompileForeachCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 0); + return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_KEEP_NONE); } /* *---------------------------------------------------------------------- * - * TclCompileEachloopCmd -- + * CompileEachloopCmd -- * * Procedure called to compile the "foreach" and "lmap" commands. * @@ -1957,14 +1965,15 @@ TclCompileForeachCmd( */ static int -TclCompileEachloopCmd( +CompileEachloopCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - int collect) /* Select collecting or accumulating mode (TCL_EACH_*) */ + int collect) /* Select collecting or accumulating mode + * (TCL_EACH_*) */ { Proc *procPtr = envPtr->procPtr; ForeachInfo *infoPtr; /* Points to the structure describing this @@ -1974,7 +1983,8 @@ TclCompileEachloopCmd( * used to point to a value list. */ int loopCtTemp; /* Index of temp var holding the loop's * iteration count. */ - int collectTemp = -1; /* Index of temp var holding the result var index. */ + int collectVar = -1; /* Index of temp var holding the result var + * index. */ Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; @@ -2091,6 +2101,14 @@ TclCompileEachloopCmd( loopIndex++; } + if (collect == TCL_EACH_COLLECT) { + collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, + envPtr); + if (collectVar < 0) { + return TCL_ERROR; + } + } + /* * We will compile the foreach command. Reserve (numLists + 1) temporary * variables: @@ -2171,15 +2189,9 @@ TclCompileEachloopCmd( */ if (collect == TCL_EACH_COLLECT) { - collectTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, envPtr); - PushLiteral(envPtr, "", 0); - if (collectTemp <= 255) { - TclEmitInstInt1( INST_STORE_SCALAR1, collectTemp, envPtr); - } else { - TclEmitInstInt4( INST_STORE_SCALAR4, collectTemp, envPtr); - } - TclEmitOpcode( INST_POP, envPtr); + Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* @@ -2208,14 +2220,9 @@ TclCompileEachloopCmd( envPtr->currStackDepth = savedStackDepth + 1; if (collect == TCL_EACH_COLLECT) { - if (collectTemp <= 255) { - TclEmitInstInt1( INST_LAPPEND_SCALAR1, collectTemp, envPtr); - } else { - TclEmitInstInt4( INST_LAPPEND_SCALAR4, collectTemp, envPtr); - } + Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); } - TclEmitOpcode( INST_POP, envPtr); - + TclEmitOpcode( INST_POP, envPtr); /* * Jump back to the test at the top of the loop. Generate a 4 byte jump if @@ -2270,12 +2277,8 @@ TclCompileEachloopCmd( */ envPtr->currStackDepth = savedStackDepth; - if (collectTemp >= 0) { - if (collectTemp <= 255) { - TclEmitInstInt1( INST_LOAD_SCALAR1, collectTemp, envPtr); - } else { - TclEmitInstInt4( INST_LOAD_SCALAR4, collectTemp, envPtr); - } + if (collect == TCL_EACH_COLLECT) { + Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); } else { PushLiteral(envPtr, "", 0); } @@ -3856,7 +3859,8 @@ TclCompileLmapCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - return TclCompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, 1); + return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_COLLECT); } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index df1fa37..c716ed2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2487,6 +2487,14 @@ typedef struct List { (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) /* + * Modes for collecting (or not) in the implementations of TclNRForeachCmd, + * TclNRLmapCmd and their compilations. + */ + +#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */ +#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ + +/* * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere, * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints. * @@ -2859,16 +2867,6 @@ struct Tcl_LoadHandle_ { #define TCL_DD_SHORTEST0 0x0 /* 'Shortest possible' after masking */ -/* Modes for collecting or accumulating in TclNREachloopCmd, - * TclCompileEachloopCmd and INST_FOREACH_STEP4. */ - -#define TCL_EACH_KEEP_NONE 0 - /* Discard iteration result like [foreach] */ - -#define TCL_EACH_COLLECT 1 - /* Collect iteration result like [lmap] */ - - /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: -- cgit v0.12 From d52dd4c19ba394378cc539de8daae266fe034307 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Oct 2012 14:54:31 +0000 Subject: ...and all the compilation and tests now work/pass --- generic/tclCompCmds.c | 55 +++--- generic/tclDictObj.c | 3 +- tests/dict.test | 54 ++++-- tests/lmap.test | 471 +++++++++++++++++++++++--------------------------- 4 files changed, 290 insertions(+), 293 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 13f479d..61f7988 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -854,6 +854,19 @@ CompileDictEachCmd( } /* + * Create temporary variable to capture return values from loop body when + * we're collecting results. + */ + + if (collect == TCL_EACH_COLLECT) { + collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, + envPtr); + if (collectVar < 0) { + return TCL_ERROR; + } + } + + /* * Check we've got a pair of variables and that they are local variables. * Then extract their indices in the LVT. */ @@ -903,23 +916,21 @@ CompileDictEachCmd( } /* - * Create temporary variable to capture return values from loop body. + * Preparation complete; issue instructions. Note that this code issues + * fixed-sized jumps. That simplifies things a lot! + * + * First up, initialize the accumulator dictionary if needed. */ if (collect == TCL_EACH_COLLECT) { - collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, - envPtr); - if (collectVar < 0) { - return TCL_ERROR; - } + PushLiteral(envPtr, "", 0); + Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* - * Preparation complete; issue instructions. Note that this code issues - * fixed-sized jumps. That simplifies things a lot! - * - * First up, get the dictionary and start the iteration. No catching of - * errors at this point. + * Get the dictionary and start the iteration. No catching of errors at + * this point. */ CompileWord(envPtr, dictTokenPtr, interp, 3); @@ -928,16 +939,6 @@ CompileDictEachCmd( TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); /* - * Initialize the accumulator dictionary, if needed. - */ - - if (collect == TCL_EACH_COLLECT) { - PushLiteral(envPtr, "", 0); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - - /* * Now we catch errors from here on so that we can finalize the search * started by Tcl_DictObjFirst above. */ @@ -973,7 +974,7 @@ CompileDictEachCmd( Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_DICT_SET, 1, envPtr); - TclEmitInt4( collectVar, envPtr); + TclEmitInt4( collectVar, envPtr); TclEmitOpcode( INST_POP, envPtr); } TclEmitOpcode( INST_POP, envPtr); @@ -1024,6 +1025,10 @@ CompileDictEachCmd( TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); + if (collect == TCL_EACH_COLLECT) { + TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( collectVar, envPtr); + } TclEmitOpcode( INST_RETURN_STK, envPtr); /* @@ -1039,7 +1044,7 @@ CompileDictEachCmd( TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Final stage of the command (normal case) is that we push an empty @@ -1052,6 +1057,8 @@ CompileDictEachCmd( envPtr->codeStart + endTargetOffset); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); + TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( collectVar, envPtr); } else { PushLiteral(envPtr, "", 0); } @@ -2279,6 +2286,8 @@ CompileEachloopCmd( envPtr->currStackDepth = savedStackDepth; if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); + TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( collectVar, envPtr); } else { PushLiteral(envPtr, "", 0); } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index dac4cbe..b64b776 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2619,6 +2619,7 @@ DictMapNRCmd( * internally so that updates, shimmering, etc are not a problem. */ + Tcl_IncrRefCount(storagePtr->accumulatorObj); Tcl_IncrRefCount(storagePtr->keyVarObj); Tcl_IncrRefCount(storagePtr->valueVarObj); Tcl_IncrRefCount(storagePtr->scriptObj); @@ -2707,7 +2708,7 @@ DictMapLoopCallback( Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done); if (done) { - Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, storagePtr->accumulatorObj); goto done; } diff --git a/tests/dict.test b/tests/dict.test index 398493a..aa22c00 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1543,15 +1543,17 @@ test dict-24.6 {dict map command: syntax} -returnCodes error -body { test dict-24.7 {dict map command: syntax} -returnCodes error -body { dict map "\{x" x x } -result {unmatched open brace in list} -test dict-24.8 {dict map command} -body { +test dict-24.8 {dict map command} -setup { + set values {} + set keys {} +} -body { # This test confirms that [dict keys], [dict values] and [dict map] # all traverse a dictionary in the same order. set dictv {a A b B c C} - set values {} - set keys [dict map {k v} $dictv { + dict map {k v} $dictv { + lappend keys $k lappend values $v - set k - }] + } set result [expr { $keys eq [dict keys $dictv] && $values eq [dict values $dictv] }] @@ -1614,19 +1616,33 @@ test dict-24.13 {dict map command: script results} { error "return didn't go far enough" }} } ok,a,b -test dict-24.14 {dict map command: handle representation loss} -body { - set dictVar {a b c d e f g h} +test dict-24.14 {dict map command: handle representation loss} -setup { + set keys {} set values {} - set keys [dict map {k v} $dictVar { +} -body { + set dictVar {a b c d e f g h} + list [dict size [dict map {k v} $dictVar { if {[llength $dictVar]} { + lappend keys $k lappend values $v return -level 0 $k } - }] - list [lsort $keys] [lsort $values] + }]] [lsort $keys] [lsort $values] } -cleanup { unset dictVar keys values k v -} -result {{a c e g} {b d f h}} +} -result {4 {a c e g} {b d f h}} +test dict-24.14a {dict map command: handle representation loss} -body { + apply {{} { + set dictVar {a b c d e f g h} + list [dict size [dict map {k v} $dictVar { + if {[llength $dictVar]} { + lappend keys $k + lappend values $v + return -level 0 $k + } + }]] [lsort $keys] [lsort $values] + }} +} -result {4 {a c e g} {b d f h}} test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup { unset -nocomplain accum array set accum {} @@ -1672,7 +1688,7 @@ test dict-24.17a {dict map command in compilation context} { dict set d $k 0 ;# Any modification will do } }} -} {{a 0}} +} {a {a 0}} test dict-24.18 {dict map command in compilation context} { # Bug 1382528 (dict for) apply {{} { @@ -1739,33 +1755,33 @@ test dict-24.22 {dict map results (non-compiled)} { dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { return -level 0 "$k,$v" } -} {{1 a,2 b} {3 c,4 d}} +} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} test dict-24.23 {dict map results (compiled)} { apply {{} { dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { return -level 0 "$k,$v" } }} -} {{1 a,2 b} {3 c,4 d}} +} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} test dict-24.23a {dict map results (compiled)} { apply {{list} { dict map {k v} [dict map {k v} $list { list $v $k }] { return -level 0 "$k,$v" } }} {a 1 b 2 c 3 d 4} -} {{1 a,2 b} {3 c,4 d}} +} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} test dict-24.24 {dict map with huge dict (non-compiled)} { - tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 1000000 x] x] { + tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 100000 x] x] { expr { $k * $v } }] -} 166666416666500000 +} 166666666600000 test dict-24.25 {dict map with huge dict (compiled)} { apply {{n} { tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat $n y] y] { expr { $k * $v } }] - }} 1000000 -} 166666416666500000 + }} 100000 +} 166666666600000 # cleanup diff --git a/tests/lmap.test b/tests/lmap.test index dc5053f..7baa77b 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -13,20 +13,16 @@ # # RCS: @(#) $Id: $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset a} -catch {unset i} -catch {unset x} - -# ----- Non-compiled operation ------------------------------------------------- - +unset -nocomplain a i x + +# ----- Non-compiled operation ----------------------------------------------- # Basic "lmap" operation (non-compiled) - test lmap-1.1 {basic lmap tests} { set a {} lmap i {a b c d} { @@ -40,62 +36,53 @@ test lmap-1.2 {basic lmap tests} { } {a b {{c d} e} {123 {{x}}}} test lmap-1.2a {basic lmap tests} { lmap i {a b {{c d} e} {123 {{x}}}} { - return -level 0 $i + return -level 0 $i } } {a b {{c d} e} {123 {{x}}}} -test lmap-1.3 {basic lmap tests} {catch {lmap} msg} 1 -test lmap-1.4 {basic lmap tests} { - catch {lmap} msg - set msg -} {wrong # args: should be "lmap varList list ?varList list ...? command"} -test lmap-1.5 {basic lmap tests} {catch {lmap i} msg} 1 -test lmap-1.6 {basic lmap tests} { - catch {lmap i} msg - set msg -} {wrong # args: should be "lmap varList list ?varList list ...? command"} -test lmap-1.7 {basic lmap tests} {catch {lmap i j} msg} 1 -test lmap-1.8 {basic lmap tests} { - catch {lmap i j} msg - set msg -} {wrong # args: should be "lmap varList list ?varList list ...? command"} -test lmap-1.9 {basic lmap tests} {catch {lmap i j k l} msg} 1 -test lmap-1.10 {basic lmap tests} { - catch {lmap i j k l} msg - set msg -} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.4 {basic lmap tests} -returnCodes error -body { + lmap +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.6 {basic lmap tests} -returnCodes error -body { + lmap i +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.8 {basic lmap tests} -returnCodes error -body { + lmap i j +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.10 {basic lmap tests} -returnCodes error -body { + lmap i j k l +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} test lmap-1.11 {basic lmap tests} { lmap i {} { - set i + set i } } {} test lmap-1.12 {basic lmap tests} { lmap i {} { - return -level 0 x + return -level 0 x } } {} -test lmap-1.13 {lmap errors} { - list [catch {lmap {{a}{b}} {1 2 3} {}} msg] $msg -} {1 {list element in braces followed by "{b}" instead of space}} -test lmap-1.14 {lmap errors} { - list [catch {lmap a {{1 2}3} {}} msg] $msg -} {1 {list element in braces followed by "3" instead of space}} -catch {unset a} -test lmap-1.15 {lmap errors} { - catch {unset a} +test lmap-1.13 {lmap errors} -returnCodes error -body { + lmap {{a}{b}} {1 2 3} {} +} -result {list element in braces followed by "{b}" instead of space} +test lmap-1.14 {lmap errors} -returnCodes error -body { + lmap a {{1 2}3} {} +} -result {list element in braces followed by "3" instead of space} +unset -nocomplain a +test lmap-1.15 {lmap errors} -setup { + unset -nocomplain a +} -body { set a(0) 44 list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo -} {1 {can't set "a": variable is array} {can't set "a": variable is array - (setting foreach loop variable "a") +} -result {1 {can't set "a": variable is array} {can't set "a": variable is array + (setting lmap loop variable "a") invoked from within "lmap a {1 2 3} {}"}} -test lmap-1.16 {lmap errors} { - list [catch {lmap {} {} {}} msg] $msg -} {1 {foreach varlist is empty}} -catch {unset a} - +test lmap-1.16 {lmap errors} -returnCodes error -body { + lmap {} {} {} +} -result {lmap varlist is empty} +unset -nocomplain a # Parallel "lmap" operation (non-compiled) - test lmap-2.1 {parallel lmap tests} { lmap {a b} {1 2 3 4} { list $b $a @@ -137,23 +124,22 @@ test lmap-2.8 {parallel lmap tests} { } } {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} test lmap-2.9 {lmap only sets vars if repeating loop} { - namespace eval ::lmap_test { - set rgb {65535 0 0} - lmap {r g b} [set rgb] {} - set ::x "r=$r, g=$g, b=$b" - } - namespace delete ::lmap_test - set x + namespace eval ::lmap_test { + set rgb {65535 0 0} + lmap {r g b} [set rgb] {} + set ::x "r=$r, g=$g, b=$b" + } + namespace delete ::lmap_test + set x } {r=65535, g=0, b=0} -test lmap-2.10 {lmap only supports local scalar variables} { - catch { unset a } - lmap {a(3)} {1 2 3 4} {set {a(3)}} -} {1 2 3 4} -catch { unset a } - +test lmap-2.10 {lmap only supports local scalar variables} -setup { + unset -nocomplain a +} -body { + lmap {a(3)} {1 2 3 4} {set {a(3)}} +} -result {1 2 3 4} +unset -nocomplain a # "lmap" with "continue" and "break" (non-compiled) - test lmap-3.1 {continue tests} { lmap i {a b c d} { if {[string compare $i "b"] == 0} continue @@ -171,149 +157,139 @@ test lmap-3.2 {continue tests} { test lmap-3.3 {break tests} { set x 0 list [lmap i {a b c d} { - incr x + incr x if {[string compare $i "c"] == 0} break set i }] $x } {{a b} 3} # Check for bug similar to #406709 test lmap-3.4 {break tests} { - set a 1 - lmap b b {list [concat a; break]; incr a} - incr a + set a 1 + lmap b b {list [concat a; break]; incr a} + incr a } {2} - -# ----- Compiled operation ------------------------------------------------------ +# ----- Compiled operation --------------------------------------------------- # Basic "lmap" operation (compiled) - test lmap-4.1 {basic lmap tests} { - apply {{} { - set a {} - lmap i {a b c d} { - set a [concat $a $i] - } - }} + apply {{} { + set a {} + lmap i {a b c d} { + set a [concat $a $i] + } + }} } {a {a b} {a b c} {a b c d}} test lmap-4.2 {basic lmap tests} { - apply {{} { - lmap i {a b {{c d} e} {123 {{x}}}} { - set i - } - }} + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + set i + } + }} } {a b {{c d} e} {123 {{x}}}} test lmap-4.2a {basic lmap tests} { - apply {{} { - lmap i {a b {{c d} e} {123 {{x}}}} { - return -level 0 $i - } - }} + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } + }} } {a b {{c d} e} {123 {{x}}}} -test lmap-4.3 {basic lmap tests} {catch { apply {{} { lmap }} } msg} 1 -test lmap-4.4 {basic lmap tests} { - catch { apply {{} { lmap }} } msg - set msg -} {wrong # args: should be "lmap varList list ?varList list ...? command"} -test lmap-4.5 {basic lmap tests} {catch { apply {{} { lmap i }} } msg} 1 -test lmap-4.6 {basic lmap tests} { - catch { apply {{} { lmap i }} } msg - set msg -} {wrong # args: should be "lmap varList list ?varList list ...? command"} -test lmap-4.7 {basic lmap tests} {catch { apply {{} { lmap i j }} } msg} 1 -test lmap-4.8 {basic lmap tests} { - catch { apply {{} { lmap i j }} } msg - set msg -} {wrong # args: should be "lmap varList list ?varList list ...? command"} -test lmap-4.9 {basic lmap tests} {catch { apply {{} { lmap i j k l }} } msg} 1 -test lmap-4.10 {basic lmap tests} { - catch { apply {{} { lmap i j k l }} } msg - set msg -} {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.4 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.6 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap i }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.8 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap i j }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.10 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap i j k l }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} test lmap-4.11 {basic lmap tests} { - apply {{} { lmap i {} { set i } }} + apply {{} { lmap i {} { set i } }} } {} test lmap-4.12 {basic lmap tests} { - apply {{} { lmap i {} { return -level 0 x } }} + apply {{} { lmap i {} { return -level 0 x } }} } {} -test lmap-4.13 {lmap errors} { - list [catch { apply {{} { lmap {{a}{b}} {1 2 3} {} }} } msg] $msg -} {1 {list element in braces followed by "{b}" instead of space}} -test lmap-4.14 {lmap errors} { - list [catch { apply {{} { lmap a {{1 2}3} {} }} } msg] $msg -} {1 {list element in braces followed by "3" instead of space}} -catch {unset a} +test lmap-4.13 {lmap errors} -returnCodes error -body { + apply {{} { lmap {{a}{b}} {1 2 3} {} }} +} -result {list element in braces followed by "{b}" instead of space} +test lmap-4.14 {lmap errors} -returnCodes error -body { + apply {{} { lmap a {{1 2}3} {} }} +} -result {list element in braces followed by "3" instead of space} +unset -nocomplain a test lmap-4.15 {lmap errors} { apply {{} { - set a(0) 44 - list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo + set a(0) 44 + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo }} } {1 {can't set "a": variable is array} {can't set "a": variable is array while executing "lmap a {1 2 3} {}"}} -test lmap-4.16 {lmap errors} { - list [catch { apply {{} { lmap {} {} {} }} } msg] $msg -} {1 {foreach varlist is empty}} -catch {unset a} - +test lmap-4.16 {lmap errors} -returnCodes error -body { + apply {{} { + lmap {} {} {} + }} +} -result {lmap varlist is empty} +unset -nocomplain a # Parallel "lmap" operation (compiled) - test lmap-5.1 {parallel lmap tests} { - apply {{} { - lmap {a b} {1 2 3 4} { - list $b $a - } - }} + apply {{} { + lmap {a b} {1 2 3 4} { + list $b $a + } + }} } {{2 1} {4 3}} test lmap-5.2 {parallel lmap tests} { - apply {{} { - lmap {a b} {1 2 3 4 5} { - list $b $a - } - }} + apply {{} { + lmap {a b} {1 2 3 4 5} { + list $b $a + } + }} } {{2 1} {4 3} {{} 5}} test lmap-5.3 {parallel lmap tests} { - apply {{} { - lmap a {1 2 3} b {4 5 6} { - list $b $a - } - }} + apply {{} { + lmap a {1 2 3} b {4 5 6} { + list $b $a + } + }} } {{4 1} {5 2} {6 3}} test lmap-5.4 {parallel lmap tests} { - apply {{} { - lmap a {1 2 3} b {4 5 6 7 8} { - list $b $a - } - }} + apply {{} { + lmap a {1 2 3} b {4 5 6 7 8} { + list $b $a + } + }} } {{4 1} {5 2} {6 3} {7 {}} {8 {}}} test lmap-5.5 {parallel lmap tests} { - apply {{} { - lmap {a b} {a b A B aa bb} c {c C cc CC} { - list $a $b $c - } - }} + apply {{} { + lmap {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } + }} } {{a b c} {A B C} {aa bb cc} {{} {} CC}} test lmap-5.6 {parallel lmap tests} { - apply {{} { - lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { - list $a$b$c$d$e - } - }} + apply {{} { + lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } + }} } {11111 22222 33333} test lmap-5.7 {parallel lmap tests} { - apply {{} { - lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { - set x $a$b$c$d$e - } - }} + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } + }} } {{1111 2} 222 33 4} test lmap-5.8 {parallel lmap tests} { - apply {{} { - lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { - join [list $a $b $c $d $e] . - } - }} + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } + }} } {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} test lmap-5.9 {lmap only sets vars if repeating loop} { apply {{} { @@ -328,34 +304,32 @@ test lmap-5.10 {lmap only supports local scalar variables} { }} } {1 2 3 4} - # "lmap" with "continue" and "break" (compiled) - test lmap-6.1 {continue tests} { - apply {{} { - lmap i {a b c d} { - if {[string compare $i "b"] == 0} continue - set i - } - }} + apply {{} { + lmap i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } + }} } {a c d} test lmap-6.2 {continue tests} { - apply {{} { - list [lmap i {a b c d} { - incr x - if {[string compare $i "b"] != 0} continue - set i - }] $x - }} + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x + }} } {b 4} test lmap-6.3 {break tests} { - apply {{} { - list [lmap i {a b c d} { - incr x - if {[string compare $i "c"] == 0} break - set i - }] $x - }} + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x + }} } {{a b} 3} # Check for bug similar to #406709 test lmap-6.4 {break tests} { @@ -366,13 +340,10 @@ test lmap-6.4 {break tests} { }} } {2} - - -# ----- Special cases and bugs ------------------------------------------------- - - -test lmap-7.1 {compiled lmap backward jump works correctly} { - catch {unset x} +# ----- Special cases and bugs ----------------------------------------------- +test lmap-7.1 {compiled lmap backward jump works correctly} -setup { + unset -nocomplain x +} -body { array set x {0 zero 1 one 2 two 3 three} lsort [apply {{arrayName} { upvar 1 $arrayName a @@ -380,16 +351,15 @@ test lmap-7.1 {compiled lmap backward jump works correctly} { list $member [set a($member)] } }} x] -} [lsort {{0 zero} {1 one} {2 two} {3 three}}] - -test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} { - catch {unset x} +} -result [lsort {{0 zero} {1 one} {2 two} {3 three}}] +test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} -setup { + unset -nocomplain x +} -body { lmap {12.0} {a b c} { set x 12.0 set x [expr $x + 1] } -} {13.0 13.0 13.0} - +} -result {13.0 13.0 13.0} # Test for incorrect "double evaluation" semantics test lmap-7.3 {delayed substitution of body} { apply {{} { @@ -397,10 +367,9 @@ test lmap-7.3 {delayed substitution of body} { lmap a [list 1 2 3] " set x $a " - set x + return $x }} } {0} - # Related to "foreach" test for [Bug 1189274]; crash on failure test lmap-7.4 {empty list handling} { proc crash {} { @@ -411,17 +380,18 @@ test lmap-7.4 {empty list handling} { } crash } {{aa = x bb = } {aa = y bb = } {aa = z bb = }} - -# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled version -test lmap-7.5 {compiled empty var list} { +# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled +# version. +test lmap-7.5 {compiled empty var list} -returnCodes error -body { proc foo {} { lmap {} x { error "reached body" } } - list [catch { foo } msg] $msg -} {1 {foreach varlist is empty}} - + foo +} -cleanup { + catch {rename foo ""} +} -result {lmap varlist is empty} test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup { proc demo {} { set vals {1 2 3 4} @@ -433,61 +403,62 @@ test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup { } -cleanup { rename demo {} } -result {2 4} - # Huge lists must not overflow the bytecode interpreter (development bug) test lmap-7.7 {huge list non-compiled} { - set x [lmap a [lrepeat 1000000 x] { set b y$a }] - list $b [llength $x] [string length $x] + set x [lmap a [lrepeat 1000000 x] { set b y$a }] + list $b [llength $x] [string length $x] } {yx 1000000 2999999} - test lmap-7.8 {huge list compiled} { - set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000] - list $b [llength $x] [string length $x] + set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000] + list $b [llength $x] [string length $x] } {yx 1000000 2999999} - test lmap-7.9 {error then dereference loop var (dev bug)} { - catch { lmap a 0 b {1 2 3} { error x } } - set a + catch { lmap a 0 b {1 2 3} { error x } } + set a } 0 test lmap-7.9a {error then dereference loop var (dev bug)} { - catch { lmap a 0 b {1 2 3} { incr a $b; error x } } - set a + catch { lmap a 0 b {1 2 3} { incr a $b; error x } } + set a } 1 -# ----- Coroutines ------------------------------------------------------------- - -test lmap-8.1 {lmap non-compiled with coroutines} { - coroutine coro apply {{} { - set values [yield [info coroutine]] - eval lmap i [list $values] {{ yield $i }} - }} ;# returns 'coro' - coro {a b c d e f} ;# -> a - coro 1 ;# -> b - coro 2 ;# -> c - coro 3 ;# -> d - coro 4 ;# -> e - coro 5 ;# -> f - list [coro 6] [info commands coro] -} {{1 2 3 4 5 6} {}} - -test lmap-8.2 {lmap compiled with coroutines} { - coroutine coro apply {{} { - set values [yield [info coroutine]] - lmap i $values { yield $i } - }} ;# returns 'coro' - coro {a b c d e f} ;# -> a - coro 1 ;# -> b - coro 2 ;# -> c - coro 3 ;# -> d - coro 4 ;# -> e - coro 5 ;# -> f - list [coro 6] [info commands coro] -} {{1 2 3 4 5 6} {}} - - +# ----- Coroutines ----------------------------------------------------------- +test lmap-8.1 {lmap non-compiled with coroutines} -body { + coroutine coro apply {{} { + set values [yield [info coroutine]] + eval lmap i [list $values] {{ yield $i }} + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} -cleanup { + catch {rename coro ""} +} -result {{1 2 3 4 5 6} {}} +test lmap-8.2 {lmap compiled with coroutines} -body { + coroutine coro apply {{} { + set values [yield [info coroutine]] + lmap i $values { yield $i } + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} -cleanup { + catch {rename coro ""} +} -result {{1 2 3 4 5 6} {}} + # cleanup -catch {unset a} -catch {unset x} +unset -nocomplain a x catch {rename foo {}} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From 1484ae31ede8ff92efccc22d56f4ff71806cc55d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 5 Oct 2012 16:37:27 +0000 Subject: 3574819 Increase test robustness by creating files in fresh directory to reduce trouble with any existing files in an existing directory. --- tests/fileName.test | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/fileName.test b/tests/fileName.test index 6dd1cb4..51f00d1 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -749,7 +749,7 @@ test filename-11.13 {Tcl_GlobCmd} { } [file join $env(HOME)] set oldpwd [pwd] set oldhome $env(HOME) -cd [temporaryDirectory] +catch {cd [makeDirectory tcl[pid]]} set env(HOME) [pwd] file delete -force globTest file mkdir globTest/a1/b1 @@ -1616,6 +1616,7 @@ catch {file delete -force C:/globTest} cd [temporaryDirectory] file delete -force globTest cd $oldpwd +catch {removeDirectory tcl[pid]} set env(HOME) $oldhome if {[testConstraint testsetplatform]} { testsetplatform $platform -- cgit v0.12 From cf9cce374ed8d3bc405f998d01d9965d224bc482 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 6 Oct 2012 06:13:09 +0000 Subject: [Bug 2459774] win/tcl/Makefile.in not compatible with msys 0.8. --- ChangeLog | 5 +++++ win/Makefile.in | 28 +++++++++++----------------- 2 files changed, 16 insertions(+), 17 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5ee0b79..6f96a5a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-10-06 Jan Nijtmans + + * win/Makefile.in: [Bug 2459774] win/tcl/Makefile.in + not compatible with msys 0.8. + 2012-10-03 Don Porter * generic/tclIO.c: When checking for std channels being closed, diff --git a/win/Makefile.in b/win/Makefile.in index b616737..fad1f09 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -90,7 +90,7 @@ COMPILE_DEBUG_FLAGS = SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. -TOP_DIR = $(shell cd @srcdir@/..; pwd) +TOP_DIR = $(shell cd @srcdir@/..; pwd -P) GENERIC_DIR = $(TOP_DIR)/generic TOMMATH_DIR = $(TOP_DIR)/libtommath WIN_DIR = $(TOP_DIR)/win @@ -112,7 +112,7 @@ ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)' | sed 's!\\!/!g') # Fully qualify library path so that `make test` # does not depend on the current directory. -LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd) +LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P) LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)' | sed 's!\\!/!g') DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ @@ -439,12 +439,6 @@ ${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @POST_MAKE_LIB@ -# assume GNU make - -# To enable concurrent parallel make of tcl.dll and tcl.lib, the tcl.dll -# targets have to depend on tcl.lib, this ensures that linking of tcl.dll -# does not execute concurrently with the renaming and recompiling of tcl.lib - ${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE} @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) @@ -544,9 +538,9 @@ gendate: # run (and the results checked) after updating to a new release of libtommath. gentommath_h: - $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\fix_tommath_h.tcl" \ - "$(TOMMATH_DIR_NATIVE)\tommath.h" \ - > "$(GENERIC_DIR_NATIVE)\tclTomMath.h" + $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/fix_tommath_h.tcl" \ + "$(TOMMATH_DIR_NATIVE)/tommath.h" \ + > "$(GENERIC_DIR_NATIVE)/tclTomMath.h" install: all install-binaries install-libraries install-doc install-packages @@ -748,7 +742,7 @@ PKG_CFG_ARGS = @PKG_CFG_ARGS@ PKG_DIR = ./pkgs packages: - @builddir=`pwd`; \ + @builddir=`pwd -P`; \ for i in $(PKGS_DIR)/*; do \ if [ -d $$i ] ; then \ if [ -x $$i/configure ] ; then \ @@ -756,7 +750,7 @@ packages: mkdir -p $(PKG_DIR)/$$pkg; \ if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \ ( cd $(PKG_DIR)/$$pkg; \ - echo "Configuring package '$$i' wd = `pwd`"; \ + echo "Configuring package '$$i' wd = `pwd -P`"; \ $$i/configure --with-tcl=$(PWD) --with-tclinclude=$(GENERIC_DIR) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \ fi ; \ echo "Building package '$$pkg'"; \ @@ -767,7 +761,7 @@ packages: cd $$builddir install-packages: packages - @builddir=`pwd`; \ + @builddir=`pwd -P`; \ for i in $(PKGS_DIR)/*; do \ if [ -d $$i ]; then \ pkg=`basename $$i`; \ @@ -780,7 +774,7 @@ install-packages: packages cd $$builddir test-packages: tcltest packages - @builddir=`pwd`; \ + @builddir=`pwd -P`; \ for i in $(PKGS_DIR)/*; do \ if [ -d $$i ]; then \ pkg=`basename $$i`; \ @@ -793,7 +787,7 @@ test-packages: tcltest packages cd $$builddir clean-packages: - @builddir=`pwd`; \ + @builddir=`pwd -P`; \ for i in $(PKGS_DIR)/*; do \ if [ -d $$i ]; then \ pkg=`basename $$i`; \ @@ -805,7 +799,7 @@ clean-packages: cd $$builddir distclean-packages: - @builddir=`pwd`; \ + @builddir=`pwd -P`; \ for i in $(PKGS_DIR)/*; do \ if [ -d $$i ]; then \ pkg=`basename $$i`; \ -- cgit v0.12 From 787d71bc6d8d517220c6b301345bf816bcecab2f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 13 Oct 2012 20:26:00 +0000 Subject: Bug 3576509: tcl::Bgerror crashes with invalid arguments --- ChangeLog | 5 +++++ generic/tclEvent.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index ee36258..ba075d7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-10-13 Jan Nijtmans + + * generic/tclEvent.c: [Bug 3576509]: tcl::Bgerror crashes with invalid + arguments + 2012-10-03 Don Porter * generic/tclIO.c: When checking for std channels being closed, diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 7daa7bb..1d72a0a 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -309,7 +309,7 @@ TclDefaultBgErrorHandlerObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tcl_Obj *keyPtr, *valuePtr; + Tcl_Obj *keyPtr, *valuePtr = NULL; Tcl_Obj *tempObjv[2]; int code, level; Tcl_InterpState saved; -- cgit v0.12 From bd2bdd6f8a4571b486ba30fbf686af3eb82ee6bc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 14 Oct 2012 19:00:39 +0000 Subject: Bug 357650: Better fix, which helps for all Tcl_DictObjGet() calls in Tcl's source code. --- ChangeLog | 6 ++++++ generic/tclDictObj.c | 1 + generic/tclEvent.c | 2 +- 3 files changed, 8 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index ba075d7..3793786 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-10-14 Jan Nijtmans + + * generic/tclDictObj.c: [Bug 3576509]: tcl::Bgerror crashes with invalid + * generic/tclEvent.c: arguments. Better fix, which helps for all + Tcl_DictObjGet() calls in Tcl's source code. + 2012-10-13 Jan Nijtmans * generic/tclEvent.c: [Bug 3576509]: tcl::Bgerror crashes with invalid diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 8f3ce3a..b066d46 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -941,6 +941,7 @@ Tcl_DictObjGet( if (dictPtr->typePtr != &tclDictType) { int result = SetDictFromAny(interp, dictPtr); if (result != TCL_OK) { + *valuePtrPtr = NULL; return result; } } diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 1d72a0a..7daa7bb 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -309,7 +309,7 @@ TclDefaultBgErrorHandlerObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tcl_Obj *keyPtr, *valuePtr = NULL; + Tcl_Obj *keyPtr, *valuePtr; Tcl_Obj *tempObjv[2]; int code, level; Tcl_InterpState saved; -- cgit v0.12