/* -*-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
PRIMITIVE_RETURN (result);
}
}
+\f
+/* 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));
+ }
+}
projects / mit-scheme.git / commitdiff