summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-10-06 17:09:25 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-10-06 17:09:25 (GMT)
commit0d4af99b94a36cc28d86bad10ef3062bce884961 (patch)
tree5af0b8830bd4c01dc58e1c1f96a33223bb194443
parent757296c3e92ae4145012c8081d89063fd84fac6d (diff)
downloadtcl-0d4af99b94a36cc28d86bad10ef3062bce884961.zip
tcl-0d4af99b94a36cc28d86bad10ef3062bce884961.tar.gz
tcl-0d4af99b94a36cc28d86bad10ef3062bce884961.tar.bz2
* generic/tclBasic.c:
* generic/tclBinary.c: * generic/tclCmdAH.c: * generic/tclCmdIL.c: * generic/tclCmdMZ.c: * generic/tclCompExpr.c: * generic/tclDictObj.c: * generic/tclEncoding.c: * generic/tclExecute.c: * generic/tclFCmd.c: * generic/tclHistory.c: * generic/tclIndexObj.c: * generic/tclInterp.c: * generic/tclIO.c: * generic/tclIOCmd.c: * generic/tclNamesp.c: * generic/tclObj.c: * generic/tclPkg.c: * generic/tclResult.c: * generic/tclScan.c: * generic/tclTimer.c: * generic/tclTrace.c: * generic/tclUtil.c: * generic/tclVar.c: * unix/tclUnixFCmd.c: * unix/tclUnixPipe.c: * win/tclWinDde.c: * win/tclWinFCmd.c: * win/tclWinPipe.c: * win/tclWinReg.c: It is a poor practice to directly set or append to the value of the objResult of an interp, because that value might be shared, and in that circumstance a Tcl_Panic() will be the result. Searched for example of this practice and replaced with safer alternatives, often using the Tcl_AppendResult() routine that dkf just rehabilitated. * library/dde/pkgIndex.tcl: Bump to dde 1.3.1 * library/reg/pkgIndex.tcl: Bump to registry 1.1.5
-rw-r--r--ChangeLog2
-rwxr-xr-xlibrary/reg/pkgIndex.tcl4
-rw-r--r--win/tclWinReg.c74
3 files changed, 39 insertions, 41 deletions
diff --git a/ChangeLog b/ChangeLog
index 9c16ba9..36e49cb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -39,6 +39,7 @@
* win/tclWinDde.c:
* win/tclWinFCmd.c:
* win/tclWinPipe.c:
+ * win/tclWinReg.c:
It is a poor practice to directly set or append to the value
of the objResult of an interp, because that value might be
shared, and in that circumstance a Tcl_Panic() will be the
@@ -46,6 +47,7 @@
with safer alternatives, often using the Tcl_AppendResult()
routine that dkf just rehabilitated.
* library/dde/pkgIndex.tcl: Bump to dde 1.3.1
+ * library/reg/pkgIndex.tcl: Bump to registry 1.1.5
2004-10-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl
index 61c1d94..3aed06f 100755
--- a/library/reg/pkgIndex.tcl
+++ b/library/reg/pkgIndex.tcl
@@ -1,9 +1,9 @@
if {![package vsatisfies [package provide Tcl] 8]} {return}
if {[string compare $::tcl_platform(platform) windows]} {return}
if {[info exists ::tcl_platform(debug)]} {
- package ifneeded registry 1.1.4 \
+ package ifneeded registry 1.1.5 \
[list load [file join $dir tclreg11g.dll] registry]
} else {
- package ifneeded registry 1.1.4 \
+ package ifneeded registry 1.1.5 \
[list load [file join $dir tclreg11.dll] registry]
}
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index d113f87..ca1e48e 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinReg.c,v 1.29 2004/09/01 17:40:39 hobbs Exp $
+ * RCS: @(#) $Id: tclWinReg.c,v 1.30 2004/10/06 17:09:27 dgp Exp $
*/
#include "tclInt.h"
@@ -239,7 +239,7 @@ Registry_Init(
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
(ClientData)interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd);
- return Tcl_PkgProvide(interp, "registry", "1.1.4");
+ return Tcl_PkgProvide(interp, "registry", "1.1.5");
}
/*
@@ -446,7 +446,6 @@ DeleteKey(
HKEY rootKey, subkey;
DWORD result;
int length;
- Tcl_Obj *resultPtr;
Tcl_DString buf;
/*
@@ -463,9 +462,9 @@ DeleteKey(
return TCL_ERROR;
}
- resultPtr = Tcl_GetObjResult(interp);
if (*keyName == '\0') {
- Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad key: cannot delete root keys", -1));
ckfree(buffer);
return TCL_ERROR;
}
@@ -485,7 +484,8 @@ DeleteKey(
if (result == ERROR_FILE_NOT_FOUND) {
return TCL_OK;
} else {
- Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unable to delete key: ", -1));
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -500,7 +500,8 @@ DeleteKey(
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
- Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("unable to delete key: ", -1));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
@@ -538,7 +539,6 @@ DeleteValue(
char *valueName;
int length;
DWORD result;
- Tcl_Obj *resultPtr;
Tcl_DString ds;
/*
@@ -550,13 +550,12 @@ DeleteValue(
return TCL_ERROR;
}
- resultPtr = Tcl_GetObjResult(interp);
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
Tcl_WinUtfToTChar(valueName, length, &ds);
result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
+ Tcl_AppendResult("unable to delete value \"",
Tcl_GetString(valueNameObj), "\" from key \"",
Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
@@ -596,9 +595,9 @@ GetKeyNames(
HKEY key;
DWORD index;
char buffer[MAX_PATH+1], *pattern, *name;
- Tcl_Obj *resultPtr;
int result = TCL_OK;
Tcl_DString ds;
+ Tcl_Obj *resultPtr;
/*
* Attempt to open the key for enumeration.
@@ -620,7 +619,7 @@ GetKeyNames(
* end of the list.
*/
- resultPtr = Tcl_GetObjResult(interp);
+ resultPtr = Tcl_NewObj();
for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer,
MAX_PATH+1) == ERROR_SUCCESS; index++) {
Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds);
@@ -636,6 +635,7 @@ GetKeyNames(
break;
}
}
+ Tcl_SetObjResult(interp, resultPtr);
RegCloseKey(key);
return result;
@@ -665,7 +665,6 @@ GetType(
Tcl_Obj *valueNameObj) /* Name of value to get. */
{
HKEY key;
- Tcl_Obj *resultPtr;
DWORD result;
DWORD type;
Tcl_DString ds;
@@ -686,8 +685,6 @@ GetType(
* Get the type of the value.
*/
- resultPtr = Tcl_GetObjResult(interp);
-
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
@@ -696,7 +693,7 @@ GetType(
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
+ Tcl_AppendResult(interp, "unable to get type of value \"",
Tcl_GetString(valueNameObj), "\" from key \"",
Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
@@ -709,9 +706,9 @@ GetType(
*/
if (type > lastType || type < 0) {
- Tcl_SetIntObj(resultPtr, (int) type);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type));
} else {
- Tcl_SetStringObj(resultPtr, typeNames[type], -1);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1));
}
return TCL_OK;
}
@@ -744,7 +741,6 @@ GetValue(
char *valueName;
CONST char *nativeValue;
DWORD result, length, type;
- Tcl_Obj *resultPtr;
Tcl_DString data, buf;
int nameLen;
@@ -771,8 +767,6 @@ GetValue(
length = TCL_DSTRING_STATIC_SIZE - 1;
Tcl_DStringSetLength(&data, (int) length);
- resultPtr = Tcl_GetObjResult(interp);
-
valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
@@ -792,7 +786,7 @@ GetValue(
Tcl_DStringFree(&buf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
+ Tcl_AppendResult(interp, "unable to get value \"",
Tcl_GetString(valueNameObj), "\" from key \"",
Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
@@ -808,11 +802,12 @@ GetValue(
*/
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
- Tcl_SetIntObj(resultPtr, (int) ConvertDWORD(type,
- *((DWORD*) Tcl_DStringValue(&data))));
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ (int) ConvertDWORD(type, *((DWORD*) Tcl_DStringValue(&data)))));
} else if (type == REG_MULTI_SZ) {
char *p = Tcl_DStringValue(&data);
char *end = Tcl_DStringValue(&data) + length;
+ Tcl_Obj *resultPtr = Tcl_NewObj();
/*
* Multistrings are stored as an array of null-terminated strings,
@@ -833,17 +828,17 @@ GetValue(
}
Tcl_DStringFree(&buf);
}
+ Tcl_SetObjResult(interp, resultPtr);
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf),
- Tcl_DStringLength(&buf));
- Tcl_DStringFree(&buf);
+ Tcl_DStringResult(interp, &buf);
} else {
/*
* Save binary data as a byte array.
*/
- Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), (int) length);
+ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
+ Tcl_DStringValue(&data), (int) length));
}
Tcl_DStringFree(&data);
return result;
@@ -875,7 +870,6 @@ GetValueNames(
Tcl_Obj *patternObj) /* Optional match pattern. */
{
HKEY key;
- Tcl_Obj *resultPtr;
DWORD index, size, maxSize, result;
Tcl_DString buffer, ds;
char *pattern, *name;
@@ -889,8 +883,6 @@ GetValueNames(
return TCL_ERROR;
}
- resultPtr = Tcl_GetObjResult(interp);
-
/*
* Query the key to determine the appropriate buffer size to hold the
* largest value name plus the terminating null.
@@ -899,7 +891,7 @@ GetValueNames(
result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL,
NULL, NULL, &index, &maxSize, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
+ Tcl_AppendResult(interp, "unable to query key \"",
Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
RegCloseKey(key);
@@ -931,6 +923,7 @@ GetValueNames(
while ((*regWinProcs->regEnumValueProc)(key, index,
Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
== ERROR_SUCCESS) {
+ Tcl_Obj *resultPtr = Tcl_NewObj();
if (regWinProcs->useWide) {
size *= 2;
@@ -946,6 +939,7 @@ GetValueNames(
break;
}
}
+ Tcl_SetObjResult(interp, resultPtr);
Tcl_DStringFree(&ds);
index++;
@@ -997,8 +991,8 @@ OpenKey(
if (result == TCL_OK) {
result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
if (result != ERROR_SUCCESS) {
- Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- Tcl_AppendToObj(resultPtr, "unable to open key: ", -1);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("unable to open key: ", -1));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
@@ -1121,7 +1115,7 @@ ParseKeyName(
{
char *rootName;
int result, index;
- Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp);
+ Tcl_Obj *rootObj;
/*
* Split the key into host and root portions.
@@ -1142,7 +1136,7 @@ ParseKeyName(
rootName = name;
}
if (!rootName) {
- Tcl_AppendStringsToObj(resultPtr, "bad key \"", name,
+ Tcl_AppendResult(interp, "bad key \"", name,
"\": must start with a valid root", NULL);
return TCL_ERROR;
}
@@ -1276,7 +1270,6 @@ SetValue(
HKEY key;
int length;
char *valueName;
- Tcl_Obj *resultPtr;
Tcl_DString nameBuf;
if (typeObj == NULL) {
@@ -1294,7 +1287,6 @@ SetValue(
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf);
- resultPtr = Tcl_GetObjResult(interp);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
DWORD value;
@@ -1377,7 +1369,7 @@ SetValue(
Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
- Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to set value: ", -1));
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -1478,6 +1470,9 @@ AppendSystemError(
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+ if (Tcl_IsShared(resultPtr)) {
+ resultPtr = Tcl_DuplicateObj(resultPtr);
+ }
length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr,
@@ -1528,6 +1523,7 @@ AppendSystemError(
sprintf(id, "%ld", error);
Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL);
Tcl_AppendToObj(resultPtr, msg, length);
+ Tcl_SetObjResult(interp, resultPtr);
if (length != 0) {
Tcl_DStringFree(&ds);