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 464 - (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 367 exception Format (* if something is seriously wrong with a pickle *)
11 :     exception BadAnchor of string (* if anchor cannot be resolved *)
12 :    
13 : blume 270 type context
14 : blume 265 type t
15 : blume 305 type ord_key = t
16 : blume 265
17 : blume 366 val newEra : unit -> unit
18 : blume 265 val revalidateCwd : unit -> unit
19 : blume 464 val invalidateCwd : unit -> unit
20 : blume 265
21 : blume 270 val cwdContext: unit -> context
22 : blume 353 val sameDirContext: t -> context
23 : blume 270
24 : blume 354 val osstring : t -> string
25 :     val descr : t -> string
26 : blume 265 val compare : t * t -> order
27 : blume 353 val contextOf : t -> context
28 :     val specOf : t -> string
29 : blume 272 val contextName : context -> string
30 : blume 265
31 : blume 352 (* Replace the anchor context in the path argument with the
32 :     * given context. Returns NONE if there was no anchor context. *)
33 : blume 354 val reAnchoredName : t * string -> string option
34 : blume 352
35 : blume 270 val native : { context: context, spec: string } -> t
36 : blume 318 val standard : PathConfig.mode -> { context: context, spec: string } -> t
37 : blume 268
38 : blume 457 val fromDescr : PathConfig.mode -> string -> t
39 :    
40 : blume 353 (* the second path argument is the path of the group spec that
41 :     * pickling is based upon. *)
42 : blume 340 val pickle : (bool -> unit) -> t * t -> string list
43 : blume 367 val unpickle : PathConfig.mode -> string list * t -> t
44 : blume 305
45 : blume 274 val tstamp : t -> TStamp.t
46 : blume 265 end
47 :    
48 :     structure AbsPath :> ABSPATH = struct
49 :    
50 :     structure P = OS.Path
51 :     structure F = OS.FileSys
52 : blume 340 val impossible = GenericVC.ErrorMsg.impossible
53 : blume 265
54 : blume 367 exception Format
55 :     exception BadAnchor of string
56 :    
57 : blume 265 (* unique file id that can handle absent files *)
58 :     datatype id =
59 :     PRESENT of F.file_id
60 :     | ABSENT of string
61 :    
62 :     (* comparison of unique file ids *)
63 :     fun compareId (PRESENT fid, PRESENT fid') = F.compare (fid, fid')
64 :     | compareId (ABSENT _, PRESENT _) = LESS
65 :     | compareId (PRESENT _, ABSENT _) = GREATER
66 :     | compareId (ABSENT s, ABSENT s') = String.compare (s, s')
67 :    
68 : blume 374 (* To maximize our chances of recognizing eqivalent path names to
69 :     * non-existing files, we use F.fullPath to expand the largest
70 :     * possible prefix of the path. *)
71 :     fun expandPath f = let
72 :     fun loop { dir, file } =
73 :     P.concat (F.fullPath dir, file)
74 :     handle _ => let
75 :     val { dir = dir', file = file' } = P.splitDirFile dir
76 :     in
77 :     loop { dir = dir', file = P.concat (file', file) }
78 :     end
79 :     in
80 :     (* An initial call to splitDirFile is ok because we already know
81 :     * that the complete path does not refer to an existing file. *)
82 :     loop (P.splitDirFile f)
83 :     end
84 : blume 265
85 : blume 374 fun getId f = (PRESENT (F.fileId f) handle _ => ABSENT (expandPath f))
86 :    
87 : blume 265 type elaboration = { stamp : unit ref,
88 :     name : string,
89 :     id : id option ref }
90 : blume 270
91 : blume 265 (* When a relative name is to be looked up wrt. CUR:
92 :     * - if the cwd hasn't changed since, then use relative path
93 :     * - if the cwd has changed, then make absolute path using name
94 :     * If we come back to the original dir, then ideally we should
95 :     * re-validate the stamp, but that would require having a cwd
96 :     * history -- and, thus, is probably not worth the effort.
97 :     *)
98 :    
99 :     type cwdinfo = { stamp: unit ref, name: string, id: id }
100 : blume 270
101 :     datatype context =
102 : blume 353 THEN_CWD of cwdinfo
103 : blume 265 | CONFIG_ANCHOR of { fetch: unit -> string,
104 : blume 304 cache: elaboration option ref,
105 :     config_name: string }
106 : blume 353 | DIR_OF of t
107 : blume 457 | ROOT of string (* carries volume *)
108 : blume 270
109 : blume 324 and t =
110 : blume 270 PATH of { context: context,
111 : blume 265 spec: string,
112 :     cache: elaboration option ref }
113 :    
114 : blume 305 type ord_key = t
115 :    
116 : blume 464 fun stdEncode p = let
117 :     fun a [] = []
118 :     | a [x] = [x]
119 :     | a (h :: t) = h :: "/" :: a t
120 :     in
121 :     case P.fromString p of
122 :     { isAbs = false, arcs, ... } => concat (a arcs)
123 :     | { vol = "", arcs, ... } => concat ("/" :: a arcs)
124 :     | { vol, arcs, ... } => concat ("%" :: vol :: "/" :: a arcs)
125 :     end
126 :    
127 : blume 265 local
128 :     val cwdInfoCache : cwdinfo option ref = ref NONE
129 :     fun cwdInfo () =
130 :     case !cwdInfoCache of
131 :     SOME i => i
132 :     | NONE => let
133 :     val stamp = ref ()
134 :     val name = F.getDir ()
135 :     val id = PRESENT (F.fileId name)
136 :     val i = { stamp = stamp, name = name, id = id }
137 :     in
138 :     cwdInfoCache := SOME i;
139 :     i
140 :     end
141 :     val cwdStamp = #stamp o cwdInfo
142 :     val cwdName = #name o cwdInfo
143 :     val cwdId = #id o cwdInfo
144 :     in
145 :     (* start a new era (i.e., invalidate all previous elaborations) *)
146 : blume 369 val newEra = Era.newEra
147 : blume 265
148 :     (* make sure the cwd is consistent *)
149 : blume 464 fun revalidateCwd () = let
150 :     fun notify { stamp, name, id } = Servers.cd (stdEncode name)
151 :     in
152 : blume 265 case !cwdInfoCache of
153 : blume 464 NONE => notify (cwdInfo ())
154 : blume 265 | SOME { name, id, ... } => let
155 :     val name' = F.getDir ()
156 :     val id' = PRESENT (F.fileId name')
157 :     in
158 : blume 464 if compareId (id, id') <> EQUAL then let
159 :     val i = { stamp = ref (), name = name', id = id' }
160 :     in
161 :     newEra ();
162 :     cwdInfoCache := SOME i;
163 :     notify i
164 :     end
165 : blume 265 else ()
166 :     end
167 : blume 464 end
168 : blume 265
169 : blume 464 fun invalidateCwd () = cwdInfoCache := NONE
170 :    
171 : blume 270 fun cwdContext () =
172 : blume 366 (revalidateCwd ();
173 :     THEN_CWD { stamp = cwdStamp (),
174 :     name = cwdName (),
175 :     id = cwdId () })
176 : blume 270
177 : blume 353 fun sameDirContext p = DIR_OF p
178 : blume 270
179 :     fun mkElab (cache, name) = let
180 :     val e : elaboration =
181 : blume 369 { stamp = Era.thisEra (), name = name, id = ref NONE }
182 : blume 265 in
183 : blume 270 cache := SOME e; e
184 :     end
185 :    
186 :     fun validElab NONE = NONE
187 :     | validElab (SOME (e as { stamp, name, id })) =
188 : blume 369 if Era.isThisEra stamp then SOME e else NONE
189 : blume 270
190 : blume 457 fun rootName vol = P.toString { isAbs = true, arcs = [], vol = vol }
191 :     val rootId = let
192 :     val m = ref (StringMap.empty: id option ref StringMap.map)
193 :     in
194 :     fn vol =>
195 :     (case StringMap.find (!m, vol) of
196 :     NONE => let
197 :     val idr = ref NONE
198 :     in
199 :     m := StringMap.insert (!m, vol, idr);
200 :     idr
201 :     end
202 :     | SOME idr => idr)
203 :     end
204 : blume 352
205 : blume 270 fun elabContext c =
206 :     case c of
207 : blume 353 THEN_CWD { stamp, name, id } =>
208 : blume 369 { stamp = Era.thisEra (), id = ref (SOME id),
209 : blume 353 name = if stamp = cwdStamp () orelse name = cwdName ()
210 : blume 270 then P.currentArc else name }
211 : blume 304 | CONFIG_ANCHOR { fetch, cache, config_name } =>
212 : blume 270 (case validElab (!cache) of
213 :     SOME e => e
214 :     | NONE => mkElab (cache, fetch ()))
215 : blume 353 | DIR_OF p => let
216 :     val { name, stamp, ... } = elab p
217 :     in
218 :     { name = P.dir name, stamp = stamp, id = ref NONE }
219 :     end
220 : blume 457 | ROOT vol => { stamp = Era.thisEra (),
221 :     name = rootName vol,
222 :     id = rootId vol }
223 : blume 265
224 : blume 305 and elab (PATH { context, spec, cache }) =
225 : blume 353 case validElab (!cache) of
226 :     SOME e => e
227 : blume 357 | NONE => mkElab (cache,
228 : blume 373 P.concat (#name (elabContext context), spec))
229 : blume 270
230 : blume 265 (* get the file id (calls elab, so don't cache externally!) *)
231 :     fun id p = let
232 :     val { id, name, ... } = elab p
233 :     in
234 :     case !id of
235 :     NONE => let
236 :     val i = getId name
237 :     in
238 :     id := SOME i; i
239 :     end
240 :     | SOME i => i
241 :     end
242 :    
243 :     (* get the name as a string (calls elab, so don't cache externally!) *)
244 : blume 354 fun osstring p = #name (elab p)
245 : blume 265
246 : blume 272 (* get the context back *)
247 : blume 353 fun contextOf (PATH { context = c, ... }) = c
248 : blume 272 fun contextName c = #name (elabContext c)
249 :    
250 :     (* get the spec back *)
251 : blume 353 fun specOf (PATH { spec = s, ... }) = s
252 : blume 272
253 : blume 265 (* compare pathnames efficiently *)
254 :     fun compare (p1, p2) = compareId (id p1, id p2)
255 :    
256 : blume 305 fun fresh (context, spec) =
257 :     PATH { context = context, spec = spec, cache = ref NONE }
258 : blume 265
259 : blume 268 (* make an abstract path from a native string *)
260 : blume 352 fun native { spec, context } = let
261 :     val { isAbs, vol, arcs } = P.fromString spec
262 : blume 457 val relSpec = P.toString { isAbs = false, vol = "", arcs = arcs }
263 : blume 352 in
264 : blume 457 if isAbs then fresh (ROOT vol, relSpec)
265 : blume 352 else fresh (context, relSpec)
266 :     end
267 : blume 268
268 : blume 265 (* make an abstract path from a standard string *)
269 : blume 318 fun standard mode { spec, context } = let
270 : blume 265 fun delim #"/" = true
271 :     | delim #"\\" = true (* accept DOS-style, too *)
272 :     | delim _ = false
273 :    
274 : blume 353 fun transl ".." = P.parentArc
275 :     | transl "." = P.currentArc
276 : blume 265 | transl arc = arc
277 :    
278 : blume 352 fun mk (arcs, context) =
279 : blume 268 fresh (context,
280 : blume 352 P.toString { isAbs = false, vol = "",
281 : blume 305 arcs = map transl arcs })
282 : blume 265 in
283 :     case String.fields delim spec of
284 : blume 353 [""] => impossible "AbsPath.standard: zero-length name"
285 : blume 457 | "" :: arcs => mk (arcs, ROOT "")
286 : blume 353 | [] => impossible "AbsPath.standard: no fields"
287 : blume 304 | arcs as (arc1 :: _) =>
288 : blume 318 (case PathConfig.configAnchor mode arc1 of
289 : blume 352 NONE => mk (arcs, context)
290 : blume 265 | SOME fetch => let
291 :     val anchorcontext =
292 :     CONFIG_ANCHOR { fetch = fetch,
293 : blume 304 cache = ref NONE,
294 :     config_name = arc1 }
295 : blume 265 in
296 : blume 352 mk (arcs, anchorcontext)
297 : blume 265 end)
298 :     end
299 : blume 268
300 : blume 305 (* make a pickle-string *)
301 : blume 353 fun pickle warn (path, gpath) = let
302 :     fun p_p (PATH { spec, context, ... }) =
303 :     spec :: p_c context
304 : blume 457 and p_c (ROOT vol) = (warn true; [vol, "r"])
305 : blume 353 | p_c (THEN_CWD _) = impossible "AbsPath.pickle: THEN_CWD"
306 :     | p_c (CONFIG_ANCHOR { config_name = n, ... }) = [n, "a"]
307 :     | p_c (DIR_OF p) =
308 :     if compare (p, gpath) = EQUAL then (warn false; ["c"])
309 :     else p_p p
310 : blume 305 in
311 : blume 340 p_p path
312 : blume 305 end
313 :    
314 : blume 353 fun unpickle mode (l, gpath) = let
315 :     fun u_p (s :: l) =
316 : blume 367 PATH { spec = s, context = u_c l, cache = ref NONE }
317 :     | u_p [] = raise Format
318 : blume 457 and u_c [vol, "r"] = ROOT vol
319 : blume 367 | u_c ["c"] = DIR_OF gpath
320 : blume 353 | u_c [n, "a"] =
321 : blume 318 (case PathConfig.configAnchor mode n of
322 : blume 367 NONE => raise BadAnchor n
323 : blume 353 | SOME fetch =>
324 : blume 367 CONFIG_ANCHOR { config_name = n,
325 :     fetch = fetch,
326 :     cache = ref NONE })
327 :     | u_c l = DIR_OF (u_p l)
328 : blume 305 in
329 : blume 353 u_p l
330 : blume 305 end
331 :    
332 : blume 354 fun tstamp p = TStamp.fmodTime (osstring p)
333 : blume 268
334 : blume 354 fun descr (PATH { spec, context, ... }) = let
335 :     fun dir (x, l) =
336 : blume 357 case P.dir x of
337 : blume 354 "" => l
338 :     | d => d :: "/" :: l
339 :     fun d_c (CONFIG_ANCHOR { config_name = n, ... }, l) =
340 :     "$" :: n :: "/" :: l
341 :     | d_c (DIR_OF (PATH { spec, context, ... }), l) =
342 : blume 464 d_c (context, dir (stdEncode spec, l))
343 : blume 354 | d_c (THEN_CWD _, l) = "./" :: l
344 : blume 457 | d_c (ROOT "", l) = "/" :: l
345 :     | d_c (ROOT vol, l) = "%" :: vol :: "/" :: l
346 : blume 274 in
347 : blume 354 concat (d_c (context, [spec]))
348 : blume 274 end
349 : blume 275
350 : blume 457 fun fromDescr mode "" = fresh (cwdContext (), P.currentArc)
351 :     | fromDescr mode d = let
352 :     val l = size d
353 :     fun split n =
354 :     if n >= l then
355 :     (String.substring (d, 1, l), P.currentArc)
356 :     else if String.sub (d, n) = #"/" then
357 :     (String.substring (d, 1, n - 1),
358 :     String.extract (d, n + 1, NONE))
359 :     else split (n + 1)
360 :     in
361 :     case String.sub (d, 0) of
362 :     #"$" => let
363 :     val (a, s) = split 1
364 :     in
365 :     case PathConfig.configAnchor mode a of
366 :     NONE => raise BadAnchor a
367 :     | SOME fetch =>
368 :     fresh (CONFIG_ANCHOR { config_name = a,
369 :     fetch = fetch,
370 :     cache = ref NONE },
371 :     s)
372 :     end
373 :     | #"/" => fresh (ROOT "", String.extract (d, 1, NONE))
374 : blume 464 | #"." =>
375 :     if String.sub (d, 1) = #"/" then
376 :     fresh (cwdContext (), String.extract (d, 2, NONE))
377 :     else
378 :     fresh (cwdContext (), d)
379 : blume 457 | #"%" => let
380 :     val (v, s) = split 1
381 :     in
382 :     fresh (ROOT v, s)
383 :     end
384 :     | _ => fresh (cwdContext (), d)
385 :     end
386 :    
387 : blume 354 fun reAnchoredName (p, dirstring) = let
388 :     fun path (PATH { context, spec, ... }) = let
389 :     fun mk c = P.concat (c, spec)
390 :     in
391 :     Option.map mk (ctxt context)
392 :     end
393 :     and ctxt (CONFIG_ANCHOR { config_name = n, ... }) =
394 :     SOME (P.concat (dirstring, n))
395 :     | ctxt (DIR_OF p) = Option.map P.dir (path p)
396 : blume 457 | ctxt (THEN_CWD _) = NONE
397 :     | ctxt (ROOT _) = NONE
398 : blume 275 in
399 : blume 373 path p
400 : blume 275 end
401 : blume 265 end
402 :     end

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