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

Parent Directory | Revision Log

---

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

---

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