Annotation of /sml/trunk/src/cm/paths/abspath.sml

Parent Directory | Revision Log

---

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

---

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