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 / pruxfs.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  10KB  |  312 lines
  1. /* -*-C-*-
  2.  
  3. $Id: pruxfs.c,v 9.56 2000/12/05 21:23:47 cph Exp $
  4.  
  5. Copyright (c) 1987-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 file-system primitives. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "ux.h"
  27. #include "osfs.h"
  28.  
  29. extern int EXFUN
  30.   (UX_read_file_status, (CONST char * filename, struct stat * s));
  31. extern int EXFUN
  32.   (UX_read_file_status_indirect, (CONST char * filename, struct stat * s));
  33. extern CONST char * EXFUN (UX_file_system_type, (CONST char * name));
  34.  
  35. static SCHEME_OBJECT EXFUN (file_attributes_internal, (struct stat * s));
  36. static void EXFUN (file_mode_string, (struct stat * s, char * a));
  37. static char EXFUN (file_type_letter, (struct stat * s));
  38. static void EXFUN (rwx, (unsigned short bits, char * chars));
  39.  
  40. DEFINE_PRIMITIVE ("FILE-MODES", Prim_file_modes, 1, 1,
  41.   "Return mode bits of FILE, as an integer.")
  42. {
  43.   struct stat stat_result;
  44.   PRIMITIVE_HEADER (1);
  45.   PRIMITIVE_RETURN
  46.     ((UX_read_file_status_indirect ((STRING_ARG (1)), (&stat_result)))
  47.      ? (LONG_TO_UNSIGNED_FIXNUM ((stat_result . st_mode) & 07777))
  48.      : SHARP_F);
  49. }
  50.  
  51. DEFINE_PRIMITIVE ("SET-FILE-MODES!", Prim_set_file_modes, 2, 2,
  52.   "Set the mode bits of FILE to MODE.")
  53. {
  54.   PRIMITIVE_HEADER (2);
  55.   if ((UX_chmod ((STRING_ARG (1)), (arg_index_integer (2, 010000)))) < 0)
  56.     error_system_call (errno, syscall_chmod);
  57.   PRIMITIVE_RETURN (SHARP_F);
  58. }
  59.  
  60. DEFINE_PRIMITIVE ("FILE-MOD-TIME", Prim_file_mod_time, 1, 1, 0)
  61. {
  62.   struct stat s;
  63.   PRIMITIVE_HEADER (1);
  64.   PRIMITIVE_RETURN
  65.     ((UX_read_file_status ((STRING_ARG (1)), (&s)))
  66.      ? (long_to_integer (s . st_mtime))
  67.      : SHARP_F);
  68. }
  69.  
  70. DEFINE_PRIMITIVE ("FILE-MOD-TIME-INDIRECT", Prim_file_mod_time_indirect, 1, 1, 0)
  71. {
  72.   struct stat s;
  73.   PRIMITIVE_HEADER (1);
  74.   PRIMITIVE_RETURN
  75.     ((UX_read_file_status_indirect ((STRING_ARG (1)), (&s)))
  76.      ? (long_to_integer (s . st_mtime))
  77.      : SHARP_F);
  78. }
  79.  
  80. DEFINE_PRIMITIVE ("FILE-ACCESS-TIME", Prim_file_acc_time, 1, 1, 0)
  81. {
  82.   struct stat s;
  83.   PRIMITIVE_HEADER (1);
  84.   PRIMITIVE_RETURN
  85.     ((UX_read_file_status ((STRING_ARG (1)), (&s)))
  86.      ? (long_to_integer (s . st_atime))
  87.      : SHARP_F);
  88. }
  89.  
  90. DEFINE_PRIMITIVE ("FILE-ACCESS-TIME-INDIRECT", Prim_file_acc_time_indirect, 1, 1, 0)
  91. {
  92.   struct stat s;
  93.   PRIMITIVE_HEADER (1);
  94.   PRIMITIVE_RETURN
  95.     ((UX_read_file_status_indirect ((STRING_ARG (1)), (&s)))
  96.      ? (long_to_integer (s . st_atime))
  97.      : SHARP_F);
  98. }
  99.  
  100. DEFINE_PRIMITIVE ("SET-FILE-TIMES!", Prim_set_file_times, 3, 3,
  101.   "Change the access and modification times of FILE.\n\
  102. The second and third arguments are the respective times.\n\
  103. The file must exist and you must be the owner (or superuser).")
  104. {
  105.   struct utimbuf times;
  106.   PRIMITIVE_HEADER (3);
  107.   times.actime = (arg_nonnegative_integer (2));
  108.   times.modtime = (arg_nonnegative_integer (3));
  109.   STD_VOID_SYSTEM_CALL
  110.     (syscall_utime, (UX_utime ((STRING_ARG (1)), (×))));
  111.   PRIMITIVE_RETURN (UNSPECIFIC);
  112. }
  113.  
  114. /* Returns a vector of 10 items:
  115.  
  116.    0 = #T iff the file is a directory,
  117.        string (name linked to) for symbolic link,
  118.        #F for all other files.
  119.    1 = number of links to the file
  120.    2 = user id, as an unsigned integer
  121.    3 = group id, as an unsigned integer
  122.    4 = last access time of the file
  123.    5 = last modification time of the file
  124.    6 = last change time of the file
  125.    7 = size of the file in bytes
  126.    8 = mode string for the file
  127.    9 = inode number of the file
  128.  
  129.    The file_mode_string stuff was gobbled from GNU Emacs. */
  130.  
  131. #define FILE_ATTRIBUTES_PRIMITIVE(stat_syscall)                \
  132. {                                    \
  133.   struct stat s;                            \
  134.   PRIMITIVE_HEADER (1);                            \
  135.   PRIMITIVE_RETURN                            \
  136.     ((stat_syscall ((STRING_ARG (1)), (&s)))                \
  137.      ? (file_attributes_internal (&s))                    \
  138.      : SHARP_F);                            \
  139. }
  140.  
  141. DEFINE_PRIMITIVE ("FILE-ATTRIBUTES", Prim_file_attributes, 1, 1,
  142.   "Given a file name, return attribute information about the file.\n\
  143. If the file exists and its status information is accessible, the result\n\
  144. is a vector of 10 items (see the reference manual for details).  Otherwise\n\
  145. the result is #F.")
  146.      FILE_ATTRIBUTES_PRIMITIVE (UX_read_file_status)
  147.  
  148. DEFINE_PRIMITIVE ("FILE-ATTRIBUTES-INDIRECT", Prim_file_attributes_indirect, 1, 1,
  149.   "Like FILE-ATTRIBUTES but indirect through symbolic links.")
  150.      FILE_ATTRIBUTES_PRIMITIVE (UX_read_file_status_indirect)
  151.  
  152. static SCHEME_OBJECT
  153. DEFUN (file_attributes_internal, (s), struct stat * s)
  154. {
  155.   SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 10, true));
  156.   SCHEME_OBJECT modes = (allocate_string (10));
  157.   switch ((s -> st_mode) & S_IFMT)
  158.     {
  159.     case S_IFDIR:
  160.       VECTOR_SET (result, 0, SHARP_T);
  161.       break;
  162. #ifdef S_IFLNK
  163.     case S_IFLNK:
  164.       VECTOR_SET (result, 0,
  165.           (char_pointer_to_string
  166.            ((unsigned char *)
  167.             (OS_file_soft_link_p
  168.              ((CONST char *) (STRING_LOC ((ARG_REF (1)), 0)))))));
  169.       break;
  170. #endif
  171.     default:
  172.       VECTOR_SET (result, 0, SHARP_F);
  173.       break;
  174.     }
  175.   VECTOR_SET (result, 1, (long_to_integer (s -> st_nlink)));
  176.   VECTOR_SET (result, 2, (long_to_integer (s -> st_uid)));
  177.   VECTOR_SET (result, 3, (long_to_integer (s -> st_gid)));
  178.   VECTOR_SET (result, 4, (long_to_integer (s -> st_atime)));
  179.   VECTOR_SET (result, 5, (long_to_integer (s -> st_mtime)));
  180.   VECTOR_SET (result, 6, (long_to_integer (s -> st_ctime)));
  181.   VECTOR_SET (result, 7, (long_to_integer (s -> st_size)));
  182.   file_mode_string (s, ((char *) (STRING_LOC (modes, 0))));
  183.   VECTOR_SET (result, 8, modes);
  184.   VECTOR_SET (result, 9, (long_to_integer (s -> st_ino)));
  185.   return (result);
  186. }
  187.  
  188. /* file_mode_string - set file attribute data
  189.  
  190.    File_mode_string converts the data in the st_mode field of file
  191.    status block `s' to a 10 character attribute string, which it
  192.    stores in the block that `a' points to.
  193.  
  194.    This attribute string is modelled after the string produced by the
  195.    Berkeley ls.
  196.  
  197.    As usual under Unix, the elements of the string are numbered from
  198.    0.  Their meanings are:
  199.  
  200.    0    File type.  'd' for directory, 'c' for character special, 'b'
  201.     for block special, 'm' for multiplex, 'l' for symbolic link,
  202.     's' for socket, 'p' for fifo, '-' for any other file type
  203.    1    'r' if the owner may read, '-' otherwise.
  204.    2    'w' if the owner may write, '-' otherwise.
  205.    3    'x' if the owner may execute, 's' if the file is set-user-id,
  206.     '-' otherwise.  'S' if the file is set-user-id, but the
  207.     execute bit isn't set.  (sys V `feature' which helps to catch
  208.     screw case.)
  209.    4    'r' if group members may read, '-' otherwise.
  210.    5    'w' if group members may write, '-' otherwise.
  211.    6    'x' if group members may execute, 's' if the file is
  212.     set-group-id, '-' otherwise.  'S' if it is set-group-id but
  213.     not executable.
  214.    7    'r' if any user may read, '-' otherwise.
  215.    8    'w' if any user may write, '-' otherwise.
  216.    9    'x' if any user may execute, 't' if the file is "sticky" (will
  217.     be retained in swap space after execution), '-' otherwise. */
  218.  
  219. static void
  220. DEFUN (file_mode_string, (s, a), struct stat * s AND char * a)
  221. {
  222.   (a[0]) = (file_type_letter (s));
  223.   rwx ((((s -> st_mode) & 0700) << 0), (& (a [1])));
  224.   rwx ((((s -> st_mode) & 0070) << 3), (& (a [4])));
  225.   rwx ((((s -> st_mode) & 0007) << 6), (& (a [7])));
  226. #ifdef S_ISUID
  227.   if (((s -> st_mode) & S_ISUID) != 0)
  228.     (a[3]) = (((a[3]) == 'x') ? 's' : 'S');
  229. #endif
  230. #ifdef S_ISGID
  231.   if (((s -> st_mode) & S_ISGID) != 0)
  232.     (a[6]) = (((a [6]) == 'x') ? 's' : 'S');
  233. #endif
  234. #ifdef S_ISVTX
  235.   if (((s -> st_mode) & S_ISVTX) != 0)
  236.     (a[9]) = (((a [9]) == 'x') ? 't' : 'T');
  237. #endif
  238. }
  239.  
  240. static char
  241. DEFUN (file_type_letter, (s), struct stat * s)
  242. {
  243.   switch ((s -> st_mode) & S_IFMT)
  244.     {
  245.     case S_IFDIR:
  246.       return ('d');
  247.     case S_IFCHR:
  248.       return ('c');
  249.     case S_IFBLK:
  250.       return ('b');
  251. #ifdef S_IFLNK
  252.     case S_IFLNK:
  253.       return ('l');
  254. #endif
  255. #ifdef S_IFMPC
  256. /* These do not seem to exist */
  257.     case S_IFMPC:
  258.     case S_IFMPB:
  259.       return ('m');
  260. #endif
  261. #ifdef S_IFSOCK
  262.     case S_IFSOCK:
  263.       return ('s');
  264. #endif
  265. #ifdef S_IFIFO
  266.     case S_IFIFO:
  267.       return ('p');
  268. #endif
  269. #ifdef S_IFNWK /* hp-ux hack */
  270.     case S_IFNWK:
  271.       return ('n');
  272. #endif
  273.     default:
  274.       return ('-');
  275.     }
  276. }
  277.  
  278. static void
  279. DEFUN (rwx, (bits, chars), unsigned short bits AND char * chars)
  280. {
  281.   (chars[0]) = (((bits & S_IRUSR) != 0) ? 'r' : '-');
  282.   (chars[1]) = (((bits & S_IWUSR) != 0) ? 'w' : '-');
  283.   (chars[2]) = (((bits & S_IXUSR) != 0) ? 'x' : '-');
  284. }
  285.  
  286. DEFINE_PRIMITIVE ("FILE-EQ?", Prim_file_eq_p, 2, 2,
  287.   "True iff the two file arguments are the same file.")
  288. {
  289.   PRIMITIVE_HEADER (2);
  290.   {
  291.     struct stat s1;
  292.     struct stat s2;
  293.     PRIMITIVE_RETURN
  294.       (BOOLEAN_TO_OBJECT
  295.        ((UX_read_file_status ((STRING_ARG (1)), (&s1)))
  296.     && (UX_read_file_status ((STRING_ARG (2)), (&s2)))
  297.     && ((s1 . st_dev) == (s2 . st_dev))
  298.     && ((s1 . st_ino) == (s2 . st_ino))));
  299.   }
  300. }
  301.  
  302. DEFINE_PRIMITIVE ("FILE-SYSTEM-TYPE", Prim_file_system_type, 1, 1, 0)
  303. {
  304.   PRIMITIVE_HEADER (1);
  305.   {
  306.     CONST char * result = (UX_file_system_type (STRING_ARG (1)));
  307.     PRIMITIVE_RETURN
  308.       (char_pointer_to_string
  309.        ((unsigned char *) ((result == 0) ? "unknown" : result)));
  310.   }
  311. }
  312.