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 / prosfs.c < prev    next >
C/C++ Source or Header  |  2001-05-08  |  10KB  |  313 lines
  1. /* -*-C-*-
  2.  
  3. $Id: prosfs.c,v 1.16 2001/05/09 03:15:11 cph Exp $
  4.  
  5. Copyright (c) 1987-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. /* Primitives to perform file-system operations. */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "osfile.h"
  28. #include "osfs.h"
  29. #include "osio.h"
  30.  
  31. extern int EXFUN (OS_channel_copy,
  32.           (off_t source_length,
  33.            Tchannel source_channel,
  34.            Tchannel destination_channel));
  35. extern void EXFUN (OS_file_copy, (CONST char *, CONST char *));
  36.  
  37. #define STRING_RESULT(expression)                    \
  38. {                                    \
  39.   CONST char * result = (expression);                    \
  40.   PRIMITIVE_RETURN                            \
  41.     ((result == 0)                            \
  42.      ? SHARP_F                                \
  43.      : (char_pointer_to_string ((unsigned char *) result)));        \
  44. }
  45.  
  46. DEFINE_PRIMITIVE ("FILE-EXISTS?", Prim_file_exists_p, 1, 1,
  47.   "Return #T iff FILENAME refers to an existing file.\n\
  48. Return #F if the file doesn't exist.\n\
  49. Return zero if it's a symbolic link that points to a nonexisting file.\n\
  50. Signal an error if the file's existence is indeterminate.")
  51. {
  52.   PRIMITIVE_HEADER (1);
  53.   {
  54.     enum file_existence result = (OS_file_existence_test (STRING_ARG (1)));
  55.     PRIMITIVE_RETURN
  56.       ((result == file_doesnt_exist)
  57.        ? SHARP_F
  58.        : (result == file_does_exist)
  59.        ? SHARP_T
  60.        : FIXNUM_ZERO);
  61.   }
  62. }
  63.  
  64. DEFINE_PRIMITIVE ("FILE-EXISTS-DIRECT?", Prim_file_exists_direct_p, 1, 1,
  65.   "Return #T iff FILENAME refers to an existing file.\n\
  66. Return #F if the file doesn't exist.\n\
  67. Return zero if it's a symbolic link.\n\
  68. Signal an error if the file's existence is indeterminate.")
  69. {
  70.   PRIMITIVE_HEADER (1);
  71.   {
  72.     enum file_existence result
  73.       = (OS_file_existence_test_direct (STRING_ARG (1)));
  74.     PRIMITIVE_RETURN
  75.       ((result == file_doesnt_exist)
  76.        ? SHARP_F
  77.        : (result == file_does_exist)
  78.        ? SHARP_T
  79.        : FIXNUM_ZERO);
  80.   }
  81. }
  82.  
  83. DEFINE_PRIMITIVE ("FILE-TYPE-DIRECT", Prim_file_type_direct, 1, 1,
  84.   "Return type of FILE, as an exact non-negative integer.\n\
  85. Don't indirect through symbolic links.")
  86. {
  87.   PRIMITIVE_HEADER (1);
  88.   {
  89.     enum file_type t = (OS_file_type_direct (STRING_ARG (1)));
  90.     PRIMITIVE_RETURN
  91.       ((t == file_type_nonexistent)
  92.        ? SHARP_F
  93.        : (ulong_to_integer ((unsigned long) t)));
  94.   }
  95. }
  96.  
  97. DEFINE_PRIMITIVE ("FILE-TYPE-INDIRECT", Prim_file_type_indirect, 1, 1,
  98.   "Return type of FILE, as an exact non-negative integer.\n\
  99. Indirect through symbolic links.")
  100. {
  101.   PRIMITIVE_HEADER (1);
  102.   {
  103.     enum file_type t = (OS_file_type_indirect (STRING_ARG (1)));
  104.     PRIMITIVE_RETURN
  105.       ((t == file_type_nonexistent)
  106.        ? SHARP_F
  107.        : (ulong_to_integer ((unsigned long) t)));
  108.   }
  109. }
  110.  
  111. DEFINE_PRIMITIVE ("FILE-ACCESS", Prim_file_access, 2, 2,
  112.   "Return #T iff FILENAME exists and is accessible according to MODE.\n\
  113. MODE is an integer between 0 and 7 inclusive, bitwise encoded:\n\
  114.   4 ==> file is readable;\n\
  115.   2 ==> file is writable;\n\
  116.   1 ==> file is executable.")
  117. {
  118.   PRIMITIVE_HEADER (2);
  119.   PRIMITIVE_RETURN
  120.     (BOOLEAN_TO_OBJECT
  121.      (OS_file_access ((STRING_ARG (1)), (arg_index_integer (2, 8)))));
  122. }
  123.  
  124. DEFINE_PRIMITIVE ("FILE-DIRECTORY?", Prim_file_directory_p, 1, 1,
  125.   "Return #T iff FILENAME refers to an existing directory.\n\
  126. Otherwise #F is returned, meaning either that FILENAME doesn't exist\n\
  127.  or that it isn't a directory.")
  128. {
  129.   PRIMITIVE_HEADER (1);
  130.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_file_directory_p (STRING_ARG (1))));
  131. }
  132.  
  133. DEFINE_PRIMITIVE ("FILE-SOFT-LINK?", Prim_file_soft_link_p, 1, 1,
  134.   "Iff FILENAME refers to an existing soft link, return the link contents.\n\
  135. Otherwise #F is returned, meaning either that FILENAME doesn't exist\n\
  136.  or that it isn't a soft link.")
  137. {
  138.   PRIMITIVE_HEADER (1);
  139.   STRING_RESULT (OS_file_soft_link_p (STRING_ARG (1)));
  140. }
  141.  
  142. DEFINE_PRIMITIVE ("FILE-REMOVE", Prim_file_remove, 1, 1,
  143.   "Delete file FILENAME.\n\
  144. If FILENAME is a soft link, the link is deleted.")
  145. {
  146.   PRIMITIVE_HEADER (1);
  147.   OS_file_remove (STRING_ARG (1));
  148.   PRIMITIVE_RETURN (UNSPECIFIC);
  149. }
  150.  
  151. DEFINE_PRIMITIVE ("FILE-REMOVE-LINK", Prim_file_remove_link, 1, 1,
  152.   "If file FILENAME is a link to another file (hard or soft), remove it.")
  153. {
  154.   PRIMITIVE_HEADER (1);
  155.   OS_file_remove_link (STRING_ARG (1));
  156.   PRIMITIVE_RETURN (UNSPECIFIC);
  157. }
  158.  
  159. DEFINE_PRIMITIVE ("FILE-RENAME", Prim_file_rename, 2, 2,
  160.   "Rename file FROM-NAME to TO-NAME.")
  161. {
  162.   PRIMITIVE_HEADER (2);
  163.   OS_file_rename ((STRING_ARG (1)), (STRING_ARG (2)));
  164.   PRIMITIVE_RETURN (UNSPECIFIC);
  165. }
  166.  
  167. DEFINE_PRIMITIVE ("FILE-LINK-HARD", Prim_file_link_hard, 2, 2,
  168.   "Create a hard link from file FROM-NAME to file TO-NAME.\n\
  169. TO-NAME becomes another name for the file FROM-NAME.")
  170. {
  171.   PRIMITIVE_HEADER (2);
  172.   OS_file_link_hard ((STRING_ARG (1)), (STRING_ARG (2)));
  173.   PRIMITIVE_RETURN (UNSPECIFIC);
  174. }
  175.  
  176. DEFINE_PRIMITIVE ("FILE-LINK-SOFT", Prim_file_link_soft, 2, 2,
  177.   "Create a soft link from file FROM-NAME to file TO-NAME.\n\
  178. TO-NAME becomes a soft link containing the string FROM-NAME.")
  179. {
  180.   PRIMITIVE_HEADER (2);
  181.   OS_file_link_soft ((STRING_ARG (1)), (STRING_ARG (2)));
  182.   PRIMITIVE_RETURN (UNSPECIFIC);
  183. }
  184.  
  185. DEFINE_PRIMITIVE ("LINK-FILE", Prim_link_file, 3, 3,
  186.   "This is an obsolete primitive.  Use `file-link-hard' or `file-link-soft'.\n\
  187. Create a new name for file FROM-NAME, called TO-NAME.\n\
  188. If third arg HARD? is #F, a soft link is created;\n\
  189.  otherwise a hard link is created.")
  190. {
  191.   PRIMITIVE_HEADER (3);
  192.   {
  193.     CONST char * from_name = (STRING_ARG (1));
  194.     CONST char * to_name = (STRING_ARG (2));
  195.     if ((ARG_REF (3)) != SHARP_F)
  196.       OS_file_link_hard (from_name, to_name);
  197.     else
  198.       OS_file_link_soft (from_name, to_name);
  199.   }
  200.   PRIMITIVE_RETURN (UNSPECIFIC);
  201. }
  202.  
  203. #ifndef FILE_COPY_BUFFER_LENGTH
  204. #define FILE_COPY_BUFFER_LENGTH 8192
  205. #endif
  206.  
  207. int
  208. DEFUN (OS_channel_copy, (source_length, source_channel, destination_channel),
  209.        off_t source_length AND
  210.        Tchannel source_channel AND
  211.        Tchannel destination_channel)
  212. {
  213.   char buffer [FILE_COPY_BUFFER_LENGTH];
  214.   off_t transfer_length =
  215.     ((source_length > (sizeof (buffer))) ? (sizeof (buffer)) : source_length);
  216.  
  217.   while (source_length > 0)
  218.   {
  219.     long nread =
  220.       (OS_channel_read (source_channel, buffer, transfer_length));
  221.     if (nread <= 0)
  222.     {
  223.       return (-1);
  224.     }
  225.     if ((OS_channel_write (destination_channel, buffer, nread)) <
  226.     nread)
  227.     {
  228.       return (-1);
  229.     }
  230.     source_length -= nread;
  231.     if (source_length < (sizeof (buffer)))
  232.       transfer_length = source_length;
  233.   }
  234.   return (0);
  235. }  
  236.  
  237. DEFINE_PRIMITIVE ("FILE-COPY", Prim_file_copy, 2, 2,
  238.   "Make a new copy of the file FROM-NAME, called TO-NAME.")
  239. {
  240.   PRIMITIVE_HEADER (2);
  241.   OS_file_copy ((STRING_ARG (1)), (STRING_ARG (2)));
  242.   PRIMITIVE_RETURN (UNSPECIFIC);
  243. }
  244.  
  245. DEFINE_PRIMITIVE ("DIRECTORY-MAKE", Prim_directory_make, 1, 1,
  246.   "Create a new directory, called NAME.")
  247. {
  248.   PRIMITIVE_HEADER (1);
  249.   OS_directory_make (STRING_ARG (1));
  250.   PRIMITIVE_RETURN (UNSPECIFIC);
  251. }
  252.  
  253. DEFINE_PRIMITIVE ("DIRECTORY-DELETE", Prim_directory_delete, 1, 1,
  254.   "Delete directory called NAME.")
  255. {
  256.   PRIMITIVE_HEADER (1);
  257.   OS_directory_delete (STRING_ARG (1));
  258.   PRIMITIVE_RETURN (UNSPECIFIC);
  259. }
  260.  
  261. DEFINE_PRIMITIVE ("FILE-TOUCH", Prim_file_touch, 1, 1,
  262.   "Given a file name, change the times of the file to the current time.\n\
  263. If the file does not exist, create it.\n\
  264. Both the access time and modification time are changed.\n\
  265. Return #F if the file existed and its time was modified.\n\
  266. Otherwise the file did not exist and it was created.")
  267. {
  268.   PRIMITIVE_HEADER (1);
  269.   PRIMITIVE_RETURN
  270.     (BOOLEAN_TO_OBJECT (OS_file_touch ((CONST char *) (STRING_ARG (1)))));
  271. }
  272.  
  273. DEFINE_PRIMITIVE ("NEW-DIRECTORY-OPEN", Prim_new_directory_open, 1, 1,
  274.   "Open the directory NAME for reading, returning a directory number.")
  275. {
  276.   PRIMITIVE_HEADER (1);
  277.   PRIMITIVE_RETURN (long_to_integer (OS_directory_open (STRING_ARG (1))));
  278. }
  279.  
  280. static unsigned int
  281. DEFUN (arg_directory_index, (argument), unsigned int argument)
  282. {
  283.   long index = (arg_integer (argument));
  284.   if (! (OS_directory_valid_p (index)))
  285.     error_bad_range_arg (argument);
  286.   return (index);
  287. }
  288.  
  289. DEFINE_PRIMITIVE ("NEW-DIRECTORY-CLOSE", Prim_new_directory_close, 1, 1,
  290.   "Close DIRECTORY.")
  291. {
  292.   PRIMITIVE_HEADER (1);
  293.   OS_directory_close (arg_directory_index (1));
  294.   PRIMITIVE_RETURN (UNSPECIFIC);
  295. }
  296.  
  297. DEFINE_PRIMITIVE ("NEW-DIRECTORY-READ", Prim_new_directory_read, 1, 1,
  298.   "Read and return a filename from DIRECTORY, or #F if no more files.")
  299. {
  300.   PRIMITIVE_HEADER (1);
  301.   STRING_RESULT (OS_directory_read (arg_directory_index (1)));
  302. }
  303.  
  304. DEFINE_PRIMITIVE ("NEW-DIRECTORY-READ-MATCHING", Prim_new_directory_read_match, 2, 2,
  305.   "Read and return a filename from DIRECTORY.\n\
  306. The filename must begin with the STRING.\n\
  307. Return #F if there are no more matching files in the directory.")
  308. {
  309.   PRIMITIVE_HEADER (2);
  310.   STRING_RESULT
  311.     (OS_directory_read_matching ((arg_directory_index (1)), (STRING_ARG (2))));
  312. }
  313.