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 270 - (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 :    
15 : blume 270 val cwdContext: unit -> context
16 :     val configContext: (unit -> string) -> context
17 :     val relativeContext: t -> context
18 :    
19 : blume 265 val name : t -> string
20 :     val compare : t * t -> order
21 :    
22 : blume 270 val native : { context: context, spec: string } -> t
23 :     val standard : { context: context, spec: string } -> t
24 : blume 268
25 :     val joinDirFile : { dir: t, file: string } -> t
26 :     val splitDirFile : t -> { dir: t, file: string }
27 :     val dir : t -> t
28 :     val file : t -> string
29 : blume 265 end
30 :    
31 :     structure AbsPath :> ABSPATH = struct
32 :    
33 :     structure P = OS.Path
34 :     structure F = OS.FileSys
35 :    
36 :     (* unique file id that can handle absent files *)
37 :     datatype id =
38 :     PRESENT of F.file_id
39 :     | ABSENT of string
40 :    
41 :     (* comparison of unique file ids *)
42 :     fun compareId (PRESENT fid, PRESENT fid') = F.compare (fid, fid')
43 :     | compareId (ABSENT _, PRESENT _) = LESS
44 :     | compareId (PRESENT _, ABSENT _) = GREATER
45 :     | compareId (ABSENT s, ABSENT s') = String.compare (s, s')
46 :    
47 : blume 270 fun getId f = (PRESENT (F.fileId f) handle _ => ABSENT f)
48 : blume 265
49 :     type elaboration = { stamp : unit ref,
50 :     name : string,
51 :     id : id option ref }
52 : blume 270
53 : blume 265 (* When a relative name is to be looked up wrt. CUR:
54 :     * - if the cwd hasn't changed since, then use relative path
55 :     * - if the cwd has changed, then make absolute path using name
56 :     * If we come back to the original dir, then ideally we should
57 :     * re-validate the stamp, but that would require having a cwd
58 :     * history -- and, thus, is probably not worth the effort.
59 :     *)
60 :    
61 :     type cwdinfo = { stamp: unit ref, name: string, id: id }
62 : blume 270
63 :     datatype context =
64 : blume 265 CUR of cwdinfo
65 :     | CONFIG_ANCHOR of { fetch: unit -> string,
66 :     cache: elaboration option ref }
67 : blume 270 | RELATIVE of t
68 :    
69 :     and t =
70 :     PATH of { context: context,
71 : blume 265 spec: string,
72 :     cache: elaboration option ref }
73 :    
74 :     local
75 :     val elabStamp = ref (ref ())
76 :     val cwdInfoCache : cwdinfo option ref = ref NONE
77 :     fun cwdInfo () =
78 :     case !cwdInfoCache of
79 :     SOME i => i
80 :     | NONE => let
81 :     val stamp = ref ()
82 :     val name = F.getDir ()
83 :     val id = PRESENT (F.fileId name)
84 :     val i = { stamp = stamp, name = name, id = id }
85 :     in
86 :     cwdInfoCache := SOME i;
87 :     i
88 :     end
89 :     val cwdStamp = #stamp o cwdInfo
90 :     val cwdName = #name o cwdInfo
91 :     val cwdId = #id o cwdInfo
92 :     fun invalidateCwdInfo () = cwdInfoCache := NONE
93 :     in
94 :     (* start a new era (i.e., invalidate all previous elaborations) *)
95 :     fun newEra () = elabStamp := ref ()
96 :    
97 :     (* make sure the cwd is consistent *)
98 :     fun revalidateCwd () =
99 :     case !cwdInfoCache of
100 :     NONE => ignore (cwdInfo ())
101 :     | SOME { name, id, ... } => let
102 :     val name' = F.getDir ()
103 :     val id' = PRESENT (F.fileId name')
104 :     in
105 :     if compareId (id, id') <> EQUAL then
106 :     (newEra ();
107 :     cwdInfoCache := SOME { stamp = ref (),
108 :     name = name', id = id' })
109 :     else ()
110 :     end
111 :    
112 : blume 270 fun cwdContext () =
113 :     CUR { stamp = cwdStamp (), name = cwdName (), id = cwdId () }
114 :    
115 :     fun configContext fetch =
116 :     CONFIG_ANCHOR { fetch = fetch, cache = ref NONE }
117 :    
118 :     fun relativeContext p = RELATIVE p
119 :    
120 :     fun mkElab (cache, name) = let
121 :     val e : elaboration =
122 :     { stamp = !elabStamp, name = name, id = ref NONE }
123 : blume 265 in
124 : blume 270 cache := SOME e; e
125 :     end
126 :    
127 :     fun validElab NONE = NONE
128 :     | validElab (SOME (e as { stamp, name, id })) =
129 :     if stamp = !elabStamp then SOME e else NONE
130 :    
131 :     fun elabContext c =
132 :     case c of
133 : blume 265 CUR { stamp, name, id } =>
134 :     { stamp = !elabStamp, id = ref (SOME id),
135 : blume 270 name = if stamp = cwdStamp () orelse
136 :     name = cwdName ()
137 :     then P.currentArc else name }
138 :     | CONFIG_ANCHOR { fetch, cache } =>
139 :     (case validElab (!cache) of
140 :     SOME e => e
141 :     | NONE => mkElab (cache, fetch ()))
142 :     | RELATIVE p => elab p
143 : blume 265
144 : blume 270 and elab (PATH { context, spec, cache }) =
145 :     (case validElab (!cache) of
146 :     SOME e => e
147 :     | NONE => let
148 :     val name =
149 :     if P.isAbsolute spec then spec
150 :     else P.mkCanonical
151 :     (P.concat (#name (elabContext context),
152 :     spec))
153 :     in
154 :     mkElab (cache, name)
155 :     end)
156 :    
157 : blume 265 (* get the file id (calls elab, so don't cache externally!) *)
158 :     fun id p = let
159 :     val { id, name, ... } = elab p
160 :     in
161 :     case !id of
162 :     NONE => let
163 :     val i = getId name
164 :     in
165 :     id := SOME i; i
166 :     end
167 :     | SOME i => i
168 :     end
169 :    
170 :     (* get the name as a string (calls elab, so don't cache externally!) *)
171 :     fun name p = #name (elab p)
172 :    
173 :     (* compare pathnames efficiently *)
174 :     fun compare (p1, p2) = compareId (id p1, id p2)
175 :    
176 : blume 268 fun fresh (context, spec) =
177 : blume 270 PATH { context = context, spec = spec, cache = ref NONE }
178 : blume 265
179 : blume 268 (* make an abstract path from a native string *)
180 :     fun native { spec, context } = fresh (context, spec)
181 :    
182 : blume 265 (* make an abstract path from a standard string *)
183 :     fun standard { spec, context } = let
184 :     fun delim #"/" = true
185 :     | delim #"\\" = true (* accept DOS-style, too *)
186 :     | delim _ = false
187 :    
188 :     fun transl ".." = OS.Path.parentArc
189 :     | transl "." = OS.Path.currentArc
190 :     | transl arc = arc
191 :    
192 :     fun mk (isAbs, arcs, context) =
193 : blume 268 fresh (context,
194 :     P.toString { isAbs = isAbs, vol = "",
195 :     arcs = map transl arcs })
196 : blume 265 in
197 :     case String.fields delim spec of
198 :     "" :: arcs => mk (true, arcs, context)
199 :     | [] => mk (false, [], context)
200 :     | arcs as (arc1 :: arcn) =>
201 :     (case PathConfig.configAnchor arc1 of
202 :     NONE => mk (false, arcs, context)
203 :     | SOME fetch => let
204 :     val anchorcontext =
205 :     CONFIG_ANCHOR { fetch = fetch,
206 :     cache = ref NONE }
207 :     in
208 :     mk (false, arcn, anchorcontext)
209 :     end)
210 :     end
211 : blume 268
212 : blume 269 (* . and .. are not permitted as file parameter *)
213 : blume 270 fun joinDirFile { dir = PATH { context, spec, ... }, file } =
214 : blume 269 if file = P.currentArc orelse file = P.parentArc then
215 :     raise Fail "AbsPath.joinDirFile: . or .."
216 : blume 270 else fresh (context, P.joinDirFile { dir = spec, file = file })
217 : blume 268
218 : blume 269 (* splitDirFile never walks past a context.
219 :     * Moreover, it is an error to split something that ends in "..". *)
220 : blume 270 fun splitDirFile (PATH { context, spec, ... }) = let
221 :     fun loop "" =
222 :     raise Fail "AbsPath.splitDirFile: tried to split a context"
223 :     | loop spec = let
224 :     val { dir, file } = P.splitDirFile spec
225 :     in
226 :     if file = P.currentArc then loop dir
227 :     else if file = P.parentArc then
228 :     raise Fail "AbsPath.splitDirFile: <path>/.."
229 :     else (dir, file)
230 :     end
231 :     val (dir, file) = loop spec
232 :     val dir = if dir = "" then P.currentArc else dir
233 :     in
234 :     { dir = fresh (context, dir), file = file }
235 :     end
236 : blume 268
237 :     val dir = #dir o splitDirFile
238 :     val file = #file o splitDirFile
239 : blume 265 end
240 :     end

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