URL https://opencores.org/ocsvn/or1k_old/or1k_old/trunk
Subversion Repositories or1k_old

[/] [or1k_old/] [trunk/] [insight/] [tcl/] [win/] [tclWinReg.c] - Blame information for rev 1782

Details | Compare with Previous | View Log

/*
 * tclWinReg.c --
 *
 *      This file contains the implementation of the "registry" Tcl
 *      built-in command.  This command is built as a dynamically
 *      loadable extension in a separate DLL.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * 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.1.1.1 2002-01-16 10:25:39 markom Exp $
 */
 
#include <tcl.h>
#include <stdlib.h>
 
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
 
/*
 * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
 * Registry_Init declaration is in the source file itself, which is only
 * accessed when we are building a library.
 */
 
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
 
/*
 * VC++ has an alternate entry point called DllMain, so we need to rename
 * our entry point.
 */
 
#ifdef DLL_BUILD
# if defined(_MSC_VER)
#  define DllEntryPoint DllMain
# endif
#endif
 
/*
 * The following macros convert between different endian ints.
 */
 
#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
 
/*
 * The following flag is used in OpenKeys to indicate that the specified
 * key should be created if it doesn't currently exist.
 */
 
#define REG_CREATE 1
 
/*
 * The following tables contain the mapping from registry root names
 * to the system predefined keys.
 */
 
static char *rootKeyNames[] = {
    "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
    "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", NULL
};
 
static HKEY rootKeys[] = {
    HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
    HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
};
 
/*
 * The following table maps from registry types to strings.  Note that
 * the indices for this array are the same as the constants for the
 * known registry types so we don't need a separate table to hold the
 * mapping.
 */
 
static char *typeNames[] = {
    "none", "sz", "expand_sz", "binary", "dword",
    "dword_big_endian", "link", "multi_sz", "resource_list", NULL
};
 
static DWORD lastType = REG_RESOURCE_LIST;
 
 
/*
 * Declarations for functions defined in this file.
 */
 
static void             AppendSystemError(Tcl_Interp *interp, DWORD error);
static DWORD            ConvertDWORD(DWORD type, DWORD value);
static int              DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
static int              DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
                            Tcl_Obj *valueNameObj);
static int              GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
                            Tcl_Obj *patternObj);
static int              GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
                            Tcl_Obj *valueNameObj);
static int              GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
                            Tcl_Obj *valueNameObj);
static int              GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
                            Tcl_Obj *patternObj);
static int              OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
                            REGSAM mode, int flags, HKEY *keyPtr);
static DWORD            OpenSubKey(char *hostName, HKEY rootKey,
                            char *keyName, REGSAM mode, int flags,
                            HKEY *keyPtr);
static int              ParseKeyName(Tcl_Interp *interp, char *name,
                            char **hostNamePtr, HKEY *rootKeyPtr,
                            char **keyNamePtr);
static DWORD            RecursiveDeleteKey(HKEY hStartKey, LPTSTR pKeyName);
static int              RegistryObjCmd(ClientData clientData,
                            Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]);
static int              SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
                            Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
                            Tcl_Obj *typeObj);
 
EXTERN int Registry_Init(Tcl_Interp *interp);
 
/*
 *----------------------------------------------------------------------
 *
 * DllEntryPoint --
 *
 *      This wrapper function is used by Windows to invoke the
 *      initialization code for the DLL.  If we are compiling
 *      with Visual C++, this routine will be renamed to DllMain.
 *      routine.
 *
 * Results:
 *      Returns TRUE;
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
#ifdef __WIN32__
#ifdef DLL_BUILD
BOOL APIENTRY
DllEntryPoint(
    HINSTANCE hInst,            /* Library instance handle. */
    DWORD reason,               /* Reason this function is being called. */
    LPVOID reserved)            /* Not used. */
{
    return TRUE;
}
#endif
#endif
 
/*
 *----------------------------------------------------------------------
 *
 * Registry_Init --
 *
 *      This procedure initializes the registry command.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
int
Registry_Init(
    Tcl_Interp *interp)
{
    Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
    return Tcl_PkgProvide(interp, "registry", "1.0");
}
 
/*
 *----------------------------------------------------------------------
 *
 * RegistryObjCmd --
 *
 *      This function implements the Tcl "registry" command.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static int
RegistryObjCmd(
    ClientData clientData,      /* Not used. */
    Tcl_Interp *interp,         /* Current interpreter. */
    int objc,                   /* Number of arguments. */
    Tcl_Obj * CONST objv[])     /* Argument values. */
{
    int index;
    char *errString;
 
    static char *subcommands[] = { "delete", "get", "keys", "set", "type",
                                   "values", (char *) NULL };
    enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx };
 
    if (objc < 2) {
        Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
        return TCL_ERROR;
    }
 
    if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
            != TCL_OK) {
        return TCL_ERROR;
    }
 
    switch (index) {
        case DeleteIdx:                 /* delete */
            if (objc == 3) {
                return DeleteKey(interp, objv[2]);
            } else if (objc == 4) {
                return DeleteValue(interp, objv[2], objv[3]);
            }
            errString = "keyName ?valueName?";
            break;
        case GetIdx:                    /* get */
            if (objc == 4) {
                return GetValue(interp, objv[2], objv[3]);
            }
            errString = "keyName valueName";
            break;
        case KeysIdx:                   /* keys */
            if (objc == 3) {
                return GetKeyNames(interp, objv[2], NULL);
            } else if (objc == 4) {
                return GetKeyNames(interp, objv[2], objv[3]);
            }
            errString = "keyName ?pattern?";
            break;
        case SetIdx:                    /* set */
            if (objc == 3) {
                HKEY key;
 
                /*
                 * Create the key and then close it immediately.
                 */
 
                if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key)
                        != TCL_OK) {
                    return TCL_ERROR;
                }
                RegCloseKey(key);
                return TCL_OK;
            } else if (objc == 5 || objc == 6) {
                Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
                return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
            }
            errString = "keyName ?valueName data ?type??";
            break;
        case TypeIdx:                   /* type */
            if (objc == 4) {
                return GetType(interp, objv[2], objv[3]);
            }
            errString = "keyName valueName";
            break;
        case ValuesIdx:                 /* values */
            if (objc == 3) {
                return GetValueNames(interp, objv[2], NULL);
            } else if (objc == 4) {
                return GetValueNames(interp, objv[2], objv[3]);
            }
            errString = "keyName ?pattern?";
            break;
    }
    Tcl_WrongNumArgs(interp, 2, objv, errString);
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * DeleteKey --
 *
 *      This function deletes a registry key.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static int
DeleteKey(
    Tcl_Interp *interp,         /* Current interpreter. */
    Tcl_Obj *keyNameObj)        /* Name of key to delete. */
{
    char *tail, *buffer, *hostName, *keyName;
    HKEY rootKey, subkey;
    DWORD result;
    int length;
    Tcl_Obj *resultPtr;
 
    /*
     * Find the parent of the key being deleted and open it.
     */
 
    keyName = Tcl_GetStringFromObj(keyNameObj, &length);
    buffer = ckalloc(length + 1);
    strcpy(buffer, keyName);
 
    if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)
            != TCL_OK) {
        ckfree(buffer);
        return TCL_ERROR;
    }
 
    resultPtr = Tcl_GetObjResult(interp);
    if (*keyName == '\0') {
        Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1);
        ckfree(buffer);
        return TCL_ERROR;
    }
 
    tail = strrchr(keyName, '\\');
    if (tail) {
        *tail++ = '\0';
    } else {
        tail = keyName;
        keyName = NULL;
    }
 
    result = OpenSubKey(hostName, rootKey, keyName,
            KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
    if (result != ERROR_SUCCESS) {
        ckfree(buffer);
        if (result == ERROR_FILE_NOT_FOUND) {
            return TCL_OK;
        } else {
            Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
            AppendSystemError(interp, result);
            return TCL_ERROR;
        }
    }
 
    /*
     * Now we recursively delete the key and everything below it.
     */
 
    result = RecursiveDeleteKey(subkey, tail);
 
    if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
        Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
        AppendSystemError(interp, result);
        result = TCL_ERROR;
    } else {
        result = TCL_OK;
    }
 
    RegCloseKey(subkey);
    ckfree(buffer);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * DeleteValue --
 *
 *      This function deletes a value from a registry key.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static int
DeleteValue(
    Tcl_Interp *interp,         /* Current interpreter. */
    Tcl_Obj *keyNameObj,        /* Name of key. */
    Tcl_Obj *valueNameObj)      /* Name of value to delete. */
{
    HKEY key;
    char *valueName;
    int length;
    DWORD result;
    Tcl_Obj *resultPtr;
 
    /*
     * Attempt to open the key for deletion.
     */
 
    if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
            != TCL_OK) {
        return TCL_ERROR;
    }
 
    resultPtr = Tcl_GetObjResult(interp);
    valueName = Tcl_GetStringFromObj(valueNameObj, &length);
    result = RegDeleteValue(key, valueName);
    if (result != ERROR_SUCCESS) {
        Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
                Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
                Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
        AppendSystemError(interp, result);
        result = TCL_ERROR;
    } else {
        result = TCL_OK;
    }
    RegCloseKey(key);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * GetKeyNames --
 *
 *      This function enumerates the subkeys of a given key.  If the
 *      optional pattern is supplied, then only keys that match the
 *      pattern will be returned.
 *
 * Results:
 *      Returns the list of subkeys in the result object of the
 *      interpreter, or an error message on failure.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static int
GetKeyNames(
    Tcl_Interp *interp,         /* Current interpreter. */
    Tcl_Obj *keyNameObj,        /* Key to enumerate. */
    Tcl_Obj *patternObj)        /* Optional match pattern. */
{
    HKEY key;
    DWORD index;
    char buffer[MAX_PATH+1], *pattern;
    Tcl_Obj *resultPtr;
    int result = TCL_OK;
 
    /*
     * Attempt to open the key for enumeration.
     */
 
    if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)
            != TCL_OK) {
        return TCL_ERROR;
    }
 
    if (patternObj) {
        pattern = Tcl_GetStringFromObj(patternObj, NULL);
    } else {
        pattern = NULL;
    }
 
    /*
     * Enumerate over the subkeys until we get an error, indicating the
     * end of the list.
     */
 
    resultPtr = Tcl_GetObjResult(interp);
    for (index = 0; RegEnumKey(key, index, buffer, MAX_PATH+1)
             == ERROR_SUCCESS; index++) {
        if (pattern && !Tcl_StringMatch(buffer, pattern)) {
            continue;
        }
        result = Tcl_ListObjAppendElement(interp, resultPtr,
                Tcl_NewStringObj(buffer, -1));
        if (result != TCL_OK) {
            break;
        }
    }
 
    RegCloseKey(key);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * GetType --
 *
 *      This function gets the type of a given registry value and
 *      places it in the interpreter result.
 *
 * Results:
 *      Returns a normal Tcl result.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static int
GetType(
    Tcl_Interp *interp,         /* Current interpreter. */
    Tcl_Obj *keyNameObj,        /* Name of key. */
    Tcl_Obj *valueNameObj)      /* Name of value to get. */
{
    HKEY key;
    Tcl_Obj *resultPtr;
    DWORD result;
    DWORD type;
 
    /*
     * Attempt to open the key for reading.
     */
 
    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
            != TCL_OK) {
        return TCL_ERROR;
    }
 
    /*
     * Get the type of the value.
     */
 
    resultPtr = Tcl_GetObjResult(interp);
 
    result = RegQueryValueEx(key, Tcl_GetStringFromObj(valueNameObj, NULL),
            NULL, &type, NULL, NULL);
    RegCloseKey(key);
 
    if (result != ERROR_SUCCESS) {
        Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
                Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
                Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
        AppendSystemError(interp, result);
        return TCL_ERROR;
    }
 
    /*
     * Set the type into the result.  Watch out for unknown types.
     * If we don't know about the type, just use the numeric value.
     */
 
    if (type > lastType || type < 0) {
        Tcl_SetIntObj(resultPtr, type);
    } else {
        Tcl_SetStringObj(resultPtr, typeNames[type], -1);
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * GetValue --
 *
 *      This function gets the contents of a registry value and places
 *      a list containing the data and the type in the interpreter
 *      result.
 *
 * Results:
 *      Returns a normal Tcl result.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static int
GetValue(
    Tcl_Interp *interp,         /* Current interpreter. */
    Tcl_Obj *keyNameObj,        /* Name of key. */
    Tcl_Obj *valueNameObj)      /* Name of value to get. */
{
    HKEY key;
    char *valueName;
    DWORD result, length, type;
    Tcl_Obj *resultPtr;
    Tcl_DString data;
 
    /*
     * Attempt to open the key for reading.
     */
 
    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
            != TCL_OK) {
        return TCL_ERROR;
    }
 
    /*
     * Initialize a Dstring to maximum statically allocated size
     * we could get one more byte by avoiding Tcl_DStringSetLength()
     * and just setting length to TCL_DSTRING_STATIC_SIZE, but this
     * should be safer if the implementation Dstrings changes.
     *
     * This allows short values to be read from the registy in one call.
     * Longer values need a second call with an expanded DString.
     */
 
    Tcl_DStringInit(&data);
    Tcl_DStringSetLength(&data, length = TCL_DSTRING_STATIC_SIZE - 1);
 
    resultPtr = Tcl_GetObjResult(interp);
 
    valueName = Tcl_GetStringFromObj(valueNameObj, NULL);
    result = RegQueryValueEx(key, valueName, NULL, &type,
            (LPBYTE) Tcl_DStringValue(&data), &length);
    if (result == ERROR_MORE_DATA) {
        Tcl_DStringSetLength(&data, length);
        result = RegQueryValueEx(key, valueName, NULL, &type,
                (LPBYTE) Tcl_DStringValue(&data), &length);
    }
    RegCloseKey(key);
    if (result != ERROR_SUCCESS) {
        Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
                Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
                Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
        AppendSystemError(interp, result);
        Tcl_DStringFree(&data);
        return TCL_ERROR;
    }
 
    /*
     * If the data is a 32-bit quantity, store it as an integer object.  If it
     * is a multi-string, store it as a list of strings.  For null-terminated
     * strings, append up the to first null.  Otherwise, store it as a binary
     * string.
     */
 
    if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
        Tcl_SetIntObj(resultPtr, ConvertDWORD(type,
                *((DWORD*) Tcl_DStringValue(&data))));
    } else if (type == REG_MULTI_SZ) {
        char *p = Tcl_DStringValue(&data);
        char *lastChar = Tcl_DStringValue(&data) + Tcl_DStringLength(&data);
 
        /*
         * Multistrings are stored as an array of null-terminated strings,
         * terminated by two null characters.  Also do a bounds check in
         * case we get bogus data.
         */
 
        while (p < lastChar && *p != '\0') {
            Tcl_ListObjAppendElement(interp, resultPtr,
                    Tcl_NewStringObj(p, -1));
            while (*p++ != '\0') {}
        }
    } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
        Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), -1);
    } else {
        Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), length);
    }
    Tcl_DStringFree(&data);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * GetValueNames --
 *
 *      This function enumerates the values of the a given key.  If
 *      the optional pattern is supplied, then only value names that
 *      match the pattern will be returned.
 *
 * Results:
 *      Returns the list of value names in the result object of the
 *      interpreter, or an error message on failure.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static int
GetValueNames(
    Tcl_Interp *interp,         /* Current interpreter. */
    Tcl_Obj *keyNameObj,        /* Key to enumerate. */
    Tcl_Obj *patternObj)        /* Optional match pattern. */
{
    HKEY key;
    Tcl_Obj *resultPtr;
    DWORD index, size, result;
    Tcl_DString buffer;
    char *pattern;
 
    /*
     * Attempt to open the key for enumeration.
     */
 
    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
            != TCL_OK) {
        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.
     */
 
    result = RegQueryInfoKey(key, NULL, NULL, NULL, NULL, NULL, NULL, &index,
        &size, NULL, NULL, NULL);
    if (result != ERROR_SUCCESS) {
        Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
                Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
        AppendSystemError(interp, result);
        RegCloseKey(key);
        result = TCL_ERROR;
        goto done;
    }
    size++;
 
 
    Tcl_DStringInit(&buffer);
    Tcl_DStringSetLength(&buffer, size);
    index = 0;
    result = TCL_OK;
 
    if (patternObj) {
        pattern = Tcl_GetStringFromObj(patternObj, NULL);
    } else {
        pattern = NULL;
    }
 
    /*
     * Enumerate the values under the given subkey until we get an error,
     * indicating the end of the list.  Note that we need to reset size
     * after each iteration because RegEnumValue smashes the old value.
     */
 
    while (RegEnumValue(key, index, Tcl_DStringValue(&buffer), &size, NULL,
            NULL, NULL, NULL) == ERROR_SUCCESS) {
        if (!pattern || Tcl_StringMatch(Tcl_DStringValue(&buffer), pattern)) {
            result = Tcl_ListObjAppendElement(interp, resultPtr,
                    Tcl_NewStringObj(Tcl_DStringValue(&buffer), size));
            if (result != TCL_OK) {
                break;
            }
        }
        index++;
        size = Tcl_DStringLength(&buffer);
    }
    Tcl_DStringFree(&buffer);
 
    done:
    RegCloseKey(key);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * OpenKey --
 *
 *      This function opens the specified key.  This function is a
 *      simple wrapper around ParseKeyName and OpenSubKey.
 *
 * Results:
 *      Returns the opened key in the keyPtr argument and a Tcl
 *      result code.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static int
OpenKey(
    Tcl_Interp *interp,         /* Current interpreter. */
    Tcl_Obj *keyNameObj,        /* Key to open. */
    REGSAM mode,                /* Access mode. */
    int flags,                  /* 0 or REG_CREATE. */
    HKEY *keyPtr)               /* Returned HKEY. */
{
    char *keyName, *buffer, *hostName;
    int length;
    HKEY rootKey;
    DWORD result;
 
    keyName = Tcl_GetStringFromObj(keyNameObj, &length);
    buffer = ckalloc(length + 1);
    strcpy(buffer, keyName);
 
    result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
    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);
            AppendSystemError(interp, result);
            result = TCL_ERROR;
        } else {
            result = TCL_OK;
        }
    }
 
    ckfree(buffer);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * OpenSubKey --
 *
 *      This function opens a given subkey of a root key on the
 *      specified host.
 *
 * Results:
 *      Returns the opened key in the keyPtr and a Windows error code
 *      as the return value.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static DWORD
OpenSubKey(
    char *hostName,             /* Host to access, or NULL for local. */
    HKEY rootKey,               /* Root registry key. */
    char *keyName,              /* Subkey name. */
    REGSAM mode,                /* Access mode. */
    int flags,                  /* 0 or REG_CREATE. */
    HKEY *keyPtr)               /* Returned HKEY. */
{
    DWORD result;
 
    /*
     * Attempt to open the root key on a remote host if necessary.
     */
 
    if (hostName) {
        result = RegConnectRegistry(hostName, rootKey, &rootKey);
        if (result != ERROR_SUCCESS) {
            return result;
        }
    }
 
    /*
     * Now open the specified key with the requested permissions.  Note
     * that this key must be closed by the caller.
     */
 
    if (flags & REG_CREATE) {
        DWORD create;
        result = RegCreateKeyEx(rootKey, keyName, 0, "",
                REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
    } else {
        result = RegOpenKeyEx(rootKey, keyName, 0, mode, keyPtr);
    }
 
    /*
     * Be sure to close the root key since we are done with it now.
     */
 
    if (hostName) {
        RegCloseKey(rootKey);
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * ParseKeyName --
 *
 *      This function parses a key name into the host, root, and subkey
 *      parts.
 *
 * Results:
 *      The pointers to the start of the host and subkey names are
 *      returned in the hostNamePtr and keyNamePtr variables.  The
 *      specified root HKEY is returned in rootKeyPtr.  Returns
 *      a standard Tcl result.
 *
 *
 * Side effects:
 *      Modifies the name string by inserting nulls.
 *
 *----------------------------------------------------------------------
 */
 
static int
ParseKeyName(
    Tcl_Interp *interp,         /* Current interpreter. */
    char *name,
    char **hostNamePtr,
    HKEY *rootKeyPtr,
    char **keyNamePtr)
{
    char *rootName;
    int result, index;
    Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp);
 
    /*
     * Split the key into host and root portions.
     */
 
    *hostNamePtr = *keyNamePtr = rootName = NULL;
    if (name[0] == '\\') {
        if (name[1] == '\\') {
            *hostNamePtr = name;
            for (rootName = name+2; *rootName != '\0'; rootName++) {
                if (*rootName == '\\') {
                    *rootName++ = '\0';
                    break;
                }
            }
        }
    } else {
        rootName = name;
    }
    if (!rootName) {
        Tcl_AppendStringsToObj(resultPtr, "bad key \"", name,
                "\": must start with a valid root", NULL);
        return TCL_ERROR;
    }
 
    /*
     * Split the root into root and subkey portions.
     */
 
    for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) {
        if (**keyNamePtr == '\\') {
            **keyNamePtr = '\0';
            (*keyNamePtr)++;
            break;
        }
    }
 
    /*
     * Look for a matching root name.
     */
 
    rootObj = Tcl_NewStringObj(rootName, -1);
    result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name",
            TCL_EXACT, &index);
    Tcl_DecrRefCount(rootObj);
    if (result != TCL_OK) {
        return TCL_ERROR;
    }
    *rootKeyPtr = rootKeys[index];
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * RecursiveDeleteKey --
 *
 *      This function recursively deletes all the keys below a starting
 *      key.  Although Windows 95 does this automatically, we still need
 *      to do this for Windows NT.
 *
 * Results:
 *      Returns a Windows error code.
 *
 * Side effects:
 *      Deletes all of the keys and values below the given key.
 *
 *----------------------------------------------------------------------
 */
 
static DWORD
RecursiveDeleteKey(
    HKEY startKey,              /* Parent of key to be deleted. */
    char *keyName)              /* Name of key to be deleted. */
{
    DWORD result, subKeyLength;
    Tcl_DString subkey;
    HKEY hKey;
 
    /*
     * Do not allow NULL or empty key name.
     */
 
    if (!keyName || lstrlen(keyName) == '\0') {
        return ERROR_BADKEY;
    }
 
    result = RegOpenKeyEx(startKey, keyName, 0,
            KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
    if (result != ERROR_SUCCESS) {
        return result;
    }
    result = RegQueryInfoKey(hKey, NULL, NULL, NULL, NULL, &subKeyLength,
            NULL, NULL, NULL, NULL, NULL, NULL);
    subKeyLength++;
    if (result != ERROR_SUCCESS) {
        return result;
    }
 
    Tcl_DStringInit(&subkey);
    Tcl_DStringSetLength(&subkey, subKeyLength);
 
    while (result == ERROR_SUCCESS) {
        /*
         * Always get index 0 because key deletion changes ordering.
         */
 
        subKeyLength = Tcl_DStringLength(&subkey);
        result=RegEnumKeyEx(hKey, 0, Tcl_DStringValue(&subkey), &subKeyLength,
                NULL, NULL, NULL, NULL);
        if (result == ERROR_NO_MORE_ITEMS) {
            result = RegDeleteKey(startKey, keyName);
            break;
        } else if (result == ERROR_SUCCESS) {
            result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
        }
    }
    Tcl_DStringFree(&subkey);
    RegCloseKey(hKey);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * SetValue --
 *
 *      This function sets the contents of a registry value.  If
 *      the key or value does not exist, it will be created.  If it
 *      does exist, then the data and type will be replaced.
 *
 * Results:
 *      Returns a normal Tcl result.
 *
 * Side effects:
 *      May create new keys or values.
 *
 *----------------------------------------------------------------------
 */
 
static int
SetValue(
    Tcl_Interp *interp,         /* Current interpreter. */
    Tcl_Obj *keyNameObj,        /* Name of key. */
    Tcl_Obj *valueNameObj,      /* Name of value to set. */
    Tcl_Obj *dataObj,           /* Data to be written. */
    Tcl_Obj *typeObj)           /* Type of data to be written. */
{
    DWORD type, result;
    HKEY key;
    int length;
    char *valueName;
    Tcl_Obj *resultPtr;
 
    if (typeObj == NULL) {
        type = REG_SZ;
    } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
            0, (int *) &type) != TCL_OK) {
        if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) {
            return TCL_ERROR;
        }
        Tcl_ResetResult(interp);
    }
    if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
        return TCL_ERROR;
    }
 
    valueName = Tcl_GetStringFromObj(valueNameObj, &length);
    resultPtr = Tcl_GetObjResult(interp);
 
    if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
        DWORD value;
        if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) {
            RegCloseKey(key);
            return TCL_ERROR;
        }
 
        value = ConvertDWORD(type, value);
        result = RegSetValueEx(key, valueName, 0, type, (BYTE*) &value,
                sizeof(DWORD));
    } else if (type == REG_MULTI_SZ) {
        Tcl_DString data;
        int objc, i;
        Tcl_Obj **objv;
        char *element;
 
        if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
            RegCloseKey(key);
            return TCL_ERROR;
        }
 
        /*
         * Append the elements as null terminated strings.  Note that
         * we must not assume the length of the string in case there are
         * embedded nulls, which aren't allowed in REG_MULTI_SZ values.
         */
 
        Tcl_DStringInit(&data);
        for (i = 0; i < objc; i++) {
            element = Tcl_GetStringFromObj(objv[i], NULL);
            Tcl_DStringAppend(&data, element, -1);
            Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
        }
        result = RegSetValueEx(key, valueName, 0, type,
                (LPBYTE) Tcl_DStringValue(&data),
                (DWORD) (Tcl_DStringLength(&data)+1));
        Tcl_DStringFree(&data);
    } else {
        char *data = Tcl_GetStringFromObj(dataObj, &length);
 
        /*
         * Include the null in the length if we are storing a null terminated
         * string.  Note that we also need to call strlen to find the first
         * null so we don't pass bad data to the registry.
         */
 
        if (type == REG_SZ || type == REG_EXPAND_SZ) {
            length = strlen(data) + 1;
        }
 
        result = RegSetValueEx(key, valueName, 0, type, (LPBYTE)data, length);
    }
    RegCloseKey(key);
    if (result != ERROR_SUCCESS) {
        Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
        AppendSystemError(interp, result);
        return TCL_ERROR;
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * AppendSystemError --
 *
 *      This routine formats a Windows system error message and places
 *      it into the interpreter result.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static void
AppendSystemError(
    Tcl_Interp *interp,         /* Current interpreter. */
    DWORD error)                /* Result code from error. */
{
    int length;
    char *msgbuf, id[10];
    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
 
    sprintf(id, "%d", error);
    length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
            | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
            MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&msgbuf,
            0, NULL);
    if (length == 0) {
        if (error == ERROR_CALL_NOT_IMPLEMENTED) {
            msgbuf = "function not supported under Win32s";
        } else {
            msgbuf = id;
        }
    } else {
        /*
         * Trim the trailing CR/LF from the system message.
         */
        if (msgbuf[length-1] == '\n') {
            msgbuf[--length] = 0;
        }
        if (msgbuf[length-1] == '\r') {
            msgbuf[--length] = 0;
        }
    }
    Tcl_SetErrorCode(interp, "WINDOWS", id, msgbuf, (char *) NULL);
    Tcl_AppendToObj(resultPtr, msgbuf, -1);
 
    if (length != 0) {
        LocalFree(msgbuf);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * ConvertDWORD --
 *
 *      This function determines whether a DWORD needs to be byte
 *      swapped, and returns the appropriately swapped value.
 *
 * Results:
 *      Returns a converted DWORD.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
static DWORD
ConvertDWORD(
    DWORD type,                 /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
    DWORD value)                /* The value to be converted. */
{
    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;
    return (type != localType) ? SWAPLONG(value) : value;
}
Browse

Tools

Subversion Repositories or1k_old

[/] [or1k_old/] [trunk/] [insight/] [tcl/] [win/] [tclWinReg.c] - Blame information for rev 1782

Line No.	Rev	Author	Line
1	578	markom	`/*`
2			`* tclWinReg.c --`
3			`*`
4			`* This file contains the implementation of the "registry" Tcl`
5			`* built-in command. This command is built as a dynamically`
6			`* loadable extension in a separate DLL.`
7			`*`
8			`* Copyright (c) 1997 by Sun Microsystems, Inc.`
9			`*`
10			`* See the file "license.terms" for information on usage and redistribution`
11			`* of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
12			`*`
13			`* RCS: @(#) $Id: tclWinReg.c,v 1.1.1.1 2002-01-16 10:25:39 markom Exp $`
14			`*/`
15
16			`#include <tcl.h>`
17			`#include <stdlib.h>`
18
19			`#define WIN32_LEAN_AND_MEAN`
20			`#include <windows.h>`
21			`#undef WIN32_LEAN_AND_MEAN`
22
23			`/*`
24			`* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the`
25			`* Registry_Init declaration is in the source file itself, which is only`
26			`* accessed when we are building a library.`
27			`*/`
28
29			`#undef TCL_STORAGE_CLASS`
30			`#define TCL_STORAGE_CLASS DLLEXPORT`
31
32			`/*`
33			`* VC++ has an alternate entry point called DllMain, so we need to rename`
34			`* our entry point.`
35			`*/`
36
37			`#ifdef DLL_BUILD`
38			`# if defined(_MSC_VER)`
39			`# define DllEntryPoint DllMain`
40			`# endif`