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

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