1 #include "ficl.h"
2
3 #if FICL_WANT_FILE
4 /*
5 * fileaccess.c
6 *
7 * Implements all of the File Access word set that can be implemented in
8 * portable C.
9 */
10
11 static void
pushIor(ficlVm * vm,int success)12 pushIor(ficlVm *vm, int success)
13 {
14 int ior;
15 if (success)
16 ior = 0;
17 else
18 ior = errno;
19 ficlStackPushInteger(vm->dataStack, ior);
20 }
21
22 /* ( c-addr u fam -- fileid ior ) */
23 static void
ficlFileOpen(ficlVm * vm,char * writeMode)24 ficlFileOpen(ficlVm *vm, char *writeMode)
25 {
26 int fam = ficlStackPopInteger(vm->dataStack);
27 int length = ficlStackPopInteger(vm->dataStack);
28 void *address = (void *)ficlStackPopPointer(vm->dataStack);
29 char mode[4];
30 FILE *f;
31 char *filename = (char *)malloc(length + 1);
32 memcpy(filename, address, length);
33 filename[length] = 0;
34
35 *mode = 0;
36
37 switch (FICL_FAM_OPEN_MODE(fam)) {
38 case 0:
39 ficlStackPushPointer(vm->dataStack, NULL);
40 ficlStackPushInteger(vm->dataStack, EINVAL);
41 goto EXIT;
42 case FICL_FAM_READ:
43 strcat(mode, "r");
44 break;
45 case FICL_FAM_WRITE:
46 strcat(mode, writeMode);
47 break;
48 case FICL_FAM_READ | FICL_FAM_WRITE:
49 strcat(mode, writeMode);
50 strcat(mode, "+");
51 break;
52 }
53
54 strcat(mode, (fam & FICL_FAM_BINARY) ? "b" : "t");
55
56 f = fopen(filename, mode);
57 if (f == NULL)
58 ficlStackPushPointer(vm->dataStack, NULL);
59 else {
60 ficlFile *ff = (ficlFile *)malloc(sizeof (ficlFile));
61 strcpy(ff->filename, filename);
62 ff->f = f;
63 ficlStackPushPointer(vm->dataStack, ff);
64
65 fseek(f, 0, SEEK_SET);
66 }
67 pushIor(vm, f != NULL);
68
69 EXIT:
70 free(filename);
71 }
72
73 /* ( c-addr u fam -- fileid ior ) */
74 static void
ficlPrimitiveOpenFile(ficlVm * vm)75 ficlPrimitiveOpenFile(ficlVm *vm)
76 {
77 ficlFileOpen(vm, "a");
78 }
79
80 /* ( c-addr u fam -- fileid ior ) */
81 static void
ficlPrimitiveCreateFile(ficlVm * vm)82 ficlPrimitiveCreateFile(ficlVm *vm)
83 {
84 ficlFileOpen(vm, "w");
85 }
86
87 /* ( fileid -- ior ) */
88 static int
ficlFileClose(ficlFile * ff)89 ficlFileClose(ficlFile *ff)
90 {
91 FILE *f = ff->f;
92 free(ff);
93 return (!fclose(f));
94 }
95
96 /* ( fileid -- ior ) */
97 static void
ficlPrimitiveCloseFile(ficlVm * vm)98 ficlPrimitiveCloseFile(ficlVm *vm)
99 {
100 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
101 pushIor(vm, ficlFileClose(ff));
102 }
103
104 /* ( c-addr u -- ior ) */
105 static void
ficlPrimitiveDeleteFile(ficlVm * vm)106 ficlPrimitiveDeleteFile(ficlVm *vm)
107 {
108 int length = ficlStackPopInteger(vm->dataStack);
109 void *address = (void *)ficlStackPopPointer(vm->dataStack);
110
111 char *filename = (char *)malloc(length + 1);
112 memcpy(filename, address, length);
113 filename[length] = 0;
114
115 pushIor(vm, !unlink(filename));
116 free(filename);
117 }
118
119 /* ( c-addr1 u1 c-addr2 u2 -- ior ) */
120 static void
ficlPrimitiveRenameFile(ficlVm * vm)121 ficlPrimitiveRenameFile(ficlVm *vm)
122 {
123 int length;
124 void *address;
125 char *from;
126 char *to;
127
128 length = ficlStackPopInteger(vm->dataStack);
129 address = (void *)ficlStackPopPointer(vm->dataStack);
130 to = (char *)malloc(length + 1);
131 memcpy(to, address, length);
132 to[length] = 0;
133
134 length = ficlStackPopInteger(vm->dataStack);
135 address = (void *)ficlStackPopPointer(vm->dataStack);
136
137 from = (char *)malloc(length + 1);
138 memcpy(from, address, length);
139 from[length] = 0;
140
141 pushIor(vm, !rename(from, to));
142
143 free(from);
144 free(to);
145 }
146
147 /* ( c-addr u -- x ior ) */
148 static void
ficlPrimitiveFileStatus(ficlVm * vm)149 ficlPrimitiveFileStatus(ficlVm *vm)
150 {
151 int status;
152 int ior;
153
154 int length = ficlStackPopInteger(vm->dataStack);
155 void *address = (void *)ficlStackPopPointer(vm->dataStack);
156
157 char *filename = (char *)malloc(length + 1);
158 memcpy(filename, address, length);
159 filename[length] = 0;
160
161 ior = ficlFileStatus(filename, &status);
162 free(filename);
163
164 ficlStackPushInteger(vm->dataStack, status);
165 ficlStackPushInteger(vm->dataStack, ior);
166 }
167
168 /* ( fileid -- ud ior ) */
169 static void
ficlPrimitiveFilePosition(ficlVm * vm)170 ficlPrimitiveFilePosition(ficlVm *vm)
171 {
172 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
173 long ud = ftell(ff->f);
174 ficlStackPushInteger(vm->dataStack, ud);
175 pushIor(vm, ud != -1);
176 }
177
178 /* ( fileid -- ud ior ) */
179 static void
ficlPrimitiveFileSize(ficlVm * vm)180 ficlPrimitiveFileSize(ficlVm *vm)
181 {
182 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
183 long ud = ficlFileSize(ff);
184 ficlStackPushInteger(vm->dataStack, ud);
185 pushIor(vm, ud != -1);
186 }
187
188 /* ( i*x fileid -- j*x ) */
189 #define nLINEBUF 256
190 static void
ficlPrimitiveIncludeFile(ficlVm * vm)191 ficlPrimitiveIncludeFile(ficlVm *vm)
192 {
193 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
194 ficlCell id = vm->sourceId;
195 int except = FICL_VM_STATUS_OUT_OF_TEXT;
196 long currentPosition, totalSize;
197 long size;
198 ficlString s;
199 vm->sourceId.p = (void *)ff;
200
201 currentPosition = ftell(ff->f);
202 totalSize = ficlFileSize(ff);
203 size = totalSize - currentPosition;
204
205 if ((totalSize != -1) && (currentPosition != -1) && (size > 0)) {
206 char *buffer = (char *)malloc(size);
207 long got = fread(buffer, 1, size, ff->f);
208 if (got == size) {
209 FICL_STRING_SET_POINTER(s, buffer);
210 FICL_STRING_SET_LENGTH(s, size);
211 except = ficlVmExecuteString(vm, s);
212 }
213 }
214
215 if ((except < 0) && (except != FICL_VM_STATUS_OUT_OF_TEXT))
216 ficlVmThrow(vm, except);
217
218 /*
219 * Pass an empty line with SOURCE-ID == -1 to flush
220 * any pending REFILLs (as required by FILE wordset)
221 */
222 vm->sourceId.i = -1;
223 FICL_STRING_SET_FROM_CSTRING(s, "");
224 ficlVmExecuteString(vm, s);
225
226 vm->sourceId = id;
227 ficlFileClose(ff);
228 }
229
230 /* ( c-addr u1 fileid -- u2 ior ) */
231 static void
ficlPrimitiveReadFile(ficlVm * vm)232 ficlPrimitiveReadFile(ficlVm *vm)
233 {
234 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
235 int length = ficlStackPopInteger(vm->dataStack);
236 void *address = (void *)ficlStackPopPointer(vm->dataStack);
237 int result;
238
239 clearerr(ff->f);
240 result = fread(address, 1, length, ff->f);
241
242 ficlStackPushInteger(vm->dataStack, result);
243 pushIor(vm, ferror(ff->f) == 0);
244 }
245
246 /* ( c-addr u1 fileid -- u2 flag ior ) */
247 static void
ficlPrimitiveReadLine(ficlVm * vm)248 ficlPrimitiveReadLine(ficlVm *vm)
249 {
250 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
251 int length = ficlStackPopInteger(vm->dataStack);
252 char *address = (char *)ficlStackPopPointer(vm->dataStack);
253 int error;
254 int flag;
255
256 if (feof(ff->f)) {
257 ficlStackPushInteger(vm->dataStack, -1);
258 ficlStackPushInteger(vm->dataStack, 0);
259 ficlStackPushInteger(vm->dataStack, 0);
260 return;
261 }
262
263 clearerr(ff->f);
264 *address = 0;
265 fgets(address, length, ff->f);
266
267 error = ferror(ff->f);
268 if (error != 0) {
269 ficlStackPushInteger(vm->dataStack, -1);
270 ficlStackPushInteger(vm->dataStack, 0);
271 ficlStackPushInteger(vm->dataStack, error);
272 return;
273 }
274
275 length = strlen(address);
276 flag = (length > 0);
277 if (length && ((address[length - 1] == '\r') ||
278 (address[length - 1] == '\n')))
279 length--;
280
281 ficlStackPushInteger(vm->dataStack, length);
282 ficlStackPushInteger(vm->dataStack, flag);
283 ficlStackPushInteger(vm->dataStack, 0); /* ior */
284 }
285
286 /* ( c-addr u1 fileid -- ior ) */
287 static void
ficlPrimitiveWriteFile(ficlVm * vm)288 ficlPrimitiveWriteFile(ficlVm *vm)
289 {
290 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
291 int length = ficlStackPopInteger(vm->dataStack);
292 void *address = (void *)ficlStackPopPointer(vm->dataStack);
293
294 clearerr(ff->f);
295 fwrite(address, 1, length, ff->f);
296 pushIor(vm, ferror(ff->f) == 0);
297 }
298
299 /* ( c-addr u1 fileid -- ior ) */
300 static void
ficlPrimitiveWriteLine(ficlVm * vm)301 ficlPrimitiveWriteLine(ficlVm *vm)
302 {
303 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
304 size_t length = (size_t)ficlStackPopInteger(vm->dataStack);
305 void *address = (void *)ficlStackPopPointer(vm->dataStack);
306
307 clearerr(ff->f);
308 if (fwrite(address, 1, length, ff->f) == length)
309 fwrite("\n", 1, 1, ff->f);
310 pushIor(vm, ferror(ff->f) == 0);
311 }
312
313 /* ( ud fileid -- ior ) */
314 static void
ficlPrimitiveRepositionFile(ficlVm * vm)315 ficlPrimitiveRepositionFile(ficlVm *vm)
316 {
317 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
318 size_t ud = (size_t)ficlStackPopInteger(vm->dataStack);
319
320 pushIor(vm, fseek(ff->f, ud, SEEK_SET) == 0);
321 }
322
323 /* ( fileid -- ior ) */
324 static void
ficlPrimitiveFlushFile(ficlVm * vm)325 ficlPrimitiveFlushFile(ficlVm *vm)
326 {
327 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
328 pushIor(vm, fflush(ff->f) == 0);
329 }
330
331 #if FICL_PLATFORM_HAS_FTRUNCATE
332 /* ( ud fileid -- ior ) */
333 static void
ficlPrimitiveResizeFile(ficlVm * vm)334 ficlPrimitiveResizeFile(ficlVm *vm)
335 {
336 ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
337 size_t ud = (size_t)ficlStackPopInteger(vm->dataStack);
338
339 pushIor(vm, ficlFileTruncate(ff, ud) == 0);
340 }
341 #endif /* FICL_PLATFORM_HAS_FTRUNCATE */
342 #endif /* FICL_WANT_FILE */
343
344 void
ficlSystemCompileFile(ficlSystem * system)345 ficlSystemCompileFile(ficlSystem *system)
346 {
347 #if !FICL_WANT_FILE
348 FICL_IGNORE(system);
349 #else
350 ficlDictionary *dictionary = ficlSystemGetDictionary(system);
351 ficlDictionary *environment = ficlSystemGetEnvironment(system);
352
353 FICL_SYSTEM_ASSERT(system, dictionary);
354 FICL_SYSTEM_ASSERT(system, environment);
355
356 ficlDictionarySetPrimitive(dictionary, "create-file",
357 ficlPrimitiveCreateFile, FICL_WORD_DEFAULT);
358 ficlDictionarySetPrimitive(dictionary, "open-file",
359 ficlPrimitiveOpenFile, FICL_WORD_DEFAULT);
360 ficlDictionarySetPrimitive(dictionary, "close-file",
361 ficlPrimitiveCloseFile, FICL_WORD_DEFAULT);
362 ficlDictionarySetPrimitive(dictionary, "include-file",
363 ficlPrimitiveIncludeFile, FICL_WORD_DEFAULT);
364 ficlDictionarySetPrimitive(dictionary, "read-file",
365 ficlPrimitiveReadFile, FICL_WORD_DEFAULT);
366 ficlDictionarySetPrimitive(dictionary, "read-line",
367 ficlPrimitiveReadLine, FICL_WORD_DEFAULT);
368 ficlDictionarySetPrimitive(dictionary, "write-file",
369 ficlPrimitiveWriteFile, FICL_WORD_DEFAULT);
370 ficlDictionarySetPrimitive(dictionary, "write-line",
371 ficlPrimitiveWriteLine, FICL_WORD_DEFAULT);
372 ficlDictionarySetPrimitive(dictionary, "file-position",
373 ficlPrimitiveFilePosition, FICL_WORD_DEFAULT);
374 ficlDictionarySetPrimitive(dictionary, "file-size",
375 ficlPrimitiveFileSize, FICL_WORD_DEFAULT);
376 ficlDictionarySetPrimitive(dictionary, "reposition-file",
377 ficlPrimitiveRepositionFile, FICL_WORD_DEFAULT);
378 ficlDictionarySetPrimitive(dictionary, "file-status",
379 ficlPrimitiveFileStatus, FICL_WORD_DEFAULT);
380 ficlDictionarySetPrimitive(dictionary, "flush-file",
381 ficlPrimitiveFlushFile, FICL_WORD_DEFAULT);
382
383 ficlDictionarySetPrimitive(dictionary, "delete-file",
384 ficlPrimitiveDeleteFile, FICL_WORD_DEFAULT);
385 ficlDictionarySetPrimitive(dictionary, "rename-file",
386 ficlPrimitiveRenameFile, FICL_WORD_DEFAULT);
387
388 #if FICL_PLATFORM_HAS_FTRUNCATE
389 ficlDictionarySetPrimitive(dictionary, "resize-file",
390 ficlPrimitiveResizeFile, FICL_WORD_DEFAULT);
391
392 ficlDictionarySetConstant(environment, "file", FICL_TRUE);
393 ficlDictionarySetConstant(environment, "file-ext", FICL_TRUE);
394 #else /* FICL_PLATFORM_HAS_FTRUNCATE */
395 ficlDictionarySetConstant(environment, "file", FICL_FALSE);
396 ficlDictionarySetConstant(environment, "file-ext", FICL_FALSE);
397 #endif /* FICL_PLATFORM_HAS_FTRUNCATE */
398
399 #endif /* !FICL_WANT_FILE */
400 }
401