1 /*
2 * Part of Scheme 48 1.9. See file COPYING for notices and license.
3 *
4 * Authors: Richard Kelsey, Jonathan Rees, Marcus Crestani, Ivan Shmakov,
5 * Mike Sperber
6 */
7
8 /*
9 * Scheme 48/POSIX I/O interface
10 */
11
12 #include <stdio.h>
13 #include <sys/types.h>
14 #include <unistd.h>
15 #include <fcntl.h>
16 #include <errno.h>
17
18 #include "scheme48.h"
19 #include "scheme48vm.h" /* ps_close_fd() */
20 #include "posix.h"
21 #include "c-mods.h"
22 #include "unix.h"
23 #include "fd-io.h"
24
25 extern void s48_init_posix_io(void);
26 static s48_ref_t posix_dup(s48_call_t call, s48_ref_t channel, s48_ref_t new_mode),
27 posix_dup2(s48_call_t call, s48_ref_t channel, s48_ref_t new_fd),
28 posix_pipe(s48_call_t call),
29 posix_close_on_exec_p(s48_call_t call, s48_ref_t channel),
30 posix_set_close_on_exec(s48_call_t call, s48_ref_t channel,
31 s48_ref_t close_p),
32 posix_io_flags(s48_call_t call, s48_ref_t channel, s48_ref_t options);
33
34 static s48_ref_t s48_enter_file_options(s48_call_t call, int options);
35
36 /*
37 * Record types imported from Scheme.
38 */
39 static s48_ref_t posix_file_options_enum_set_type_binding;
40
41 /*
42 * Install all exported functions in Scheme48.
43 */
44 void
s48_init_posix_io(void)45 s48_init_posix_io(void)
46 {
47 S48_EXPORT_FUNCTION(posix_dup);
48 S48_EXPORT_FUNCTION(posix_dup2);
49 S48_EXPORT_FUNCTION(posix_pipe);
50 S48_EXPORT_FUNCTION(posix_close_on_exec_p);
51 S48_EXPORT_FUNCTION(posix_set_close_on_exec);
52 S48_EXPORT_FUNCTION(posix_io_flags);
53
54 posix_file_options_enum_set_type_binding =
55 s48_get_imported_binding_2("posix-file-options-enum-set-type");
56 }
57
58 /*
59 * Moves `channel' to a new file descriptor and returns a new channel that uses
60 * `channel''s old file descriptor.
61 *
62 * Without all the error checking, this is:
63 * old_fd = channel_os_index(channel);
64 * new_fd = dup(old_fd);
65 * s48_set_channel_os_index(channel, new_fd);
66 * return s48_add_channel(old_fd);
67 *
68 */
69
70 static s48_ref_t
posix_dup(s48_call_t call,s48_ref_t channel,s48_ref_t new_mode)71 posix_dup(s48_call_t call, s48_ref_t channel, s48_ref_t new_mode)
72 {
73 int new_fd, old_fd, flags;
74 long status;
75 s48_ref_t s48_status;
76 s48_ref_t old_mode;
77 s48_ref_t new_channel;
78
79 if (!s48_channel_p_2(call, channel) ||
80 s48_eq_p_2(call, s48_channel_status_2(call, channel), s48_channel_status_closed_2(call)))
81 s48_assertion_violation_2(call, "posix_dup", "not an open channel", 1, channel);
82
83 old_fd = s48_unsafe_extract_long_2(call, s48_unsafe_channel_os_index_2(call, channel));
84 old_mode = s48_unsafe_channel_status_2(call, channel);
85
86 RETRY_OR_RAISE_NEG(new_fd, dup(old_fd));
87
88 s48_status = s48_set_channel_os_index_2(call, channel, new_fd);
89
90 if (!s48_true_p_2(call, s48_status)) {
91 ps_close_fd(new_fd); /* retries if interrupted */
92 s48_raise_scheme_exception_2(call, s48_extract_long_2(call, s48_status), 1, channel); }
93
94 if (s48_eq_p_2(call, new_mode, s48_channel_status_output_2(call))
95 && s48_eq_p_2(call, old_mode, s48_channel_status_input_2(call))) {
96 RETRY_OR_RAISE_NEG(flags, fcntl(new_fd, F_GETFL));
97 RETRY_OR_RAISE_NEG(status, fcntl(new_fd, F_SETFL, flags | O_NONBLOCK)); }
98
99 new_channel = s48_add_channel_2(call,
100 s48_false_p_2(call, new_mode) ? old_mode : new_mode,
101 s48_unsafe_channel_id_2(call, channel),
102 old_fd);
103
104 if (!s48_channel_p_2(call, new_channel)) {
105 ps_close_fd(old_fd); /* retries if interrupted */
106 s48_raise_scheme_exception_2(call, s48_extract_long_2(call, new_channel), 1, channel); }
107
108 return new_channel;
109 }
110
111 /*
112 * Same again, except that we get told what the new file descriptor is to be.
113 * We close the channel currently using that descriptor, if there be one.
114 *
115 * Without all the error checking, this is:
116 * old_fd = channel_os_index(channel);
117 * dup2(old_fd, new_fd);
118 * s48_set_channel_os_index(channel, new_fd);
119 * return s48_add_channel(old_fd);
120 */
121
122 static s48_ref_t
posix_dup2(s48_call_t call,s48_ref_t channel,s48_ref_t new_fd)123 posix_dup2(s48_call_t call, s48_ref_t channel, s48_ref_t new_fd)
124 {
125 s48_ref_t new_channel;
126 s48_ref_t s48_status;
127 int status;
128 int new_c_fd, old_c_fd;
129
130 if (!s48_channel_p_2(call, channel) ||
131 s48_eq_p_2(call, s48_channel_status_2(call, channel), s48_channel_status_closed_2(call)))
132 s48_assertion_violation_2(call, "posix_dup2", "not an open channel", 1, channel);
133
134 if (!s48_fixnum_p_2(call, new_fd) || new_fd < 0)
135 s48_assertion_violation_2(call, "posix_dup2", "fd not a nonnegative fixnum", 1, new_fd);
136
137 old_c_fd = s48_extract_long_2(call, s48_unsafe_channel_os_index_2(call, channel));
138 new_c_fd = s48_extract_long_2(call, new_fd);
139
140 s48_close_channel(new_c_fd);
141
142 RETRY_OR_RAISE_NEG(status, dup2(old_c_fd, new_c_fd));
143
144 s48_status = s48_set_channel_os_index_2(call, channel, new_c_fd);
145
146 if (!s48_true_p_2(call, s48_status)) {
147 ps_close_fd(new_c_fd); /* retries if interrupted */
148 s48_raise_scheme_exception_2(call, s48_extract_long_2(call, s48_status), 1, channel); }
149
150 new_channel = s48_add_channel_2(call,
151 s48_unsafe_channel_status_2(call, channel),
152 s48_unsafe_channel_id_2(call, channel),
153 old_c_fd);
154
155 if (!s48_channel_p_2(call, new_channel)) {
156 ps_close_fd(old_c_fd); /* retries if interrupted */
157 s48_raise_scheme_exception_2(call, s48_extract_long_2(call, new_channel), 1, channel); }
158
159 return new_channel;
160 }
161
162 /*
163 * Opens a pipe and returns a pair (<input-channel> . <output-channel>).
164 *
165 * Synopsis:
166 * int fds[2];
167 * pipe(fds);
168 * return s48_cons(s48_add_channel(fds[1]), s48_add_channel(fds[2]));
169 */
170
171 static s48_ref_t
posix_pipe(s48_call_t call)172 posix_pipe(s48_call_t call)
173 { int fildes[2],
174 status;
175 s48_ref_t in_channel, out_channel;
176 s48_ref_t id = s48_enter_string_latin_1_2 (call, "pipe");
177
178 RETRY_OR_RAISE_NEG(status, pipe(fildes));
179
180 in_channel = s48_add_channel_2(call, s48_channel_status_input_2(call), id, fildes[0]);
181
182 if (!s48_channel_p_2(call, in_channel)) {
183 ps_close_fd(fildes[0]); /* retries if interrupted */
184 ps_close_fd(fildes[1]); /* retries if interrupted */
185 s48_raise_scheme_exception_2(call, s48_extract_long_2(call, in_channel), 0); }
186
187 RETRY_OR_RAISE_NEG(status, fcntl(fildes[1], F_SETFL, O_NONBLOCK));
188 out_channel = s48_add_channel_2(call, s48_channel_status_output_2(call), id, fildes[1]);
189
190 if (!s48_channel_p_2(call, out_channel)) {
191 s48_close_channel(fildes[0]);
192 ps_close_fd(fildes[1]); /* retries if interrupted */
193 s48_raise_scheme_exception_2(call, s48_extract_long_2(call, in_channel), 0); }
194
195 return s48_cons_2(call, in_channel, out_channel);
196 }
197
198 static s48_ref_t
posix_close_on_exec_p(s48_call_t call,s48_ref_t channel)199 posix_close_on_exec_p(s48_call_t call, s48_ref_t channel)
200 {
201 int c_fd,
202 status;
203
204 if (!s48_channel_p_2(call, channel) ||
205 s48_eq_p_2(call,
206 s48_channel_status_2(call, channel),
207 s48_channel_status_closed_2(call)))
208 s48_assertion_violation_2(call, "posix_close_on_exec_p", "not an open channel", 1, channel);
209
210 c_fd = s48_unsafe_extract_long_2(call, s48_unsafe_channel_os_index_2(call, channel));
211
212 RETRY_OR_RAISE_NEG(status, fcntl(c_fd, F_GETFD));
213
214 return s48_enter_boolean_2(call, status & FD_CLOEXEC);
215 }
216
217 static s48_ref_t
posix_set_close_on_exec(s48_call_t call,s48_ref_t channel,s48_ref_t value)218 posix_set_close_on_exec(s48_call_t call, s48_ref_t channel, s48_ref_t value)
219 {
220 int status, new_status;
221 int c_fd;
222
223 if (!s48_channel_p_2(call, channel) ||
224 s48_eq_p_2(call,
225 s48_channel_status_2(call, channel),
226 s48_channel_status_closed_2(call)))
227 s48_assertion_violation_2(call, "posix_set_close_on_exec", "not an open channel", 1, channel);
228
229 c_fd = s48_unsafe_extract_long_2(call, s48_unsafe_channel_os_index_2(call, channel));
230
231 RETRY_OR_RAISE_NEG(status, fcntl(c_fd, F_GETFD));
232
233 if (s48_extract_boolean_2(call, value))
234 new_status = status | FD_CLOEXEC;
235 else
236 new_status = status & ! FD_CLOEXEC;
237
238 if (new_status != status)
239 RETRY_OR_RAISE_NEG(status, fcntl(c_fd, F_SETFD, new_status));
240
241 return s48_unspecific_2(call);
242 }
243
244 static s48_ref_t
posix_io_flags(s48_call_t call,s48_ref_t channel,s48_ref_t options)245 posix_io_flags(s48_call_t call, s48_ref_t channel, s48_ref_t options)
246 {
247 int status;
248 int c_fd;
249
250 if (!s48_channel_p_2(call, channel) ||
251 s48_eq_p_2(call,
252 s48_channel_status_2(call, channel),
253 s48_channel_status_closed_2(call)))
254 s48_assertion_violation_2(call, "posix_io_flags", "not an open channel", 1, channel);
255
256 c_fd = s48_unsafe_extract_long_2(call, s48_unsafe_channel_os_index_2(call, channel));
257
258 if (s48_false_p_2(call, options)) {
259
260 RETRY_OR_RAISE_NEG(status, fcntl(c_fd, F_GETFL));
261
262 return s48_enter_file_options(call, status);
263 }
264 else {
265 int c_options = s48_extract_file_options(call, options);
266
267 RETRY_OR_RAISE_NEG(status, fcntl(c_fd, F_SETFL, c_options));
268
269 return s48_unspecific_2(call);
270 }
271 }
272
273 /* ************************************************************ */
274 /* File options.
275 *
276 * We translate the local bits into our own bits and vice versa.
277 */
278
279 s48_ref_t
s48_enter_file_options(s48_call_t call,int file_options)280 s48_enter_file_options(s48_call_t call, int file_options)
281 {
282 s48_ref_t sch_file_options;
283 int my_file_options;
284
285 my_file_options =
286 (O_CREAT & file_options ? 00001 : 0) |
287 (O_EXCL & file_options ? 00002 : 0) |
288 (O_NOCTTY & file_options ? 00004 : 0) |
289 (O_TRUNC & file_options ? 00010 : 0) |
290 (O_APPEND & file_options ? 00020 : 0) |
291 /* POSIX 2nd ed., not in Linux
292 (O_DSYNC & file_options ? 00040 : 0) |
293 */
294 (O_NONBLOCK & file_options ? 00100 : 0) |
295 /* POSIX 2nd ed., not in Linux
296 (O_RSYNC & file_options ? 00200 : 0) |
297 */
298 /* Not in FreeBSD
299 (O_SYNC & file_options ? 00400 : 0) |
300 */
301 (O_RDONLY & file_options ? 01000 : 0) |
302 (O_RDWR & file_options ? 02000 : 0) |
303 (O_WRONLY & file_options ? 04000 : 0);
304
305 sch_file_options
306 = s48_integer2enum_set_2(call, posix_file_options_enum_set_type_binding,
307 my_file_options);
308
309 return sch_file_options;
310 }
311
312 int
s48_extract_file_options(s48_call_t call,s48_ref_t sch_file_options)313 s48_extract_file_options(s48_call_t call, s48_ref_t sch_file_options)
314 {
315 int c_file_options;
316 long file_options;
317
318 s48_check_enum_set_type_2(call, sch_file_options,
319 posix_file_options_enum_set_type_binding);
320
321 file_options = s48_enum_set2integer_2(call, sch_file_options);
322
323 c_file_options =
324 (00001 & file_options ? O_CREAT : 0) |
325 (00002 & file_options ? O_EXCL : 0) |
326 (00004 & file_options ? O_NOCTTY : 0) |
327 (00010 & file_options ? O_TRUNC : 0) |
328 (00020 & file_options ? O_APPEND : 0) |
329 /* POSIX 2nd ed., not in Linux
330 (00040 & file_options ? O_DSYNC : 0) |
331 */
332 (00100 & file_options ? O_NONBLOCK : 0) |
333 /* POSIX 2nd ed., not in Linux
334 (00200 & file_options ? O_RSYNC : 0) |
335 */
336 /* Not in FreeBSD
337 (00400 & file_options ? O_SYNC : 0) |
338 */
339 (01000 & file_options ? O_RDONLY : 0) |
340 (02000 & file_options ? O_RDWR : 0) |
341 (04000 & file_options ? O_WRONLY : 0);
342
343 return c_file_options;
344 }
345
346