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
11static void
12pushIor(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 ) */
23static void
24ficlFileOpen(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
69EXIT:
70	free(filename);
71}
72
73/* ( c-addr u fam -- fileid ior ) */
74static void
75ficlPrimitiveOpenFile(ficlVm *vm)
76{
77	ficlFileOpen(vm, "a");
78}
79
80/* ( c-addr u fam -- fileid ior ) */
81static void
82ficlPrimitiveCreateFile(ficlVm *vm)
83{
84	ficlFileOpen(vm, "w");
85}
86
87/* ( fileid -- ior ) */
88static int
89ficlFileClose(ficlFile *ff)
90{
91	FILE *f = ff->f;
92	free(ff);
93	return (!fclose(f));
94}
95
96/* ( fileid -- ior ) */
97static void
98ficlPrimitiveCloseFile(ficlVm *vm)
99{
100	ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
101	pushIor(vm, ficlFileClose(ff));
102}
103
104/* ( c-addr u -- ior ) */
105static void
106ficlPrimitiveDeleteFile(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 ) */
120static void
121ficlPrimitiveRenameFile(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 ) */
148static void
149ficlPrimitiveFileStatus(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 ) */
169static void
170ficlPrimitiveFilePosition(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 ) */
179static void
180ficlPrimitiveFileSize(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
190static void
191ficlPrimitiveIncludeFile(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 ) */
231static void
232ficlPrimitiveReadFile(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 ) */
247static void
248ficlPrimitiveReadLine(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 ) */
287static void
288ficlPrimitiveWriteFile(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 ) */
300static void
301ficlPrimitiveWriteLine(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 ) */
314static void
315ficlPrimitiveRepositionFile(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 ) */
324static void
325ficlPrimitiveFlushFile(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 ) */
333static void
334ficlPrimitiveResizeFile(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
344void
345ficlSystemCompileFile(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