common/ficl/fileaccess.c

#include "ficl.h"

#if FICL_WANT_FILE
/*
 * fileaccess.c
 *
 * Implements all of the File Access word set that can be implemented in
 * portable C.
 */

static void
pushIor(ficlVm *vm, int success)
{
    int ior;
    if (success)
        ior = 0;
    else
        ior = errno;
    ficlStackPushInteger(vm->dataStack, ior);
}

/* ( c-addr u fam -- fileid ior ) */
static void
ficlFileOpen(ficlVm *vm, char *writeMode)
{
    int fam = ficlStackPopInteger(vm->dataStack);
    int length = ficlStackPopInteger(vm->dataStack);
    void *address = (void *)ficlStackPopPointer(vm->dataStack);
    char mode[4];
    FILE *f;
    char *filename = (char *)malloc(length + 1);
    memcpy(filename, address, length);
    filename[length] = 0;

    *mode = 0;

    switch (FICL_FAM_OPEN_MODE(fam)) {
    case 0:
        ficlStackPushPointer(vm->dataStack, NULL);
        ficlStackPushInteger(vm->dataStack, EINVAL);
    goto EXIT;
    case FICL_FAM_READ:
        strcat(mode, "r");
    break;
    case FICL_FAM_WRITE:
        strcat(mode, writeMode);
    break;
    case FICL_FAM_READ | FICL_FAM_WRITE:
        strcat(mode, writeMode);
        strcat(mode, "+");
    break;
    }

    strcat(mode, (fam & FICL_FAM_BINARY) ? "b" : "t");

    f = fopen(filename, mode);
    if (f == NULL)
        ficlStackPushPointer(vm->dataStack, NULL);
    else {
        ficlFile *ff = (ficlFile *)malloc(sizeof (ficlFile));
        strcpy(ff->filename, filename);
        ff->f = f;
        ficlStackPushPointer(vm->dataStack, ff);

        fseek(f, 0, SEEK_SET);
    }
    pushIor(vm, f != NULL);

EXIT:
    free(filename);
}

/* ( c-addr u fam -- fileid ior ) */
static void
ficlPrimitiveOpenFile(ficlVm *vm)
{
    ficlFileOpen(vm, "a");
}

/* ( c-addr u fam -- fileid ior ) */
static void
ficlPrimitiveCreateFile(ficlVm *vm)
{
    ficlFileOpen(vm, "w");
}

/* ( fileid -- ior ) */
static int
ficlFileClose(ficlFile *ff)
{
    FILE *f = ff->f;
    free(ff);
    return (!fclose(f));
}

/* ( fileid -- ior ) */
static void
ficlPrimitiveCloseFile(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    pushIor(vm, ficlFileClose(ff));
}

/* ( c-addr u -- ior ) */
static void
ficlPrimitiveDeleteFile(ficlVm *vm)
{
    int length = ficlStackPopInteger(vm->dataStack);
    void *address = (void *)ficlStackPopPointer(vm->dataStack);

    char *filename = (char *)malloc(length + 1);
    memcpy(filename, address, length);
    filename[length] = 0;

    pushIor(vm, !unlink(filename));
    free(filename);
}

/* ( c-addr1 u1 c-addr2 u2 -- ior ) */
static void
ficlPrimitiveRenameFile(ficlVm *vm)
{
    int length;
    void *address;
    char *from;
    char *to;

    length = ficlStackPopInteger(vm->dataStack);
    address = (void *)ficlStackPopPointer(vm->dataStack);
    to = (char *)malloc(length + 1);
    memcpy(to, address, length);
    to[length] = 0;

    length = ficlStackPopInteger(vm->dataStack);
    address = (void *)ficlStackPopPointer(vm->dataStack);

    from = (char *)malloc(length + 1);
    memcpy(from, address, length);
    from[length] = 0;

    pushIor(vm, !rename(from, to));

    free(from);
    free(to);
}

/* ( c-addr u -- x ior ) */
static void
ficlPrimitiveFileStatus(ficlVm *vm)
{
    int status;
    int ior;

    int length = ficlStackPopInteger(vm->dataStack);
    void *address = (void *)ficlStackPopPointer(vm->dataStack);

    char *filename = (char *)malloc(length + 1);
    memcpy(filename, address, length);
    filename[length] = 0;

    ior = ficlFileStatus(filename, &status);
    free(filename);

    ficlStackPushInteger(vm->dataStack, status);
    ficlStackPushInteger(vm->dataStack, ior);
}

/* ( fileid -- ud ior ) */
static void
ficlPrimitiveFilePosition(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    long ud = ftell(ff->f);
    ficlStackPushInteger(vm->dataStack, ud);
    pushIor(vm, ud != -1);
}

/* ( fileid -- ud ior ) */
static void
ficlPrimitiveFileSize(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    long ud = ficlFileSize(ff);
    ficlStackPushInteger(vm->dataStack, ud);
    pushIor(vm, ud != -1);
}

/* ( i*x fileid -- j*x ) */
#define nLINEBUF    256
static void
ficlPrimitiveIncludeFile(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    ficlCell id = vm->sourceId;
    int  except = FICL_VM_STATUS_OUT_OF_TEXT;
    long currentPosition, totalSize;
    long size;
    ficlString s;
    vm->sourceId.p = (void *)ff;

    currentPosition = ftell(ff->f);
    totalSize = ficlFileSize(ff);
    size = totalSize - currentPosition;

    if ((totalSize != -1) && (currentPosition != -1) && (size > 0)) {
        char *buffer = (char *)malloc(size);
        long got = fread(buffer, 1, size, ff->f);
        if (got == size) {
            FICL_STRING_SET_POINTER(s, buffer);
            FICL_STRING_SET_LENGTH(s, size);
            except = ficlVmExecuteString(vm, s);
        }
    }

    if ((except < 0) && (except != FICL_VM_STATUS_OUT_OF_TEXT))
        ficlVmThrow(vm, except);

    /*
     * Pass an empty line with SOURCE-ID == -1 to flush
     * any pending REFILLs (as required by FILE wordset)
     */
    vm->sourceId.i = -1;
    FICL_STRING_SET_FROM_CSTRING(s, "");
    ficlVmExecuteString(vm, s);

    vm->sourceId = id;
    ficlFileClose(ff);
}

/* ( c-addr u1 fileid -- u2 ior ) */
static void
ficlPrimitiveReadFile(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    int length = ficlStackPopInteger(vm->dataStack);
    void *address = (void *)ficlStackPopPointer(vm->dataStack);
    int result;

    clearerr(ff->f);
    result = fread(address, 1, length, ff->f);

    ficlStackPushInteger(vm->dataStack, result);
    pushIor(vm, ferror(ff->f) == 0);
}

/* ( c-addr u1 fileid -- u2 flag ior ) */
static void
ficlPrimitiveReadLine(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    int length = ficlStackPopInteger(vm->dataStack);
    char *address = (char *)ficlStackPopPointer(vm->dataStack);
    int error;
    int flag;

    if (feof(ff->f)) {
        ficlStackPushInteger(vm->dataStack, -1);
        ficlStackPushInteger(vm->dataStack, 0);
        ficlStackPushInteger(vm->dataStack, 0);
        return;
    }

    clearerr(ff->f);
    *address = 0;
    fgets(address, length, ff->f);

    error = ferror(ff->f);
    if (error != 0) {
        ficlStackPushInteger(vm->dataStack, -1);
        ficlStackPushInteger(vm->dataStack, 0);
        ficlStackPushInteger(vm->dataStack, error);
        return;
    }

    length = strlen(address);
    flag = (length > 0);
    if (length && ((address[length - 1] == '\r') ||
        (address[length - 1] == '\n')))
        length--;

    ficlStackPushInteger(vm->dataStack, length);
    ficlStackPushInteger(vm->dataStack, flag);
    ficlStackPushInteger(vm->dataStack, 0); /* ior */
}

/* ( c-addr u1 fileid -- ior ) */
static void
ficlPrimitiveWriteFile(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    int length = ficlStackPopInteger(vm->dataStack);
    void *address = (void *)ficlStackPopPointer(vm->dataStack);

    clearerr(ff->f);
    fwrite(address, 1, length, ff->f);
    pushIor(vm, ferror(ff->f) == 0);
}

/* ( c-addr u1 fileid -- ior ) */
static void
ficlPrimitiveWriteLine(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    size_t length = (size_t)ficlStackPopInteger(vm->dataStack);
    void *address = (void *)ficlStackPopPointer(vm->dataStack);

    clearerr(ff->f);
    if (fwrite(address, 1, length, ff->f) == length)
        fwrite("\n", 1, 1, ff->f);
    pushIor(vm, ferror(ff->f) == 0);
}

/* ( ud fileid -- ior ) */
static void
ficlPrimitiveRepositionFile(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    size_t ud = (size_t)ficlStackPopInteger(vm->dataStack);

    pushIor(vm, fseek(ff->f, ud, SEEK_SET) == 0);
}

/* ( fileid -- ior ) */
static void
ficlPrimitiveFlushFile(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    pushIor(vm, fflush(ff->f) == 0);
}

#if FICL_PLATFORM_HAS_FTRUNCATE
/* ( ud fileid -- ior ) */
static void
ficlPrimitiveResizeFile(ficlVm *vm)
{
    ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
    size_t ud = (size_t)ficlStackPopInteger(vm->dataStack);

    pushIor(vm, ficlFileTruncate(ff, ud) == 0);
}
#endif /* FICL_PLATFORM_HAS_FTRUNCATE */
#endif /* FICL_WANT_FILE */

void
ficlSystemCompileFile(ficlSystem *system)
{
#if !FICL_WANT_FILE
    FICL_IGNORE(system);
#else
    ficlDictionary *dictionary = ficlSystemGetDictionary(system);
    ficlDictionary *environment = ficlSystemGetEnvironment(system);

    FICL_SYSTEM_ASSERT(system, dictionary);
    FICL_SYSTEM_ASSERT(system, environment);

    ficlDictionarySetPrimitive(dictionary, "create-file",
        ficlPrimitiveCreateFile,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "open-file",
        ficlPrimitiveOpenFile,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "close-file",
        ficlPrimitiveCloseFile,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "include-file",
        ficlPrimitiveIncludeFile,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "read-file",
        ficlPrimitiveReadFile,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "read-line",
        ficlPrimitiveReadLine,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "write-file",
        ficlPrimitiveWriteFile,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "write-line",
        ficlPrimitiveWriteLine,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "file-position",
        ficlPrimitiveFilePosition,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "file-size",
        ficlPrimitiveFileSize,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "reposition-file",
        ficlPrimitiveRepositionFile,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "file-status",
        ficlPrimitiveFileStatus,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "flush-file",
        ficlPrimitiveFlushFile,  FICL_WORD_DEFAULT);

    ficlDictionarySetPrimitive(dictionary, "delete-file",
        ficlPrimitiveDeleteFile,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "rename-file",
        ficlPrimitiveRenameFile,  FICL_WORD_DEFAULT);

#if FICL_PLATFORM_HAS_FTRUNCATE
    ficlDictionarySetPrimitive(dictionary, "resize-file",
        ficlPrimitiveResizeFile,  FICL_WORD_DEFAULT);

    ficlDictionarySetConstant(environment, "file", FICL_TRUE);
    ficlDictionarySetConstant(environment, "file-ext", FICL_TRUE);
#else /*  FICL_PLATFORM_HAS_FTRUNCATE */
    ficlDictionarySetConstant(environment, "file", FICL_FALSE);
    ficlDictionarySetConstant(environment, "file-ext", FICL_FALSE);
#endif /* FICL_PLATFORM_HAS_FTRUNCATE */

#endif /* !FICL_WANT_FILE */
}