From: Chris Hanson Date: Tue, 9 Mar 1999 05:39:03 +0000 (+0000) Subject: Implement primitives to provide registry access. X-Git-Tag: 20090517-FFI~4581 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=488ff21c49163da97603cca4398115e6c9443ab2;p=mit-scheme.git Implement primitives to provide registry access. --- diff --git a/v7/src/microcode/ntapi.h b/v7/src/microcode/ntapi.h index f7d084afb..74219c42b 100644 --- a/v7/src/microcode/ntapi.h +++ b/v7/src/microcode/ntapi.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: ntapi.h,v 1.9 1999/01/02 06:11:34 cph Exp $ +$Id: ntapi.h,v 1.10 1999/03/09 05:39:03 cph Exp $ Copyright (c) 1997, 1999 Massachusetts Institute of Technology @@ -35,6 +35,7 @@ enum syscall_names apicall_DeleteFile, apicall_DuplicateHandle, apicall_EnumWindows, + apicall_ExpandEnvironmentStrings, apicall_FindFirstFile, apicall_GetExitCodeProcess, apicall_GetFileAttributes, @@ -48,6 +49,16 @@ enum syscall_names apicall_MsgWaitForMultipleObjects, apicall_PeekNamedPipe, apicall_ReadFile, + apicall_RegCloseKey, + apicall_RegCreateKeyEx, + apicall_RegDeleteKey, + apicall_RegDeleteValue, + apicall_RegEnumKeyEx, + apicall_RegEnumValue, + apicall_RegOpenKeyEx, + apicall_RegQueryInfoKey, + apicall_RegQueryValueEx, + apicall_RegSetValueEx, apicall_RemoveDirectory, apicall_SetCurrentDirectory, apicall_SetFileAttributes, @@ -881,6 +892,7 @@ static char * syscall_names_table [] = "DELETE-FILE", "DUPLICATE-HANDLE", "ENUM-WINDOWS", + "EXPAND-ENVIRONMENT-STRINGS", "FIND-FIRST-FILE", "GET-EXIT-CODE-PROCESS", "GET-FILE-ATTRIBUTES", @@ -894,6 +906,16 @@ static char * syscall_names_table [] = "MSG-WAIT-FOR-MULTIPLE-OBJECTS", "PEEK-NAMED-PIPE", "READ-FILE", + "REG-CLOSE-KEY", + "REG-CREATE-KEY-EX", + "REG-DELETE-KEY", + "REG-DELETE-VALUE", + "REG-ENUM-KEY-EX", + "REG-ENUM-VALUE", + "REG-OPEN-KEY-EX", + "REG-QUERY-INFO-KEY", + "REG-QUERY-VALUE-EX", + "REG-SET-VALUE-EX", "REMOVE-DIRECTORY", "SET-CURRENT-DIRECTORY", "SET-FILE-ATTRIBUTES", diff --git a/v7/src/microcode/prntenv.c b/v7/src/microcode/prntenv.c index b85761b64..49bfb4b4c 100644 --- a/v7/src/microcode/prntenv.c +++ b/v7/src/microcode/prntenv.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: prntenv.c,v 1.8 1999/01/02 06:11:34 cph Exp $ +$Id: prntenv.c,v 1.9 1999/03/09 05:38:59 cph Exp $ Copyright (c) 1993-1999 Massachusetts Institute of Technology @@ -81,3 +81,417 @@ DEFINE_PRIMITIVE ("WIN32-VIRTUAL-QUERY", Prim_win32_virtual_query, 1, 1, 0) PRIMITIVE_RETURN (result); } } + +/* Registry Access */ + +#define REGISTRY_API_CALL(proc, args) \ +{ \ + LONG API_code = (proc args); \ + if (API_code != ERROR_SUCCESS) \ + NT_error_api_call (API_code, apicall_ ## proc); \ +} + +#define HKEY_ARG(n) ((HKEY) (arg_ulong_integer (n))) +#define SUBKEY_ARG(n) ((LPCTSTR) (STRING_ARG (n))) +#define HKEY_TO_OBJECT(hkey) (ulong_to_integer ((unsigned long) (hkey))) + +#define GUARANTEE_RESULT_SPACE() \ +{ \ + /* Do GC now if not enough storage to cons result. */ \ + /* 1024 is arbitrary but big enough for these primitives. */ \ + Primitive_GC_If_Needed (1024); \ +} + +#define ACCUM_PRK(name) \ +{ \ + v = (cons ((cons ((char_pointer_to_string (#name)), \ + (HKEY_TO_OBJECT (name)))), \ + v)); \ +} + +DEFINE_PRIMITIVE ("win32-predefined-registry-keys", Prim_win32_predefined_registry_keys, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); + { + SCHEME_OBJECT v = EMPTY_LIST; +#ifdef HKEY_CLASSES_ROOT + ACCUM_PRK (HKEY_CLASSES_ROOT); +#endif +#ifdef HKEY_CURRENT_USER + ACCUM_PRK (HKEY_CURRENT_USER); +#endif +#ifdef HKEY_LOCAL_MACHINE + ACCUM_PRK (HKEY_LOCAL_MACHINE); +#endif +#ifdef HKEY_USERS + ACCUM_PRK (HKEY_USERS); +#endif +#ifdef HKEY_PERFORMANCE_DATA + ACCUM_PRK (HKEY_PERFORMANCE_DATA); +#endif +#ifdef HKEY_CURRENT_CONFIG + ACCUM_PRK (HKEY_CURRENT_CONFIG); +#endif +#ifdef HKEY_DYN_DATA + ACCUM_PRK (HKEY_DYN_DATA); +#endif + PRIMITIVE_RETURN (v); + } +} + +DEFINE_PRIMITIVE ("win32-open-registry-key", Prim_win32_open_registry_key, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + CHECK_ARG (3, WEAK_PAIR_P); + GUARANTEE_RESULT_SPACE (); + { + HKEY result; + REGSAM mask = KEY_ALL_ACCESS; + while (1) + { + LONG code + = (RegOpenKeyEx ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0, + mask, (&result))); + if (code == ERROR_SUCCESS) + { + SET_PAIR_CDR ((ARG_REF (3)), (HKEY_TO_OBJECT (result))); + break; + } + if (code == ERROR_FILE_NOT_FOUND) + { + SET_PAIR_CDR ((ARG_REF (3)), SHARP_F); + break; + } + if (code == ERROR_ACCESS_DENIED) + switch (mask) + { + case KEY_ALL_ACCESS: + mask = KEY_READ; + continue; + case KEY_READ: + mask = KEY_ENUMERATE_SUB_KEYS; + continue; + case KEY_ENUMERATE_SUB_KEYS: + break; + } + NT_error_api_call (code, apicall_RegOpenKeyEx); + } + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("win32-create-registry-key", Prim_win32_create_registry_key, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + CHECK_ARG (3, WEAK_PAIR_P); + GUARANTEE_RESULT_SPACE (); + { + HKEY result; + DWORD disposition; + REGSAM mask = KEY_ALL_ACCESS; + while (1) + { + LONG code + = (RegCreateKeyEx ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0, + "", REG_OPTION_NON_VOLATILE, + mask, 0, (&result), (&disposition))); + if (code == ERROR_SUCCESS) + break; + if (code == ERROR_ACCESS_DENIED) + switch (mask) + { + case KEY_ALL_ACCESS: + mask = KEY_READ; + continue; + case KEY_READ: + mask = KEY_ENUMERATE_SUB_KEYS; + continue; + case KEY_ENUMERATE_SUB_KEYS: + break; + } + NT_error_api_call (code, apicall_RegCreateKeyEx); + } + SET_PAIR_CDR ((ARG_REF (3)), (HKEY_TO_OBJECT (result))); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (disposition == REG_CREATED_NEW_KEY)); + } +} + +DEFINE_PRIMITIVE ("win32-close-registry-key", Prim_win32_close_registry_key, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + REGISTRY_API_CALL (RegCloseKey, (HKEY_ARG (1))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("win32-set-registry-value", Prim_win32_set_registry_value, 4, 4, 0) +{ + PRIMITIVE_HEADER (4); + { + DWORD data_type = (arg_ulong_integer (3)); + DWORD data_length; + BYTE * data; + union + { + DWORD dword; + BYTE bytes [4]; + } dword_data; + switch (data_type) + { + case REG_DWORD_LITTLE_ENDIAN: + { + DWORD arg = (arg_ulong_integer (4)); + ((dword_data . bytes) [0]) = (arg & 0xFF); + ((dword_data . bytes) [1]) = ((arg >> 8) & 0xFF); + ((dword_data . bytes) [2]) = ((arg >> 16) & 0xFF); + ((dword_data . bytes) [3]) = ((arg >> 24) & 0xFF); + } + data_length = (sizeof (dword_data . bytes)); + data = (dword_data . bytes); + break; + case REG_DWORD_BIG_ENDIAN: + { + DWORD arg = (arg_ulong_integer (4)); + ((dword_data . bytes) [3]) = (arg & 0xFF); + ((dword_data . bytes) [2]) = ((arg >> 8) & 0xFF); + ((dword_data . bytes) [1]) = ((arg >> 16) & 0xFF); + ((dword_data . bytes) [0]) = ((arg >> 24) & 0xFF); + } + data_length = (sizeof (dword_data . bytes)); + data = (dword_data . bytes); + break; + case REG_SZ: + case REG_EXPAND_SZ: + case REG_MULTI_SZ: + CHECK_ARG (4, STRING_P); + data_length = ((STRING_LENGTH (ARG_REF (4))) + 1); + data = ((BYTE *) (STRING_LOC ((ARG_REF (4)), 0))); + break; + default: + CHECK_ARG (4, STRING_P); + data_length = (STRING_LENGTH (ARG_REF (4))); + data = ((BYTE *) (STRING_LOC ((ARG_REF (4)), 0))); + break; + break; + } + REGISTRY_API_CALL + (RegSetValueEx, ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0, + data_type, data, data_length)); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("win32-delete-registry-value", Prim_win32_delete_registry_value, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + REGISTRY_API_CALL (RegDeleteValue, ((HKEY_ARG (1)), (SUBKEY_ARG (2)))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("win32-delete-registry-key", Prim_win32_delete_registry_key, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + REGISTRY_API_CALL (RegDeleteKey, ((HKEY_ARG (1)), (SUBKEY_ARG (2)))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("win32-enumerate-registry-key", Prim_win32_enumerate_registry_key, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + GUARANTEE_RESULT_SPACE (); + CHECK_ARG (3, STRING_P); + { + DWORD buffer_size = ((STRING_LENGTH (ARG_REF (3))) + 1); + FILETIME last_write_time; + LONG code + = (RegEnumKeyEx ((HKEY_ARG (1)), + ((DWORD) (arg_ulong_integer (2))), + ((CHAR *) (STRING_LOC ((ARG_REF (3)), 0))), + (&buffer_size), + 0, 0, 0, (&last_write_time))); + if (code == ERROR_NO_MORE_ITEMS) + PRIMITIVE_RETURN (SHARP_F); + if (code != ERROR_SUCCESS) + NT_error_api_call (code, apicall_RegEnumKeyEx); + PRIMITIVE_RETURN (ulong_to_integer (buffer_size)); + } +} + +DEFINE_PRIMITIVE ("win32-query-info-registry-key", Prim_win32_query_info_registry_key, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + GUARANTEE_RESULT_SPACE (); + { + DWORD n_sub_keys; + DWORD max_sub_key_length; + DWORD n_values; + DWORD max_value_name_length; + DWORD max_value_length; + REGISTRY_API_CALL + (RegQueryInfoKey, ((HKEY_ARG (1)), + 0, 0, 0, + (&n_sub_keys), + (&max_sub_key_length), + 0, + (&n_values), + (&max_value_name_length), + (&max_value_length), + 0, 0)); + /* Gratuitous incompatibility alert! NT doesn't include the + terminating zero in the length field; 95/98 does. */ + if (NT_windows_type == wintype_95) + max_sub_key_length -= 1; + { + SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, 1)); + VECTOR_SET (result, 0, (ulong_to_integer (n_sub_keys))); + VECTOR_SET (result, 1, (ulong_to_integer (max_sub_key_length))); + VECTOR_SET (result, 2, (ulong_to_integer (n_values))); + VECTOR_SET (result, 3, (ulong_to_integer (max_value_name_length))); + VECTOR_SET (result, 4, (ulong_to_integer (max_value_length))); + PRIMITIVE_RETURN (result); + } + } +} + +DEFINE_PRIMITIVE ("win32-enumerate-registry-value", Prim_win32_enumerate_registry_value, 4, 4, 0) +{ + PRIMITIVE_HEADER (4); + GUARANTEE_RESULT_SPACE (); + CHECK_ARG (3, STRING_P); + if ((ARG_REF (4)) != SHARP_F) + CHECK_ARG (4, STRING_P); + { + DWORD name_size = ((STRING_LENGTH (ARG_REF (3))) + 1); + DWORD data_type; + DWORD data_size + = (((ARG_REF (4)) == SHARP_F) + ? 0 + : (STRING_LENGTH (ARG_REF (4)))); + LONG code + = (RegEnumValue ((HKEY_ARG (1)), + ((DWORD) (arg_ulong_integer (2))), + ((LPTSTR) (STRING_LOC ((ARG_REF (3)), 0))), + (&name_size), + 0, + (&data_type), + (((ARG_REF (4)) == SHARP_F) + ? 0 + : ((LPBYTE) (STRING_LOC ((ARG_REF (4)), 0)))), + (&data_size))); + if (code == ERROR_NO_MORE_ITEMS) + PRIMITIVE_RETURN (SHARP_F); + if (code != ERROR_SUCCESS) + NT_error_api_call (code, apicall_RegEnumValue); + { + SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 3, 1)); + VECTOR_SET (result, 0, (ulong_to_integer (name_size))); + VECTOR_SET (result, 1, (ulong_to_integer (data_type))); + VECTOR_SET (result, 2, (ulong_to_integer (data_size))); + PRIMITIVE_RETURN (result); + } + } +} + +DEFINE_PRIMITIVE ("win32-query-info-registry-value", Prim_win32_query_info_registry_value, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + GUARANTEE_RESULT_SPACE (); + { + DWORD data_type; + DWORD data_size; + LONG code + = (RegQueryValueEx ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0, + (&data_type), 0, (&data_size))); + if (code == ERROR_FILE_NOT_FOUND) + PRIMITIVE_RETURN (SHARP_F); + if (code != ERROR_SUCCESS) + NT_error_api_call (code, apicall_RegQueryValueEx); + PRIMITIVE_RETURN + (cons ((ulong_to_integer (data_type)), + (ulong_to_integer (data_size)))); + } +} + +DEFINE_PRIMITIVE ("win32-query-registry-value", Prim_win32_query_registry_value, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + GUARANTEE_RESULT_SPACE (); + { + DWORD data_type; + DWORD data_size; + union + { + DWORD dword; + BYTE bytes [4]; + } dword_converter; + SCHEME_OBJECT result; + BYTE * data; + + { + LONG code + = (RegQueryValueEx ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0, + (&data_type), 0, (&data_size))); + if (code == ERROR_FILE_NOT_FOUND) + PRIMITIVE_RETURN (SHARP_F); + if (code != ERROR_SUCCESS) + NT_error_api_call (code, apicall_RegQueryValueEx); + } + switch (data_type) + { + case REG_DWORD_LITTLE_ENDIAN: + case REG_DWORD_BIG_ENDIAN: + data = (& (dword_converter . bytes)); + break; + + case REG_SZ: + case REG_EXPAND_SZ: + case REG_MULTI_SZ: + result = (allocate_string (data_size - 1)); + data = ((BYTE *) (STRING_LOC (result, 0))); + break; + + default: + result = (allocate_string (data_size)); + data = ((BYTE *) (STRING_LOC (result, 0))); + break; + } + REGISTRY_API_CALL + (RegQueryValueEx, ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0, + 0, data, (&data_size))); + switch (data_type) + { + case REG_DWORD_LITTLE_ENDIAN: + result + = (ulong_to_integer + (((DWORD) ((dword_converter . bytes) [0])) + || (((DWORD) ((dword_converter . bytes) [1])) << 8) + || (((DWORD) ((dword_converter . bytes) [2])) << 16) + || (((DWORD) ((dword_converter . bytes) [3])) << 24))); + break; + case REG_DWORD_BIG_ENDIAN: + result + = (ulong_to_integer + (((DWORD) ((dword_converter . bytes) [3])) + || (((DWORD) ((dword_converter . bytes) [2])) << 8) + || (((DWORD) ((dword_converter . bytes) [1])) << 16) + || (((DWORD) ((dword_converter . bytes) [0])) << 24))); + break; + } + PRIMITIVE_RETURN (cons ((ulong_to_integer (data_type)), result)); + } +} + +DEFINE_PRIMITIVE ("win32-expand-environment-strings", Prim_win32_expand_environment_strings, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + CHECK_ARG (1, STRING_P); + CHECK_ARG (2, STRING_P); + { + DWORD n_chars + = (ExpandEnvironmentStrings (((LPCTSTR) (STRING_LOC ((ARG_REF (1)), 0))), + ((LPTSTR) (STRING_LOC ((ARG_REF (2)), 0))), + ((STRING_LENGTH (ARG_REF (2))) + 1))); + if (n_chars == 0) + NT_error_api_call ((GetLastError ()), apicall_ExpandEnvironmentStrings); + PRIMITIVE_RETURN (ulong_to_integer (n_chars - 1)); + } +}