/* -*-C-*-

$Id: prntfs.c,v 1.19 2003/02/14 18:28:23 cph Exp $

Copyright (c) 1993-2001 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme 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.

MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

*/

/* NT-specific file-system primitives. */

#include "scheme.h"
#include "prims.h"
#include "nt.h"
#include "ntfs.h"

#include <sys/utime.h>
#include <memory.h>
#include <math.h>

extern void EXFUN (OS_file_copy, (CONST char *, CONST char *));
extern int win32_directory_read (unsigned int, WIN32_FIND_DATA *);

static double ut_zero = 0.0;

static void
initialize_ut_zero (void)
{
  if (ut_zero == 0.0)
    {
      SYSTEMTIME st;
      FILETIME ft;
      (st . wYear) = 1970;
      (st . wMonth) = 1;
      (st . wDay) = 1;
      (st . wHour) = 0;
      (st . wMinute) = 0;
      (st . wSecond) = 0;
      (st . wMilliseconds) = 0;
      (void) SystemTimeToFileTime ((&st), (&ft));
      ut_zero
	= ((((double) (ft . dwHighDateTime)) * 4294967296.)
	   + ((double) (ft . dwLowDateTime)));
    }
}

unsigned long
file_time_to_unix_time (FILETIME * ft)
{
  double fd
    = ((((double) (ft -> dwHighDateTime)) * 4294967296.)
       + ((double) (ft -> dwLowDateTime)));
  initialize_ut_zero ();
  if (fd <= ut_zero)
    return (0);
  return ((unsigned long) (floor (((fd - ut_zero) + 5000000.) / 10000000.)));
}

void
unix_time_to_file_time (unsigned long ut, FILETIME * ft)
{
  double ud = ((((double) ut) * 10000000.) + ut_zero);
  double udh = (floor (ud / 4294967296.));
  (ft -> dwHighDateTime) = ((DWORD) udh);
  (ft -> dwLowDateTime) = ((DWORD) (ud -(udh * 4294967296.)));
}

DEFINE_PRIMITIVE ("FILE-MODES", Prim_file_modes, 1, 1,
  "Return mode bits of FILE, as an integer.")
{
  BY_HANDLE_FILE_INFORMATION info;
  PRIMITIVE_HEADER (1);
  switch (NT_get_file_info ((STRING_ARG (1)), (&info), 0))
    {
    case gfi_ok:
      PRIMITIVE_RETURN
	(ulong_to_integer
	 (((info . dwFileAttributes) == 0xFFFFFFFF)
	  ? 0
	  : (info . dwFileAttributes)));
    case gfi_not_found:
      PRIMITIVE_RETURN (SHARP_F);
    default:
      PRIMITIVE_RETURN (ulong_to_integer (0));
    }
}

DEFINE_PRIMITIVE ("SET-FILE-MODES!", Prim_set_file_modes, 2, 2,
  "Set the mode bits of FILE to MODE.")
{
  PRIMITIVE_HEADER (2);
  STD_BOOL_API_CALL
    (SetFileAttributes, ((STRING_ARG (1)), (arg_ulong_integer (2))));
  PRIMITIVE_RETURN (UNSPECIFIC);
}

DEFINE_PRIMITIVE ("FILE-MOD-TIME", Prim_file_mod_time, 1, 1, 0)
{
  BY_HANDLE_FILE_INFORMATION info;
  PRIMITIVE_HEADER (1);
  switch (NT_get_file_info ((STRING_ARG (1)), (&info), 0))
    {
    case gfi_ok:
      PRIMITIVE_RETURN
	(ulong_to_integer
	 (file_time_to_unix_time (& (info . ftLastWriteTime))));
    case gfi_not_found:
      PRIMITIVE_RETURN (SHARP_F);
    default:
      PRIMITIVE_RETURN (ulong_to_integer (0));
    }
}

DEFINE_PRIMITIVE ("SET-FILE-TIMES!", Prim_set_file_times, 3, 3,
  "Change the access and modification times of FILE.\n\
The second and third arguments are the respective times.\n\
The file must exist and you must be the owner.")
{
  const char * filename;
  DWORD attributes;
  int disable_ro;
  HANDLE hfile;
  FILETIME atime;
  FILETIME mtime;
  PRIMITIVE_HEADER (3);

  filename = (STRING_ARG (1));
  attributes = (GetFileAttributes (filename));
  disable_ro
    = ((attributes != 0xFFFFFFFF)
       && ((attributes & FILE_ATTRIBUTE_READONLY) != 0));
  if (disable_ro)
    STD_BOOL_API_CALL (SetFileAttributes,
		       (filename, (attributes & (~FILE_ATTRIBUTE_READONLY))));
  STD_HANDLE_API_CALL
    (hfile,
     CreateFile, (filename,
		  GENERIC_WRITE,
		  FILE_SHARE_READ,
		  0,
		  OPEN_EXISTING,
		  FILE_ATTRIBUTE_NORMAL,
		  NULL));
  unix_time_to_file_time ((arg_ulong_integer (2)), (&atime));
  unix_time_to_file_time ((arg_ulong_integer (3)), (&mtime));
  if (!SetFileTime (hfile, 0, (&atime), (&mtime)))
    {
      DWORD code = (GetLastError ());
      (void) CloseHandle (hfile);
      NT_error_api_call (code, apicall_SetFileTime);
    }
  if (disable_ro)
    STD_BOOL_API_CALL (SetFileAttributes, (filename, attributes));
  STD_BOOL_API_CALL (CloseHandle, (hfile));
  PRIMITIVE_RETURN (UNSPECIFIC);
}

/* Returns a vector of 10 items:
   0 = #T iff the file is a directory,
       string (name linked to) for symbolic link,
       #F for all other files.
   1 = number of links to the file
   2 = user id, as an unsigned integer
   3 = group id, as an unsigned integer
   4 = last access time of the file
   5 = last modification time of the file
   6 = last change time of the file
   7 = size of the file in bytes
   8 = mode string for the file
   9 = inode number of the file
   */

static SCHEME_OBJECT
dword_pair_to_integer (DWORD low, DWORD high)
{
  SCHEME_OBJECT result = (ulong_to_integer (low));
  if (high != 0)
    result = (integer_add
	      ((integer_multiply
		((ulong_to_integer (high)),
		 (integer_add_1 (ulong_to_integer (0xFFFFFFFF))))),
	       result));
  return (result);
}

#define STORE_FILE_TIME(index, name)					\
  VECTOR_SET (result, (index),						\
	      (ulong_to_integer						\
	       (((name) == 0) ? 0 : (file_time_to_unix_time (name)))))

#define ATTRIBUTE_LETTER(index, mask, letter)				\
  STRING_SET (modes, (index), ((attributes & (mask)) ? (letter) : '-'))

/* Maximum number of words needed for an attributes vector.
   This is intentionally higher than strictly necessary.  */
#define MAX_ATTRIBUTES_ALLOCATION 256

static SCHEME_OBJECT
create_attributes_vector (DWORD attributes, DWORD nlinks,
			  DWORD uid, DWORD gid,
			  FILETIME * atime, FILETIME * mtime, FILETIME * ctime,
			  DWORD size_low, DWORD size_high,
			  DWORD inode_low, DWORD inode_high)
{
  SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 11, 0));
  SCHEME_OBJECT modes = (allocate_string (6));
  VECTOR_SET (result, 0,
	      (BOOLEAN_TO_OBJECT (attributes & FILE_ATTRIBUTE_DIRECTORY)));
  VECTOR_SET (result, 1, (ulong_to_integer (nlinks)));
  VECTOR_SET (result, 2, (ulong_to_integer (uid)));
  VECTOR_SET (result, 3, (ulong_to_integer (gid)));
  STORE_FILE_TIME(4, atime);
  STORE_FILE_TIME(5, mtime);
  STORE_FILE_TIME(6, ctime);
  VECTOR_SET (result, 7, (dword_pair_to_integer (size_low, size_high)));
  ATTRIBUTE_LETTER (0, FILE_ATTRIBUTE_DIRECTORY, 'd');
  ATTRIBUTE_LETTER (1, FILE_ATTRIBUTE_READONLY, 'r');
  ATTRIBUTE_LETTER (2, FILE_ATTRIBUTE_HIDDEN, 'h');
  ATTRIBUTE_LETTER (3, FILE_ATTRIBUTE_SYSTEM, 's');
  ATTRIBUTE_LETTER (4, FILE_ATTRIBUTE_ARCHIVE, 'a');
  ATTRIBUTE_LETTER (5, FILE_ATTRIBUTE_COMPRESSED, 'c');
  VECTOR_SET (result, 8, modes);
  VECTOR_SET (result, 9, (dword_pair_to_integer (inode_low, inode_high)));
  VECTOR_SET (result, 10, (ulong_to_integer (attributes)));
  return (result);
}

#undef STORE_FILE_TIME
#undef ATTRIBUTE_LETTER

DEFINE_PRIMITIVE ("FILE-ATTRIBUTES", Prim_file_attributes, 1, 1,
  "Given a file name, return attribute information about the file.\n\
If the file exists and its status information is accessible, the result\n\
is a vector of 10 items (see the reference manual for details).  Otherwise\n\
the result is #F.")
{
  BY_HANDLE_FILE_INFORMATION info;
  PRIMITIVE_HEADER (1);
  Primitive_GC_If_Needed (MAX_ATTRIBUTES_ALLOCATION);
  switch (NT_get_file_info ((STRING_ARG (1)), (&info), 1))
    {
    case gfi_not_found:
      PRIMITIVE_RETURN (SHARP_F);
    case gfi_ok:
      PRIMITIVE_RETURN
	(create_attributes_vector
	 ((info . dwFileAttributes), (info . nNumberOfLinks), 0, 0,
	  (& (info . ftLastAccessTime)),
	  (& (info . ftLastWriteTime)),
	  (& (info . ftCreationTime)),
	  (info . nFileSizeLow), (info . nFileSizeHigh),
	  (info . nFileIndexLow), (info . nFileIndexHigh)));
    default:
      PRIMITIVE_RETURN
	(create_attributes_vector (0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0));
    }
}

DEFINE_PRIMITIVE ("FILE-EQ?", Prim_file_eq_p, 2, 2,
  "True iff the two file arguments are the same file.")
{
  static char buf1[128], buf2[128];
  char *filepart;
  PRIMITIVE_HEADER (2);

  if (GetFullPathName(STRING_ARG (1), 128, buf1, &filepart) == 0  ||
      GetFullPathName(STRING_ARG (2), 128, buf2, &filepart) == 0)
    error_external_return ();
  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((strcmp (&buf1[0], &buf2[0])) == 0));
}

DEFINE_PRIMITIVE ("NT-GET-VOLUME-INFORMATION", Prim_NT_get_vol_info, 1, 1, 0)
{
  char name [256];
  DWORD serial_number;
  DWORD max_component_length;
  DWORD file_system_flags;
  char file_system_name [256];
  SCHEME_OBJECT result;
  PRIMITIVE_HEADER (1);

  if (! (GetVolumeInformation ((STRING_ARG (1)),
			       name,
			       (sizeof (name)),
			       (&serial_number),
			       (&max_component_length),
			       (&file_system_flags),
			       file_system_name,
			       (sizeof (file_system_name)))))
    PRIMITIVE_RETURN (SHARP_F);
  result = (allocate_marked_vector (TC_VECTOR, 5, 1));
  VECTOR_SET (result, 0, (char_pointer_to_string (name)));
  VECTOR_SET (result, 1, (ulong_to_integer (serial_number)));
  VECTOR_SET (result, 2, (ulong_to_integer (max_component_length)));
  VECTOR_SET (result, 3, (ulong_to_integer (file_system_flags)));
  VECTOR_SET (result, 4, (char_pointer_to_string (file_system_name)));
  PRIMITIVE_RETURN (result);
}

DEFINE_PRIMITIVE ("NT-COPY-FILE", Prim_NT_copy_file, 2, 2, 0)
{
  PRIMITIVE_HEADER (2);
  OS_file_copy ((STRING_ARG (1)), (STRING_ARG (2)));
  PRIMITIVE_RETURN (UNSPECIFIC);
}

DEFINE_PRIMITIVE ("NT-GET-FILE-ATTRIBUTES", Prim_NT_get_file_attributes, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  {
    CONST char * filename = (STRING_ARG (1));
    DWORD attributes = (GetFileAttributes (filename));
    if (attributes == 0xFFFFFFFF)
      {
	DWORD code = (GetLastError ());
	if (STAT_NOT_FOUND_P (code))
	  PRIMITIVE_RETURN (SHARP_F);
	NT_error_api_call (code, apicall_GetFileAttributes);
      }
    PRIMITIVE_RETURN (ulong_to_integer (attributes));
  }
}

DEFINE_PRIMITIVE ("NT-SET-FILE-ATTRIBUTES", Prim_NT_set_file_attributes, 2, 2, 0)
{
  PRIMITIVE_HEADER (2);
  STD_BOOL_API_CALL
    (SetFileAttributes, ((STRING_ARG (1)), (arg_ulong_integer (2))));
  PRIMITIVE_RETURN (UNSPECIFIC);
}

static unsigned int
DEFUN (arg_directory_index, (argument), unsigned int argument)
{
  long index = (arg_integer (argument));
  if (! (OS_directory_valid_p (index)))
    error_bad_range_arg (argument);
  return (index);
}

DEFINE_PRIMITIVE ("WIN32-DIRECTORY-READ", Prim_win32_directory_read, 1, 1,
  "Read and return a filename from DIRECTORY, or #F if no more files.")
{
  PRIMITIVE_HEADER (1);
  {
    WIN32_FIND_DATA info;
    /* 69 is 2 words for pair, plus 68 words for string with maximum
       length of 260 bytes including the terminating zero.  260 is the
       current value of MAX_PATH at this time.  */
    Primitive_GC_If_Needed (MAX_ATTRIBUTES_ALLOCATION + 69);
    PRIMITIVE_RETURN
      ((win32_directory_read ((arg_directory_index (1)), (&info)))
       ? (cons ((char_pointer_to_string (info . cFileName)),
		(create_attributes_vector
		 ((info . dwFileAttributes), 1, 0, 0,
		  (& (info . ftLastAccessTime)),
		  (& (info . ftLastWriteTime)),
		  (& (info . ftCreationTime)),
		  (info . nFileSizeLow), (info . nFileSizeHigh), 0, 0))))
       : SHARP_F);
  }
}
