diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 2 | ||||
| -rw-r--r-- | generic/tcl.h | 2 | ||||
| -rw-r--r-- | generic/tclConfig.c | 2 | ||||
| -rw-r--r-- | generic/tclEncoding.c | 55 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 2 | ||||
| -rw-r--r-- | generic/tclInt.decls | 2 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 4 | ||||
| -rw-r--r-- | generic/tclLoad.c | 284 | ||||
| -rw-r--r-- | generic/tclPkgConfig.c | 2 | ||||
| -rw-r--r-- | generic/tclTest.c | 2 | ||||
| -rw-r--r-- | generic/tclZipfs.c | 199 |
11 files changed, 365 insertions, 191 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 790d9fb..293368d 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -888,7 +888,7 @@ declare 243 { } # Removed in 9.0 (stub entry only) #declare 244 { -# void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, +# void Tcl_StaticPackage(Tcl_Interp *interp, const char *prefix, # Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) #} # Removed in 9.0 (stub entry only) diff --git a/generic/tcl.h b/generic/tcl.h index b02efcf..fbad71c 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2189,7 +2189,7 @@ EXTERN void Tcl_FindExecutable(const char *argv0); EXTERN void Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *panicProc); EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, - const char *pkgName, + const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 85e05e9..09b1b27 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -178,7 +178,7 @@ Tcl_RegisterConfig( * QueryConfigObjCmd -- * * Implementation of "::<package>::pkgconfig", the command to query - * configuration information embedded into a binary library. + * configuration information embedded into a library. * * Results: * A standard tcl result. diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 70dc321..a1b6fe5 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -512,7 +512,7 @@ FillEncodingFileMap(void) /* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */ #define TCL_ENCODING_LE 0x40 /* Little-endian encoding */ -#define TCL_ENCODING_EXTERNAL 0x80 /* Converting from internal to external variant */ +#define TCL_ENCODING_EXTERNAL 0x80 /* Converting from internal to external variant */ void TclInitEncodingSubsystem(void) @@ -1266,8 +1266,8 @@ Tcl_UtfToExternalDString( flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags | TCL_ENCODING_EXTERNAL, &state, dst, dstLen, &srcRead, &dstWrote, - &dstChars); + srcLen, flags | TCL_ENCODING_EXTERNAL, &state, dst, dstLen, + &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); if (result != TCL_CONVERT_NOSPACE) { @@ -1368,8 +1368,8 @@ Tcl_UtfToExternal( dstLen -= encodingPtr->nullSize; result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, - flags | TCL_ENCODING_EXTERNAL, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, - dstCharsPtr); + flags | TCL_ENCODING_EXTERNAL, statePtr, dst, dstLen, srcReadPtr, + dstWrotePtr, dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; } @@ -2182,23 +2182,32 @@ UtfToUtfProc( /* * Always check before using TclUtfToUCS4. Not doing can so * cause it run beyond the end of the buffer! If we happen such an - * incomplete char its bytes are made to represent themselves. + * incomplete char its bytes are made to represent themselves + * unless the user has explicitly asked to be told. */ + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_MULTIBYTE; + break; + } ch = UCHAR(*src); src += 1; dst += Tcl_UniCharToUtf(ch, dst); } else { src += TclUtfToUCS4(src, &ch); if ((ch | 0x7FF) == 0xDFFF) { - /* A surrogate character is detected, handle especially */ + /* + * A surrogate character is detected, handle especially. + */ + int low = ch; size_t len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; + if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { - *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); - *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); - *dst++ = (char) ((ch | 0x80) & 0xBF); - continue; + *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); + *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); + *dst++ = (char) ((ch | 0x80) & 0xBF); + continue; } src += len; dst += Tcl_UniCharToUtf(ch, dst); @@ -2264,13 +2273,21 @@ Utf16ToUtfProc( } result = TCL_OK; - /* check alignment with utf-16 (2 == sizeof(UTF-16)) */ + /* + * Check alignment with utf-16 (2 == sizeof(UTF-16)) + */ + if ((srcLen % 2) != 0) { result = TCL_CONVERT_MULTIBYTE; srcLen--; } - /* If last code point is a high surrogate, we cannot handle that yet */ - if ((srcLen >= 2) && ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) { + + /* + * If last code point is a high surrogate, we cannot handle that yet. + */ + + if ((srcLen >= 2) && + ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) { result = TCL_CONVERT_MULTIBYTE; srcLen-= 2; } @@ -2292,10 +2309,12 @@ Utf16ToUtfProc( } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); } + /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. */ + if (ch && ch < 0x80) { *dst++ = (ch & 0xFF); } else { @@ -2905,7 +2924,9 @@ Iso88591FromUtfProc( break; } #if TCL_UTF_MAX <= 3 - if ((ch >= 0xD800) && (len < 3)) len = 4; + if ((ch >= 0xD800) && (len < 3)) { + len = 4; + } #endif /* * Plunge on, using '?' as a fallback character. @@ -2950,7 +2971,7 @@ TableFreeProc( ClientData clientData) /* TableEncodingData that specifies * encoding. */ { - TableEncodingData *dataPtr = (TableEncodingData *)clientData; + TableEncodingData *dataPtr = (TableEncodingData *) clientData; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] @@ -3008,7 +3029,7 @@ EscapeToUtfProc( * correspond to the bytes stored in the * output buffer. */ { - EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; + EscapeEncodingData *dataPtr = (EscapeEncodingData *) clientData; const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd; const unsigned short *const *tableToUnicode; const Encoding *encodingPtr; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 3a9e07f..b665589 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -1237,7 +1237,6 @@ PrintUsage( int width, numSpaces; #define NUM_SPACES 20 static const char spaces[] = " "; - char tmp[TCL_DOUBLE_SPACE]; Tcl_Obj *msg; /* @@ -1287,7 +1286,6 @@ PrintUsage( case TCL_ARGV_FLOAT: Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g", *((double *) infoPtr->dstPtr)); - sprintf(tmp, "%g", *((double *) infoPtr->dstPtr)); break; case TCL_ARGV_STRING: { char *string = *((char **) infoPtr->dstPtr); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index eb18fd8..99d2aaa 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -577,7 +577,7 @@ declare 256 { Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } declare 257 { - void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, + void TclStaticPackage(Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index fc0a9a3..e57b295 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -573,7 +573,7 @@ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Obj *part2Ptr, const int flags); /* 257 */ EXTERN void TclStaticPackage(Tcl_Interp *interp, - const char *pkgName, + const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 258 */ @@ -844,7 +844,7 @@ typedef struct TclIntStubs { Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ - void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ + void (*tclStaticPackage) (Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 259 */ } TclIntStubs; diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 364e97b..0a38249 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -13,19 +13,19 @@ #include "tclInt.h" /* - * The following structure describes a package that has been loaded either + * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call - * to TclGetLoadedPackages). All such packages are linked together into a - * single list for the process. Packages are never unloaded, until the + * to Tcl_StaticPackage). All such libraries are linked together into a + * single list for the process. Library are never unloaded, until the * application exits, when TclFinalizeLoad is called, and these structures are * freed. */ typedef struct LoadedPackage { - char *fileName; /* Name of the file from which the package was - * loaded. An empty string means the package + char *fileName; /* Name of the file from which the library was + * loaded. An empty string means the library * is loaded statically. Malloc-ed. */ - char *packageName; /* Name of package prefix for the package, + char *prefix; /* Prefix for the library, * properly capitalized (first letter UC, * others LC), no "_", as in "Net". * Malloc-ed. */ @@ -35,57 +35,57 @@ typedef struct LoadedPackage { * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; /* Initialization function to call to - * incorporate this package into a trusted + * incorporate this library into a trusted * interpreter. */ Tcl_PackageInitProc *safeInitProc; /* Initialization function to call to - * incorporate this package into a safe + * incorporate this library into a safe * interpreter (one that will execute - * untrusted scripts). NULL means the package + * untrusted scripts). NULL means the library * can't be used in unsafe interpreters. */ Tcl_PackageUnloadProc *unloadProc; - /* Finalisation function to unload a package + /* Finalization function to unload a library * from a trusted interpreter. NULL means that - * the package cannot be unloaded. */ + * the library cannot be unloaded. */ Tcl_PackageUnloadProc *safeUnloadProc; - /* Finalisation function to unload a package + /* Finalization function to unload a library * from a safe interpreter. NULL means that - * the package cannot be unloaded. */ - int interpRefCount; /* How many times the package has been loaded + * the library cannot be unloaded. */ + int interpRefCount; /* How many times the library has been loaded * in trusted interpreters. */ - int safeInterpRefCount; /* How many times the package has been loaded + int safeInterpRefCount; /* How many times the library has been loaded * in safe interpreters. */ struct LoadedPackage *nextPtr; - /* Next in list of all packages loaded into + /* Next in list of all libraries loaded into * this application process. NULL means end of * list. */ } LoadedPackage; /* * TCL_THREADS - * There is a global list of packages that is anchored at firstPackagePtr. + * There is a global list of libraries that is anchored at firstPackagePtr. * Access to this list is governed by a mutex. */ static LoadedPackage *firstPackagePtr = NULL; - /* First in list of all packages loaded into + /* First in list of all libraries loaded into * this process. */ TCL_DECLARE_MUTEX(packageMutex) /* - * The following structure represents a particular package that has been + * The following structure represents a particular library that has been * incorporated into a particular interpreter (by calling its initialization * function). There is a list of these structures for each interpreter, with * an AssocData value (key "load") for the interpreter that points to the - * first package (if any). + * first library (if any). */ typedef struct InterpPackage { LoadedPackage *pkgPtr; /* Points to detailed information about - * package. */ + * library. */ struct InterpPackage *nextPtr; - /* Next package in this interpreter, or NULL + /* Next library in this interpreter, or NULL * for end of list. */ } InterpPackage; @@ -122,13 +122,13 @@ Tcl_LoadObjCmd( { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp, initName, safeInitName; + Tcl_DString pfx, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; const char *symbols[2]; Tcl_PackageInitProc *initProc; - const char *p, *fullFileName, *packageName; + const char *p, *fullFileName, *prefix; Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; size_t len; @@ -159,7 +159,7 @@ Tcl_LoadObjCmd( } } if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { @@ -167,23 +167,23 @@ Tcl_LoadObjCmd( } fullFileName = TclGetString(objv[1]); - Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&pfx); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); Tcl_DStringInit(&unloadName); Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc >= 3) { - packageName = TclGetString(objv[2]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = TclGetString(objv[2]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -191,7 +191,7 @@ Tcl_LoadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -206,39 +206,39 @@ Tcl_LoadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * only no statically loaded library with the same prefix. */ Tcl_MutexLock(&packageMutex); defaultPtr = NULL; for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if (packageName == NULL) { + if (prefix == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + TclDStringClear(&pfx); + Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_DStringAppend(&tmp, pkgPtr->prefix, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pfx)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { + Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + TclDStringClear(&pfx); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { @@ -246,12 +246,12 @@ Tcl_LoadObjCmd( } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* - * Can't have two different packages loaded from the same file. + * Can't have two different libraries loaded from the same file. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" is already loaded for package \"%s\"", - fullFileName, pkgPtr->packageName)); + "file \"%s\" is already loaded for prefix \"%s\"", + fullFileName, pkgPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "SPLITPERSONALITY", NULL); code = TCL_ERROR; @@ -265,8 +265,8 @@ Tcl_LoadObjCmd( } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then * there's nothing for us to do. */ @@ -283,12 +283,12 @@ Tcl_LoadObjCmd( if (pkgPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error - * if the desired package is a static one. + * if the desired library is a static one. */ if (fullFileName[0] == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" isn't loaded statically", packageName)); + "no library with prefix \"%s\" is loaded statically", prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", NULL); code = TCL_ERROR; @@ -296,11 +296,11 @@ Tcl_LoadObjCmd( } /* - * Figure out the module name if it wasn't provided explicitly. + * Figure out the prefix if it wasn't provided explicitly. */ - if (packageName != NULL) { - Tcl_DStringAppend(&pkgName, packageName, -1); + if (prefix != NULL) { + Tcl_DStringAppend(&pfx, prefix, -1); } else { Tcl_Obj *splitPtr, *pkgGuessPtr; int pElements; @@ -311,11 +311,11 @@ Tcl_LoadObjCmd( */ /* - * The platform-specific code couldn't figure out the module - * name. Make a guess by taking the last element of the file - * name, stripping off any leading "lib", and then using all - * of the alphabetic and underline characters that follow - * that. + * The platform-specific code couldn't figure out the prefix. + * Make a guess by taking the last element of the file + * name, stripping off any leading "lib" and/or "tcl", and + * then using all of the alphabetic and underline characters + * that follow that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); @@ -346,42 +346,42 @@ Tcl_LoadObjCmd( if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't figure out package name for %s", + "couldn't figure out prefix for %s", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATPACKAGE", NULL); + "WHATLIBRARY", NULL); code = TCL_ERROR; goto done; } - Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); + Tcl_DStringAppend(&pfx, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); } /* - * Fix the capitalization in the package name so that the first + * Fix the capitalization in the prefix so that the first * character is in caps (or title case) but the others are all * lower-case. */ - Tcl_DStringSetLength(&pkgName, - Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); + Tcl_DStringSetLength(&pfx, + Tcl_UtfToTitle(Tcl_DStringValue(&pfx))); /* * Compute the names of the two initialization functions, based on the - * package name. + * prefix. */ - TclDStringAppendDString(&initName, &pkgName); + TclDStringAppendDString(&initName, &pfx); TclDStringAppendLiteral(&initName, "_Init"); - TclDStringAppendDString(&safeInitName, &pkgName); + TclDStringAppendDString(&safeInitName, &pfx); TclDStringAppendLiteral(&safeInitName, "_SafeInit"); - TclDStringAppendDString(&unloadName, &pkgName); + TclDStringAppendDString(&unloadName, &pfx); TclDStringAppendLiteral(&unloadName, "_Unload"); - TclDStringAppendDString(&safeUnloadName, &pkgName); + TclDStringAppendDString(&safeUnloadName, &pfx); TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); /* - * Call platform-specific code to load the package and find the two + * Call platform-specific code to load the library and find the two * initialization functions. */ @@ -397,16 +397,16 @@ Tcl_LoadObjCmd( } /* - * Create a new record to describe this package. + * Create a new record to describe this library. */ pkgPtr = (LoadedPackage *)Tcl_Alloc(sizeof(LoadedPackage)); len = strlen(fullFileName) + 1; pkgPtr->fileName = (char *)Tcl_Alloc(len); memcpy(pkgPtr->fileName, fullFileName, len); - len = Tcl_DStringLength(&pkgName) + 1; - pkgPtr->packageName = (char *)Tcl_Alloc(len); - memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); + len = Tcl_DStringLength(&pfx) + 1; + pkgPtr->prefix = (char *)Tcl_Alloc(len); + memcpy(pkgPtr->prefix, Tcl_DStringValue(&pfx), len); pkgPtr->loadHandle = loadHandle; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = (Tcl_PackageInitProc *) @@ -435,15 +435,15 @@ Tcl_LoadObjCmd( } /* - * Invoke the package's initialization function (either the normal one or + * Invoke the library's initialization function (either the normal one or * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { if (pkgPtr->safeInitProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use package in a safe interpreter: no" - " %s_SafeInit procedure", pkgPtr->packageName)); + "can't use library in a safe interpreter: no" + " %s_SafeInit procedure", pkgPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); code = TCL_ERROR; @@ -453,8 +453,8 @@ Tcl_LoadObjCmd( } else { if (pkgPtr->initProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't attach package to interpreter: no %s_Init procedure", - pkgPtr->packageName)); + "can't attach library to interpreter: no %s_Init procedure", + pkgPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; @@ -485,7 +485,7 @@ Tcl_LoadObjCmd( } /* - * Record the fact that the package has been loaded in the target + * Record the fact that the library has been loaded in the target * interpreter. * * Update the proper reference count. @@ -500,8 +500,8 @@ Tcl_LoadObjCmd( Tcl_MutexUnlock(&packageMutex); /* - * Refetch ipFirstPtr: loading the package may have introduced additional - * static packages at the head of the linked list! + * Refetch ipFirstPtr: loading the library may have introduced additional + * static libraries at the head of the linked list! */ ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); @@ -511,7 +511,7 @@ Tcl_LoadObjCmd( Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); done: - Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&pfx); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&unloadName); @@ -546,13 +546,13 @@ Tcl_UnloadObjCmd( { Tcl_Interp *target; /* Which interpreter to unload from. */ LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp; + Tcl_DString pfx, tmp; Tcl_PackageUnloadProc *unloadProc; InterpPackage *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; int trustedRefCount = -1, safeRefCount = -1; const char *fullFileName = ""; - const char *packageName; + const char *prefix; static const char *const options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; @@ -596,7 +596,7 @@ Tcl_UnloadObjCmd( endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? fileName ?packageName? ?interp?"); + "?-switch ...? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { @@ -604,19 +604,19 @@ Tcl_UnloadObjCmd( } fullFileName = TclGetString(objv[i]); - Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&pfx); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc - i >= 2) { - packageName = TclGetString(objv[i+1]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = TclGetString(objv[i+1]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -624,7 +624,7 @@ Tcl_UnloadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -638,13 +638,13 @@ Tcl_UnloadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: - * - Its name and file match the once we're looking for. - * - Its file matches, and we weren't given a name. - * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * - Its prefix and file match the once we're looking for. + * - Its file matches, and we weren't given a prefix. + * - Its prefix matches, the file name was specified as empty, and there is + * only no statically loaded library with the same prefix. */ Tcl_MutexLock(&packageMutex); @@ -653,26 +653,26 @@ Tcl_UnloadObjCmd( for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { int namesMatch, filesMatch; - if (packageName == NULL) { + if (prefix == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + TclDStringClear(&pfx); + Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_DStringAppend(&tmp, pkgPtr->prefix, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pfx)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { + Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + TclDStringClear(&pfx); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { @@ -685,12 +685,12 @@ Tcl_UnloadObjCmd( Tcl_MutexUnlock(&packageMutex); if (fullFileName[0] == 0) { /* - * It's an error to try unload a static package. + * It's an error to try unload a static library. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" is loaded statically and cannot be unloaded", - packageName)); + "library with prefix \"%s\" is loaded statically and cannot be unloaded", + prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", NULL); code = TCL_ERROR; @@ -710,8 +710,8 @@ Tcl_UnloadObjCmd( } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then we + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then we * should proceed with unloading. */ @@ -727,7 +727,7 @@ Tcl_UnloadObjCmd( } if (code != TCL_OK) { /* - * The package has not been loaded in this interpreter. + * The library has not been loaded in this interpreter. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -770,7 +770,7 @@ Tcl_UnloadObjCmd( } /* - * We are ready to unload the package. First, evaluate the unload + * We are ready to unload the library. First, evaluate the unload * function. If this fails, we cannot proceed with unload. Also, we must * specify the proper flag to pass to the unload callback. * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should @@ -890,7 +890,7 @@ Tcl_UnloadObjCmd( Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); Tcl_Free(defaultPtr->fileName); - Tcl_Free(defaultPtr->packageName); + Tcl_Free(defaultPtr->prefix); Tcl_Free(defaultPtr); Tcl_Free(ipPtr); Tcl_MutexUnlock(&packageMutex); @@ -909,7 +909,7 @@ Tcl_UnloadObjCmd( } done: - Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&pfx); Tcl_DStringFree(&tmp); if (!complain && (code != TCL_OK)) { code = TCL_OK; @@ -923,14 +923,14 @@ Tcl_UnloadObjCmd( * * Tcl_StaticPackage -- * - * This function is invoked to indicate that a particular package has + * This function is invoked to indicate that a particular library has * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this function completes, the package becomes loadable via the + * Once this function completes, the library becomes loadable via the * "load" command with an empty file name. * *---------------------------------------------------------------------- @@ -938,28 +938,28 @@ Tcl_UnloadObjCmd( void Tcl_StaticPackage( - Tcl_Interp *interp, /* If not NULL, it means that the package has + Tcl_Interp *interp, /* If not NULL, it means that the library has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ - const char *pkgName, /* Name of package (must be properly + const char *prefix, /* Prefix (must be properly * capitalized: first letter upper case, * others lower case). */ Tcl_PackageInitProc *initProc, /* Function to call to incorporate this - * package into a trusted interpreter. */ + * library into a trusted interpreter. */ Tcl_PackageInitProc *safeInitProc) /* Function to call to incorporate this - * package into a safe interpreter (one that + * library into a safe interpreter (one that * will execute untrusted scripts). NULL means - * the package can't be used in safe + * the library can't be used in safe * interpreters. */ { LoadedPackage *pkgPtr; InterpPackage *ipPtr, *ipFirstPtr; /* - * Check to see if someone else has already reported this package as + * Check to see if someone else has already reported this library as * statically loaded in the process. */ @@ -967,14 +967,14 @@ Tcl_StaticPackage( for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { if ((pkgPtr->initProc == initProc) && (pkgPtr->safeInitProc == safeInitProc) - && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + && (strcmp(pkgPtr->prefix, prefix) == 0)) { break; } } Tcl_MutexUnlock(&packageMutex); /* - * If the package is not yet recorded as being loaded statically, add it + * If the library is not yet recorded as being loaded statically, add it * to the list now. */ @@ -982,8 +982,8 @@ Tcl_StaticPackage( pkgPtr = (LoadedPackage *)Tcl_Alloc(sizeof(LoadedPackage)); pkgPtr->fileName = (char *)Tcl_Alloc(1); pkgPtr->fileName[0] = 0; - pkgPtr->packageName = (char *)Tcl_Alloc(strlen(pkgName) + 1); - strcpy(pkgPtr->packageName, pkgName); + pkgPtr->prefix = (char *)Tcl_Alloc(strlen(prefix) + 1); + strcpy(pkgPtr->prefix, prefix); pkgPtr->loadHandle = NULL; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = safeInitProc; @@ -996,7 +996,7 @@ Tcl_StaticPackage( if (interp != NULL) { /* - * If we're loading the package into an interpreter, determine whether + * If we're loading the library into an interpreter, determine whether * it's already loaded. */ @@ -1008,7 +1008,7 @@ Tcl_StaticPackage( } /* - * Package isn't loaded in the current interp yet. Mark it as now being + * Library isn't loaded in the current interp yet. Mark it as now being * loaded. */ @@ -1032,7 +1032,7 @@ Tcl_StaticPackage( * list of lists is placed in the interp's result. Each sublist * corresponds to one loaded file; its first element is the name of the * file (or an empty string for something that's statically loaded) and - * the second element is the name of the package in that file. + * the second element is the prefix of the library in that file. * * Side effects: * None. @@ -1048,8 +1048,8 @@ TclGetLoadedPackagesEx( * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ - const char *packageName) /* Package name or NULL. If NULL, return info - * for all packages. + const char *prefix) /* Prefix or NULL. If NULL, return info + * for all prefixes. */ { Tcl_Interp *target; @@ -1063,7 +1063,7 @@ TclGetLoadedPackagesEx( for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + pkgDesc[1] = Tcl_NewStringObj(pkgPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } @@ -1079,15 +1079,15 @@ TclGetLoadedPackagesEx( ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); /* - * Return information about all of the available packages. + * Return information about all of the available libraries. */ - if (packageName) { + if (prefix) { resultObj = NULL; for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; - if (!strcmp(packageName, pkgPtr->packageName)) { + if (!strcmp(prefix, pkgPtr->prefix)) { resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); break; } @@ -1100,7 +1100,7 @@ TclGetLoadedPackagesEx( } /* - * Return information about only the packages that are loaded in a given + * Return information about only the libraries that are loaded in a given * interpreter. */ @@ -1108,7 +1108,7 @@ TclGetLoadedPackagesEx( for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + pkgDesc[1] = Tcl_NewStringObj(pkgPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } Tcl_SetObjResult(interp, resultObj); @@ -1196,7 +1196,7 @@ TclFinalizeLoad(void) #endif Tcl_Free(pkgPtr->fileName); - Tcl_Free(pkgPtr->packageName); + Tcl_Free(pkgPtr->prefix); Tcl_Free(pkgPtr); } } diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 672d3c9..d84472c 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -2,7 +2,7 @@ * tclPkgConfig.c -- * * This file contains the configuration information to embed into the tcl - * binary library. + * library. * * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * diff --git a/generic/tclTest.c b/generic/tclTest.c index 03bb581..a51f473 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4243,7 +4243,7 @@ TeststaticpkgCmd( if (argc != 4) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " pkgName safe loaded\"", NULL); + argv[0], " prefix safe loaded\"", NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index aa83f28..d953bca 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -47,6 +47,7 @@ #define ZIPFS_VOLUME_LEN 9 #define ZIPFS_APP_MOUNT "//zipfs:/app" #define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl" +#define ZIPFS_FALLBACK_ENCODING "cp437" /* * Various constants and offsets found in ZIP archive files @@ -262,11 +263,19 @@ static struct { int wrmax; /* Maximum write size of a file; only written * to from Tcl code in a trusted interpreter, * so NOT protected by mutex. */ + char *fallbackEntryEncoding;/* The fallback encoding for ZIP entries when + * they are believed to not be UTF-8; only + * written to from Tcl code in a trusted + * interpreter, so not protected by mutex. */ + Tcl_Encoding utf8; /* The UTF-8 encoding that we prefer to use + * for the strings (especially filenames) + * embedded in a ZIP. Other encodings are used + * dynamically. */ int idCount; /* Counter for channel names */ Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ } ZipFS = { - 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0, + 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, NULL, NULL, 0, {0,{0,0,0,0},0,0,0,0,0,0,0,0,0}, {0,{0,0,0,0},0,0,0,0,0,0,0,0,0} }; @@ -686,6 +695,115 @@ CountSlashes( /* *------------------------------------------------------------------------- * + * DecodeZipEntryText -- + * + * Given a sequence of bytes from an entry in a ZIP central directory, + * convert that into a Tcl string. This is complicated because we don't + * actually know what encoding is in use! So we try to use UTF-8, and if + * that goes wrong, we fall back to a user-specified encoding, or to an + * encoding we specify (Windows code page 437), or to ISO 8859-1 if + * absolutely nothing else works. + * + * During Tcl startup, we skip the user-specified encoding and cp437, as + * we may well not have any loadable encodings yet. Tcl's own library + * files ought to be using ASCII filenames. + * + * Results: + * The decoded filename; the filename is owned by the argument DString. + * + * Side effects: + * Updates dstPtr. + * + *------------------------------------------------------------------------- + */ + +static char * +DecodeZipEntryText( + const unsigned char *inputBytes, + unsigned int inputLength, + Tcl_DString *dstPtr) +{ + Tcl_Encoding encoding; + const char *src; + char *dst; + int dstLen, srcLen = inputLength, flags; + Tcl_EncodingState state; + + Tcl_DStringInit(dstPtr); + if (inputLength < 1) { + return Tcl_DStringValue(dstPtr); + } + + /* + * We can't use Tcl_ExternalToUtfDString at this point; it has no way to + * fail. So we use this modified version of it that can report encoding + * errors to us (so we can fall back to something else). + * + * The utf-8 encoding is implemented internally, and so is guaranteed to + * be present. + */ + + src = (const char *) inputBytes; + dst = Tcl_DStringValue(dstPtr); + dstLen = dstPtr->spaceAvl - 1; + flags = TCL_ENCODING_START | TCL_ENCODING_END | + TCL_ENCODING_STOPONERROR; /* Special flag! */ + + while (1) { + int srcRead, dstWrote; + int result = Tcl_ExternalToUtf(NULL, ZipFS.utf8, src, srcLen, flags, + &state, dst, dstLen, &srcRead, &dstWrote, NULL); + int soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + + if (result == TCL_OK) { + Tcl_DStringSetLength(dstPtr, soFar); + return Tcl_DStringValue(dstPtr); + } else if (result != TCL_CONVERT_NOSPACE) { + break; + } + + flags &= ~TCL_ENCODING_START; + src += srcRead; + srcLen -= srcRead; + if (Tcl_DStringLength(dstPtr) == 0) { + Tcl_DStringSetLength(dstPtr, dstLen); + } + Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); + dst = Tcl_DStringValue(dstPtr) + soFar; + dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; + } + + /* + * Something went wrong. Fall back to another encoding. Those *can* use + * Tcl_ExternalToUtfDString(). + */ + + encoding = NULL; + if (ZipFS.fallbackEntryEncoding) { + encoding = Tcl_GetEncoding(NULL, ZipFS.fallbackEntryEncoding); + } + if (!encoding) { + encoding = Tcl_GetEncoding(NULL, ZIPFS_FALLBACK_ENCODING); + } + if (!encoding) { + /* + * Fallback to internal encoding that always converts all bytes. + * Should only happen when a filename isn't UTF-8 and we've not got + * our encodings initialised for some reason. + */ + + encoding = Tcl_GetEncoding(NULL, "iso8859-1"); + } + + char *converted = Tcl_ExternalToUtfDString(encoding, + (const char *) inputBytes, inputLength, dstPtr); + Tcl_FreeEncoding(encoding); + return converted; +} + +/* + *------------------------------------------------------------------------- + * * CanonicalPath -- * * This function computes the canonical path from a directory and file @@ -1546,9 +1664,7 @@ ZipFSCatalogFilesystem( pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS); comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); - path = Tcl_DStringValue(&ds); + path = DecodeZipEntryText(q + ZIP_CENTRAL_HEADER_LEN, pathlen, &ds); if ((pathlen > 0) && (path[pathlen - 1] == '/')) { Tcl_DStringSetLength(&ds, pathlen - 1); path = Tcl_DStringValue(&ds); @@ -1738,6 +1854,10 @@ ZipfsSetup(void) Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); ZipFS.idCount = 1; ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; + ZipFS.fallbackEntryEncoding = + Tcl_Alloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1); + strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING); + ZipFS.utf8 = Tcl_GetEncoding(NULL, "utf-8"); ZipFS.initialized = 1; } @@ -2357,6 +2477,9 @@ RandomChar( * input file is added to the given fileHash table for later creation of * the central ZIP directory. * + * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it + * would always encode comments as UTF-8, if it supported comments. + * * Results: * A standard Tcl result. * @@ -2371,7 +2494,8 @@ static int ZipAddFile( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *pathObj, /* Actual name of the file to add. */ - const char *name, /* Name to use in the ZIP archive. */ + const char *name, /* Name to use in the ZIP archive, in Tcl's + * internal encoding. */ Tcl_Channel out, /* The open ZIP archive being built. */ const char *passwd, /* Password for encoding the file, or NULL if * the file is to be unprotected. */ @@ -2386,7 +2510,10 @@ ZipAddFile( Tcl_HashEntry *hPtr; ZipEntry *z; z_stream stream; - const char *zpath; + Tcl_DString zpathDs; /* Buffer for the encoded filename. */ + const char *zpathExt; /* Filename in external encoding (true + * UTF-8). */ + const char *zpathTcl; /* Filename in Tcl's internal encoding. */ int crc, flush, zpathlen; size_t nbyte, nbytecompr, len, olen, align = 0; long long headerStartOffset, dataStartOffset, dataEndOffset; @@ -2399,23 +2526,31 @@ ZipAddFile( * nothing to do. */ - zpath = name; - while (zpath && zpath[0] == '/') { - zpath++; + zpathTcl = name; + while (zpathTcl && zpathTcl[0] == '/') { + zpathTcl++; } - if (!zpath || (zpath[0] == '\0')) { + if (!zpathTcl || (zpathTcl[0] == '\0')) { return TCL_OK; } - zpathlen = strlen(zpath); + /* + * Convert to encoded form. Note that we use strlen() here; if someone's + * crazy enough to embed NULs in filenames, they deserve what they get! + */ + + zpathExt = Tcl_UtfToExternalDString(ZipFS.utf8, zpathTcl, -1, &zpathDs); + zpathlen = strlen(zpathExt); if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "path too long for \"%s\"", TclGetString(pathObj))); ZIPFS_ERROR_CODE(interp, "PATH_LEN"); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } in = Tcl_FSOpenFileChannel(interp, pathObj, "rb", 0); if (!in) { + Tcl_DStringFree(&zpathDs); #ifdef _WIN32 /* hopefully a directory */ if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { @@ -2443,6 +2578,7 @@ ZipAddFile( while (1) { len = Tcl_Read(in, buf, bufsize); if (len == ERROR_LENGTH) { + Tcl_DStringFree(&zpathDs); if (nbyte == 0 && errno == EISDIR) { Tcl_Close(interp, in); return TCL_OK; @@ -2463,6 +2599,7 @@ ZipAddFile( Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s", TclGetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } @@ -2479,7 +2616,7 @@ ZipAddFile( */ memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); - memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); + memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpathExt, zpathlen); len = zpathlen + ZIP_LOCAL_HEADER_LEN; if ((size_t) Tcl_Write(out, buf, len) != len) { writeErrorWithChannelOpen: @@ -2487,6 +2624,7 @@ ZipAddFile( "write error on \"%s\": %s", TclGetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } @@ -2563,6 +2701,7 @@ ZipAddFile( "compression init error on \"%s\"", TclGetString(pathObj))); ZIPFS_ERROR_CODE(interp, "DEFLATE_INIT"); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } @@ -2585,6 +2724,7 @@ ZipAddFile( ZIPFS_ERROR_CODE(interp, "DEFLATE"); deflateEnd(&stream); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } olen = sizeof(obuf) - stream.avail_out; @@ -2625,6 +2765,7 @@ ZipAddFile( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "seek error: %s", Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } nbytecompr = (passwd ? 12 : 0); @@ -2660,8 +2801,10 @@ ZipAddFile( Tcl_TruncateChannel(out, dataEndOffset); } Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); + zpathExt = NULL; - hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); + hPtr = Tcl_CreateHashEntry(fileHash, zpathTcl, &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "non-unique path name \"%s\"", TclGetString(pathObj))); @@ -2758,8 +2901,8 @@ ZipFSFind( * should be skipped. * * Returns: - * Pointer to the name, which will be in memory owned by one of the - * argument objects. + * Pointer to the name (in Tcl's internal encoding), which will be in + * memory owned by one of the argument objects. * * Side effects: * None (if Tcl_Objs have string representations) @@ -2772,8 +2915,10 @@ ComputeNameInArchive( Tcl_Obj *pathObj, /* The path to the origin file */ Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP * archive */ - const char *strip, /* A prefix to strip */ - int slen) /* The length of the prefix */ + const char *strip, /* A prefix to strip; may be NULL if no + * stripping need be done. */ + int slen) /* The length of the prefix; must be 0 if no + * stripping need be done. */ { const char *name; int len; @@ -2811,6 +2956,9 @@ ComputeNameInArchive( * file. It's the core of the implementation of [zipfs mkzip], [zipfs * mkimg], [zipfs lmkzip] and [zipfs lmkimg]. * + * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it + * would always encode comments as UTF-8, if it supported comments. + * * Results: * A standard Tcl result. * @@ -3023,6 +3171,9 @@ ZipFSMkZipOrImg( dataStartOffset = Tcl_Tell(out); if (mappingList == NULL && stripPrefix != NULL) { strip = TclGetStringFromObj(stripPrefix, &slen); + if (!slen) { + strip = NULL; + } } for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { Tcl_Obj *pathObj = lobjv[i]; @@ -3047,25 +3198,27 @@ ZipFSMkZipOrImg( for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { const char *name = ComputeNameInArchive(lobjv[i], (mappingList ? lobjv[i + 1] : NULL), strip, slen); + Tcl_DString ds; - if (name[0] == '\0') { - continue; - } hPtr = Tcl_FindHashEntry(&fileHash, name); if (!hPtr) { continue; } z = (ZipEntry *) Tcl_GetHashValue(hPtr); - len = strlen(z->name); + + name = Tcl_UtfToExternalDString(ZipFS.utf8, z->name, -1, &ds); + len = Tcl_DStringLength(&ds); SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf, z, len, dataStartOffset); if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) - || ((size_t) Tcl_Write(out, z->name, len) != len)) { + || ((size_t) Tcl_Write(out, name, len) != len)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); + Tcl_DStringFree(&ds); goto done; } + Tcl_DStringFree(&ds); count++; } @@ -5518,6 +5671,8 @@ TclZipfs_Init( if (!Tcl_IsSafe(interp)) { Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax, TCL_LINK_INT); + Tcl_LinkVar(interp, "::tcl::zipfs::fallbackEntryEncoding", + (char *) &ZipFS.fallbackEntryEncoding, TCL_LINK_STRING); } ensemble = TclMakeEnsemble(interp, "zipfs", Tcl_IsSafe(interp) ? (initMap + 4) : initMap); |