/* -*-C-*-

$Id: prntenv.c,v 1.10 2000/12/05 21:23:47 cph Exp $

Copyright (c) 1993-2000 Massachusetts Institute of Technology

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/

/* Unix-specific process-environment primitives. */
/* Win32 imitation */

#include "scheme.h"
#include "prims.h"
#include "nt.h"
#include "ntio.h"

DEFINE_PRIMITIVE ("FILE-TIME->STRING", Prim_file_time_to_string, 1, 1,
  "Convert a file system time stamp into a date/time string.")
{
  PRIMITIVE_HEADER (1);
  CHECK_ARG (1, INTEGER_P);
  {
    time_t clock = (arg_integer (1));
    char * time_string = (ctime (&clock));
    if (time_string == 0)
      PRIMITIVE_RETURN (SHARP_F);
    (time_string[24]) = '\0';
    PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) time_string));
  }
}

DEFINE_PRIMITIVE ("GET-ENVIRONMENT-VARIABLE", Prim_get_environment_variable, 1, 1,
  "Look up the value of a variable in the user's shell environment.\n\
The argument, a variable name, must be a string.\n\
The result is either a string (the variable's value),\n\
 or #F indicating that the variable does not exist.")
{
  PRIMITIVE_HEADER (1);
  {
    CONST char * variable_value = (getenv (STRING_ARG (1)));
    PRIMITIVE_RETURN
      ((variable_value == 0)
       ? SHARP_F
       : (char_pointer_to_string ((unsigned char *) variable_value)));
  }
}

#define VQRESULT(index, value)						\
  VECTOR_SET (result, index, (ulong_to_integer (value)))


DEFINE_PRIMITIVE ("WIN32-VIRTUAL-QUERY", Prim_win32_virtual_query, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  {
    MEMORY_BASIC_INFORMATION info;
    SCHEME_OBJECT result;
    (void) VirtualQuery
      (((LPCVOID) (arg_ulong_integer (1))), (&info), (sizeof (info)));
    result = (allocate_marked_vector (TC_VECTOR, 7, 1));
    VQRESULT (0, ((unsigned long) (info.BaseAddress)));
    VQRESULT (1, ((unsigned long) (info.AllocationBase)));
    VQRESULT (2, (info.AllocationProtect));
    VQRESULT (3, (info.RegionSize));
    VQRESULT (4, (info.State));
    VQRESULT (5, (info.Protect));
    VQRESULT (6, (info.Type));
    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));
  }
}