From 7ca040ad884baacea75bb242383440f3ce80e0bb Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 6 Mar 2019 01:42:13 +0000 Subject: [39fed4dae5] Minimal fix for volatile lifetime of string returned by Tcl_PkgRequire(). We need a test for this ticket to go in the test suite. --- generic/tclPkg.c | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index d4080c2..510f5e6 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -40,10 +40,7 @@ typedef struct PkgAvail { */ typedef struct Package { - char *version; /* Version that has been supplied in this - * interpreter via "package provide" - * (malloc'ed). NULL means the package doesn't - * exist in this interpreter yet. */ + Tcl_Obj *version; PkgAvail *availPtr; /* First in list of all available versions of * this package. */ const void *clientData; /* Client data. */ @@ -150,12 +147,13 @@ Tcl_PkgProvideEx( pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { - DupString(pkgPtr->version, version); + pkgPtr->version = Tcl_NewStringObj(version, -1); + Tcl_IncrRefCount(pkgPtr->version); pkgPtr->clientData = clientData; return TCL_OK; } - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { @@ -175,7 +173,7 @@ Tcl_PkgProvideEx( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "conflicting versions provided for package \"%s\": %s, then %s", - name, pkgPtr->version, version)); + name, Tcl_GetString(pkgPtr->version), version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -474,7 +472,8 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { */ if (reqc != 0) { - CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL); + CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version), + &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); @@ -482,7 +481,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "version conflict for package \"%s\": have %s, need", - name, reqPtr->pkgPtr->version)); + name, Tcl_GetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); @@ -495,7 +494,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { *ptr = reqPtr->pkgPtr->clientData; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); + Tcl_SetObjResult(interp, reqPtr->pkgPtr->version); return TCL_OK; } @@ -694,8 +693,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { } else { char *pvi, *vi; - if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, - NULL) != TCL_OK) { + if (TCL_OK != CheckVersionAndConvert(interp, + Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) { result = TCL_ERROR; } else if (CheckVersionAndConvert(interp, versionToProvide, &vi, NULL) != TCL_OK) { @@ -712,7 +711,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { "attempt to provide package %s %s failed:" " package %s %s provided instead", name, versionToProvide, - name, reqPtr->pkgPtr->version)); + name, Tcl_GetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "WRONGPROVIDE", NULL); } @@ -750,7 +749,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { */ if (reqPtr->pkgPtr->version != NULL) { - ckfree(reqPtr->pkgPtr->version); + Tcl_DecrRefCount(reqPtr->pkgPtr->version); reqPtr->pkgPtr->version = NULL; } reqPtr->pkgPtr->clientData = NULL; @@ -926,7 +925,7 @@ TclNRPackageObjCmd( pkgPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); + Tcl_DecrRefCount(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; @@ -1084,8 +1083,7 @@ TclNRPackageObjCmd( if (hPtr != NULL) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(pkgPtr->version, -1)); + Tcl_SetObjResult(interp, pkgPtr->version); } } return TCL_OK; @@ -1378,7 +1376,7 @@ TclFreePackageInfo( hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); + Tcl_DecrRefCount(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; -- cgit v0.12 From 1d47b2fc79eb8184485753b3ff7230f6426a0306 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 6 Mar 2019 06:26:36 +0000 Subject: V1.3. PLATFORM_IDENTIFY, MULTIPLATFORM_INSTALL macro, optionally copy PDBs. The PLATFORM_IDENTIFY macro matches the output of Tcl's platform::identify and is meant to permit extensions to pick a platform-specific directory for binaries. MULTIPLATFORM_INSTALL can be set by extensions to install into a platform specific subdirectory as returned by the platform::identify Tcl command. The default automatic pkgIndex.tcl is modified accordingly. If OPTS=pdbs is set, the default install target will also copy PDBS. --- win/makefile.vc | 8 ++++++++ win/rules.vc | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 58 insertions(+), 6 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index a6709d1..647ba89 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -379,6 +379,9 @@ dlls: setup $(TCLREGLIB) $(TCLDDELIB) all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs tcltest: setup $(TCLTEST) dlls $(CAT32) install: install-binaries install-libraries install-docs install-pkgs +!if $(SYMBOLS) +install: install-pdbs +!endif setup: default-setup test: test-core test-pkgs @@ -913,6 +916,11 @@ install-msgs: @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" +install-pdbs: + @echo Installing debug symbols + @$(CPY) "$(OUT_DIR)\*.pdb" "$(BIN_INSTALL_DIR)\" +# "emacs font-lock highlighting fix + #--------------------------------------------------------------------- # Clean up #--------------------------------------------------------------------- diff --git a/win/rules.vc b/win/rules.vc index 8db4752..ff5a202 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 2 +RULES_VERSION_MINOR = 3 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" @@ -475,6 +475,21 @@ MACHINE = AMD64 MACHINE=$(ARCH) !endif +#--------------------------------------------------------------- +# The PLATFORM_IDENTIFY macro matches the values returned by +# the Tcl platform::identify command +!if "$(MACHINE)" == "AMD64" +PLATFORM_IDENTIFY = win32-x86_64 +!else +PLATFORM_IDENTIFY = win32-ix86 +!endif + +# The MULTIPLATFORM macro controls whether binary extensions are installed +# in platform-specific directories. Intended to be set/used by extensions. +!ifndef MULTIPLATFORM_INSTALL +MULTIPLATFORM_INSTALL = 0 +!endif + #------------------------------------------------------------ # Figure out the *host* architecture by reading the registry @@ -739,6 +754,8 @@ TCL_THREADS = 1 USE_THREAD_ALLOC= 1 !endif +# Yes, it's weird that the "symbols" option controls DEBUG and +# the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 @@ -1226,8 +1243,13 @@ INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION) +!if $(MULTIPLATFORM_INSTALL) +LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) +BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) +!else LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) +!endif DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos @@ -1513,9 +1535,15 @@ DEFAULT_BUILD_TARGET = $(PROJECT) default-target: $(DEFAULT_BUILD_TARGET) +!if $(SYMBOLS) +default-pkgindex: + @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ + [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl +!else default-pkgindex: @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl +!endif default-pkgindex-tea: @if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl @@ -1525,15 +1553,26 @@ default-pkgindex-tea: @PKG_LIB_FILE@ $(PRJLIBNAME) << - default-install: default-install-binaries default-install-libraries +!if $(SYMBOLS) +default-install: default-install-pdbs +!endif +# Again to deal with historical brokenness, there is some confusion +# in terminlogy. For extensions, the "install-binaries" was used to +# locate target directory for *binary shared libraries* and thus +# the appropriate macro is LIB_INSTALL_DIR since BIN_INSTALL_DIR is +# for executables (exes). On the other hand the "install-libraries" +# target is for *scripts* and should have been called "install-scripts". default-install-binaries: $(PRJLIB) - @echo Installing binaries to '$(SCRIPT_INSTALL_DIR)' - @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" - @$(CPY) $(PRJLIB) "$(SCRIPT_INSTALL_DIR)" >NUL + @echo Installing binaries to '$(LIB_INSTALL_DIR)' + @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" + @$(CPY) $(PRJLIB) "$(LIB_INSTALL_DIR)" >NUL -default-install-libraries: $(OUT_DIR)\pkgIndex.tcl +# Alias for default-install-scripts +default-install-libraries: default-install-scripts + +default-install-scripts: $(OUT_DIR)\pkgIndex.tcl @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)' @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" @echo Installing package index in '$(SCRIPT_INSTALL_DIR)' @@ -1544,6 +1583,11 @@ default-install-stubs: @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" @$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL +default-install-pdbs: + @echo Installing PDBs to '$(LIB_INSTALL_DIR)' + @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" + @$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\" + default-install-docs-html: @echo Installing documentation files to '$(DOC_INSTALL_DIR)' @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" -- cgit v0.12 From fa0f595cf9f339ac2922ffea021e3763df775cb8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 7 Mar 2019 07:58:39 +0000 Subject: Fix [9471e6e304]: InitWinEnv not thread safe --- generic/tclEnv.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 40ced17..b001153 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -135,6 +135,18 @@ TclSetupEnv( } p2++; p2[-1] = '\0'; +#if defined(_WIN32) + /* + * Enforce PATH and COMSPEC to be all uppercase. This eliminates + * additional trace logic otherwise required in init.tcl. + */ + + if (strcasecmp(p1, "PATH") == 0) { + p1 = "PATH"; + } else if (strcasecmp(p1, "COMSPEC") == 0) { + p1 = "COMSPEC"; + } +#endif obj1 = Tcl_NewStringObj(p1, -1); obj2 = Tcl_NewStringObj(p2, -1); Tcl_DStringFree(&envString); -- cgit v0.12 From 65baf6c706d7cfa12cfbc06610f7e9a51c5c81e8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 7 Mar 2019 08:00:29 +0000 Subject: Fix some gcc/MSVC (harmless) compiler warnings. Remove some unnecessary end-of-line spacing --- generic/tclCmdMZ.c | 23 +++++++++++------------ unix/tclUnixTime.c | 2 +- win/nmakehlp.c | 14 +++++++------- win/tclWinFile.c | 10 +++++----- win/tclWinLoad.c | 2 +- win/tclWinTest.c | 2 +- win/tclWinTime.c | 22 +++++++++++----------- 7 files changed, 37 insertions(+), 38 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1112578..29527c1 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2392,7 +2392,7 @@ StringRplcCmd( Tcl_Obj *resultPtr; /* - * We are re-fetching in case the string argument is same value as + * We are re-fetching in case the string argument is same value as * an index argument, and shimmering cost us our ustring. */ @@ -4274,8 +4274,8 @@ Tcl_TimeObjCmd( * Tcl_TimeRateObjCmd -- * * This object-based procedure is invoked to process the "timerate" Tcl - * command. - * This is similar to command "time", except the execution limited by + * command. + * This is similar to command "time", except the execution limited by * given time (in milliseconds) instead of repetition count. * * Example: @@ -4297,8 +4297,7 @@ Tcl_TimeRateObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static - double measureOverhead = 0; /* global measure-overhead */ + static double measureOverhead = 0; /* global measure-overhead */ double overhead = -1; /* given measure-overhead */ register Tcl_Obj *objPtr; register int result, i; @@ -4386,13 +4385,13 @@ usage: Tcl_Obj *clobjv[6]; Tcl_WideInt maxCalTime = 5000; double lastMeasureOverhead = measureOverhead; - - clobjv[0] = objv[0]; + + clobjv[0] = objv[0]; i = 1; if (direct) { clobjv[i++] = direct; } - clobjv[i++] = objPtr; + clobjv[i++] = objPtr; /* reset last measurement overhead */ measureOverhead = (double)0; @@ -4409,7 +4408,7 @@ usage: i--; clobjv[i++] = calibrate; - clobjv[i++] = objPtr; + clobjv[i++] = objPtr; /* set last measurement overhead to max */ measureOverhead = (double)UWIDE_MAX; @@ -4510,7 +4509,7 @@ usage: maxcnt = 0; result = TCL_OK; } - + /* don't check time up to threshold */ if (--threshold > 0) continue; @@ -4580,7 +4579,7 @@ usage: if (overhead > 0) { /* estimate the time of overhead (microsecs) */ Tcl_WideUInt curOverhead = overhead * count; - if (middle > curOverhead) { + if ((Tcl_WideUInt)middle > curOverhead) { middle -= curOverhead; } else { middle = 0; @@ -4609,7 +4608,7 @@ usage: } objs[2] = Tcl_NewWideIntObj(count); /* iterations */ - + /* calculate speed as rate (count) per sec */ if (!middle) middle++; /* +1 ms, just to avoid divide by zero */ if (count < (WIDE_MAX / 1000000)) { diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 375e366..2a30386 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -248,7 +248,7 @@ TclpWideClicksToNanoseconds( * * TclpWideClickInMicrosec -- * - * This procedure return scale to convert click values from the + * This procedure return scale to convert click values from the * TclpGetWideClicks native resolution to microsecond resolution * and back. * diff --git a/win/nmakehlp.c b/win/nmakehlp.c index b759020..c21de63 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -686,10 +686,10 @@ SubstituteFile( BOOL FileExists(LPCTSTR szPath) { #ifndef INVALID_FILE_ATTRIBUTES - #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) + #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) #endif DWORD pathAttr = GetFileAttributes(szPath); - return (pathAttr != INVALID_FILE_ATTRIBUTES && + return (pathAttr != INVALID_FILE_ATTRIBUTES && !(pathAttr & FILE_ATTRIBUTE_DIRECTORY)); } @@ -740,7 +740,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) #if 0 /* This function is not available in Visual C++ 6 */ /* * Use numerics 0 -> FindExInfoStandard, - * 1 -> FindExSearchLimitToDirectories, + * 1 -> FindExSearchLimitToDirectories, * as these are not defined in Visual C++ 6 */ hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0); @@ -755,7 +755,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) do { int sublen; /* - * We need to check it is a directory despite the + * We need to check it is a directory despite the * FindExSearchLimitToDirectories in the above call. See SDK docs */ if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) @@ -786,15 +786,15 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) * that is used to confirm it is the correct directory. * The search path for the package directory is currently only * the parent and grandparent of the current working directory. - * If found, the command prints + * If found, the command prints * name_DIRPATH= * and returns 0. If not found, does not print anything and returns 1. */ static int LocateDependency(const char *keypath) { int i, ret; - static char *paths[] = {"..", "..\\..", "..\\..\\.."}; - + static const char *paths[] = {"..", "..\\..", "..\\..\\.."}; + for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) { ret = LocateDependencyHelper(paths[i], keypath); if (ret == 0) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index b9787c7..809bcf0 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1460,9 +1460,9 @@ TclpGetUserHome( domain = Tcl_UtfFindFirst(name, '@'); if (domain == NULL) { const char *ptr; - + /* no domain - firstly check it's the current user */ - if ( (ptr = TclpGetUserName(&ds)) != NULL + if ( (ptr = TclpGetUserName(&ds)) != NULL && strcasecmp(name, ptr) == 0 ) { /* try safest and fastest way to get current user home */ @@ -1485,7 +1485,7 @@ TclpGetUserHome( Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) { - /* + /* * user does not exists - if domain was not specified, * try again using current domain. */ @@ -1600,7 +1600,7 @@ NativeAccess( return 0; } - /* + /* * If it's not a directory (assume file), do several fast checks: */ if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) { @@ -2031,7 +2031,7 @@ NativeStat( */ fileHandle = CreateFile(nativePath, GENERIC_READ, - FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, + FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 2946ea2..69263e9 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -88,7 +88,7 @@ TclpDlopen( Tcl_DString ds; - /* + /* * Remember the first error on load attempt to be used if the * second load attempt below also fails. */ diff --git a/win/tclWinTest.c b/win/tclWinTest.c index aa2c15a..30fc4b4 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -572,7 +572,7 @@ TestplatformChmod( */ if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA( - (LPSTR) nativePath, SE_FILE_OBJECT, + (LPSTR) nativePath, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/, NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) { res = 0; diff --git a/win/tclWinTime.c b/win/tclWinTime.c index d4e84ba..77924ee 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -257,7 +257,7 @@ TclpGetWideClicks(void) /* * The frequency of the performance counter is fixed at system boot and - * is consistent across all processors. Therefore, the frequency need + * is consistent across all processors. Therefore, the frequency need * only be queried upon application initialization. */ if (QueryPerformanceFrequency(&perfCounterFreq)) { @@ -268,7 +268,7 @@ TclpGetWideClicks(void) wideClick.perfCounter = 0; wideClick.microsecsScale = 1; } - + wideClick.initialized = 1; } if (wideClick.perfCounter) { @@ -289,7 +289,7 @@ TclpGetWideClicks(void) * * TclpWideClickInMicrosec -- * - * This procedure return scale to convert wide click values from the + * This procedure return scale to convert wide click values from the * TclpGetWideClicks native resolution to microsecond resolution * and back. * @@ -328,7 +328,7 @@ TclpWideClickInMicrosec(void) *---------------------------------------------------------------------- */ -Tcl_WideInt +Tcl_WideInt TclpGetMicroseconds(void) { Tcl_WideInt usecSincePosixEpoch; @@ -447,7 +447,7 @@ NativeCalc100NsTicks( LONGLONG curCounterFreq, LONGLONG curCounter ) { - return fileTimeLastCall + + return fileTimeLastCall + ((curCounter - perfCounterLastCall) * 10000000 / curCounterFreq); } @@ -1065,7 +1065,7 @@ UpdateTimeEachSecond(void) return; } QueryPerformanceCounter(&curPerfCounter); - + lastFileTime.QuadPart = curFileTime.QuadPart; /* @@ -1133,7 +1133,7 @@ UpdateTimeEachSecond(void) /* calculate new frequency and estimate drift to the next second */ vt1 = 20000000 + curFileTime.QuadPart; driftFreq = (estFreq * 20000000 / (vt1 - vt0)); - /* + /* * Avoid too large drifts (only half of the current difference), * that allows also be more accurate (aspire to the smallest tdiff), * so then we can prolong calibration interval by tdiff < 100000 @@ -1141,13 +1141,13 @@ UpdateTimeEachSecond(void) driftFreq = timeInfo.curCounterFreq.QuadPart + (driftFreq - timeInfo.curCounterFreq.QuadPart) / 2; - /* + /* * Average between estimated, 2 current and 5 drifted frequencies, * (do the soft drifting as possible) */ estFreq = (estFreq + 2 * timeInfo.curCounterFreq.QuadPart + 5 * driftFreq) / 8; } - + /* Avoid too large discrepancy from nominal frequency */ if (estFreq > 1003*timeInfo.nominalFreq.QuadPart/1000) { estFreq = 1003*timeInfo.nominalFreq.QuadPart/1000; @@ -1156,9 +1156,9 @@ UpdateTimeEachSecond(void) estFreq = 997*timeInfo.nominalFreq.QuadPart/1000; vt0 = curFileTime.QuadPart; } else if (vt0 != curFileTime.QuadPart) { - /* + /* * Be sure the clock ticks never backwards (avoid it by negative drifting) - * just compare native time (in 100-ns) before and hereafter using + * just compare native time (in 100-ns) before and hereafter using * new calibrated values) and do a small adjustment (short time freeze) */ LARGE_INTEGER newPerfCounter; -- cgit v0.12 From d37dcc7d71cf81acd27329b604e523488c0b40cb Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 7 Mar 2019 14:12:44 +0000 Subject: Fix automatic pkgIndex generation for multiplatform installs --- win/rules.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/rules.vc b/win/rules.vc index ff5a202..485a0f7 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1535,7 +1535,7 @@ DEFAULT_BUILD_TARGET = $(PROJECT) default-target: $(DEFAULT_BUILD_TARGET) -!if $(SYMBOLS) +!if $(MULTIPLATFORM_INSTALL) default-pkgindex: @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl -- cgit v0.12 From 781c32ac29d9ab9c771d3dee2ed305450e9d8378 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 7 Mar 2019 20:02:09 +0000 Subject: [39fed4dae5] Proposed test --- generic/tclTestProcBodyObj.c | 47 +++++++++++++++++++++++++++++++++++++++++++- tests/proc.test | 3 +++ 2 files changed, 49 insertions(+), 1 deletion(-) diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 4d32c5a..fba2844 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -21,13 +21,14 @@ */ static const char packageName[] = "procbodytest"; -static const char packageVersion[] = "1.0"; +static const char packageVersion[] = "1.1"; /* * Name of the commands exported by this package */ static const char procCommand[] = "proc"; +static const char checkCommand[] = "check"; /* * this struct describes an entry in the table of command names and command @@ -46,6 +47,8 @@ typedef struct CmdTable { static int ProcBodyTestProcObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int ProcBodyTestCheckObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe); static int RegisterCommand(Tcl_Interp* interp, const char *namespace, const CmdTable *cmdTablePtr); @@ -57,11 +60,13 @@ static int RegisterCommand(Tcl_Interp* interp, static const CmdTable commands[] = { { procCommand, ProcBodyTestProcObjCmd, 1 }, + { checkCommand, ProcBodyTestCheckObjCmd, 1 }, { 0, 0, 0 } }; static const CmdTable safeCommands[] = { { procCommand, ProcBodyTestProcObjCmd, 1 }, + { checkCommand, ProcBodyTestCheckObjCmd, 1 }, { 0, 0, 0 } }; @@ -301,6 +306,46 @@ ProcBodyTestProcObjCmd( } /* + *---------------------------------------------------------------------- + * + * ProcBodyTestCheckObjCmd -- + * + * Implements the "procbodytest::check" command. Here is the command + * description: + * procbodytest::check + * + * Performs an internal check that the Tcl_PkgPresent() command returns + * the same version number as was registered when the procbodytest package + * was provided. Places a boolean in the interp result indicating the + * test outcome. + * + * Results: + * Returns a standard Tcl code. + * + *---------------------------------------------------------------------- + */ + +static int +ProcBodyTestCheckObjCmd( + ClientData dummy, /* context; not used */ + Tcl_Interp *interp, /* the current interpreter */ + int objc, /* argument count */ + Tcl_Obj *const objv[]) /* arguments */ +{ + const char *version; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + version = Tcl_PkgPresent(interp, packageName, packageVersion, 1); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + strcmp(version, packageVersion) == 0)); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/proc.test b/tests/proc.test index e06720e..670ac98 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -313,6 +313,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set rename getbytes {} unset -nocomplain end i tmp leakedBytes } -result 0 +test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest { + procbodytest::check +} 1 test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body { proc p args {} ; # this will be bytecompiled into t -- cgit v0.12 From c5abbcaaf4c32c6bfce25ff1a589f6e704116729 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 7 Mar 2019 22:13:25 +0000 Subject: In the 8.6.* releases, Tcl_GetStringResult() still passes through interp->result. Have to ask specifically for the string rep of the value we want. --- generic/tclPkg.c | 4 ++-- generic/tclTestProcBodyObj.c | 2 -- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 510f5e6..c1e2078 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -316,7 +316,7 @@ Tcl_PkgRequireEx( if (version == NULL) { if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { - result = Tcl_GetStringResult(interp); + result = Tcl_GetString(Tcl_GetObjResult(interp)); Tcl_ResetResult(interp); } } else { @@ -330,7 +330,7 @@ Tcl_PkgRequireEx( } Tcl_IncrRefCount(ov); if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { - result = Tcl_GetStringResult(interp); + result = Tcl_GetString(Tcl_GetObjResult(interp)); Tcl_ResetResult(interp); } TclDecrRefCount(ov); diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index de1fa52..fba2844 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -340,8 +340,6 @@ ProcBodyTestCheckObjCmd( } version = Tcl_PkgPresent(interp, packageName, packageVersion, 1); -fprintf(stdout, "CHECK %p '%s' %p '%s'\n", version, version, -packageVersion, packageVersion); fflush(stdout); Tcl_SetObjResult(interp, Tcl_NewBooleanObj( strcmp(version, packageVersion) == 0)); return TCL_OK; -- cgit v0.12 From 2d4e87b986c01a174757d0c728164f7809206654 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 8 Mar 2019 04:35:41 +0000 Subject: fixed mistake ($howmuch is substituted in tests and can be larger as last event index created by too small measurement time). --- tests-perf/timer-event.perf.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests-perf/timer-event.perf.tcl b/tests-perf/timer-event.perf.tcl index 805f0f8..c5a7d45 100644 --- a/tests-perf/timer-event.perf.tcl +++ b/tests-perf/timer-event.perf.tcl @@ -76,7 +76,7 @@ proc test-queue {{reptime {1000 10000}}} { # cancel forwards "after 0" / $howmuch timer-events in queue: setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime} setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events} - {after cancel $ev([incr i]); if {$i >= $howmuch} break} + {after cancel $ev([incr i]); if {$i >= $le} break} cleanup {update; unset -nocomplain ev} # cancel backwards "after 0" / $howmuch timer-events in queue: setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime} -- cgit v0.12