/* -*-C-*-

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

Copyright (c) 1994-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.
*/

#include "scheme.h"
#include "prims.h"
#include "os2.h"
#include "osfs.h"

extern FILESTATUS3 * OS2_read_file_status (const char *);
extern void OS2_write_file_status (const char *, FILESTATUS3 *);
extern char * OS2_drive_type (char);
extern long OS2_timezone (void);
extern long OS2_daylight_savings_p (void);
extern void EXFUN (OS_file_copy, (CONST char *, CONST char *));

static SCHEME_OBJECT time_to_integer (FDATE *, FTIME *);
static void integer_to_time (SCHEME_OBJECT, FDATE *, FTIME *);

DEFINE_PRIMITIVE ("FILE-ATTRIBUTES", Prim_file_attributes, 1, 1,
  "Return attributes of FILE, as an integer.")
{
  PRIMITIVE_HEADER (1);
  {
    FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
    PRIMITIVE_RETURN
      ((info == 0)
       ? SHARP_F
       : (LONG_TO_UNSIGNED_FIXNUM (info -> attrFile)));
  }
}

DEFINE_PRIMITIVE ("SET-FILE-ATTRIBUTES!", Prim_set_file_attributes, 2, 2,
  "Set the attributes of FILE to ATTRIBUTES.")
{
  PRIMITIVE_HEADER (2);
  {
    FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
    if (info == 0)
      error_bad_range_arg (1);
    (info -> attrFile) = (arg_index_integer (2, 0x10000));
    OS2_write_file_status ((STRING_ARG (1)), info);
    PRIMITIVE_RETURN (UNSPECIFIC);
  }
}

DEFINE_PRIMITIVE ("FILE-LENGTH", Prim_file_length, 1, 1,
  "Return attributes of FILE, as an integer.")
{
  PRIMITIVE_HEADER (1);
  {
    FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
    PRIMITIVE_RETURN
      ((info == 0)
       ? SHARP_F
       : (ulong_to_integer (info -> cbFile)));
  }
}

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);
  {
    PSZ result;
    XTD_API_CALL
      (dos_scan_env, ((STRING_ARG (1)), (& result)),
       {
	 if (rc == ERROR_ENVVAR_NOT_FOUND)
	   PRIMITIVE_RETURN (SHARP_F);
       });
    PRIMITIVE_RETURN (char_pointer_to_string (result));
  }
}

DEFINE_PRIMITIVE ("FILE-EQ?", Prim_file_eq_p, 2, 2,
  "True iff the two file arguments are the same file.")
{
  PRIMITIVE_HEADER (2);
  CHECK_ARG (1, STRING_P);
  CHECK_ARG (2, STRING_P);
  {
    unsigned long length = (STRING_LENGTH (ARG_REF (1)));
    const char * s1 = (STRING_LOC ((ARG_REF (1)), 0));
    const char * s2 = (STRING_LOC ((ARG_REF (2)), 0));
    const char * e1 = (s1 + length);
    if ((STRING_LENGTH (ARG_REF (2))) != length)
      PRIMITIVE_RETURN (SHARP_F);
    while (s1 < e1)
      if ((char_upcase (*s1++)) != (char_upcase (*s2++)))
	PRIMITIVE_RETURN (SHARP_F);
    PRIMITIVE_RETURN (SHARP_T);
  }
}

DEFINE_PRIMITIVE ("FILE-MOD-TIME", Prim_file_mod_time, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  {
    FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
    PRIMITIVE_RETURN
      ((info == 0)
       ? SHARP_F
       : (time_to_integer ((& (info -> fdateLastWrite)),
			   (& (info -> ftimeLastWrite)))));
  }
}

DEFINE_PRIMITIVE ("FILE-ACCESS-TIME", Prim_file_acc_time, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  {
    FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
    PRIMITIVE_RETURN
      ((info == 0)
       ? SHARP_F
       : (time_to_integer ((& (info -> fdateLastAccess)),
			   (& (info -> ftimeLastAccess)))));
  }
}

static SCHEME_OBJECT
time_to_integer (FDATE * date, FTIME * time)
{
  unsigned long accum;
  accum = (date -> year);
  accum = ((accum << 4) | (date -> month));
  accum = ((accum << 5) | (date -> day));
  accum = ((accum << 5) | (time -> hours));
  accum = ((accum << 6) | (time -> minutes));
  accum = ((accum << 5) | (time -> twosecs));
  return (ulong_to_integer (accum));
}

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 (or superuser).")
{
  PRIMITIVE_HEADER (3);
  {
    FILESTATUS3 * info = (OS2_read_file_status (STRING_ARG (1)));
    SCHEME_OBJECT atime = (ARG_REF (2));
    SCHEME_OBJECT mtime = (ARG_REF (3));
    if (info == 0)
      error_bad_range_arg (1);
    if (atime != SHARP_F)
      {
	if (!INTEGER_P (atime))
	  error_wrong_type_arg (2);
	if (integer_negative_p (atime))
	  error_bad_range_arg (2);
	integer_to_time (atime,
			 (& (info -> fdateLastAccess)),
			 (& (info -> ftimeLastAccess)));
      }
    if (mtime != SHARP_F)
      {
	if (!INTEGER_P (mtime))
	  error_wrong_type_arg (3);
	if (integer_negative_p (mtime))
	  error_bad_range_arg (3);
	integer_to_time (mtime,
			 (& (info -> fdateLastWrite)),
			 (& (info -> ftimeLastWrite)));
      }
    OS2_write_file_status ((STRING_ARG (1)), info);
  }
  PRIMITIVE_RETURN (UNSPECIFIC);
}

static void
integer_to_time (SCHEME_OBJECT encoding, FDATE * date, FTIME * time)
{
  unsigned long accum = (integer_to_ulong (encoding));
  (time -> twosecs) = (accum & 0x1f);
  accum >>= 5;
  (time -> minutes) = (accum & 0x3f);
  accum >>= 6;
  (time -> hours) = (accum & 0x1f);
  accum >>= 5;
  (date -> day) = (accum & 0x1f);
  accum >>= 5;
  (date -> month) = (accum & 0x0f);
  accum >>= 4;
  (date -> year) = accum;
}

DEFINE_PRIMITIVE ("FILE-INFO", Prim_file_info, 1, 1,
  "Given a file name, return information about the file.\n\
If the file exists and its information is accessible,\n\
 the result is a vector of 6 items.\n\
Otherwise the result is #F.")
{
  FILESTATUS3 * info;
  SCHEME_OBJECT result;
  PRIMITIVE_HEADER (1);

  info = (OS2_read_file_status (STRING_ARG (1)));
  if (info == 0)
    PRIMITIVE_RETURN (SHARP_F);
  result = (allocate_marked_vector (TC_VECTOR, 8, true));
  VECTOR_SET (result, 0,
	      ((((info -> attrFile) & FILE_DIRECTORY) != 0)
	       ? SHARP_T
	       : SHARP_F));
  VECTOR_SET (result, 1,
	      (time_to_integer ((& (info -> fdateLastAccess)),
				(& (info -> ftimeLastAccess)))));
  VECTOR_SET (result, 2,
	      (time_to_integer ((& (info -> fdateLastWrite)),
				(& (info -> ftimeLastWrite)))));
  VECTOR_SET (result, 3,
	      (time_to_integer ((& (info -> fdateCreation)),
				(& (info -> ftimeCreation)))));
  VECTOR_SET (result, 4, (ulong_to_integer (info -> cbFile)));
  {
    unsigned int attr = (info -> attrFile);
    SCHEME_OBJECT modes = (allocate_string (5));
    char * s = ((char *) (STRING_LOC (modes, 0)));
    (s[0]) = (((attr & FILE_DIRECTORY) != 0) ? 'd' : '-');
    (s[1]) = (((attr & FILE_READONLY)  != 0) ? 'r' : '-');
    (s[2]) = (((attr & FILE_HIDDEN)    != 0) ? 'h' : '-');
    (s[3]) = (((attr & FILE_SYSTEM)    != 0) ? 's' : '-');
    (s[4]) = (((attr & FILE_ARCHIVED)  != 0) ? 'a' : '-');
    VECTOR_SET (result, 5, modes);
    VECTOR_SET (result, 6, (ulong_to_integer (attr)));
  }
  VECTOR_SET (result, 7, (ulong_to_integer (info -> cbFileAlloc)));
  PRIMITIVE_RETURN (result);
}

DEFINE_PRIMITIVE ("DRIVE-TYPE", Prim_drive_type, 1, 1, 0)
{
  SCHEME_OBJECT arg;
  char * type;
  PRIMITIVE_HEADER (1);

  CHECK_ARG (1, STRING_P);
  arg = (ARG_REF (1));
  if (! (((STRING_LENGTH (arg)) == 1) && (isalpha (STRING_REF (arg, 0)))))
    error_bad_range_arg (1);
  type = (OS2_drive_type (STRING_REF (arg, 0)));
  PRIMITIVE_RETURN (char_pointer_to_string ((type == 0) ? "unknown" : type));
}

DEFINE_PRIMITIVE ("CURRENT-PID", Prim_current_pid, 0, 0,
  "Return Scheme's PID.")
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (ulong_to_integer (OS2_scheme_pid));
}

DEFINE_PRIMITIVE ("DOS-QUERY-MEMORY", Prim_dos_query_memory, 2, 2, 0)
{
  PRIMITIVE_HEADER (2);
  {
    ULONG start = (arg_ulong_integer (1));
    ULONG length = (arg_ulong_integer (2));
    ULONG flags;
    XTD_API_CALL
      (dos_query_mem, (((PVOID) start), (&length), (&flags)),
       {
	 if (rc == ERROR_INVALID_ADDRESS)
	   PRIMITIVE_RETURN (SHARP_F);
       });
    PRIMITIVE_RETURN (cons ((ulong_to_integer (length)),
			    (ulong_to_integer (flags))));
  }
}

DEFINE_PRIMITIVE ("OS2-TIME-ZONE", Prim_OS2_timezone, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (long_to_integer (OS2_timezone ()));
}

DEFINE_PRIMITIVE ("OS2-DAYLIGHT-SAVINGS-TIME?", Prim_OS2_dst_p, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS2_daylight_savings_p ()));
}

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

DEFINE_PRIMITIVE ("OS2-SET-REL-MAX-FH", Prim_OS2_set_rel_max_fh, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  {
    LONG req_max_fh = (arg_integer (1));
    ULONG current_max_fh;
    STD_API_CALL (dos_set_rel_max_fh, ((&req_max_fh), (&current_max_fh)));
    PRIMITIVE_RETURN (ulong_to_integer (current_max_fh));
  }
}