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

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