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

Parent Directory | 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