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 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 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 75 ficlPrimitiveOpenFile(ficlVm *vm) 76 { 77 ficlFileOpen(vm, "a"); 78 } 79 80 /* ( c-addr u fam -- fileid ior ) */ 81 static void 82 ficlPrimitiveCreateFile(ficlVm *vm) 83 { 84 ficlFileOpen(vm, "w"); 85 } 86 87 /* ( fileid -- ior ) */ 88 static int 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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