1 /* io.c: Ports and I/O primitives.
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include "config.h"
32
33 #include <errno.h>
34 #include <stdio.h>
35 #ifdef HAVE_PWD_H
36 # include <pwd.h>
37 #endif
38 #include <string.h>
39 #include <sys/types.h>
40 #include <sys/param.h>
41 #include <sys/stat.h>
42
43 #ifdef HAVE_UNISTD_H
44 # include <unistd.h>
45 #endif
46
47 #include "kernel.h"
48
49 extern void Flush_Output (Object);
50
51 extern int errno;
52 extern char *getenv();
53
54 Object Curr_Input_Port, Curr_Output_Port;
55 Object Standard_Input_Port, Standard_Output_Port;
56
Init_Io()57 void Init_Io () {
58 Standard_Input_Port = Make_Port (P_INPUT, stdin, Make_String ("stdin", 5));
59 Standard_Output_Port = Make_Port (0, stdout, Make_String ("stdout", 6));
60 Curr_Input_Port = Standard_Input_Port;
61 Curr_Output_Port = Standard_Output_Port;
62 Global_GC_Link (Standard_Input_Port);
63 Global_GC_Link (Standard_Output_Port);
64 Global_GC_Link (Curr_Input_Port);
65 Global_GC_Link (Curr_Output_Port);
66 }
67
Reset_IO(int destructive)68 void Reset_IO (int destructive) {
69 Discard_Input (Curr_Input_Port);
70 if (destructive)
71 Discard_Output (Curr_Output_Port);
72 else
73 Flush_Output (Curr_Output_Port);
74 Curr_Input_Port = Standard_Input_Port;
75 Curr_Output_Port = Standard_Output_Port;
76 }
77
Make_Port(int flags,FILE * f,Object name)78 Object Make_Port (int flags, FILE *f, Object name) {
79 Object port;
80 GC_Node;
81
82 GC_Link (name);
83 port = Alloc_Object (sizeof (struct S_Port), T_Port, 0);
84 PORT(port)->flags = flags|P_OPEN;
85 PORT(port)->file = f;
86 PORT(port)->name = name;
87 PORT(port)->ptr = 0;
88 PORT(port)->lno = 1;
89 PORT(port)->closefun = fclose;
90 GC_Unlink;
91 return port;
92 }
93
P_Port_File_Name(Object p)94 Object P_Port_File_Name (Object p) {
95 Check_Type (p, T_Port);
96 return (PORT(p)->flags & P_STRING) ? False : PORT(p)->name;
97 }
98
P_Port_Line_Number(Object p)99 Object P_Port_Line_Number (Object p) {
100 Check_Type (p, T_Port);
101 return Make_Unsigned (PORT(p)->lno);
102 }
103
P_Eof_Objectp(Object x)104 Object P_Eof_Objectp (Object x) {
105 return TYPE(x) == T_End_Of_File ? True : False;
106 }
107
P_Current_Input_Port()108 Object P_Current_Input_Port () { return Curr_Input_Port; }
109
P_Current_Output_Port()110 Object P_Current_Output_Port () { return Curr_Output_Port; }
111
P_Input_Portp(Object x)112 Object P_Input_Portp (Object x) {
113 return TYPE(x) == T_Port && IS_INPUT(x) ? True : False;
114 }
115
P_Output_Portp(Object x)116 Object P_Output_Portp (Object x) {
117 return TYPE(x) == T_Port && IS_OUTPUT(x) ? True : False;
118 }
119
Path_Max()120 unsigned int Path_Max () {
121 #if defined(PATH_MAX) /* POSIX */
122 return PATH_MAX;
123 #elif defined(MAXPATHLEN) /* 4.3 BSD */
124 return MAXPATHLEN;
125 #elif defined(_PC_PATH_MAX)
126 static int r;
127 if (r == 0) {
128 if ((r = pathconf ("/", _PC_PATH_MAX)) == -1)
129 r = 1024;
130 r++;
131 }
132 return r;
133 #else
134 return 1024;
135 #endif
136 }
137
Get_File_Name(Object name)138 Object Get_File_Name (Object name) {
139 register unsigned int len;
140
141 if (TYPE(name) == T_Symbol)
142 name = SYMBOL(name)->name;
143 else if (TYPE(name) != T_String)
144 Wrong_Type_Combination (name, "string or symbol");
145 len = STRING(name)->size;
146 if (len > Path_Max () || len == 0)
147 Primitive_Error ("invalid file name");
148 return name;
149 }
150
Internal_Tilde_Expand(register char * s,register char ** dirp)151 char *Internal_Tilde_Expand (register char *s, register char **dirp) {
152 register char *p;
153 #ifdef HAVE_PWD_H
154 struct passwd *pw, *getpwnam();
155 #endif
156
157 if (*s++ != '~')
158 return 0;
159 for (p = s; *p && *p != '/'; p++)
160 ;
161 if (*p == '/') *p++ = 0;
162 #ifdef HAVE_PWD_H
163 if (*s == '\0') {
164 if ((*dirp = getenv ("HOME")) == 0)
165 *dirp = "";
166 } else {
167 if ((pw = getpwnam (s)) == 0)
168 Primitive_Error ("unknown user: ~a", Make_String (s, strlen (s)));
169 *dirp = pw->pw_dir;
170 }
171 #else
172 *dirp = "";
173 #endif
174 return p;
175 }
176
General_File_Operation(Object s,register int op)177 Object General_File_Operation (Object s, register int op) {
178 register char *r;
179 Object ret, fn;
180 Alloca_Begin;
181
182 fn = Get_File_Name (s);
183 Get_Strsym_Stack (fn, r);
184 switch (op) {
185 case 0: {
186 char *p, *dir;
187 p = Internal_Tilde_Expand (r, &dir);
188 if (p == 0) {
189 Alloca_End;
190 return s;
191 }
192 Alloca (r, char*, strlen (dir) + 1 + strlen (p) + 1);
193 sprintf (r, "%s" SEPARATOR_STRING "%s", dir, p);
194 ret = Make_String (r, strlen (r));
195 Alloca_End;
196 return ret;
197 }
198 case 1: {
199 struct stat st;
200 /* Doesn't make much sense to check for errno != ENOENT here:
201 */
202 ret = stat (r, &st) == 0 ? True : False;
203 Alloca_End;
204 return ret;
205 }
206 default: {
207 return Null; /* Just to avoid compiler warnings */
208 }}
209 /*NOTREACHED*/
210 }
211
P_Tilde_Expand(Object s)212 Object P_Tilde_Expand (Object s) {
213 return General_File_Operation (s, 0);
214 }
215
P_File_Existsp(Object s)216 Object P_File_Existsp (Object s) {
217 return General_File_Operation (s, 1);
218 }
219
Close_All_Files()220 void Close_All_Files () {
221 Terminate_Type (T_Port);
222 }
223
Terminate_File(Object port)224 Object Terminate_File (Object port) {
225 (void)(PORT(port)->closefun) (PORT(port)->file);
226 PORT(port)->flags &= ~P_OPEN;
227 return Void;
228 }
229
Open_File(char * name,int flags,int err)230 Object Open_File (char *name, int flags, int err) {
231 register FILE *f;
232 char *dir, *p;
233 Object fn, port;
234 struct stat st;
235 Alloca_Begin;
236
237 p = Internal_Tilde_Expand (name, &dir);
238 if (p) {
239 Alloca (name, char*, strlen (dir) + 1 + strlen (p) + 1);
240 sprintf (name, "%s" SEPARATOR_STRING "%s", dir, p);
241 }
242 if (!err && stat (name, &st) == -1 &&
243 (errno == ENOENT || errno == ENOTDIR)) {
244 Alloca_End;
245 return Null;
246 }
247 switch (flags & (P_INPUT|P_BIDIR)) {
248 case 0: p = "w"; break;
249 case P_INPUT: p = "r"; break;
250 default: p = "r+"; break;
251 }
252 fn = Make_String (name, strlen (name));
253 Disable_Interrupts;
254 if ((f = fopen (name, p)) == NULL) {
255 Saved_Errno = errno; /* errno valid here? */
256 Primitive_Error ("~s: ~E", fn);
257 }
258 port = Make_Port (flags, f, fn);
259 Register_Object (port, (GENERIC)0, Terminate_File, 0);
260 Enable_Interrupts;
261 Alloca_End;
262 return port;
263 }
264
General_Open_File(Object name,int flags,Object path)265 Object General_Open_File (Object name, int flags, Object path) {
266 Object port, pref;
267 char *buf = 0;
268 register char *fn;
269 register unsigned int plen, len, blen = 0, gotpath = 0;
270 Alloca_Begin;
271
272 name = Get_File_Name (name);
273 len = STRING(name)->size;
274 fn = STRING(name)->data;
275 #ifdef WIN32
276 if (fn[0] < 'A' || fn[0] > 'Z' || fn[1] != ':' ) {
277 #else
278 if (fn[0] != '/' && fn[0] != '~') {
279 #endif
280 for ( ; TYPE(path) == T_Pair; path = Cdr (path)) {
281 pref = Car (path);
282 if (TYPE(pref) == T_Symbol)
283 pref = SYMBOL(pref)->name;
284 if (TYPE(pref) != T_String)
285 continue;
286 gotpath = 1;
287 plen = STRING(pref)->size;
288 if (plen > Path_Max () || plen == 0)
289 continue;
290 if (len + plen + 2 > blen) {
291 blen = len + plen + 2;
292 Alloca (buf, char*, blen);
293 }
294 memcpy (buf, STRING(pref)->data, plen);
295 if (buf[plen-1] != SEPARATOR_CHAR)
296 buf[plen++] = SEPARATOR_CHAR;
297 memcpy (buf+plen, fn, len);
298 buf[len+plen] = '\0';
299 port = Open_File (buf, flags, 0);
300 /* No GC has been taken place in Open_File() if it returns Null.
301 */
302 if (!Nullp (port)) {
303 Alloca_End;
304 return port;
305 }
306 }
307 }
308 if (gotpath)
309 Primitive_Error ("file ~s not found", name);
310 if (len + 1 > blen)
311 Alloca (buf, char*, len + 1);
312 memcpy (buf, fn, len);
313 buf[len] = '\0';
314 port = Open_File (buf, flags, 1);
315 Alloca_End;
316 return port;
317 }
318
319 Object P_Open_Input_File (Object name) {
320 return General_Open_File (name, P_INPUT, Null);
321 }
322
323 Object P_Open_Output_File (Object name) {
324 return General_Open_File (name, 0, Null);
325 }
326
327 Object P_Open_Input_Output_File (Object name) {
328 return General_Open_File (name, P_BIDIR, Null);
329 }
330
331 Object General_Close_Port (Object port) {
332 register int flags, err = 0;
333 FILE *f;
334
335 Check_Type (port, T_Port);
336 flags = PORT(port)->flags;
337 if (!(flags & P_OPEN) || (flags & P_STRING))
338 return Void;
339 f = PORT(port)->file;
340 if (f == stdin || f == stdout)
341 return Void;
342 if ((PORT(port)->closefun) (f) == EOF) {
343 Saved_Errno = errno; /* errno valid here? */
344 err++;
345 }
346 PORT(port)->flags &= ~P_OPEN;
347 Deregister_Object (port);
348 if (err)
349 Primitive_Error ("write error on ~s: ~E", port);
350 return Void;
351 }
352
353 Object P_Close_Input_Port (Object port) {
354 return General_Close_Port (port);
355 }
356
357 Object P_Close_Output_Port (Object port) {
358 return General_Close_Port (port);
359 }
360
361 #define General_With(prim,curr,flags) Object prim (Object name, Object thunk) {\
362 Object old, ret;\
363 GC_Node2;\
364 \
365 Check_Procedure (thunk);\
366 old = curr;\
367 GC_Link2 (thunk, old);\
368 curr = General_Open_File (name, flags, Null);\
369 ret = Funcall (thunk, Null, 0);\
370 (void)General_Close_Port (curr);\
371 GC_Unlink;\
372 curr = old;\
373 return ret;\
374 }
375
376 General_With (P_With_Input_From_File, Curr_Input_Port, P_INPUT)
377 General_With (P_With_Output_To_File, Curr_Output_Port, 0)
378
379 Object General_Call_With (Object name, int flags, Object proc) {
380 Object port, ret;
381 GC_Node2;
382
383 Check_Procedure (proc);
384 GC_Link2 (proc, port);
385 port = General_Open_File (name, flags, Null);
386 port = Cons (port, Null);
387 ret = Funcall (proc, port, 0);
388 (void)General_Close_Port (Car (port));
389 GC_Unlink;
390 return ret;
391 }
392
393 Object P_Call_With_Input_File (Object name, Object proc) {
394 return General_Call_With (name, P_INPUT, proc);
395 }
396
397 Object P_Call_With_Output_File (Object name, Object proc) {
398 return General_Call_With (name, 0, proc);
399 }
400
401 Object P_Open_Input_String (Object string) {
402 Check_Type (string, T_String);
403 return Make_Port (P_STRING|P_INPUT, (FILE *)0, string);
404 }
405
406 Object P_Open_Output_String () {
407 return Make_Port (P_STRING, (FILE *)0, Make_String ((char *)0, 0));
408 }
409