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 353 - (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 : blume 305 type ord_key = t
13 : blume 265
14 :     val revalidateCwd : unit -> unit
15 : blume 277 val newEra : unit -> unit
16 : blume 265
17 : blume 270 val cwdContext: unit -> context
18 : blume 353 val sameDirContext: t -> context
19 : blume 270
20 : blume 265 val name : t -> string
21 :     val compare : t * t -> order
22 : blume 353 val contextOf : t -> context
23 :     val specOf : t -> string
24 : blume 272 val contextName : context -> string
25 : blume 265
26 : blume 352 (* Replace the anchor context in the path argument with the
27 :     * given context. Returns NONE if there was no anchor context. *)
28 : blume 353 val reAnchor : t * string -> t option
29 : blume 352
30 : blume 270 val native : { context: context, spec: string } -> t
31 : blume 318 val standard : PathConfig.mode -> { context: context, spec: string } -> t
32 : blume 268
33 : blume 353 (* the second path argument is the path of the group spec that
34 :     * pickling is based upon. *)
35 : blume 340 val pickle : (bool -> unit) -> t * t -> string list
36 :     val unpickle : PathConfig.mode -> string list * t -> t option
37 : blume 305
38 : blume 268 val joinDirFile : { dir: t, file: string } -> t
39 :     val splitDirFile : t -> { dir: t, file: string }
40 :     val dir : t -> t
41 :     val file : t -> string
42 : blume 274
43 :     val exists : t -> bool
44 :     val tstamp : t -> TStamp.t
45 : blume 345 val setTime : t * TStamp.t -> unit
46 : blume 349 val delete : t -> unit
47 : blume 275
48 :     (* The open?Out functions automagically create any necessary directories
49 : blume 352 * and announce this activity. *)
50 : blume 275 val openTextIn : t -> TextIO.instream
51 : blume 297 val openTextOut : t -> TextIO.outstream
52 : blume 275 val openBinIn : t -> BinIO.instream
53 : blume 297 val openBinOut : t -> BinIO.outstream
54 : blume 265 end
55 :    
56 :     structure AbsPath :> ABSPATH = struct
57 :    
58 :     structure P = OS.Path
59 :     structure F = OS.FileSys
60 : blume 340 val impossible = GenericVC.ErrorMsg.impossible
61 : blume 265
62 :     (* unique file id that can handle absent files *)
63 :     datatype id =
64 :     PRESENT of F.file_id
65 :     | ABSENT of string
66 :    
67 :     (* comparison of unique file ids *)
68 :     fun compareId (PRESENT fid, PRESENT fid') = F.compare (fid, fid')
69 :     | compareId (ABSENT _, PRESENT _) = LESS
70 :     | compareId (PRESENT _, ABSENT _) = GREATER
71 :     | compareId (ABSENT s, ABSENT s') = String.compare (s, s')
72 :    
73 : blume 270 fun getId f = (PRESENT (F.fileId f) handle _ => ABSENT f)
74 : blume 265
75 :     type elaboration = { stamp : unit ref,
76 :     name : string,
77 :     id : id option ref }
78 : blume 270
79 : blume 265 (* When a relative name is to be looked up wrt. CUR:
80 :     * - if the cwd hasn't changed since, then use relative path
81 :     * - if the cwd has changed, then make absolute path using name
82 :     * If we come back to the original dir, then ideally we should
83 :     * re-validate the stamp, but that would require having a cwd
84 :     * history -- and, thus, is probably not worth the effort.
85 :     *)
86 :    
87 :     type cwdinfo = { stamp: unit ref, name: string, id: id }
88 : blume 270
89 :     datatype context =
90 : blume 353 THEN_CWD of cwdinfo
91 : blume 265 | CONFIG_ANCHOR of { fetch: unit -> string,
92 : blume 304 cache: elaboration option ref,
93 :     config_name: string }
94 : blume 353 | DIR_OF of t
95 : blume 352 | ROOT
96 : blume 270
97 : blume 324 and t =
98 : blume 270 PATH of { context: context,
99 : blume 265 spec: string,
100 :     cache: elaboration option ref }
101 :    
102 : blume 305 type ord_key = t
103 :    
104 : blume 265 local
105 :     val elabStamp = ref (ref ())
106 :     val cwdInfoCache : cwdinfo option ref = ref NONE
107 :     fun cwdInfo () =
108 :     case !cwdInfoCache of
109 :     SOME i => i
110 :     | NONE => let
111 :     val stamp = ref ()
112 :     val name = F.getDir ()
113 :     val id = PRESENT (F.fileId name)
114 :     val i = { stamp = stamp, name = name, id = id }
115 :     in
116 :     cwdInfoCache := SOME i;
117 :     i
118 :     end
119 :     val cwdStamp = #stamp o cwdInfo
120 :     val cwdName = #name o cwdInfo
121 :     val cwdId = #id o cwdInfo
122 :     in
123 :     (* start a new era (i.e., invalidate all previous elaborations) *)
124 :     fun newEra () = elabStamp := ref ()
125 :    
126 :     (* make sure the cwd is consistent *)
127 :     fun revalidateCwd () =
128 :     case !cwdInfoCache of
129 :     NONE => ignore (cwdInfo ())
130 :     | SOME { name, id, ... } => let
131 :     val name' = F.getDir ()
132 :     val id' = PRESENT (F.fileId name')
133 :     in
134 :     if compareId (id, id') <> EQUAL then
135 :     (newEra ();
136 :     cwdInfoCache := SOME { stamp = ref (),
137 :     name = name', id = id' })
138 :     else ()
139 :     end
140 :    
141 : blume 270 fun cwdContext () =
142 : blume 353 THEN_CWD { stamp = cwdStamp (), name = cwdName (), id = cwdId () }
143 : blume 270
144 : blume 353 fun sameDirContext p = DIR_OF p
145 : blume 270
146 :     fun mkElab (cache, name) = let
147 :     val e : elaboration =
148 :     { stamp = !elabStamp, name = name, id = ref NONE }
149 : blume 265 in
150 : blume 270 cache := SOME e; e
151 :     end
152 :    
153 :     fun validElab NONE = NONE
154 :     | validElab (SOME (e as { stamp, name, id })) =
155 :     if stamp = !elabStamp then SOME e else NONE
156 :    
157 : blume 352 val rootName = P.toString { isAbs = true, arcs = [], vol = "" }
158 : blume 353 val rootId = ref (NONE: id option)
159 : blume 352
160 : blume 270 fun elabContext c =
161 :     case c of
162 : blume 353 THEN_CWD { stamp, name, id } =>
163 : blume 265 { stamp = !elabStamp, id = ref (SOME id),
164 : blume 353 name = if stamp = cwdStamp () orelse name = cwdName ()
165 : blume 270 then P.currentArc else name }
166 : blume 304 | CONFIG_ANCHOR { fetch, cache, config_name } =>
167 : blume 270 (case validElab (!cache) of
168 :     SOME e => e
169 :     | NONE => mkElab (cache, fetch ()))
170 : blume 353 | DIR_OF p => let
171 :     val { name, stamp, ... } = elab p
172 :     in
173 :     { name = P.dir name, stamp = stamp, id = ref NONE }
174 :     end
175 :     | ROOT => { stamp = !elabStamp, name = rootName, id = rootId }
176 : blume 265
177 : blume 305 and elab (PATH { context, spec, cache }) =
178 : blume 353 case validElab (!cache) of
179 :     SOME e => e
180 :     | NONE => let
181 :     val name = P.mkCanonical
182 :     (P.concat (#name (elabContext context),
183 :     spec))
184 :     in
185 :     mkElab (cache, name)
186 :     end
187 : blume 270
188 : blume 265 (* get the file id (calls elab, so don't cache externally!) *)
189 :     fun id p = let
190 :     val { id, name, ... } = elab p
191 :     in
192 :     case !id of
193 :     NONE => let
194 :     val i = getId name
195 :     in
196 :     id := SOME i; i
197 :     end
198 :     | SOME i => i
199 :     end
200 :    
201 :     (* get the name as a string (calls elab, so don't cache externally!) *)
202 :     fun name p = #name (elab p)
203 :    
204 : blume 272 (* get the context back *)
205 : blume 353 fun contextOf (PATH { context = c, ... }) = c
206 : blume 272 fun contextName c = #name (elabContext c)
207 :    
208 :     (* get the spec back *)
209 : blume 353 fun specOf (PATH { spec = s, ... }) = s
210 : blume 272
211 : blume 265 (* compare pathnames efficiently *)
212 :     fun compare (p1, p2) = compareId (id p1, id p2)
213 :    
214 : blume 305 fun fresh (context, spec) =
215 :     PATH { context = context, spec = spec, cache = ref NONE }
216 : blume 265
217 : blume 268 (* make an abstract path from a native string *)
218 : blume 352 fun native { spec, context } = let
219 :     val { isAbs, vol, arcs } = P.fromString spec
220 :     val relSpec = P.toString { isAbs = false, vol = vol, arcs = arcs }
221 :     in
222 :     if isAbs then fresh (ROOT, relSpec)
223 :     else fresh (context, relSpec)
224 :     end
225 : blume 268
226 : blume 265 (* make an abstract path from a standard string *)
227 : blume 318 fun standard mode { spec, context } = let
228 : blume 265 fun delim #"/" = true
229 :     | delim #"\\" = true (* accept DOS-style, too *)
230 :     | delim _ = false
231 :    
232 : blume 353 fun transl ".." = P.parentArc
233 :     | transl "." = P.currentArc
234 : blume 265 | transl arc = arc
235 :    
236 : blume 352 fun mk (arcs, context) =
237 : blume 268 fresh (context,
238 : blume 352 P.toString { isAbs = false, vol = "",
239 : blume 305 arcs = map transl arcs })
240 : blume 265 in
241 :     case String.fields delim spec of
242 : blume 353 [""] => impossible "AbsPath.standard: zero-length name"
243 :     | "" :: arcs => mk (arcs, ROOT)
244 :     | [] => impossible "AbsPath.standard: no fields"
245 : blume 304 | arcs as (arc1 :: _) =>
246 : blume 318 (case PathConfig.configAnchor mode arc1 of
247 : blume 352 NONE => mk (arcs, context)
248 : blume 265 | SOME fetch => let
249 :     val anchorcontext =
250 :     CONFIG_ANCHOR { fetch = fetch,
251 : blume 304 cache = ref NONE,
252 :     config_name = arc1 }
253 : blume 265 in
254 : blume 352 mk (arcs, anchorcontext)
255 : blume 265 end)
256 :     end
257 : blume 268
258 : blume 305 (* make a pickle-string *)
259 : blume 353 fun pickle warn (path, gpath) = let
260 :     fun p_p (PATH { spec, context, ... }) =
261 :     spec :: p_c context
262 :     and p_c ROOT = (warn true; ["r"])
263 :     | p_c (THEN_CWD _) = impossible "AbsPath.pickle: THEN_CWD"
264 :     | p_c (CONFIG_ANCHOR { config_name = n, ... }) = [n, "a"]
265 :     | p_c (DIR_OF p) =
266 :     if compare (p, gpath) = EQUAL then (warn false; ["c"])
267 :     else p_p p
268 : blume 305 in
269 : blume 340 p_p path
270 : blume 305 end
271 :    
272 : blume 353 fun unpickle mode (l, gpath) = let
273 :     fun u_p (s :: l) =
274 :     Option.map
275 :     (fn c => PATH { spec = s, context = c, cache = ref NONE })
276 :     (u_c l)
277 :     | u_p [] = NONE
278 :     and u_c ["r"] = SOME ROOT
279 :     | u_c ["c"] = SOME (DIR_OF gpath)
280 :     | u_c [n, "a"] =
281 : blume 318 (case PathConfig.configAnchor mode n of
282 : blume 353 NONE => NONE
283 :     | SOME fetch =>
284 :     SOME (CONFIG_ANCHOR { config_name = n,
285 :     fetch = fetch,
286 :     cache = ref NONE }))
287 :     | u_c l = Option.map DIR_OF (u_p l)
288 : blume 305 in
289 : blume 353 u_p l
290 : blume 305 end
291 :    
292 : blume 269 (* . and .. are not permitted as file parameter *)
293 : blume 305 fun joinDirFile { dir = PATH { context, spec, ... }, file } =
294 : blume 269 if file = P.currentArc orelse file = P.parentArc then
295 : blume 340 impossible "AbsPath.joinDirFile: . or .."
296 : blume 305 else fresh (context, P.joinDirFile { dir = spec, file = file })
297 : blume 268
298 : blume 269 (* splitDirFile never walks past a context.
299 :     * Moreover, it is an error to split something that ends in "..". *)
300 : blume 305 fun splitDirFile (PATH { context, spec, ... }) = let
301 : blume 270 fun loop "" =
302 : blume 340 impossible "AbsPath.splitDirFile: tried to split a context"
303 : blume 270 | loop spec = let
304 :     val { dir, file } = P.splitDirFile spec
305 :     in
306 :     if file = P.currentArc then loop dir
307 :     else if file = P.parentArc then
308 : blume 340 impossible "AbsPath.splitDirFile: <path>/.."
309 : blume 270 else (dir, file)
310 :     end
311 :     val (dir, file) = loop spec
312 :     val dir = if dir = "" then P.currentArc else dir
313 :     in
314 : blume 305 { dir = fresh (context, dir), file = file }
315 : blume 270 end
316 : blume 268
317 :     val dir = #dir o splitDirFile
318 :     val file = #file o splitDirFile
319 : blume 274
320 :     fun fileExists n = F.access (n, []) handle _ => false
321 :     fun fileModTime n = F.modTime n handle _ => Time.zeroTime
322 :    
323 :     val exists = fileExists o name
324 :    
325 : blume 330 fun tstamp p = let
326 : blume 274 val n = name p
327 :     in
328 : blume 330 if fileExists n then TStamp.TSTAMP (fileModTime n)
329 :     else TStamp.NOTSTAMP
330 : blume 274 end
331 : blume 275
332 : blume 345 fun setTime (p, TStamp.NOTSTAMP) = ()
333 : blume 353 | setTime (p, TStamp.TSTAMP t) = F.setTime (name p, SOME t)
334 : blume 345
335 : blume 353 fun delete p = F.remove (name p) handle _ => ()
336 : blume 349
337 : blume 297 fun openOut fileopener ap = let
338 : blume 275 val p = name ap
339 :     fun generic (maker, pmaker, p) =
340 :     maker p
341 :     handle exn => let
342 :     val { dir, ... } = P.splitDirFile p
343 :     in
344 :     if dir = "" orelse fileExists dir then raise exn
345 :     else (pmaker dir; maker p)
346 :     end
347 :     fun makedirs dir = generic (F.mkDir, makedirs, dir)
348 :     fun advertisemakedirs dir =
349 : blume 310 (Say.vsay ["[creating directory ", dir, " ...]\n"];
350 : blume 275 makedirs dir)
351 :     in
352 :     generic (fileopener, advertisemakedirs, p)
353 :     end
354 :    
355 :     val openTextIn = TextIO.openIn o name
356 :     val openBinIn = BinIO.openIn o name
357 :     val openTextOut = openOut TextIO.openOut
358 :     val openBinOut = openOut BinIO.openOut
359 : blume 265 end
360 : blume 352
361 : blume 353 fun reAnchor (p, dirstring) = let
362 :     fun path (PATH { context, spec, ... }) = let
363 :     fun mk c = PATH { context = c, spec = spec, cache = ref NONE }
364 : blume 352 in
365 : blume 353 Option.map mk (ctxt context)
366 : blume 352 end
367 : blume 353 and ctxt (CONFIG_ANCHOR { config_name = n, ... }) =
368 :     SOME (CONFIG_ANCHOR { config_name = n,
369 :     fetch = fn () => P.concat (dirstring, n),
370 :     cache = ref NONE })
371 :     | ctxt (DIR_OF p) = Option.map DIR_OF (path p)
372 :     | ctxt (THEN_CWD _) = NONE
373 :     | ctxt ROOT = NONE
374 : blume 352 in
375 :     path p
376 :     end
377 : blume 265 end

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