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

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