home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / prntenv.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  15KB  |  498 lines
  1. /* -*-C-*-
  2.  
  3. $Id: prntenv.c,v 1.10 2000/12/05 21:23:47 cph Exp $
  4.  
  5. Copyright (c) 1993-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Unix-specific process-environment primitives. */
  23. /* Win32 imitation */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "nt.h"
  28. #include "ntio.h"
  29.  
  30. DEFINE_PRIMITIVE ("FILE-TIME->STRING", Prim_file_time_to_string, 1, 1,
  31.   "Convert a file system time stamp into a date/time string.")
  32. {
  33.   PRIMITIVE_HEADER (1);
  34.   CHECK_ARG (1, INTEGER_P);
  35.   {
  36.     time_t clock = (arg_integer (1));
  37.     char * time_string = (ctime (&clock));
  38.     if (time_string == 0)
  39.       PRIMITIVE_RETURN (SHARP_F);
  40.     (time_string[24]) = '\0';
  41.     PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) time_string));
  42.   }
  43. }
  44.  
  45. DEFINE_PRIMITIVE ("GET-ENVIRONMENT-VARIABLE", Prim_get_environment_variable, 1, 1,
  46.   "Look up the value of a variable in the user's shell environment.\n\
  47. The argument, a variable name, must be a string.\n\
  48. The result is either a string (the variable's value),\n\
  49.  or #F indicating that the variable does not exist.")
  50. {
  51.   PRIMITIVE_HEADER (1);
  52.   {
  53.     CONST char * variable_value = (getenv (STRING_ARG (1)));
  54.     PRIMITIVE_RETURN
  55.       ((variable_value == 0)
  56.        ? SHARP_F
  57.        : (char_pointer_to_string ((unsigned char *) variable_value)));
  58.   }
  59. }
  60.  
  61. #define VQRESULT(index, value)                        \
  62.   VECTOR_SET (result, index, (ulong_to_integer (value)))
  63.  
  64.  
  65. DEFINE_PRIMITIVE ("WIN32-VIRTUAL-QUERY", Prim_win32_virtual_query, 1, 1, 0)
  66. {
  67.   PRIMITIVE_HEADER (1);
  68.   {
  69.     MEMORY_BASIC_INFORMATION info;
  70.     SCHEME_OBJECT result;
  71.     (void) VirtualQuery
  72.       (((LPCVOID) (arg_ulong_integer (1))), (&info), (sizeof (info)));
  73.     result = (allocate_marked_vector (TC_VECTOR, 7, 1));
  74.     VQRESULT (0, ((unsigned long) (info.BaseAddress)));
  75.     VQRESULT (1, ((unsigned long) (info.AllocationBase)));
  76.     VQRESULT (2, (info.AllocationProtect));
  77.     VQRESULT (3, (info.RegionSize));
  78.     VQRESULT (4, (info.State));
  79.     VQRESULT (5, (info.Protect));
  80.     VQRESULT (6, (info.Type));
  81.     PRIMITIVE_RETURN (result);
  82.   }
  83. }
  84.  
  85. /* Registry Access */
  86.  
  87. #define REGISTRY_API_CALL(proc, args)                    \
  88. {                                    \
  89.   LONG API_code = (proc args);                        \
  90.   if (API_code != ERROR_SUCCESS)                    \
  91.     NT_error_api_call (API_code, apicall_ ## proc);            \
  92. }
  93.  
  94. #define HKEY_ARG(n) ((HKEY) (arg_ulong_integer (n)))
  95. #define SUBKEY_ARG(n) ((LPCTSTR) (STRING_ARG (n)))
  96. #define HKEY_TO_OBJECT(hkey) (ulong_to_integer ((unsigned long) (hkey)))
  97.  
  98. #define GUARANTEE_RESULT_SPACE()                    \
  99. {                                    \
  100.   /* Do GC now if not enough storage to cons result. */            \
  101.   /* 1024 is arbitrary but big enough for these primitives.  */        \
  102.   Primitive_GC_If_Needed (1024);                    \
  103. }
  104.  
  105. #define ACCUM_PRK(name)                            \
  106. {                                    \
  107.   v = (cons ((cons ((char_pointer_to_string (#name)),            \
  108.             (HKEY_TO_OBJECT (name)))),                \
  109.          v));                            \
  110. }
  111.  
  112. DEFINE_PRIMITIVE ("win32-predefined-registry-keys", Prim_win32_predefined_registry_keys, 0, 0, 0)
  113. {
  114.   PRIMITIVE_HEADER (0);
  115.   {
  116.     SCHEME_OBJECT v = EMPTY_LIST;
  117. #ifdef HKEY_CLASSES_ROOT
  118.     ACCUM_PRK (HKEY_CLASSES_ROOT);
  119. #endif
  120. #ifdef HKEY_CURRENT_USER
  121.     ACCUM_PRK (HKEY_CURRENT_USER);
  122. #endif
  123. #ifdef HKEY_LOCAL_MACHINE
  124.     ACCUM_PRK (HKEY_LOCAL_MACHINE);
  125. #endif
  126. #ifdef HKEY_USERS
  127.     ACCUM_PRK (HKEY_USERS);
  128. #endif
  129. #ifdef HKEY_PERFORMANCE_DATA
  130.     ACCUM_PRK (HKEY_PERFORMANCE_DATA);
  131. #endif
  132. #ifdef HKEY_CURRENT_CONFIG
  133.     ACCUM_PRK (HKEY_CURRENT_CONFIG);
  134. #endif
  135. #ifdef HKEY_DYN_DATA
  136.     ACCUM_PRK (HKEY_DYN_DATA);
  137. #endif
  138.     PRIMITIVE_RETURN (v);
  139.   }
  140. }
  141.  
  142. DEFINE_PRIMITIVE ("win32-open-registry-key", Prim_win32_open_registry_key, 3, 3, 0)
  143. {
  144.   PRIMITIVE_HEADER (3);
  145.   CHECK_ARG (3, WEAK_PAIR_P);
  146.   GUARANTEE_RESULT_SPACE ();
  147.   {
  148.     HKEY result;
  149.     REGSAM mask = KEY_ALL_ACCESS;
  150.     while (1)
  151.       {
  152.     LONG code
  153.       = (RegOpenKeyEx ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0,
  154.                mask, (&result)));
  155.     if (code == ERROR_SUCCESS)
  156.       {
  157.         SET_PAIR_CDR ((ARG_REF (3)), (HKEY_TO_OBJECT (result)));
  158.         break;
  159.       }
  160.     if (code == ERROR_FILE_NOT_FOUND)
  161.       {
  162.         SET_PAIR_CDR ((ARG_REF (3)), SHARP_F);
  163.         break;
  164.       }
  165.     if (code == ERROR_ACCESS_DENIED)
  166.       switch (mask)
  167.         {
  168.         case KEY_ALL_ACCESS:
  169.           mask = KEY_READ;
  170.           continue;
  171.         case KEY_READ:
  172.           mask = KEY_ENUMERATE_SUB_KEYS;
  173.           continue;
  174.         case KEY_ENUMERATE_SUB_KEYS:
  175.           break;
  176.         }
  177.     NT_error_api_call (code, apicall_RegOpenKeyEx);
  178.       }
  179.   }
  180.   PRIMITIVE_RETURN (UNSPECIFIC);
  181. }
  182.  
  183. DEFINE_PRIMITIVE ("win32-create-registry-key", Prim_win32_create_registry_key, 3, 3, 0)
  184. {
  185.   PRIMITIVE_HEADER (3);
  186.   CHECK_ARG (3, WEAK_PAIR_P);
  187.   GUARANTEE_RESULT_SPACE ();
  188.   {
  189.     HKEY result;
  190.     DWORD disposition;
  191.     REGSAM mask = KEY_ALL_ACCESS;
  192.     while (1)
  193.       {
  194.     LONG code
  195.       = (RegCreateKeyEx ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0,
  196.                  "", REG_OPTION_NON_VOLATILE,
  197.                  mask, 0, (&result), (&disposition)));
  198.     if (code == ERROR_SUCCESS)
  199.       break;
  200.     if (code == ERROR_ACCESS_DENIED)
  201.       switch (mask)
  202.         {
  203.         case KEY_ALL_ACCESS:
  204.           mask = KEY_READ;
  205.           continue;
  206.         case KEY_READ:
  207.           mask = KEY_ENUMERATE_SUB_KEYS;
  208.           continue;
  209.         case KEY_ENUMERATE_SUB_KEYS:
  210.           break;
  211.         }
  212.     NT_error_api_call (code, apicall_RegCreateKeyEx);
  213.       }
  214.     SET_PAIR_CDR ((ARG_REF (3)), (HKEY_TO_OBJECT (result)));
  215.     PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (disposition == REG_CREATED_NEW_KEY));
  216.   }
  217. }
  218.  
  219. DEFINE_PRIMITIVE ("win32-close-registry-key", Prim_win32_close_registry_key, 1, 1, 0)
  220. {
  221.   PRIMITIVE_HEADER (1);
  222.   REGISTRY_API_CALL (RegCloseKey, (HKEY_ARG (1)));
  223.   PRIMITIVE_RETURN (UNSPECIFIC);
  224. }
  225.  
  226. DEFINE_PRIMITIVE ("win32-set-registry-value", Prim_win32_set_registry_value, 4, 4, 0)
  227. {
  228.   PRIMITIVE_HEADER (4);
  229.   {
  230.     DWORD data_type = (arg_ulong_integer (3));
  231.     DWORD data_length;
  232.     BYTE * data;
  233.     union
  234.       {
  235.     DWORD dword;
  236.     BYTE bytes [4];
  237.       } dword_data;
  238.     switch (data_type)
  239.       {
  240.       case REG_DWORD_LITTLE_ENDIAN:
  241.     {
  242.       DWORD arg = (arg_ulong_integer (4));
  243.       ((dword_data . bytes) [0]) = (arg & 0xFF);
  244.       ((dword_data . bytes) [1]) = ((arg >> 8) & 0xFF);
  245.       ((dword_data . bytes) [2]) = ((arg >> 16) & 0xFF);
  246.       ((dword_data . bytes) [3]) = ((arg >> 24) & 0xFF);
  247.     }
  248.     data_length = (sizeof (dword_data . bytes));
  249.     data = (dword_data . bytes);
  250.     break;
  251.       case REG_DWORD_BIG_ENDIAN:
  252.     {
  253.       DWORD arg = (arg_ulong_integer (4));
  254.       ((dword_data . bytes) [3]) = (arg & 0xFF);
  255.       ((dword_data . bytes) [2]) = ((arg >> 8) & 0xFF);
  256.       ((dword_data . bytes) [1]) = ((arg >> 16) & 0xFF);
  257.       ((dword_data . bytes) [0]) = ((arg >> 24) & 0xFF);
  258.     }
  259.     data_length = (sizeof (dword_data . bytes));
  260.     data = (dword_data . bytes);
  261.     break;
  262.       case REG_SZ:
  263.       case REG_EXPAND_SZ:
  264.       case REG_MULTI_SZ:
  265.     CHECK_ARG (4, STRING_P);
  266.     data_length = ((STRING_LENGTH (ARG_REF (4))) + 1);
  267.     data = ((BYTE *) (STRING_LOC ((ARG_REF (4)), 0)));
  268.     break;
  269.       default:
  270.     CHECK_ARG (4, STRING_P);
  271.     data_length = (STRING_LENGTH (ARG_REF (4)));
  272.     data = ((BYTE *) (STRING_LOC ((ARG_REF (4)), 0)));
  273.     break;
  274.     break;
  275.       }
  276.     REGISTRY_API_CALL
  277.       (RegSetValueEx, ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0,
  278.                data_type, data, data_length));
  279.   }
  280.   PRIMITIVE_RETURN (UNSPECIFIC);
  281. }
  282.  
  283. DEFINE_PRIMITIVE ("win32-delete-registry-value", Prim_win32_delete_registry_value, 2, 2, 0)
  284. {
  285.   PRIMITIVE_HEADER (2);
  286.   REGISTRY_API_CALL (RegDeleteValue, ((HKEY_ARG (1)), (SUBKEY_ARG (2))));
  287.   PRIMITIVE_RETURN (UNSPECIFIC);
  288. }
  289.  
  290. DEFINE_PRIMITIVE ("win32-delete-registry-key", Prim_win32_delete_registry_key, 2, 2, 0)
  291. {
  292.   PRIMITIVE_HEADER (2);
  293.   REGISTRY_API_CALL (RegDeleteKey, ((HKEY_ARG (1)), (SUBKEY_ARG (2))));
  294.   PRIMITIVE_RETURN (UNSPECIFIC);
  295. }
  296.  
  297. DEFINE_PRIMITIVE ("win32-enumerate-registry-key", Prim_win32_enumerate_registry_key, 3, 3, 0)
  298. {
  299.   PRIMITIVE_HEADER (3);
  300.   GUARANTEE_RESULT_SPACE ();
  301.   CHECK_ARG (3, STRING_P);
  302.   {
  303.     DWORD buffer_size = ((STRING_LENGTH (ARG_REF (3))) + 1);
  304.     FILETIME last_write_time;
  305.     LONG code
  306.       = (RegEnumKeyEx ((HKEY_ARG (1)),
  307.                ((DWORD) (arg_ulong_integer (2))),
  308.                ((CHAR *) (STRING_LOC ((ARG_REF (3)), 0))),
  309.                (&buffer_size),
  310.                0, 0, 0, (&last_write_time)));
  311.     if (code == ERROR_NO_MORE_ITEMS)
  312.       PRIMITIVE_RETURN (SHARP_F);
  313.     if (code != ERROR_SUCCESS)
  314.       NT_error_api_call (code, apicall_RegEnumKeyEx);
  315.     PRIMITIVE_RETURN (ulong_to_integer (buffer_size));
  316.   }
  317. }
  318.  
  319. DEFINE_PRIMITIVE ("win32-query-info-registry-key", Prim_win32_query_info_registry_key, 1, 1, 0)
  320. {
  321.   PRIMITIVE_HEADER (1);
  322.   GUARANTEE_RESULT_SPACE ();
  323.   {
  324.     DWORD n_sub_keys;
  325.     DWORD max_sub_key_length;
  326.     DWORD n_values;
  327.     DWORD max_value_name_length;
  328.     DWORD max_value_length;
  329.     REGISTRY_API_CALL
  330.       (RegQueryInfoKey, ((HKEY_ARG (1)),
  331.              0, 0, 0,
  332.              (&n_sub_keys),
  333.              (&max_sub_key_length),
  334.              0,
  335.              (&n_values),
  336.              (&max_value_name_length),
  337.              (&max_value_length),
  338.              0, 0));
  339.     /* Gratuitous incompatibility alert!  NT doesn't include the
  340.        terminating zero in the length field; 95/98 does.  */
  341.     if (NT_windows_type == wintype_95)
  342.       max_sub_key_length -= 1;
  343.     {
  344.       SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, 1));
  345.       VECTOR_SET (result, 0, (ulong_to_integer (n_sub_keys)));
  346.       VECTOR_SET (result, 1, (ulong_to_integer (max_sub_key_length)));
  347.       VECTOR_SET (result, 2, (ulong_to_integer (n_values)));
  348.       VECTOR_SET (result, 3, (ulong_to_integer (max_value_name_length)));
  349.       VECTOR_SET (result, 4, (ulong_to_integer (max_value_length)));
  350.       PRIMITIVE_RETURN (result);
  351.     }
  352.   }
  353. }
  354.  
  355. DEFINE_PRIMITIVE ("win32-enumerate-registry-value", Prim_win32_enumerate_registry_value, 4, 4, 0)
  356. {
  357.   PRIMITIVE_HEADER (4);
  358.   GUARANTEE_RESULT_SPACE ();
  359.   CHECK_ARG (3, STRING_P);
  360.   if ((ARG_REF (4)) != SHARP_F)
  361.     CHECK_ARG (4, STRING_P);
  362.   {
  363.     DWORD name_size = ((STRING_LENGTH (ARG_REF (3))) + 1);
  364.     DWORD data_type;
  365.     DWORD data_size
  366.       = (((ARG_REF (4)) == SHARP_F)
  367.      ? 0
  368.      : (STRING_LENGTH (ARG_REF (4))));
  369.     LONG code
  370.       = (RegEnumValue ((HKEY_ARG (1)),
  371.                ((DWORD) (arg_ulong_integer (2))),
  372.                ((LPTSTR) (STRING_LOC ((ARG_REF (3)), 0))),
  373.                (&name_size),
  374.                0,
  375.                (&data_type),
  376.                (((ARG_REF (4)) == SHARP_F)
  377.             ? 0
  378.             : ((LPBYTE) (STRING_LOC ((ARG_REF (4)), 0)))),
  379.                (&data_size)));
  380.     if (code == ERROR_NO_MORE_ITEMS)
  381.       PRIMITIVE_RETURN (SHARP_F);
  382.     if (code != ERROR_SUCCESS)
  383.       NT_error_api_call (code, apicall_RegEnumValue);
  384.     {
  385.       SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 3, 1));
  386.       VECTOR_SET (result, 0, (ulong_to_integer (name_size)));
  387.       VECTOR_SET (result, 1, (ulong_to_integer (data_type)));
  388.       VECTOR_SET (result, 2, (ulong_to_integer (data_size)));
  389.       PRIMITIVE_RETURN (result);
  390.     }
  391.   }
  392. }
  393.  
  394. DEFINE_PRIMITIVE ("win32-query-info-registry-value", Prim_win32_query_info_registry_value, 2, 2, 0)
  395. {
  396.   PRIMITIVE_HEADER (2);
  397.   GUARANTEE_RESULT_SPACE ();
  398.   {
  399.     DWORD data_type;
  400.     DWORD data_size;
  401.     LONG code
  402.       = (RegQueryValueEx ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0,
  403.               (&data_type), 0, (&data_size)));
  404.     if (code == ERROR_FILE_NOT_FOUND)
  405.       PRIMITIVE_RETURN (SHARP_F);
  406.     if (code != ERROR_SUCCESS)
  407.       NT_error_api_call (code, apicall_RegQueryValueEx);
  408.     PRIMITIVE_RETURN
  409.       (cons ((ulong_to_integer (data_type)),
  410.          (ulong_to_integer (data_size))));
  411.   }
  412. }
  413.  
  414. DEFINE_PRIMITIVE ("win32-query-registry-value", Prim_win32_query_registry_value, 2, 2, 0)
  415. {
  416.   PRIMITIVE_HEADER (2);
  417.   GUARANTEE_RESULT_SPACE ();
  418.   {
  419.     DWORD data_type;
  420.     DWORD data_size;
  421.     union
  422.       {
  423.     DWORD dword;
  424.     BYTE bytes [4];
  425.       } dword_converter;
  426.     SCHEME_OBJECT result;
  427.     BYTE * data;
  428.  
  429.     {
  430.       LONG code
  431.     = (RegQueryValueEx ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0,
  432.                 (&data_type), 0, (&data_size)));
  433.       if (code == ERROR_FILE_NOT_FOUND)
  434.     PRIMITIVE_RETURN (SHARP_F);
  435.       if (code != ERROR_SUCCESS)
  436.     NT_error_api_call (code, apicall_RegQueryValueEx);
  437.     }
  438.     switch (data_type)
  439.       {
  440.       case REG_DWORD_LITTLE_ENDIAN:
  441.       case REG_DWORD_BIG_ENDIAN:
  442.     data = (& (dword_converter . bytes));
  443.     break;
  444.  
  445.       case REG_SZ:
  446.       case REG_EXPAND_SZ:
  447.       case REG_MULTI_SZ:
  448.     result = (allocate_string (data_size - 1));
  449.     data = ((BYTE *) (STRING_LOC (result, 0)));
  450.     break;
  451.  
  452.       default:
  453.     result = (allocate_string (data_size));
  454.     data = ((BYTE *) (STRING_LOC (result, 0)));
  455.     break;
  456.       }
  457.     REGISTRY_API_CALL
  458.       (RegQueryValueEx, ((HKEY_ARG (1)), (SUBKEY_ARG (2)), 0,
  459.              0, data, (&data_size)));
  460.     switch (data_type)
  461.       {
  462.       case REG_DWORD_LITTLE_ENDIAN:
  463.     result
  464.       = (ulong_to_integer
  465.          (((DWORD) ((dword_converter . bytes) [0]))
  466.           || (((DWORD) ((dword_converter . bytes) [1])) << 8)
  467.           || (((DWORD) ((dword_converter . bytes) [2])) << 16)
  468.           || (((DWORD) ((dword_converter . bytes) [3])) << 24)));
  469.     break;
  470.       case REG_DWORD_BIG_ENDIAN:
  471.     result
  472.       = (ulong_to_integer
  473.          (((DWORD) ((dword_converter . bytes) [3]))
  474.           || (((DWORD) ((dword_converter . bytes) [2])) << 8)
  475.           || (((DWORD) ((dword_converter . bytes) [1])) << 16)
  476.           || (((DWORD) ((dword_converter . bytes) [0])) << 24)));
  477.     break;
  478.       }
  479.     PRIMITIVE_RETURN (cons ((ulong_to_integer (data_type)), result));
  480.   }
  481. }
  482.  
  483. DEFINE_PRIMITIVE ("win32-expand-environment-strings", Prim_win32_expand_environment_strings, 2, 2, 0)
  484. {
  485.   PRIMITIVE_HEADER (2);
  486.   CHECK_ARG (1, STRING_P);
  487.   CHECK_ARG (2, STRING_P);
  488.   {
  489.     DWORD n_chars
  490.       = (ExpandEnvironmentStrings (((LPCTSTR) (STRING_LOC ((ARG_REF (1)), 0))),
  491.                    ((LPTSTR) (STRING_LOC ((ARG_REF (2)), 0))),
  492.                    ((STRING_LENGTH (ARG_REF (2))) + 1)));
  493.     if (n_chars == 0)
  494.       NT_error_api_call ((GetLastError ()), apicall_ExpandEnvironmentStrings);
  495.     PRIMITIVE_RETURN (ulong_to_integer (n_chars - 1));
  496.   }
  497. }
  498.