/** 
   FILE ---  Optional File-Access Word Set
  
    Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
  
    @see     GNU LGPL
    @author  Tektronix CTE              @(#) %derived_by: guidod %
    @version %version: bln_mpt1!5.8 %
      (%date_modified: Tue Sep 10 13:28:57 2002 %)
  
    @description
         The Optional File-Access Word Set and
         File-Access Extension Words.
         These words imply some kind of file-system unlike
         the BLOCK wordset.
  
 */
/*@{*/
#if defined(__version_control__) && defined(__GNUC__)
static char* id __attribute__((unused)) = 
"@(#) $Id: %full_filespec: file-ext.c~bln_mpt1!5.8:csrc:bln_12xx!1 % $";
#endif

#define _P4_SOURCE 1

#include <pfe/pfe-base.h>
#include <pfe/def-xtra.h>

#include <stdio.h>
#include <errno.h>

#include <pfe/file-sub.h>
#include <pfe/logging.h>
#include <pfe/_missing.h>

/* long <-> p4dcell conversion macros, won't work on 16 bit machines */
#define UL2UDC(UL, UDC)	((UDC).hi = 0, (UDC).lo = (p4ucell)(UL))
#define UDC2UL(HI, LO)	(LO)

#ifndef _NULLFILE_ROBUST   /* USER-CONFIG */
#ifdef  PFE_HAVE_WINBASE_H /* read/write check for NULL-file w/in pfe itself */
#define _NULLFILE_ROBUST 1 /* win32 API will SIGBUS on NULL-file read/write */
#else
#define _NULLFILE_ROBUST 0
#endif
#endif

#if _NULLFILE_ROBUST+0
#define _is_nullfile(X) !(X)
#else
#define _is_nullfile(X) 0
#endif

#ifdef PFE_WITH_FIG
#define CHECKFILE " - did an earlier FILE-OPEN fail?" \
                  " - often it is file permissions" \
                  " - file or directory read-only?"
#else
#define CHECKFILE " (did some FILE-OPEN fail?)"
#endif

/* ================================================================= */

/** BIN ( access-mode -- access-mode' )
   modify the give file access-mode to be a binary-mode
 */
FCode (p4_bin)
{
    *SP += FMODE_BIN;
}


/** CLOSE-FILE ( file -- code )
   close the file and return the status-code
 */
FCode (p4_close_file)
{
    File *fid = (File *) SP[0];

    if (_is_nullfile(fid)) goto nullfile;
    SP[0] = p4_close_file (fid) ? errno : 0;
    return;
 nullfile:
    SP[0] = EINVAL;
    P4_warn ("close on NULL file");
}


/** CREATE-FILE ( str-adr str-len mode -- file code )
   create the file with the given name and open
   it - returns the file id and a status code.
   A code of zero means success. An existing file
   of the same name is truncated upon open.
 */
FCode (p4_create_file)
{
    char *fn = (char *) SP[2];	/* c-addr, name */
    p4ucell u = SP[1];		/* length of name */
    p4cell fam = SP[0];		/* file access mode */
    File *fid = p4_create_file (fn, u, fam);
    
    SP += 1;
    SP[1] = (p4cell) fid;
    SP[0] = fid ? 0 : errno;
}


/** DELETE-FILE ( str-adr str-len -- code )
   delete the named file and return a status code
 */
FCode (p4_delete_file)
{
    char* fnz = p4_pocket_filename ((char*)SP[1], SP[0]) ; /* as asciiz */
    SP += 1;
    SP[0] = _pfe_remove (fnz) ? errno : 0;
}


/** FILE-POSITION ( file -- p.pos code )
   return the current position in the file and
   return a status code. A code of zero means success.
 */
FCode (p4_file_position)
{
    File *fid = (File *) SP[0];	/* file-id */
    long pos;
    p4udcell ud;

    if (_is_nullfile(fid)) goto nullfile;
    pos = ftell (fid->f);
    SP -= 2;
    if (pos != -1)
    
{
        UL2UDC (pos, ud);
        SP[0] = 0;		/* ior */
    }
else
{
        ud.lo = ud.hi = UCELL_MAX;
        SP[0] = errno;		/* ior */
    }

    *(p4udcell *) &SP[1] = ud;	/* ud */
    return;
 nullfile:
    ud.lo = ud.hi = 0;
    *(p4udcell *) &SP[1] = ud;
    SP[0] = EINVAL;
    P4_warn ("trying seek on NULL file");
}


/** FILE-SIZE ( file -- s.size code )
   return the current size of the file and
   return a status code. A code of zero means success.
 */
FCode (p4_file_size)
{
    File *fid = (File *) SP[0];	/* fileid */
    long size;
    p4udcell ud;

    if (_is_nullfile(fid)) goto nullfile;
    size = fsize (fid->f);
    SP -= 2;
    if (size != -1)
    
{
        UL2UDC (size, ud);
        SP[0] = 0;		/* ior */
    }
else
{
        ud.lo = ud.hi = UCELL_MAX;
        SP[0] = errno;		/* ior */
    }

    *(p4udcell *) &SP[1] = ud;	/* ud */
    return;
 nullfile:
    ud.lo = ud.hi = 0;
    *(p4udcell *) &SP[1] = ud;
    SP[0] = EINVAL;
    P4_warn ("trying seek on NULL file");
}


/** INCLUDE-FILE ( file -- )
   => INTERPRET the given file
 */
FCode (p4_include_file)
{
    p4_include_file ((File *) *SP++);
}


/** INCLUDED ( str-adr str-len -- )
   open the named file and then => INCLUDE-FILE
   see also the interactive => INCLUDE
 */
FCode (p4_included)
{
    char *fn = (char *) SP[1];	/* c-addr, name */
    p4ucell u = SP[0];		/* length of name */

    SP += 2;
    p4_included (fn, u);
}


/** OPEN-FILE ( str-adr str-len mode -- file code )
   open the named file with mode. returns the
   file id and a status code. A code of zero
   means success.
 */
FCode (p4_open_file)
{
    char *fn = (char *) SP[2];	/* c-addr, name */
    p4ucell u = SP[1];		/* length of name */
    p4cell fam = SP[0];		/* file access mode */
    File *fid = p4_open_file (fn, u, fam);

    SP += 1;
    SP[1] = (p4cell) fid;
    SP[0] = fid ? 0 : errno;
}


/** READ-FILE ( str-adr str-len file -- count code )
   fill the given string buffer with characters
   from the buffer. A status code of zero means
   success and the returned count gives the
   number of bytes actually read. If an error
   occurs the number of already transferred bytes 
   is returned.
 */
FCode (p4_read_file)
{
    char *c_addr = (char *) SP[2];
    p4ucell u = SP[1];
    File *fid = (File *) SP[0];
    SP += 1;
    if (_is_nullfile(fid)) goto nullfile;
    SP[0] = p4_read_file (c_addr, &u, fid);
    SP[1] = u;
    return;
 nullfile:
    SP[0] = EINVAL;
    SP[1] = 0;
    P4_fail ("trying read from NULL file" CHECKFILE);
}


/** READ-LINE ( str-adr str-len file -- count flag code )
   fill the given string buffer with one line
   from the file. A line termination character
   (or character sequence under WIN/DOS) may
   also be placed in the buffer but is not
   included in the final count. In other respects
   this function performs a => READ-FILE
 */
FCode (p4_read_line)
{
    char *c_addr = (char *) SP[2];
    p4ucell u = SP[1];
    File *fid = (File *) SP[0];
    p4cell ior;
    if (_is_nullfile(fid)) goto nullfile;
    SP[1] = p4_read_line (c_addr, &u, fid, &ior);
    SP[2] = u;
    SP[0] = ior;
    return;
 nullfile:
    SP[0] = EINVAL;
    SP[1] = EINVAL;
    SP[2] = 0;
    P4_fail ("trying read from NULL file" CHECKFILE);
}


/** REPOSITION-FILE ( o.offset file -- code )
   reposition the file offset - the next => FILE-POSITION
   would return o.offset then. returns a status code.
 */
FCode (p4_reposition_file)
{
    File *fid = (File *) SP[0];
    long pos = UDC2UL (SP[1], SP[2]);

    if (_is_nullfile(fid)) goto nullfile;
    SP += 2;
    SP[0] = p4_reposition_file (fid, pos);
    return;
 nullfile:
    SP[0] = EINVAL;
    P4_warn ("trying seek on NULL file");
}


/** RESIZE-FILE ( s.size file -- code )
   resize the give file, returns a status code.
 */
FCode (p4_resize_file)
{
    File *fid = (File *) SP[0];
    long size = UDC2UL (SP[1], SP[2]);

    if (_is_nullfile(fid)) goto nullfile;
    SP += 2;
    if (p4_resize_file (fid, size) != 0)
        *SP = errno;
    else
        *SP = 0, fid->size = (p4ucell) (size / BPBUF);
    return;
 nullfile:
    SP[0] = EINVAL;
    P4_fail ("trying seek on NULL file" CHECKFILE);
}


/** WRITE-FILE ( str-adr str-len file -- code )
   write characters from the string buffer to a file,
   returns a status code.
 */ 
FCode (p4_write_file)
{
    char *c_addr = (char *) SP[2];
    p4ucell u = SP[1];
    File *fid = (File *) SP[0];

    SP += 2;
    if (_is_nullfile(fid)) goto nullfile;
    SP[0] = p4_write_file (c_addr, u, fid);
    return;
 nullfile:
    SP[0] = EINVAL;
    P4_fail ("trying write to NULL file" CHECKFILE);
}


/** WRITE-LINE ( str-adr str-len file -- code )
   write characters from the string buffer to a file,
   and add the line-terminator to the end of it.
   returns a status code.
 */
FCode (p4_write_line)
{
    char *c_addr = (char *) SP[2];
    p4ucell u = SP[1];
    File *fid = (File *) SP[0];

    SP += 2;
    if (_is_nullfile(fid)) goto nullfile;
    if ((SP[0] = p4_write_file (c_addr, u, fid)) == 0)
        putc ('\n', fid->f);
    return;
 nullfile:
    SP[0] = EINVAL;
    P4_fail ("trying write to NULL file" CHECKFILE);
}


/** FILE-STATUS ( str-adr str-len -- sub-code code )
   check the named file - if it exists
   the status code is zero. The sub-code
   is implementation-specific.
 */
FCode (p4_file_status)
{
    int mode = p4_file_access ((char *) SP[1], SP[0]);

    if (mode == -1)
    
{
        SP[1] = 0;
        SP[0] = errno;
    }
else
{
        SP[1] = mode;
        SP[0] = 0;
    }

}


/** FLUSH-FILE ( file -- code )
   flush all unsaved buffers of the file to disk.
   A status code of zero means success.
 */
FCode (p4_flush_file)
{
    File *fid = (File *) SP[0];

    if (_is_nullfile(fid)) goto nullfile;
    if (BLOCK_FILE == fid)
    
{
        FX (p4_save_buffers);
        SP[0] = 0;
    }
else
{
        if (fflush (fid->f))
            SP[0] = errno;
        else
            SP[0] = 0;
    }

    return;
 nullfile:
    SP[0] = EINVAL;
    P4_warn ("trying flush on NULL file");
}


/** RENAME-FILE ( str-adr1 str-len1 str-adr2 str-len2 -- code )
   rename the file named by string1 to the name of string2.
   returns a status-code
 */
FCode (p4_rename_file)
{
    char* oldnm;
    char* newnm;

    oldnm = p4_pocket_filename ((char *) SP[3], SP[2]);
    newnm = p4_pocket_filename ((char *) SP[1], SP[0]);
    SP += 3;
    *SP = _P4_rename (oldnm, newnm) ? errno : 0;
}


static FCode (p__max_files)
{
    FX_PUSH (PFE_set.max_files);
}



/** R/O ( -- bitmask )
   a bitmask for => OPEN-FILE ( => R/O => R/W => W/O => BIN )
 */

/** W/O ( -- bitmask )
   a bitmask for => OPEN-FILE or => CREATE-FILE ( => R/O => R/W => W/O => BIN )
 */

/** R/W ( -- bitmask )
   a bitmask for => OPEN-FILE or => CREATE-FILE ( => R/O => R/W => W/O => BIN )
 */

/** "ENVIRONMENT MAX-FILES" ( -- number )
   the number of opened file-ids allowed during compilation.
   portable programs can check this with => ENVIRONMENT?
 */

P4_LISTWORDS (file) =
{
    P4_INTO ("[ANS]", 0),
    P4_FXco ("BIN",		 p4_bin),
    P4_FXco ("CLOSE-FILE",	 p4_close_file),
    P4_FXco ("CREATE-FILE",	 p4_create_file),
    P4_FXco ("DELETE-FILE",	 p4_delete_file),
    P4_FXco ("FILE-POSITION",	 p4_file_position),
    P4_FXco ("FILE-SIZE",	 p4_file_size),
    P4_FXco ("INCLUDE-FILE",	 p4_include_file),
    P4_FXco ("INCLUDED",	 p4_included),
    P4_FXco ("OPEN-FILE",	 p4_open_file),
    P4_OCoN ("R/O",		 FMODE_RO),
    P4_OCoN ("R/W",		 FMODE_RW),
    P4_FXco ("READ-FILE",	 p4_read_file),
    P4_FXco ("READ-LINE",	 p4_read_line),
    P4_FXco ("REPOSITION-FILE",	 p4_reposition_file),
    P4_FXco ("RESIZE-FILE",	 p4_resize_file),
    P4_OCoN ("W/O",		 FMODE_WO),
    P4_FXco ("WRITE-FILE",	 p4_write_file),
    P4_FXco ("WRITE-LINE",	 p4_write_line),
    P4_FXco ("FILE-STATUS",	 p4_file_status),
    P4_FXco ("FLUSH-FILE",	 p4_flush_file),
    P4_FXco ("RENAME-FILE",	 p4_rename_file),

    P4_INTO ("ENVIRONMENT", 0 ),
    P4_OCON ("FILE-EXT",	 1994 ),
    P4_FXCO ("MAX-FILES",	 p__max_files),
    
}
;
P4_COUNTWORDS (file, "File-access + extensions");

/*@}*/