Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/PervEnv/UnixNoPosix/os-filesys.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/PervEnv/UnixNoPosix/os-filesys.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/PervEnv/UnixNoPosix/os-filesys.sml

1 : monnier 16 (* os-filesys.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * The implementation of the generic file system interface (OS.FileSys).
6 :     * The OS dependencies are mostly hidden in the run-time system support,
7 :     * but the implementation of fullPath and realPath are UNIX specific.
8 :     *
9 :     *)
10 :    
11 :     structure OS_FileSys : OS_FILE_SYS =
12 :     struct
13 :    
14 :     type c_dirstream = Core.Assembly.object (* the underlying C DIRSTREAM *)
15 :    
16 :     datatype dirstream = DS of {
17 :     dirStrm : c_dirstream,
18 :     isOpen : bool ref
19 :     }
20 :    
21 :     fun osFunc x = CInterface.c_function "SMLNJ-OS" x
22 :    
23 :     local
24 :     val openDir' : string -> c_dirstream = osFunc "openDir"
25 :     val readDir' : c_dirstream -> string = osFunc "readDir"
26 :     val rewindDir' : c_dirstream -> unit = osFunc "rewindDir"
27 :     val closeDir' : c_dirstream -> unit = osFunc "closeDir"
28 :     in
29 :     fun openDir path = DS{
30 :     dirStrm = openDir' path,
31 :     isOpen = ref true
32 :     }
33 :     fun readDir (DS{dirStrm, isOpen = ref false}) =
34 :     PreBasis.error "readDir on closed directory stream"
35 :     | readDir (DS{dirStrm, ...}) = readDir' dirStrm
36 :     fun rewindDir (DS{dirStrm, isOpen = ref false}) =
37 :     PreBasis.error "rewindDir on closed directory stream"
38 :     | rewindDir (DS{dirStrm, ...}) = rewindDir' dirStrm
39 :     fun closeDir (DS{dirStrm, isOpen = ref false}) = ()
40 :     | closeDir (DS{dirStrm, isOpen}) = (
41 :     isOpen := false;
42 :     closeDir' dirStrm)
43 :     end (* local *)
44 :    
45 :     val chDir : string -> unit = osFunc "chDir"
46 :     val getDir : unit -> string = osFunc "getDir"
47 :     val mkDir : string -> unit = osFunc "mkDir"
48 :     val rmDir : string -> unit = osFunc "removeDir"
49 :     val isDir : string -> bool = osFunc "isDir"
50 :    
51 :     val isLink : string -> bool = osFunc "isLink"
52 :     val readLink : string -> string = osFunc "readLink"
53 :    
54 :     (* the maximum number of links allowed *)
55 :     val maxLinks = 64
56 :    
57 :     structure P = OS_Path;
58 :    
59 :     (* A UNIX specific implementation of fullPath *)
60 :     fun fullPath p = let
61 :     val oldCWD = getDir()
62 :     fun mkPath pathFromRoot =
63 :     P.toString{isAbs=true, vol="", arcs=List.rev pathFromRoot}
64 :     fun walkPath (0, _, _) = raise PreBasis.SysErr("too many links", NONE)
65 :     | walkPath (n, pathFromRoot, []) =
66 :     mkPath pathFromRoot
67 :     | walkPath (n, pathFromRoot, ""::al) =
68 :     walkPath (n, pathFromRoot, al)
69 :     | walkPath (n, pathFromRoot, "."::al) =
70 :     walkPath (n, pathFromRoot, al)
71 :     | walkPath (n, [], ".."::al) =
72 :     walkPath (n, [], al)
73 :     | walkPath (n, _::r, ".."::al) = (
74 :     chDir ".."; walkPath (n, r, al))
75 :     | walkPath (n, pathFromRoot, [arc]) =
76 :     if (isLink arc)
77 :     then expandLink (n, pathFromRoot, arc, [])
78 :     else mkPath (arc::pathFromRoot)
79 :     | walkPath (n, pathFromRoot, arc::al) =
80 :     if (isLink arc)
81 :     then expandLink (n, pathFromRoot, arc, al)
82 :     else (chDir arc; walkPath (n, arc::pathFromRoot, al))
83 :     and expandLink (n, pathFromRoot, link, rest) = (
84 :     case (P.fromString(readLink link))
85 :     of {isAbs=false, arcs, ...} =>
86 :     walkPath (n-1, pathFromRoot, List.@(arcs, rest))
87 :     | {isAbs=true, arcs, ...} =>
88 :     gotoRoot (n-1, List.@(arcs, rest))
89 :     (* end case *))
90 :     and gotoRoot (n, arcs) = (
91 :     chDir "/";
92 :     walkPath (n, [], arcs))
93 :     fun computeFullPath arcs =
94 :     (gotoRoot(maxLinks, arcs) before chDir oldCWD)
95 :     handle ex => (chDir oldCWD; raise ex)
96 :     in
97 :     case (P.fromString p)
98 :     of {isAbs=false, arcs, ...} => let
99 :     val {arcs=arcs', ...} = P.fromString(oldCWD)
100 :     in
101 :     computeFullPath (List.@(arcs', arcs))
102 :     end
103 :     | {isAbs=true, arcs, ...} => computeFullPath arcs
104 :     (* end case *)
105 :     end
106 :    
107 :     fun realPath p = if (P.isAbsolute p)
108 :     then fullPath p
109 :     else P.mkRelative (fullPath p, fullPath(getDir()))
110 :    
111 :     local
112 :     val modTime' : string -> int = osFunc "modTime"
113 :     val setTime' : (string * int option) -> unit = osFunc "setTime"
114 :     val rename' : (string * string) -> unit = osFunc "rename"
115 :     in
116 :     fun modTime path = let val s = modTime' path
117 :     in
118 :     PreBasis.TIME{sec=s, usec=0}
119 :     end
120 :     fun setTime (path, SOME(PreBasis.TIME{sec, usec})) = setTime' (path, SOME sec)
121 :     | setTime (path, NONE) = setTime' (path, NONE)
122 :     val remove : string -> unit = osFunc "remove"
123 :     fun rename {old, new} = rename'(old, new)
124 :     end (* local *)
125 :    
126 :     datatype access = A_READ | A_WRITE | A_EXEC
127 :    
128 :     local
129 :     val access' : (string * int list) -> bool = osFunc "access"
130 :     val map_mode = List.map (fn A_READ => 0 | A_WRITE => 1 | A_EXEC => 2)
131 :     in
132 :     fun access (path, alist) = access' (path, map_mode alist)
133 :     end (* local *)
134 :    
135 :     fun tmpName {dir : string option, prefix : string option} =
136 :     raise Fail "OS.FileSys.tmpName unimplemented"
137 :    
138 :     end; (* FILE_SYS *)
139 :    
140 :    
141 :     (*
142 :     * $Log: os-filesys.sml,v $
143 :     * Revision 1.1.1.1 1997/01/14 01:38:26 george
144 :     * Version 109.24
145 :     *
146 :     *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0