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/cm/paths/abspath.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/paths/abspath.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 286 - (view) (download)

1 : blume 265 (*
2 : blume 267 * Operations over abstract path names.
3 : blume 265 *
4 : blume 267 * Copyright (c) 1999 by Lucent Technologies, Bell Laboratories
5 : blume 265 *
6 : blume 267 * Author: Matthias Blume (blume@cs.princeton.edu)
7 : blume 265 *)
8 :     signature ABSPATH = sig
9 :    
10 : blume 270 type context
11 : blume 265 type t
12 :    
13 :     val revalidateCwd : unit -> unit
14 : blume 277 val newEra : unit -> unit
15 : blume 265
16 : blume 270 val cwdContext: unit -> context
17 :     val configContext: (unit -> string) -> context
18 :     val relativeContext: t -> context
19 :    
20 : blume 265 val name : t -> string
21 :     val compare : t * t -> order
22 : blume 272 val context : t -> context
23 :     val spec : t -> string
24 :     val contextName : context -> string
25 : blume 265
26 : blume 270 val native : { context: context, spec: string } -> t
27 :     val standard : { context: context, spec: string } -> t
28 : blume 268
29 :     val joinDirFile : { dir: t, file: string } -> t
30 :     val splitDirFile : t -> { dir: t, file: string }
31 :     val dir : t -> t
32 :     val file : t -> string
33 : blume 274
34 :     val exists : t -> bool
35 :     val tstamp : t -> TStamp.t
36 :     val stabletstamp : t -> TStamp.t
37 : blume 275
38 :     (* The open?Out functions automagically create any necessary directories
39 :     * and announce this activity via their string consumer argument. *)
40 :     val openTextIn : t -> TextIO.instream
41 :     val openTextOut : (string -> unit) -> t -> TextIO.outstream
42 :     val openBinIn : t -> BinIO.instream
43 :     val openBinOut : (string -> unit) -> t -> BinIO.outstream
44 : blume 265 end
45 :    
46 :     structure AbsPath :> ABSPATH = struct
47 :    
48 :     structure P = OS.Path
49 :     structure F = OS.FileSys
50 :    
51 :     (* unique file id that can handle absent files *)
52 :     datatype id =
53 :     PRESENT of F.file_id
54 :     | ABSENT of string
55 :    
56 :     (* comparison of unique file ids *)
57 :     fun compareId (PRESENT fid, PRESENT fid') = F.compare (fid, fid')
58 :     | compareId (ABSENT _, PRESENT _) = LESS
59 :     | compareId (PRESENT _, ABSENT _) = GREATER
60 :     | compareId (ABSENT s, ABSENT s') = String.compare (s, s')
61 :    
62 : blume 270 fun getId f = (PRESENT (F.fileId f) handle _ => ABSENT f)
63 : blume 265
64 :     type elaboration = { stamp : unit ref,
65 :     name : string,
66 :     id : id option ref }
67 : blume 270
68 : blume 265 (* When a relative name is to be looked up wrt. CUR:
69 :     * - if the cwd hasn't changed since, then use relative path
70 :     * - if the cwd has changed, then make absolute path using name
71 :     * If we come back to the original dir, then ideally we should
72 :     * re-validate the stamp, but that would require having a cwd
73 :     * history -- and, thus, is probably not worth the effort.
74 :     *)
75 :    
76 :     type cwdinfo = { stamp: unit ref, name: string, id: id }
77 : blume 270
78 :     datatype context =
79 : blume 265 CUR of cwdinfo
80 :     | CONFIG_ANCHOR of { fetch: unit -> string,
81 :     cache: elaboration option ref }
82 : blume 270 | RELATIVE of t
83 :    
84 :     and t =
85 :     PATH of { context: context,
86 : blume 265 spec: string,
87 :     cache: elaboration option ref }
88 :    
89 :     local
90 :     val elabStamp = ref (ref ())
91 :     val cwdInfoCache : cwdinfo option ref = ref NONE
92 :     fun cwdInfo () =
93 :     case !cwdInfoCache of
94 :     SOME i => i
95 :     | NONE => let
96 :     val stamp = ref ()
97 :     val name = F.getDir ()
98 :     val id = PRESENT (F.fileId name)
99 :     val i = { stamp = stamp, name = name, id = id }
100 :     in
101 :     cwdInfoCache := SOME i;
102 :     i
103 :     end
104 :     val cwdStamp = #stamp o cwdInfo
105 :     val cwdName = #name o cwdInfo
106 :     val cwdId = #id o cwdInfo
107 :     fun invalidateCwdInfo () = cwdInfoCache := NONE
108 :     in
109 :     (* start a new era (i.e., invalidate all previous elaborations) *)
110 :     fun newEra () = elabStamp := ref ()
111 :    
112 :     (* make sure the cwd is consistent *)
113 :     fun revalidateCwd () =
114 :     case !cwdInfoCache of
115 :     NONE => ignore (cwdInfo ())
116 :     | SOME { name, id, ... } => let
117 :     val name' = F.getDir ()
118 :     val id' = PRESENT (F.fileId name')
119 :     in
120 :     if compareId (id, id') <> EQUAL then
121 :     (newEra ();
122 :     cwdInfoCache := SOME { stamp = ref (),
123 :     name = name', id = id' })
124 :     else ()
125 :     end
126 :    
127 : blume 270 fun cwdContext () =
128 :     CUR { stamp = cwdStamp (), name = cwdName (), id = cwdId () }
129 :    
130 :     fun configContext fetch =
131 :     CONFIG_ANCHOR { fetch = fetch, cache = ref NONE }
132 :    
133 :     fun relativeContext p = RELATIVE p
134 :    
135 :     fun mkElab (cache, name) = let
136 :     val e : elaboration =
137 :     { stamp = !elabStamp, name = name, id = ref NONE }
138 : blume 265 in
139 : blume 270 cache := SOME e; e
140 :     end
141 :    
142 :     fun validElab NONE = NONE
143 :     | validElab (SOME (e as { stamp, name, id })) =
144 :     if stamp = !elabStamp then SOME e else NONE
145 :    
146 :     fun elabContext c =
147 :     case c of
148 : blume 265 CUR { stamp, name, id } =>
149 :     { stamp = !elabStamp, id = ref (SOME id),
150 : blume 270 name = if stamp = cwdStamp () orelse
151 :     name = cwdName ()
152 :     then P.currentArc else name }
153 :     | CONFIG_ANCHOR { fetch, cache } =>
154 :     (case validElab (!cache) of
155 :     SOME e => e
156 :     | NONE => mkElab (cache, fetch ()))
157 :     | RELATIVE p => elab p
158 : blume 265
159 : blume 270 and elab (PATH { context, spec, cache }) =
160 :     (case validElab (!cache) of
161 :     SOME e => e
162 :     | NONE => let
163 :     val name =
164 :     if P.isAbsolute spec then spec
165 :     else P.mkCanonical
166 :     (P.concat (#name (elabContext context),
167 :     spec))
168 :     in
169 :     mkElab (cache, name)
170 :     end)
171 :    
172 : blume 265 (* get the file id (calls elab, so don't cache externally!) *)
173 :     fun id p = let
174 :     val { id, name, ... } = elab p
175 :     in
176 :     case !id of
177 :     NONE => let
178 :     val i = getId name
179 :     in
180 :     id := SOME i; i
181 :     end
182 :     | SOME i => i
183 :     end
184 :    
185 :     (* get the name as a string (calls elab, so don't cache externally!) *)
186 :     fun name p = #name (elab p)
187 :    
188 : blume 272 (* get the context back *)
189 :     fun context (PATH { context = c, ... }) = c
190 :     fun contextName c = #name (elabContext c)
191 :    
192 :     (* get the spec back *)
193 :     fun spec (PATH { spec = s, ... }) = s
194 :    
195 : blume 265 (* compare pathnames efficiently *)
196 :     fun compare (p1, p2) = compareId (id p1, id p2)
197 :    
198 : blume 268 fun fresh (context, spec) =
199 : blume 270 PATH { context = context, spec = spec, cache = ref NONE }
200 : blume 265
201 : blume 268 (* make an abstract path from a native string *)
202 :     fun native { spec, context } = fresh (context, spec)
203 :    
204 : blume 265 (* make an abstract path from a standard string *)
205 :     fun standard { spec, context } = let
206 :     fun delim #"/" = true
207 :     | delim #"\\" = true (* accept DOS-style, too *)
208 :     | delim _ = false
209 :    
210 :     fun transl ".." = OS.Path.parentArc
211 :     | transl "." = OS.Path.currentArc
212 :     | transl arc = arc
213 :    
214 :     fun mk (isAbs, arcs, context) =
215 : blume 268 fresh (context,
216 :     P.toString { isAbs = isAbs, vol = "",
217 :     arcs = map transl arcs })
218 : blume 265 in
219 :     case String.fields delim spec of
220 :     "" :: arcs => mk (true, arcs, context)
221 : blume 286 | [] => mk (false, [], context) (* shouldn't happen *)
222 :     | [arc] => mk (false, [arc], context)
223 : blume 265 | arcs as (arc1 :: arcn) =>
224 :     (case PathConfig.configAnchor arc1 of
225 :     NONE => mk (false, arcs, context)
226 :     | SOME fetch => let
227 :     val anchorcontext =
228 :     CONFIG_ANCHOR { fetch = fetch,
229 :     cache = ref NONE }
230 :     in
231 :     mk (false, arcn, anchorcontext)
232 :     end)
233 :     end
234 : blume 268
235 : blume 269 (* . and .. are not permitted as file parameter *)
236 : blume 270 fun joinDirFile { dir = PATH { context, spec, ... }, file } =
237 : blume 269 if file = P.currentArc orelse file = P.parentArc then
238 :     raise Fail "AbsPath.joinDirFile: . or .."
239 : blume 270 else fresh (context, P.joinDirFile { dir = spec, file = file })
240 : blume 268
241 : blume 269 (* splitDirFile never walks past a context.
242 :     * Moreover, it is an error to split something that ends in "..". *)
243 : blume 270 fun splitDirFile (PATH { context, spec, ... }) = let
244 :     fun loop "" =
245 :     raise Fail "AbsPath.splitDirFile: tried to split a context"
246 :     | loop spec = let
247 :     val { dir, file } = P.splitDirFile spec
248 :     in
249 :     if file = P.currentArc then loop dir
250 :     else if file = P.parentArc then
251 :     raise Fail "AbsPath.splitDirFile: <path>/.."
252 :     else (dir, file)
253 :     end
254 :     val (dir, file) = loop spec
255 :     val dir = if dir = "" then P.currentArc else dir
256 :     in
257 :     { dir = fresh (context, dir), file = file }
258 :     end
259 : blume 268
260 :     val dir = #dir o splitDirFile
261 :     val file = #file o splitDirFile
262 : blume 274
263 :     fun fileExists n = F.access (n, []) handle _ => false
264 :     fun fileModTime n = F.modTime n handle _ => Time.zeroTime
265 :    
266 :     val exists = fileExists o name
267 :    
268 :     fun tstamp0 TS p = let
269 :     val n = name p
270 :     in
271 :     if fileExists n then TS (fileModTime n) else TStamp.NOTSTAMP
272 :     end
273 :     val tstamp = tstamp0 TStamp.TSTAMP
274 :     val stabletstamp = tstamp0 TStamp.STABLETSTAMP
275 : blume 275
276 :     fun openOut fileopener (say: string -> unit) ap = let
277 :     val p = name ap
278 :     fun generic (maker, pmaker, p) =
279 :     maker p
280 :     handle exn => let
281 :     val { dir, ... } = P.splitDirFile p
282 :     in
283 :     if dir = "" orelse fileExists dir then raise exn
284 :     else (pmaker dir; maker p)
285 :     end
286 :     fun makedirs dir = generic (F.mkDir, makedirs, dir)
287 :     fun advertisemakedirs dir =
288 :     (say (concat ["[creating directory ", dir, " ...]\n"]);
289 :     makedirs dir)
290 :     in
291 :     generic (fileopener, advertisemakedirs, p)
292 :     end
293 :    
294 :     val openTextIn = TextIO.openIn o name
295 :     val openBinIn = BinIO.openIn o name
296 :     val openTextOut = openOut TextIO.openOut
297 :     val openBinOut = openOut BinIO.openOut
298 : blume 265 end
299 :     end

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