(* FileSys -- 1995-06-16, 1998-05-07 *)

local 

    (* The type of directory structures, as handled by the OS: *)
    prim_type dirstruct_; 

    (* Primitives from runtime/sys.c -- raise Io on error *)
    prim_val chdir_  : string -> unit            = 1 "sys_chdir";
    prim_val remove_ : string -> unit            = 1 "sys_remove";
    prim_val rename_ : string -> string -> unit  = 2 "sys_rename";

    (* Primitives from runtime/mosml.c -- raise Fail on error *)
    prim_val access_    : string -> int -> bool  = 2 "sml_access";
    prim_val getdir_    : unit -> string         = 1 "sml_getdir"; 
    prim_val isdir_     : string -> bool         = 1 "sml_isdir";
    prim_val mkdir_     : string -> unit         = 1 "sml_mkdir";
    prim_val tmpnam_    : unit -> string         = 1 "sml_tmpnam";
    prim_val modtime_   : string -> real         = 1 "sml_modtime";
    prim_val rmdir_     : string -> unit         = 1 "sml_rmdir";
    prim_val settime_   : string -> real -> unit = 2 "sml_settime";
    prim_val filesize_  : string -> int          = 1 "sml_filesize";

    prim_val opendir_   : string -> dirstruct_   = 1 "sml_opendir";
    prim_val readdir_   : dirstruct_ -> string   = 1 "sml_readdir";
    prim_val rewinddir_ : dirstruct_ -> unit     = 1 "sml_rewinddir";
    prim_val closedir_  : dirstruct_ -> unit     = 1 "sml_closedir";

    fun formatErr mlOp (SOME operand) reason =
	mlOp ^ " failed on `" ^ operand ^ "': " ^ reason
      | formatErr mlOp NONE reason =
	mlOp ^ " failed: " ^ reason

    (* Raise SysErr from ML function *)
    fun raiseSysML mlOp operand reason =
	raise SysErr (formatErr mlOp operand reason, NONE)

    (* Raise SysErr with OS specific explanation if errno <> 0 *)
    fun raiseSys mlOp operand reason =
	let prim_val errno_    : unit -> int        = 1 "sml_errno";
	    prim_val errormsg_ : int -> string      = 1 "sml_errormsg"; 
	    prim_val mkerrno_  : int -> syserror    = 1 "identity";
            val errno = errno_ ()
	in
	    if errno = 0 then raiseSysML mlOp operand reason
	    else raise SysErr 
		(formatErr mlOp operand (errormsg_ errno), 
		 SOME (mkerrno_ errno))
	end
in

    type dirstream  = dirstruct_ option ref;
    datatype access = A_READ | A_WRITE | A_EXEC;

    fun access (path, perm) =
	let fun mem p = if List.exists (fn q => p=q) perm then 1 else 0
	    val permcode = mem A_READ + 2 * mem A_WRITE + 4 * mem A_EXEC
	in 
	    (access_ path permcode) 
	    handle Fail s => raiseSys "access" (SOME path) s
	end;

    fun getDir () =
	(getdir_ ()) 
	handle Fail s => raiseSys "getDir" NONE s;

    fun isDir p = 
	(isdir_ p) handle Fail s => raiseSys "isDir" (SOME p) s;

    fun mkDir p = 
	(mkdir_ p) handle Fail s => raiseSys "mkDir" (SOME p) s;

#ifdef unix
    fun chDir p =
	(chdir_ p)
	handle SysErr _ => raiseSys "chDir" (SOME p) "chdir";

    fun mosmlFullPath p = 
	let prim_val islink_   : string -> bool   = 1 "sml_islink"
	    prim_val readlink_ : string -> string = 1 "sml_readlink"
            val links = ref 0
	    fun incrlink () = 
		if !links < 30 then links := !links + 1
		else raise Fail "Too many symbolic links encountered"
	    open Path
	    fun expand p = 
		let val {vol, arcs, isAbs} = Path.fromString p
		    val root = if isAbs then vol ^ "/" else vol
		in mkCanonical (List.foldl followlink root arcs) end
	    and followlink (a, p) = 
		let val file = concat(p, a)
		in
		    if islink_ file then 
			(incrlink(); 
			 expand(mkAbsolute(readlink_ file, p)))
		    else
			file
		end
	in 
	    (expand(mkAbsolute(p, getDir())))
	    handle Fail s => raiseSys "fullPath" (SOME p) s
	end;

    fun fullPath p =
	let prim_val realpath_ : string -> string = 1 "sml_realpath"
	in 
	    (realpath_ p) 
	    handle Fail "realpath not supported" => mosmlFullPath p
		 | Fail s => raiseSys "fullPath" (SOME p) s 
	end;
	
    fun isLink p =
	let prim_val islink_ : string -> bool = 1 "sml_islink"
        in (islink_ p) handle Fail s => raiseSys "isLink" (SOME p) s end;

    fun readLink p =
	let prim_val readlink_ : string -> string = 1 "sml_readlink"
	in (readlink_ p) handle Fail s => raiseSys "readLink" (SOME p) s end;

    type file_id = real;  (* Namely, 2^17 * device id  + inode number *)

    fun fileId p : file_id =
	let prim_val devinode_ : string -> real = 1 "sml_devinode"
	in (devinode_ p) handle Fail s => raiseSys "fileId" (SOME p) s end;

    fun hash (fid : file_id) = 
	let prim_val hash_param : int -> int -> 'a -> word
						= 3 "hash_univ_param";
	in hash_param 50 500 fid end;

    fun compare (fid1 : file_id, fid2) =
	if fid1 < fid2 then LESS
	else if fid1 > fid2 then GREATER
	else EQUAL    
#endif
#if defined(msdos) || defined(win32)
    fun chDir p =
	let prim_val setdisk_ : int -> unit = 1 "sml_setdisk"
	    fun failvol () = raiseSys "chDir" (SOME p) "Illegal volume name"
	    fun volno c =		(* A = 0, B = 1, ... *)
		if Char.isAlpha c then (Char.ord c - 65) mod 32
		else failvol ()
	    val vol = Path.getVolume p
	in 
	    if vol = "" then ()
	    else (setdisk_ (volno (String.sub(vol, 0))))
		 handle Fail s => failvol ();
	    (chdir_ p) handle SysErr _ => raiseSys "chDir" (SOME p) "chdir"
	end;

    fun fullPath p =
	let open Path 
	    val realp = mkCanonical(mkAbsolute(p, getDir()))
	in 
	    if access (realp, []) then realp 
	    else raise raiseSys "fullPath" (SOME realp) 
		                "No such file or directory"
	end

    fun isLink p =
	if access_ p 0 then false 
	else raiseSys "isLink" (SOME p) "No such file";

    fun readLink p =
	raiseSys "readLink" (SOME p) "No symlinks";

    type file_id = string * word; (* The full path and the hash value *)

    fun fileId p : file_id =
	let prim_val hash_param : int -> int -> 'a -> word
						= 3 "hash_univ_param"
            fun stringToLower s = CharVector.tabulate(size s, 
			          fn i => Char.toLower(CharVector.sub(s, i)));
            val p' = stringToLower (fullPath p) 
		     handle SysErr(s, _) => raiseSys "fileId" (SOME p) s 
	in (p', hash_param 50 500 p') end

    fun hash ((_, hashval) : file_id) = hashval

    fun compare ((p1, h1) : file_id, (p2, h2)) =
	if h1 = h2 then String.compare(p1, p2)
	else if h1 < h2 then LESS
	else GREATER
#endif
#ifdef macintosh
    fun chDir p =
	(chdir_ p)
	handle SysErr _ => raiseSys "chDir" (SOME p) "chdir";

    fun fullPath p =
	let prim_val realpath_ : string -> string = 1 "sml_realpath"
	in 
	    (realpath_ p) 
	    handle Fail s => raiseSys "fullPath" (SOME p) s 
	end;

    fun isLink p =
	let prim_val islink_ : string -> bool = 1 "sml_islink"
        in (islink_ p) handle Fail s => raiseSys "isLink" (SOME p) s end;

    fun readLink p =
	let prim_val readlink_ : string -> string = 1 "sml_readlink"
	in (readlink_ p) handle Fail s => raiseSys "readLink" (SOME p) s end;

    type file_id = real;  (* Namely, 2^17 * device id  + inode number *)

    fun fileId p : file_id =
	let prim_val devinode_ : string -> real = 1 "sml_devinode"
	in (devinode_ p) handle Fail s => raiseSys "fileId" (SOME p) s end;

    fun hash (fid : file_id) = 
	let prim_val hash_param : int -> int -> 'a -> word
						= 3 "hash_univ_param";
	in hash_param 50 500 fid end;

    fun compare (fid1 : file_id, fid2) =
	if fid1 < fid2 then LESS
	else if fid1 > fid2 then GREATER
	else EQUAL    
#endif

    fun realPath p =
	if Path.isAbsolute p then fullPath p
	else Path.mkRelative(fullPath p, getDir());

    fun rmDir p = 
	(rmdir_ p) handle Fail s => raiseSys "rmDir" (SOME p) s;

    fun tmpName () =
	(tmpnam_ ())
	handle Fail s => raiseSys "tmpName" NONE s

    fun modTime p = 
	(Time.fromReal (modtime_ p))
	handle Fail s => raiseSys "modTime" (SOME p) s;

    fun fileSize p =
	(filesize_ p) 
	handle Fail s => raiseSys "fileSize" (SOME p) s;

    fun remove p = 
	(remove_ p)
	handle SysErr _ => raiseSys "remove" (SOME p) "unlink";

    fun rename {old, new} = 
	(rename_ old new) 
	handle SysErr _ => raiseSys "rename" (SOME old) "rename";

    fun setTime (path, time) =
	let val tsec = 
	    Time.toReal (case time of NONE => Time.now() | SOME t => t)
	in
	    (settime_ path tsec) 
	    handle Fail s => raiseSys "setTime" (SOME path) s
	end;

    fun openDir path = 
	(ref (SOME (opendir_ path)))
	handle Fail s => raiseSys "openDir" (SOME path) s;

    fun mkOpt "" = NONE
      | mkOpt s  = SOME s

    fun readDir (ref NONE) = 
	raiseSysML "readDir" NONE "Directory stream is closed"
#ifdef macintosh
      | readDir (ref (SOME dstr)) = mkOpt (readdir_ dstr);
#else
      | readDir (arg as ref (SOME dstr)) =
        let val entry = readdir_ dstr
        in
            if entry <> Path.parentArc andalso entry <> Path.currentArc then
                mkOpt entry
            else
                readDir arg
        end
#endif
 
    fun rewindDir (ref NONE) =
	raiseSysML "rewindDir" NONE "Directory stream is closed"
      | rewindDir (ref (SOME dstr)) = rewinddir_ dstr;

    fun closeDir (ref NONE) = ()
      | closeDir (r as ref (SOME dstr)) = 
	(r := NONE; closedir_ dstr);
end;