-- Copyright 1993-1998, by the Cecil Project
-- Department of Computer Science and Engineering, University of Washington
-- See the LICENSE file for license information.

-- unix_files are actually predefined, so insert standard lie here...
(--DOC
  A `unix_file' object acts like a mutable, extensible, positionable
  stream of characters, as well as supporting lots of standard file
  I/O operations.
  <EXAMPLE>
    template object unix_file
		isa m_positionable_stream[char], extensible_stream[char];
  <ENDEXAMPLE>
--)

-- I split these into 2 DOC comments as a hack.  Maybe the right thing
-- to do is to include the first DOC explicitly in the manual?
(--DOC
  Unix files can be opened, given the name of the file and an open
  mode, using `open_file'. The optional `if_error' closure taken by
  `open_file' and many other file operations is invoked if there was a
  standard Unix error during the operation, passing the Unix `errno'
  value as the integer argument to the closure. The `error_string'
  function converts `errno' to an error message, using the Unix
  `sys_errlist'. The `unix_error' function invokes error with an
  appropriate error message derived from a user-supplied message and
  the `errno' code. The `nonfatal_unix_error' also prints the error
  message, but then successfully returns to the caller.

  The three standard files can be returned by the `stdin', `stdout', and
  `stderr' functions. Six functions are available to query properties of
  the file: whether or not the file is readable and/or writable and
  whether or not writes always append. The `read' functions read up to
  `size' characters into a buffer; they return how many characters
  actually were read. The `read_line' functions work like `read', except
  that they stop reading after they've seen (and copied to the buffer)
  a newline character. The `write' functions write their argument
  character buffer (optionally copying only `size' characters) to the
  file. Collectors can be written to a file directly, more efficiently
  than first flattening the collector into a string. Individual
  characters can also be written to a file.

  The `mod_time' operations return the modification timestamp of the file;
  `get_mod_time' is a convenience in case the file hasn't been opened
  yet. (The `time' data structure supports parsing the timestamp integer.)

  In addition to the other stream-style operations, `unix_file's support
  testing whether they have detected the end of the file (subtly different
  than actually being at the end of the file) and performing `lseek'-style
  repositioning relative either to the start of the file, the current
  position, or the end of the file.
--)


prim c_++ {

#ifdef INDEXED_FIELDS

#include <fcntl.h>
#include <pwd.h>
#include <errno.h>

// include files to get at definition of fstat
#ifdef VORTEX_SOLARIS
#include <sys/types.h>
#include <sys/stat.h>
#elif VORTEX_POWERPC
#include <sys/stat.h>
#elif VORTEX_ALPHA
#include <sys/types.h>
#include <sys/stat.h>
#elif VORTEX_LINUX
#include <sys/stat.h>
#include <unistd.h>
#elif VORTEX_HPUX
#include <sys/stat.h>
#endif

static int file_FILE_field_offset = -1;
static void lookup_file_FILE_field_offset(OOP p) {
    FieldEntry* e = p->map()->findField("file@anon:unix_file:");
    if (e == NULL) {
      fatal("expected to find a 'file' field in unix__file_obj");
    }
    file_FILE_field_offset = e->offset;
}
static int file_name_field_offset = -1;
static void lookup_file_name_field_offset(OOP p) {
    FieldEntry* e = p->map()->findField("name@anon:unix_file:");
    if (e == NULL) {
      fatal("expected to find a 'name' field in unix__file_obj");
    }
    file_name_field_offset = e->offset;
}
extern "C" OOP create_initialized_unix__file_obj();
inline OOP newFileObject(FILE* f, char* n) {
  OOP res = create_initialized_unix__file_obj();
  if (file_FILE_field_offset == -1) lookup_file_FILE_field_offset(res);
  SF_OOP(res, file_FILE_field_offset, FILE*, f);
  if (file_name_field_offset == -1) lookup_file_name_field_offset(res);
  SF_OOP(res, file_name_field_offset, char*, n);
  return res;
}
inline FILE* getFileFILE(OOP f) {
  if (file_FILE_field_offset == -1) lookup_file_FILE_field_offset(f);
  return GF_OOP(f, file_FILE_field_offset, FILE*);
}
inline char* getFileName(OOP f) {
  if (file_name_field_offset == -1) lookup_file_name_field_offset(f);
  return GF_OOP(f, file_name_field_offset, char*);
}

#else

extern "C++" {
#include "file.h"
}
#include <errno.h>

inline OOP newFileObject(FILE* f, char* n) {
    return asTaggedPointer(new CecilFileObject(f, n));
}
inline FILE* getFileFILE(OOP f) {
    return f->asFile()->file;
}
inline char* getFileName(OOP f) {
    return f->asFile()->name;
}

#endif

#ifdef ACCURATE_GC_LIB
#include "gc-stuff.h"
#endif

};


method stdin():unix_file (** return_type(unix_file), sends() **) {
    prim c_++ {
#ifdef INDEXED_FIELDS
	static OOP file_stdin = NULL;
	if (file_stdin == NULL) {
	    file_stdin = newFileObject(stdin, "<stdin>");
#ifdef ACCURATE_GC_LIB
  	    register_global_oop(file_stdin);
#endif	
	}
#ifdef DISPATCHERS
        RETURN(file_stdin);
#else
        BP(file_stdin);
#endif
#else
#ifdef DISPATCHERS
        RETURN(BASE(file_stdin));
#else
        BP(BASE(file_stdin));
#endif
#endif
    }
}

method stdout():unix_file (** return_type(unix_file), sends() **) {
    prim c_++ {
#ifdef INDEXED_FIELDS
	static OOP file_stdout = NULL;
	if (file_stdout == NULL) {
	    file_stdout = newFileObject(stdout, "<stdout>");
#ifdef ACCURATE_GC_LIB
  	    register_global_oop(file_stdout);
#endif	
	}
#ifdef DISPATCHERS
        RETURN(file_stdout);
#else
        BP(file_stdout);
#endif
#else
#ifdef DISPATCHERS
        RETURN(BASE(file_stdout));
#else
        BP(BASE(file_stdout));
#endif
#endif
    }
}

method stderr():unix_file (** return_type(unix_file), sends() **) {
    prim c_++ {
#ifdef INDEXED_FIELDS
	static OOP file_stderr = NULL;
	if (file_stderr == NULL) {
	    file_stderr = newFileObject(stderr, "<stderr>");
#ifdef ACCURATE_GC_LIB
  	    register_global_oop(file_stderr);
#endif	
	}
#ifdef DISPATCHERS
        RETURN(file_stderr);
#else
        BP(file_stderr);
#endif
#else
#ifdef DISPATCHERS
        RETURN(BASE(file_stderr));
#else
        BP(BASE(file_stderr));
#endif
#endif
    }
}

abstract object open_mode;
private field unix_string(@:open_mode):i_string;
concrete representation open_for_reading isa open_mode { unix_string := "r" };
concrete representation create_for_writing isa open_mode { unix_string := "w" };
concrete representation open_for_append isa open_mode { unix_string := "a" };
concrete representation open_for_update isa open_mode { unix_string := "r+" };
concrete representation create_for_update isa open_mode { unix_string := "w+" };
concrete representation open_for_appending_update isa open_mode { unix_string := "a+" };

method open_file(n@:string, m@:open_mode):unix_file {
    open_file(n, m, &(i:int){ unix_error(i, "opening file") }) }
method open_file(n@:string, m@:open_mode, if_error:&(int):unix_file):unix_file{
    open_file_internal(n.expand_filename.as_vstring, m.unix_string.as_vstring,
		       if_error) }
private method open_file_internal(n@:vstring, m@:vstring,
			  if_error:&(int):unix_file):unix_file
                    (** sends(r1 = eval([if_error],[int])),
		        return_type(r1,unix_file),
		        does_io, formals_escape(f,f,f) **) {
  prim c_++ {
    char* ns = AS_C_STRING(n);
    char* ms = AS_C_STRING(m);
    FILE* file = fopen(ns, ms);
    if (file == NULL) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  "1#open_file_internal(@vstring,@vstring,c)");
    } else {
#ifdef DISPATCHERS
	RETURN(newFileObject(file, ns));
#else
	BP(newFileObject(file, ns));
#endif
    }
  }
}

method name(f@:unix_file):string (** return_type(i_vstring),
				     sends(), formals_escape(f) **) {
    prim c_++ {
#ifdef DISPATCHERS
	RETURN(NEW_STRING(getFileName(f)));
#else
	BP(NEW_STRING(getFileName(f)));
#endif
    }
}

prim c_++ {
inline static int flags(FILE* file) { 
    return fcntl(fileno(file), F_GETFL, 0); }
inline static bool is_readable(FILE* file) { 
    int fl = (flags(file) & O_ACCMODE);
    return (fl == O_RDONLY) || (fl == O_RDWR); }
inline static bool is_writable(FILE* file) { 
    int fl = (flags(file) & O_ACCMODE);
    return (fl == O_WRONLY) || (fl == O_RDWR); }
inline static bool is_read_write(FILE* file) { 
    return flags(file) & O_RDWR; }
inline static bool is_append(FILE* file) { 
    return flags(file) & O_APPEND; }
inline static bool is_non_blocking(FILE* file) { 
    return flags(file) & O_NDELAY; }
};

method is_readable(f@:unix_file):bool (** return_type(true, false),
				          sends(), formals_escape(f) **) {
    prim c_++: "
#ifdef DISPATCHERS
      RETURN(is_readable(getFileFILE(f)) ? BASE(true) : BASE(false));
#else
      BP(is_readable(getFileFILE(f)) ? BASE(true) : BASE(false));
#endif
    "
}
method is_unreadable(f@:unix_file):bool { f.is_readable.not }

method is_writable(f@:unix_file):bool (** return_type(true, false),
				          sends(), formals_escape(f) **) {
    prim c_++: "
#ifdef DISPATCHERS
      RETURN(is_writable(getFileFILE(f)) ? BASE(true) : BASE(false));
#else
      BP(is_writable(getFileFILE(f)) ? BASE(true) : BASE(false));
#endif
    "
}
method is_unwritable(f@:unix_file):bool { f.is_writable.not }

method is_read_write(f@:unix_file):bool (** return_type(true, false),
					    sends(), formals_escape(f) **) {
    prim c_++: "
#ifdef DISPATCHERS
      RETURN(is_read_write(getFileFILE(f)) ? BASE(true) : BASE(false));
#else
      BP(is_read_write(getFileFILE(f)) ? BASE(true) : BASE(false));
#endif
    "
}

method is_append(f@:unix_file):bool (** return_type(true, false),
					    sends(), formals_escape(f) **) {
    prim c_++: "
#ifdef DISPATCHERS
      RETURN(is_append(getFileFILE(f)) ? BASE(true) : BASE(false));
#else
      BP(is_append(getFileFILE(f)) ? BASE(true) : BASE(false));
#endif
    "
}

method read(f@:unix_file, buffer@:m_indexed[char], size:int):int {
    read(f, buffer, size, &(i:int){ unix_error(i, "reading file") }) }
method read(f@:unix_file, buffer@:m_indexed[char], size:int,
	    if_error:&(int):int):int {
    let s:m_vstring := buffer.as_m_vstring;
    let nread:int := read(f, s, size, &(code:int){ ^ eval(if_error, code) });
    do(nread, &(i:int){ buffer!i := s!i; });
    nread }
method read(f@:unix_file, buffer@:m_vstring, size@:int,
	    if_error:&(int):int):int (** return_type(r1,int),
				         sends(r1 = eval([if_error],[int])),
				         does_io, formals_escape(f,f,f,f) **) {
  prim c_++: "
    int s = size->asInt();
    if (s > NUM_ELEMS(buffer)) {
	fatalEnv(currentEnv, \"reading more than the buffer can hold\");
    }
    if (s < 0) {
	fatalEnv(currentEnv, \"reading a negative amount\");
    }
    FILE* fl = getFileFILE(f);
    clearerr(fl);
    int res = fread(VEC_ELEMS(buffer, char), 1, s, fl);
    if (ferror(fl)) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  \"1#read(@unix_file,@m_vstring,@int,d)\");
    } else {
#ifdef DISPATCHERS
	RETURN(asTaggedInt(res));
#else
	BP(asTaggedInt(res));
#endif
    }"
}


-- this is the only useful read_line(), and should perhaps be written in C
-- returns the line's contents with no trailing \n; "" if the line is empty
--
method read_line(f@:unix_file, if_eof@closure:&():string):string {
    read_line(f, if_eof, &(i:int){ unix_error(i, "reading file") }) }
method read_line(f@:unix_file, if_eof@closure:&():string,
			       if_error@closure:&(i:int):string):string {
    let buffer_len := 1023;
    let buf:m_vstring := new_m_vstring_no_init(buffer_len);
    let err_cl := &(i:int){ ^eval(if_error, i) };

    let var nread:int := read_line(f, buf, buffer_len, err_cl);
    if(nread <= 0, { ^eval(if_eof) });

    let var nl_pos:int := find_index(buf, '\n', { -1 });
    if(nl_pos >= 0, {
	^copy_from(buf, 0, nl_pos);
    });

    -- now infrequent case
    let res:extensible_sequence[string] := new_m_list[string]();
    loop_exit(&(exit:&():none){
	res.add_last(copy_from(buf, 0, nread));

	nread := read_line(f, buf, buffer_len, err_cl);
	if(nread <= 0, exit);

	nl_pos := find_index(buf, '\n', { -1 });
	if(nl_pos >= 0, {
	    res.add_last(copy_from(buf, 0, nl_pos));
	    eval(exit);
	});
    });

    res.flatten }

method read_line(f@:unix_file, buffer@:m_indexed[char], size:int):int {
    read_line(f, buffer, size, &(i:int){ unix_error(i, "reading file") }) }
method read_line(f@:unix_file, buffer@:m_indexed[char], size:int,
		 if_error:&(int):int):int {
    let s:m_vstring := buffer.as_m_vstring;
    let nread:int := read_line(f, s, size,
			       &(code:int){ ^ eval(if_error, code) });
    do(nread, &(i:int){ buffer!i := s!i; });
    nread }
method read_line(f@:unix_file, buffer@:m_vstring, size:int,
		 if_error:&(int):int):int {
    read_line_internal(f, buffer, size, &(code:int){ ^ eval(if_error, code) });
    find_index(buffer, '\0') }
private method read_line_internal(f@:unix_file, buffer@:m_vstring, size@:int,
				  if_error:&(int):void):void
                          (** sends(r1 = eval([if_error],[int])),
			      return_type(r1,void),
			      does_io, formals_escape(f,f,f,f) **) {
  prim c_++: "
    int s = size->asInt();
    if (s > NUM_ELEMS(buffer)) {
	fatalEnv(currentEnv, \"reading more than the buffer can hold\");
    }
    if (s < 0) {
	fatalEnv(currentEnv, \"reading a negative amount\");
    }
    FILE* fl = getFileFILE(f);
    clearerr(fl);
    char* res = fgets(VEC_ELEMS(buffer,char), s, fl);
    if (ferror(fl)) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  \"1#read_line_internal(@unix_file,@m_vstring,@int,d)\");
    } else {
	if (res == NULL && s > 0) {
	    // copy over a NULL char to beginning of buffer
	    VEC_ELEM(buffer,0,char) = '\\0';
	}
#ifdef DISPATCHERS
	RETURN(BASE(void));
#else
	BP(BASE(void));
#endif
    }"
}

method write_char(f@:unix_file, x:char):void {
    write(f, x.as_string);
}

method write(f@:unix_file, buffer@:indexed[char]):void {
    write(f, buffer, buffer.length);
}
method write(f@:unix_file, buffer@:indexed[char], size:int):void {
    write(f, buffer, size, &(i:int){ unix_error(i, "writing file") });
}
method write(f@:unix_file, buffer@:indexed[char], size:int,
		  if_error:&(int):void):void {
    write(f, buffer.as_vstring, size, if_error);
}
method write(f@:unix_file, buffer@:vstring, size@:int,
		  if_error:&(int):void):void {
    let written:int :=
      write_internal(f, buffer, size, &(i:int){ eval(if_error, i); ^ });
    if_false(written = size, { eval(if_error, -1); });
}
private method write_internal(f@:unix_file, buffer@:vstring, size@:int,
			      if_error:&(int):int):int
                        (** sends(r1 = eval([if_error],[int])),
			    return_type(r1,int),
			    does_io, formals_escape(f,f,f,f) **) {
  prim c_++: "
    int s = size->asInt();
    if (s > NUM_ELEMS(buffer)) {
	fatalEnv(currentEnv, \"writing more than the buffer holds\");
    }
    if (s < 0) {
	fatalEnv(currentEnv, \"writing a negative amount\");
    }
    FILE* fl = getFileFILE(f);
    clearerr(fl);
    int res = fwrite(VEC_ELEMS(buffer,char), 1, s, fl);
    if (ferror(fl)) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  \"1#write_internal(@unix_file,@vstring,@int,d)\");
    } else {
#ifdef DISPATCHERS
	RETURN(asTaggedInt(res));
#else
	BP(asTaggedInt(res));
#endif
    }"
}

method print(s@:string, f:unix_file):void {
    write(f, s);
    flush(f);	-- always do this?
}
method write_to_file(o:any, fname:string):void {
    write_to_file(o, fname, &(err:int){
	unix_error(err, "writing object to file " || fname) });
}
method write_to_file(o:any, fname:string, if_error:&(int):none):void {
    let f:unix_file := open_file(fname, create_for_writing, if_error);
    let s:string := o.print_string;
    write(f, s, s.length, if_error);
    close(f, if_error);
}

method position(f@:unix_file):int {
    position(f, &(i:int){ unix_error(i, "retrieving current position") }) }
method position(f@:unix_file, if_error:&(int):int):int
                         (** sends(r1 = eval([if_error],[int])),
			     return_type(r1,int),
			     formals_escape(f,f) **) {
  prim c_++: "
    FILE* fl = getFileFILE(f);
    clearerr(fl);
    int res = ftell(fl);
    if (ferror(fl)) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  \"1#position(@unix_file,b)\");
    } else {
#ifdef DISPATCHERS
	RETURN(asTaggedInt(res));
#else
	BP(asTaggedInt(res));
#endif
    }"
}

abstract object position_mode;
  private field unix_int(@:position_mode):int;
concrete representation from_start isa position_mode { unix_int := 0 };
concrete representation from_current_position isa position_mode { unix_int := 1 };
concrete representation from_end isa position_mode { unix_int := 2 };

method set_position(f@:unix_file, offset:int, if_error:&(int):void):void {
    set_position_relative(f, offset, from_start, if_error);
}
method set_position_relative(f@:unix_file, offset:int,
                             from@:position_mode):void {
    set_position_relative(f, offset, from, &(i:int){
	unix_error(i, "setting current position") });
}
method set_position_relative(f@:unix_file, offset:int, from@:position_mode,
			     if_error:&(int):void):void {
    set_position_internal(f, offset, from.unix_int, if_error);
}
private method set_position_internal(f@:unix_file, myoffset@:int, from@:int,
			     if_error:&(int):void):void
                                 (** sends(r1 = eval([if_error],[int])),
				     return_type(r1, void),
				     does_io, formals_escape(f,f,f,f) **) {
  prim c_++: "
    FILE* fl = getFileFILE(f);
    clearerr(fl);
    int res = fseek(fl, myoffset->asInt(), from->asInt());
    if (ferror(fl)) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  \"1#set_position_internal(@unix_file,@int,@int,d)\");
    } else {
#ifdef DISPATCHERS
	RETURN(BASE(void));
#else
	BP(BASE(void));
#endif
    }"
}

method detected_eof(f@:unix_file):bool (** return_type(true, false),
					   sends(), formals_escape(f)  **) {
  prim c_++: "
    FILE* fl = getFileFILE(f);
#ifdef DISPATCHERS
    RETURN(feof(fl) ? BASE(true) : BASE(false));
#else
    BP(feof(fl) ? BASE(true) : BASE(false));
#endif
  "
}

method length(f@:unix_file):int {
    -- isn't there a better way??
    let pos:int := f.position;
    set_position_relative(f, 0, from_end);
    let len:int := f.position;
    f.position := pos;
    len }

method flush(f@:unix_file):void {
    flush(f, &(i:int){ unix_error(i, "flushing file") }) }
method flush(f@:unix_file, if_error:&(int):void):void
                         (** sends(r1 = eval([if_error],[int])),
                             return_type(r1, void),
			     does_io, formals_escape(f,f) **) {
  prim c_++: "
    FILE* fl = getFileFILE(f);
    clearerr(fl);
    int res = fflush(fl);
    if (ferror(fl)) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  \"1#flush(@unix_file,b)\");
    } else {
#ifdef DISPATCHERS
	RETURN(BASE(void));
#else
	BP(BASE(void));
#endif
    }"
}

method close(f@:unix_file):void {
    close(f, &(i:int){ nonfatal_unix_error(i, "closing file") }) }
method close(f@:unix_file, if_error:&(int):void):void
           (** sends(r1 = eval([if_error],[int])), return_type(r1,void),
	       doess_io, formals_escape(f,f) **) {
  prim c_++: "
    FILE* fl = getFileFILE(f);
    int res = fclose(fl);
    // ferror() won't work on linux after file is closed, so just check res
    if (res) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  \"1#close(@unix_file,b)\");
    } else {
#ifdef DISPATCHERS
	RETURN(BASE(void));
#else
	BP(BASE(void));
#endif
    }"
}

method get_mod_time(f_name@:string, if_error:&(int):int):int {
    get_mod_time_internal(f_name.expand_filename, if_error) }

method get_mod_time_internal(f_name@:string, if_error:&(int):int):int
                     (** sends(r1 = eval([if_error],[int])),
                         return_type(r1,int),
		         formals_escape(f,f) **) {
  prim c_++: "
    char* c = AS_C_STRING(f_name);
    struct stat buf;
    int res = stat(c, &buf);
    if (res) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  \"1#get_mod_time_internal(@string,b)\");
    } else {
        assert(asTaggedInt(buf.st_mtime)->asInt() == buf.st_mtime,
               \"st_mtime value too large for tagged integer\");
#ifdef DISPATCHERS
        RETURN(asTaggedInt(buf.st_mtime));
#else
        BP(asTaggedInt(buf.st_mtime));
#endif
    }"
}

method mod_time(f@:unix_file):int {
  mod_time(f, &(code:int){ unix_error(code, "getting mod_time") }) }
method mod_time(f@:unix_file, if_error:&(int):int):int
                (** sends(r1 = eval([if_error],[int])),
		    return_type(r1,int),
		    formals_escape(f,f) **) {
  prim c_++: "
    FILE* fl = getFileFILE(f);
    struct stat buf;
    clearerr(fl);
    int res = fstat(fileno(fl), &buf);
    if (ferror(fl)) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  \"1#mod_time(@unix_file,b)\");
    } else {
        assert(asTaggedInt(buf.st_mtime)->asInt() == buf.st_mtime,
               \"st_mtime value too large for tagged integer\");
#ifdef DISPATCHERS
        RETURN(asTaggedInt(buf.st_mtime));
#else
        BP(asTaggedInt(buf.st_mtime));
#endif
    }"
}

-- These should be in <errno.h>, why aren't they?
prim c_++ {
  extern int sys_nerr;
  extern char* sys_errlist[];
};

method error_string(i:int):string (** return_type(i_vstring), sends(),
				      formals_escape(f) **) {
  prim c_++: "
    OOP str = NEW_STRING(i->asInt() < 0 || i->asInt() >= sys_nerr ? 
		  \"unknown error code\" : sys_errlist[i->asInt()]);
#ifdef DISPATCHERS
    RETURN(str);
#else
    BP(str);
#endif
"
}

method unix_error(i:int, s:string):none {
    error(["error when ", s, ": ", error_string(i)]) }

method nonfatal_unix_error(i:int, s:string):void {
    print_line(["error when ", s, ": ", error_string(i)].flatten);
}


-- File stream operations: file = stream[char]

-- for now, consider all streams writable, etc. in the type signature,
-- and check at run-time whether operations are legal;
-- would like a hierarchy of read_file, write_file, read_write_file,
-- append_file, etc., so operations can be type-checked.

extend unix_file isa m_positionable_stream[char], extensible_stream[char];

--DOCSKIP
predicate readable_unix_file isa unix_file when unix_file.is_readable;
predicate unreadable_unix_file isa unix_file when unix_file.is_unreadable;
predicate writable_unix_file isa unix_file when unix_file.is_writable;
predicate unwritable_unix_file isa unix_file when unix_file.is_unwritable;
predicate read_only_unix_file isa readable_unix_file, unwritable_unix_file;
predicate write_only_unix_file isa writable_unix_file, unreadable_unix_file;
predicate read_write_unix_file isa readable_unix_file, writable_unix_file;
divide unix_file into readable_unix_file, unreadable_unix_file;
divide unix_file into writable_unix_file, unwritable_unix_file;
--DOCENDSKIP

-- implementations of stream operations

-- these routines are affected by unix file's advancing the file position
-- automatically if a character is read from the file.  extra f.backward
-- calls are placed where necessary to move the position backwards.

method next(f@:unreadable_unix_file, at_end:&():char):char {
    error("file is not readable") }
method next(f@:readable_unix_file, at_end:&():char):char {
    let buf:m_vstring := new_m_vstring_no_init(1);
    let cnt:int := read(f, buf, 1);
    if (cnt = 0, at_end, { buf!0 }) }

method peek_next(f@:unix_file, at_end:&():char):char {
    let c:char := next(f, { ^ eval(at_end) });
    f.backward;
    c }

method peek_prev(f@:unix_file, at_start:&():char):char {
    backward(f, { ^ eval(at_start) });
    f.next }

method prev(f@:unix_file, at_start:&():char):char {
    let c:char := peek_prev(f, { ^ eval(at_start) });
    f.backward;
    c }

method set_next(f@:unwritable_unix_file, x:char):void {
    error("file is not writable");
}
method set_next(f@:writable_unix_file, x:char):void {
    if(f.is_append & { f.before_end }, {
	error("file can't be written in the middle") });
    f.write_char(x);
}

method set_peek_next(f@:unix_file, x:char):void {
    f.next := x;
    f.backward;
}

method set_peek_prev(f@:unix_file, x:char):void {
    f.backward;
    f.next := x;
}

method set_prev(f@:unix_file, x:char):void {
    f.peek_prev := x;
    f.backward;
}

method add_last(f@:unwritable_unix_file, x:char):void {
    error("file is not writable");
}
method add_last(f@:writable_unix_file, x:char):void {
    if_false(f.is_append, {
	-- advance to end, if not an append-only file
	f.to_end;
    });
    f.write_char(x);
}

----------
-- Some common file system operations
----------

(--DOC
  A number of file-related operations have been defined. The `find_file'
  operation takes a file name and a directory search path and returns
  an absolute path name for the first file that matches the name in
  the search path. To do this work `find_file' invokes `file_exists' to
  test whether a given file name is defined and expand to expand away
  ~user file-name prefixes. The `parse_path' helper function converts a
  Unix search path string (directory names separated by colons) into a
  sequence of directory names.
--)

method file_exists(s:string):bool {
  let f:unix_file := open_file(s, open_for_reading, &(i:int){ ^ false });
  close(f);
  true }

-- A version that lets the user specify the separator.  This means it can
-- be used to either split a single file path into its individual dirs, or
-- to split a path string into its component directories.
method parse_path(path_string@:string, path_separator:char):extensible_sequence[string] {
  let dirs:extensible_sequence[string] := new_m_list[string]();
  let var pos:int := 0;
  path_string.do_associations(&(i:int,c:char){
    if(c = path_separator, {
      dirs.add_last(path_string.copy_from(pos, i));
      pos := i.succ;
    });
  });
  if(pos < path_string.length, {
    dirs.add_last(path_string.copy_from(pos, path_string.length));
  });
  dirs }
method parse_path(path_string@:string):extensible_sequence[string] {
    path_string.parse_path(':') }

method path_name(t@:string):string {
    let var end:int := 0;
    t.do_associations(&(i:int, c:char){ if(c = '/', { end := i }) });
    t.copy_from(0, end) }
method strip_leading_path(t@:string):string {
    t.remove_prefix(t.path_name).remove_prefix("/") }

-- more conventional names for same methods
method dirname(t@:string):string {
    let pname:string := t.path_name;
    if(pname.non_empty, { pname }, { "." }) }
method basename(t@:string):string { t.strip_leading_path }


method expand_filename(s@:string):string {
  expand_filename(s, &(i:int){
      unix_error(i, "expanding filename \"" || s || "\"") }) }

prim c_++ {
#ifdef INDEXED_FIELDS
    static char* expand_dir(const char* in, char* out) {
	static char err[BUFSIZ + 50];
	if (*in != '~') {
	    if (strlen(in) >= BUFSIZ) {
		sprintf(err, "'%s' exceeds %d chars in length", in, BUFSIZ);
		return err;
	    }
	    strcpy(out, in);
	    return NULL;
	}

	const char* slash = in;
	for (; !((*slash == '/') || (*slash == '\0'));  slash++);

	char* dirName = "";

	if (in + 1  ==  slash) {
	    char* p = getenv("HOME");
	    if (p) dirName = p;

	} else {
	    char user[BUFSIZ];
	    if (slash  -  (in + 1)  >= sizeof(user)) {
		sprintf(err, "'%*s' exceeds %d in length",
			slash - (in + 1),  in + 1,  sizeof(user) - 1);
		return err;
	    }
	    strncpy(user, in + 1,  slash - (in + 1));
	    user[slash - (in + 1)] = '\0';
	    struct passwd* p = getpwnam(user);
	    if (p) {
		dirName = p->pw_dir;
	    } else {
		sprintf(err, "unable to find a home directory for user: %s\n", 
			user);
		return err;
	    }
	}

	if (strlen(dirName) + strlen(slash)  >=  BUFSIZ) {
	    sprintf(err, "'%s%s' exceeds %d characters in length",
		    dirName, slash, BUFSIZ);
	    return err;
	}
	sprintf(out, "%s%s", dirName, slash);
	return NULL;
    }
#else
    extern "C" char* expand_dir(const char* in, char* out);
#endif
};

method expand_filename(s@:string, if_error:&(int):string):string
              (** sends(r1 = eval([if_error],[int])),
	          return_type(r1,i_vstring),
	          formals_escape(f,f) **) {
  prim c_++: "
    char out_buf[BUFSIZ];
    char* dir_buf = AS_C_STRING(s);
    if (expand_dir(dir_buf, out_buf) != NULL) {
	// it would be nice to be able to use the returned error message
        // somehow....
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(EACCES)),
                  \"1#expand_filename(@string,b)\");
    } else {
#ifdef DISPATCHERS
        RETURN(NEW_STRING(out_buf));
#else
        BP(NEW_STRING(out_buf));
#endif
    }"
}

method shrink_filename(s@:string):string {
    let home:string := env!"HOME";
    if(home.is_empty | { not(s.has_prefix(home)) }, { ^s });

    let res:string := s.remove_prefix(home);
    if(res.non_empty &{ res.first != '/' }, { ^s });
    "~" || res }

method is_abs_filename(s@:string):bool {
    if(s.is_empty, { ^false });
    let first_char:char := s.first;
    first_char = '/' |{ first_char = '~' } }

-- In dirs, "" means the current directory like ".";
-- any double '/'s result in ignoring the part of the string
-- from the beginning through the first '/'
--
method find_file(base_name@:string, dirs@:ordered_collection[string],
                 if_fail:&(string):string):string {
  if(base_name.is_empty, {^ eval(if_fail,"cannot look for empty file name") });

  if(base_name.is_abs_filename, {
    -- handle absolute filenames specially
    if(file_exists(base_name), { ^ base_name.shrink_filename });
  }, {
    dirs.do(&(dir:string){
      let dir_separator :=
	if(dir.is_empty | { dir.last = '/' }, { "" }, { "/" });
      let name:string := dir || dir_separator || base_name;
      if(file_exists(name), { ^ name.shrink_filename });
    });
  });
  eval(if_fail, "file " || base_name || " not found in path [" ||
                dirs.elems_print_string || "]") }

method find_file(base_name@:string, dirs@:sequence[string]):string {
  find_file(base_name, dirs, &(error_msg:string){ error(error_msg) }) }


(-- objectIO prims --)

prim c_++ {
#ifdef INDEXED_FIELDS
#include "objectIO.h"
#else
extern "C++" {
#include "objectIO.h"
}
#endif
};

method write_object_to_file_name(obj:any, f_name:string):void {
    write_object_to_file_name(obj, f_name, &(:int){
	error("Error writing object to " || f_name);
    });
}
method write_object_to_file_name(obj:any, f_name:string,
				 if_error:&(int):void):void {
    let f:unix_file :=
      open_file(f_name, create_for_writing, &(e:int){ eval(if_error, e); ^ });
    write_object_to_file(obj, f, if_error);
    close(f);
}

method write_object_to_file(x:any, f@:unix_file, use_bs@:bool):void {
    write_object_to_file(x, f, use_bs, &(:int){
	error("Error writing object to file");
    });
}

method write_object_to_file(x:any, f@:unix_file,
			    if_error@closure:&(int):void):void {
    -- default to using backspaces to erase characters
    write_object_to_file(x, f, true, if_error)
}

method write_object_to_file(x:any, f@:unix_file, use_bs@:bool,
			    if_error:&(int):void):void {
    write_object_to_file(x, f, use_bs.as_integer, if_error);
}

private method write_object_to_file(x:any, f@:unix_file, use_bs@:int,
				    if_error:&(int):void):void
		(** sends(eval([if_error],[int])), return_type(void), does_io,
		    formals_escape(f,f,f,f) **) {
  prim c_++ {
    FILE* fl = getFileFILE(f);
    clearerr(fl);
    writeObjectToFile(fl, x, use_bs->asInt());
    if (ferror(fl)) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  "1#write_object_to_file(a,@unix_file,@int,d)");
    } else {
#ifdef DISPATCHERS
	RETURN(BASE(void));
#else
	BP(BASE(void));
#endif
    }
  }
}

method read_object_from_file_name(f_name@:string):dynamic {
    read_object_from_file_name(f_name, true) }

method read_object_from_file_name(f_name@:string, use_bs:bool):dynamic {
    read_object_from_file_name(f_name, use_bs, &(:int){
	error("Error reading object from " || f_name)
    }) }

method read_object_from_file_name(f_name@:string, use_bs:bool,
				  if_error:&(int):dynamic):dynamic {
    let error := &(e:int){ ^ eval(if_error, e) };
    let f:unix_file := open_file(f_name, open_for_reading, error);
    let result:dynamic := read_object_from_file(f, use_bs, error);
    close(f);
    result }

method read_object_from_file(f@:unix_file, use_bs@:bool):dynamic {
    read_object_from_file(f, use_bs, &(:int){
	error("Error reading object from file")
    }) }

method read_object_from_file(f@:unix_file,
			     if_error@closure:&(int):dynamic):dynamic {
    -- default to using backspaces to erase characters
    read_object_from_file(f, true, if_error) }

method read_object_from_file(f@:unix_file, use_bs:bool,
			     if_error:&(int):dynamic):dynamic {
    read_object_from_file(f, use_bs.as_integer, if_error) }

private method read_object_from_file(f@:unix_file, use_bs@:int,
				     if_error:&(int):dynamic):dynamic
	(** sends(r1 = eval([if_error],[int])), return_type(r1, unknown), 
	    does_io, formals_escape(f,f,f) **) {
  prim c_++ {
    FILE* fl = getFileFILE(f);
    clearerr(fl);
    OOP objRead = readObjectFromFile(fl, use_bs->asInt());
    if (ferror(fl)) {
        TAIL_SEND(eval, 0, 2, (if_error, asTaggedInt(errno)),
                  "1#read_object_from_file(@unix_file,@int,c)");
    } else {
#ifdef DISPATCHERS
	RETURN(objRead);
#else
	BP(objRead);
#endif
    }
  }
}