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 / prntfs.c < prev    next >
C/C++ Source or Header  |  2001-05-08  |  12KB  |  376 lines
  1. /* -*-C-*-
  2.  
  3. $Id: prntfs.c,v 1.17 2001/05/09 03:15:08 cph Exp $
  4.  
  5. Copyright (c) 1993-2001 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
  20. USA.
  21. */
  22.  
  23. /* NT-specific file-system primitives. */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "nt.h"
  28. #include "ntfs.h"
  29.  
  30. #include <sys/utime.h>
  31. #include <memory.h>
  32. #include <math.h>
  33.  
  34. extern void EXFUN (OS_file_copy, (CONST char *, CONST char *));
  35. extern int win32_directory_read (unsigned int, WIN32_FIND_DATA *);
  36.  
  37. static double ut_zero = 0.0;
  38.  
  39. static void
  40. initialize_ut_zero (void)
  41. {
  42.   if (ut_zero == 0.0)
  43.     {
  44.       SYSTEMTIME st;
  45.       FILETIME ft;
  46.       (st . wYear) = 1970;
  47.       (st . wMonth) = 1;
  48.       (st . wDay) = 1;
  49.       (st . wHour) = 0;
  50.       (st . wMinute) = 0;
  51.       (st . wSecond) = 0;
  52.       (st . wMilliseconds) = 0;
  53.       (void) SystemTimeToFileTime ((&st), (&ft));
  54.       ut_zero
  55.     = ((((double) (ft . dwHighDateTime)) * 4294967296.)
  56.        + ((double) (ft . dwLowDateTime)));
  57.     }
  58. }
  59.  
  60. unsigned long
  61. file_time_to_unix_time (FILETIME * ft)
  62. {
  63.   double fd
  64.     = ((((double) (ft -> dwHighDateTime)) * 4294967296.)
  65.        + ((double) (ft -> dwLowDateTime)));
  66.   initialize_ut_zero ();
  67.   if (fd <= ut_zero)
  68.     return (0);
  69.   return ((unsigned long) (floor (((fd - ut_zero) + 5000000.) / 10000000.)));
  70. }
  71.  
  72. void
  73. unix_time_to_file_time (unsigned long ut, FILETIME * ft)
  74. {
  75.   double ud = ((((double) ut) * 10000000.) + ut_zero);
  76.   double udh = (floor (ud / 4294967296.));
  77.   (ft -> dwHighDateTime) = ((DWORD) udh);
  78.   (ft -> dwLowDateTime) = ((DWORD) (ud -(udh * 4294967296.)));
  79. }
  80.  
  81. DEFINE_PRIMITIVE ("FILE-MODES", Prim_file_modes, 1, 1,
  82.   "Return mode bits of FILE, as an integer.")
  83. {
  84.   BY_HANDLE_FILE_INFORMATION info;
  85.   PRIMITIVE_HEADER (1);
  86.   switch (NT_get_file_info ((STRING_ARG (1)), (&info), 0))
  87.     {
  88.     case gfi_ok:
  89.       PRIMITIVE_RETURN
  90.     (ulong_to_integer
  91.      (((info . dwFileAttributes) == 0xFFFFFFFF)
  92.       ? 0
  93.       : (info . dwFileAttributes)));
  94.     case gfi_not_found:
  95.       PRIMITIVE_RETURN (SHARP_F);
  96.     default:
  97.       PRIMITIVE_RETURN (ulong_to_integer (0));
  98.     }
  99. }
  100.  
  101. DEFINE_PRIMITIVE ("SET-FILE-MODES!", Prim_set_file_modes, 2, 2,
  102.   "Set the mode bits of FILE to MODE.")
  103. {
  104.   PRIMITIVE_HEADER (2);
  105.   STD_BOOL_API_CALL
  106.     (SetFileAttributes, ((STRING_ARG (1)), (arg_ulong_integer (2))));
  107.   PRIMITIVE_RETURN (UNSPECIFIC);
  108. }
  109.  
  110. DEFINE_PRIMITIVE ("FILE-MOD-TIME", Prim_file_mod_time, 1, 1, 0)
  111. {
  112.   BY_HANDLE_FILE_INFORMATION info;
  113.   PRIMITIVE_HEADER (1);
  114.   switch (NT_get_file_info ((STRING_ARG (1)), (&info), 0))
  115.     {
  116.     case gfi_ok:
  117.       PRIMITIVE_RETURN
  118.     (ulong_to_integer
  119.      (file_time_to_unix_time (& (info . ftLastWriteTime))));
  120.     case gfi_not_found:
  121.       PRIMITIVE_RETURN (SHARP_F);
  122.     default:
  123.       PRIMITIVE_RETURN (ulong_to_integer (0));
  124.     }
  125. }
  126.  
  127. DEFINE_PRIMITIVE ("SET-FILE-TIMES!", Prim_set_file_times, 3, 3,
  128.   "Change the access and modification times of FILE.\n\
  129. The second and third arguments are the respective times.\n\
  130. The file must exist and you must be the owner.")
  131. {
  132.   const char * filename;
  133.   DWORD attributes;
  134.   int disable_ro;
  135.   HANDLE hfile;
  136.   FILETIME atime;
  137.   FILETIME mtime;
  138.   PRIMITIVE_HEADER (3);
  139.  
  140.   filename = (STRING_ARG (1));
  141.   attributes = (GetFileAttributes (filename));
  142.   disable_ro
  143.     = ((attributes != 0xFFFFFFFF)
  144.        && ((attributes & FILE_ATTRIBUTE_READONLY) != 0));
  145.   if (disable_ro)
  146.     STD_BOOL_API_CALL (SetFileAttributes,
  147.                (filename, (attributes & (~FILE_ATTRIBUTE_READONLY))));
  148.   STD_HANDLE_API_CALL
  149.     (hfile,
  150.      CreateFile, (filename,
  151.           GENERIC_WRITE,
  152.           FILE_SHARE_READ,
  153.           0,
  154.           OPEN_EXISTING,
  155.           FILE_ATTRIBUTE_NORMAL,
  156.           NULL));
  157.   unix_time_to_file_time ((arg_ulong_integer (2)), (&atime));
  158.   unix_time_to_file_time ((arg_ulong_integer (3)), (&mtime));
  159.   if (!SetFileTime (hfile, 0, (&atime), (&mtime)))
  160.     {
  161.       DWORD code = (GetLastError ());
  162.       (void) CloseHandle (hfile);
  163.       NT_error_api_call (code, apicall_SetFileTime);
  164.     }
  165.   if (disable_ro)
  166.     STD_BOOL_API_CALL (SetFileAttributes, (filename, attributes));
  167.   STD_BOOL_API_CALL (CloseHandle, (hfile));
  168.   PRIMITIVE_RETURN (UNSPECIFIC);
  169. }
  170.  
  171. /* Returns a vector of 10 items:
  172.    0 = #T iff the file is a directory,
  173.        string (name linked to) for symbolic link,
  174.        #F for all other files.
  175.    1 = number of links to the file
  176.    2 = user id, as an unsigned integer
  177.    3 = group id, as an unsigned integer
  178.    4 = last access time of the file
  179.    5 = last modification time of the file
  180.    6 = last change time of the file
  181.    7 = size of the file in bytes
  182.    8 = mode string for the file
  183.    9 = inode number of the file
  184.    */
  185.  
  186. static SCHEME_OBJECT
  187. dword_pair_to_integer (DWORD low, DWORD high)
  188. {
  189.   SCHEME_OBJECT result = (ulong_to_integer (low));
  190.   if (high != 0)
  191.     result = (integer_add
  192.           ((integer_multiply
  193.         ((ulong_to_integer (high)),
  194.          (integer_add_1 (ulong_to_integer (0xFFFFFFFF))))),
  195.            result));
  196.   return (result);
  197. }
  198.  
  199. #define STORE_FILE_TIME(index, name)                    \
  200.   VECTOR_SET (result, (index),                        \
  201.           (ulong_to_integer                        \
  202.            (((name) == 0) ? 0 : (file_time_to_unix_time (name)))))
  203.  
  204. #define ATTRIBUTE_LETTER(index, mask, letter)                \
  205.   STRING_SET (modes, (index), ((attributes & (mask)) ? (letter) : '-'))
  206.  
  207. /* Maximum number of words needed for an attributes vector.
  208.    This is intentionally higher than strictly necessary.  */
  209. #define MAX_ATTRIBUTES_ALLOCATION 256
  210.  
  211. static SCHEME_OBJECT
  212. create_attributes_vector (DWORD attributes, DWORD nlinks,
  213.               DWORD uid, DWORD gid,
  214.               FILETIME * atime, FILETIME * mtime, FILETIME * ctime,
  215.               DWORD size_low, DWORD size_high,
  216.               DWORD inode_low, DWORD inode_high)
  217. {
  218.   SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 11, 0));
  219.   SCHEME_OBJECT modes = (allocate_string (6));
  220.   VECTOR_SET (result, 0,
  221.           (BOOLEAN_TO_OBJECT (attributes & FILE_ATTRIBUTE_DIRECTORY)));
  222.   VECTOR_SET (result, 1, (ulong_to_integer (nlinks)));
  223.   VECTOR_SET (result, 2, (ulong_to_integer (uid)));
  224.   VECTOR_SET (result, 3, (ulong_to_integer (gid)));
  225.   STORE_FILE_TIME(4, atime);
  226.   STORE_FILE_TIME(5, mtime);
  227.   STORE_FILE_TIME(6, ctime);
  228.   VECTOR_SET (result, 7, (dword_pair_to_integer (size_low, size_high)));
  229.   ATTRIBUTE_LETTER (0, FILE_ATTRIBUTE_DIRECTORY, 'd');
  230.   ATTRIBUTE_LETTER (1, FILE_ATTRIBUTE_READONLY, 'r');
  231.   ATTRIBUTE_LETTER (2, FILE_ATTRIBUTE_HIDDEN, 'h');
  232.   ATTRIBUTE_LETTER (3, FILE_ATTRIBUTE_SYSTEM, 's');
  233.   ATTRIBUTE_LETTER (4, FILE_ATTRIBUTE_ARCHIVE, 'a');
  234.   ATTRIBUTE_LETTER (5, FILE_ATTRIBUTE_COMPRESSED, 'c');
  235.   VECTOR_SET (result, 8, modes);
  236.   VECTOR_SET (result, 9, (dword_pair_to_integer (inode_low, inode_high)));
  237.   VECTOR_SET (result, 10, (ulong_to_integer (attributes)));
  238.   return (result);
  239. }
  240.  
  241. #undef STORE_FILE_TIME
  242. #undef ATTRIBUTE_LETTER
  243.  
  244. DEFINE_PRIMITIVE ("FILE-ATTRIBUTES", Prim_file_attributes, 1, 1,
  245.   "Given a file name, return attribute information about the file.\n\
  246. If the file exists and its status information is accessible, the result\n\
  247. is a vector of 10 items (see the reference manual for details).  Otherwise\n\
  248. the result is #F.")
  249. {
  250.   BY_HANDLE_FILE_INFORMATION info;
  251.   PRIMITIVE_HEADER (1);
  252.   Primitive_GC_If_Needed (MAX_ATTRIBUTES_ALLOCATION);
  253.   switch (NT_get_file_info ((STRING_ARG (1)), (&info), 1))
  254.     {
  255.     case gfi_not_found:
  256.       PRIMITIVE_RETURN (SHARP_F);
  257.     case gfi_ok:
  258.       PRIMITIVE_RETURN
  259.     (create_attributes_vector
  260.      ((info . dwFileAttributes), (info . nNumberOfLinks), 0, 0,
  261.       (& (info . ftLastAccessTime)),
  262.       (& (info . ftLastWriteTime)),
  263.       (& (info . ftCreationTime)),
  264.       (info . nFileSizeLow), (info . nFileSizeHigh),
  265.       (info . nFileIndexLow), (info . nFileIndexHigh)));
  266.     default:
  267.       PRIMITIVE_RETURN
  268.     (create_attributes_vector (0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0));
  269.     }
  270. }
  271.  
  272. DEFINE_PRIMITIVE ("FILE-EQ?", Prim_file_eq_p, 2, 2,
  273.   "True iff the two file arguments are the same file.")
  274. {
  275.   static char buf1[128], buf2[128];
  276.   char *filepart;
  277.   PRIMITIVE_HEADER (2);
  278.  
  279.   if (GetFullPathName(STRING_ARG (1), 128, buf1, &filepart) == 0  ||
  280.       GetFullPathName(STRING_ARG (2), 128, buf2, &filepart) == 0)
  281.     error_external_return ();
  282.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((strcmp (&buf1[0], &buf2[0])) == 0));
  283. }
  284.  
  285. DEFINE_PRIMITIVE ("NT-GET-VOLUME-INFORMATION", Prim_NT_get_vol_info, 1, 1, 0)
  286. {
  287.   char name [256];
  288.   DWORD serial_number;
  289.   DWORD max_component_length;
  290.   DWORD file_system_flags;
  291.   char file_system_name [256];
  292.   SCHEME_OBJECT result;
  293.   PRIMITIVE_HEADER (1);
  294.  
  295.   if (! (GetVolumeInformation ((STRING_ARG (1)),
  296.                    name,
  297.                    (sizeof (name)),
  298.                    (&serial_number),
  299.                    (&max_component_length),
  300.                    (&file_system_flags),
  301.                    file_system_name,
  302.                    (sizeof (file_system_name)))))
  303.     PRIMITIVE_RETURN (SHARP_F);
  304.   result = (allocate_marked_vector (TC_VECTOR, 5, 1));
  305.   VECTOR_SET (result, 0, (char_pointer_to_string (name)));
  306.   VECTOR_SET (result, 1, (ulong_to_integer (serial_number)));
  307.   VECTOR_SET (result, 2, (ulong_to_integer (max_component_length)));
  308.   VECTOR_SET (result, 3, (ulong_to_integer (file_system_flags)));
  309.   VECTOR_SET (result, 4, (char_pointer_to_string (file_system_name)));
  310.   PRIMITIVE_RETURN (result);
  311. }
  312.  
  313. DEFINE_PRIMITIVE ("NT-COPY-FILE", Prim_NT_copy_file, 2, 2, 0)
  314. {
  315.   PRIMITIVE_HEADER (2);
  316.   OS_file_copy ((STRING_ARG (1)), (STRING_ARG (2)));
  317.   PRIMITIVE_RETURN (UNSPECIFIC);
  318. }
  319.  
  320. DEFINE_PRIMITIVE ("NT-GET-FILE-ATTRIBUTES", Prim_NT_get_file_attributes, 1, 1, 0)
  321. {
  322.   PRIMITIVE_HEADER (1);
  323.   {
  324.     CONST char * filename = (STRING_ARG (1));
  325.     DWORD attributes = (GetFileAttributes (filename));
  326.     if (attributes == 0xFFFFFFFF)
  327.       {
  328.     DWORD code = (GetLastError ());
  329.     if (STAT_NOT_FOUND_P (code))
  330.       PRIMITIVE_RETURN (SHARP_F);
  331.     NT_error_api_call (code, apicall_GetFileAttributes);
  332.       }
  333.     PRIMITIVE_RETURN (ulong_to_integer (attributes));
  334.   }
  335. }
  336.  
  337. DEFINE_PRIMITIVE ("NT-SET-FILE-ATTRIBUTES", Prim_NT_set_file_attributes, 2, 2, 0)
  338. {
  339.   PRIMITIVE_HEADER (2);
  340.   STD_BOOL_API_CALL
  341.     (SetFileAttributes, ((STRING_ARG (1)), (arg_ulong_integer (2))));
  342.   PRIMITIVE_RETURN (UNSPECIFIC);
  343. }
  344.  
  345. static unsigned int
  346. DEFUN (arg_directory_index, (argument), unsigned int argument)
  347. {
  348.   long index = (arg_integer (argument));
  349.   if (! (OS_directory_valid_p (index)))
  350.     error_bad_range_arg (argument);
  351.   return (index);
  352. }
  353.  
  354. DEFINE_PRIMITIVE ("WIN32-DIRECTORY-READ", Prim_win32_directory_read, 1, 1,
  355.   "Read and return a filename from DIRECTORY, or #F if no more files.")
  356. {
  357.   PRIMITIVE_HEADER (1);
  358.   {
  359.     WIN32_FIND_DATA info;
  360.     /* 69 is 2 words for pair, plus 68 words for string with maximum
  361.        length of 260 bytes including the terminating zero.  260 is the
  362.        current value of MAX_PATH at this time.  */
  363.     Primitive_GC_If_Needed (MAX_ATTRIBUTES_ALLOCATION + 69);
  364.     PRIMITIVE_RETURN
  365.       ((win32_directory_read ((arg_directory_index (1)), (&info)))
  366.        ? (cons ((char_pointer_to_string (info . cFileName)),
  367.         (create_attributes_vector
  368.          ((info . dwFileAttributes), 1, 0, 0,
  369.           (& (info . ftLastAccessTime)),
  370.           (& (info . ftLastWriteTime)),
  371.           (& (info . ftCreationTime)),
  372.           (info . nFileSizeLow), (info . nFileSizeHigh), 0, 0))))
  373.        : SHARP_F);
  374.   }
  375. }
  376.