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/srcpath.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1368 - (view) (download)

1 : blume 354 (*
2 : blume 666 * Operations over abstract names for CM source files.
3 : blume 354 *
4 : blume 666 * Copyright (c) 2000 by Lucent Technologies, Bell Laboratories
5 : blume 354 *
6 : blume 801 * Author: Matthias Blume
7 : blume 354 *)
8 :     signature SRCPATH = sig
9 : blume 367
10 : blume 666 exception Format
11 : blume 367
12 : blume 666 type file
13 :     type dir
14 :     type env
15 :     type anchor = string
16 :     type prefile
17 : blume 354
18 : blume 666 type rebindings = { anchor: anchor, value: prefile } list
19 : blume 354
20 : blume 666 type ord_key = file
21 :    
22 :     (* path comparison *)
23 :     val compare : file * file -> order
24 :    
25 :     (* re-establish stability of ordering *)
26 : blume 354 val sync : unit -> unit
27 :    
28 : blume 666 (* forget all known path names *)
29 :     val clear : unit -> unit
30 :    
31 :     (* re-validate current working directory *)
32 : blume 366 val revalidateCwd : unit -> unit
33 :    
34 : blume 735 (* register a "client" module that wishes to be notified when
35 :     * the CWD changes *)
36 :     val addClientToBeNotified : (string -> unit) -> unit
37 :    
38 :     (* make sure all such clients get notified about the a CWD during
39 :     * next validation *)
40 : blume 666 val scheduleNotification : unit -> unit
41 : blume 464
42 : blume 666 (* new "empty" env *)
43 :     val newEnv : unit -> env
44 : blume 354
45 : blume 666 (* destructive updates to anchor settings (for configuration) *)
46 :     val set_anchor : env * anchor * string option -> unit (* native syntax! *)
47 :     val get_anchor : env * anchor -> string option
48 :     val reset_anchors : env -> unit
49 : blume 366
50 : blume 735 (* process a specification file; must sync afterwards!
51 :     * The function argument is used for issuing warnings. *)
52 :     val processSpecFile :
53 :     { env : env, specfile : string, say : string list -> unit }
54 :     -> TextIO.instream -> unit
55 : blume 354
56 : blume 666 (* non-destructive bindings for anchors (for anchor scoping) *)
57 :     val bind: env -> rebindings -> env
58 : blume 354
59 : blume 666 (* make abstract paths *)
60 :     val native : { err: string -> unit } ->
61 :     { context: dir, spec: string } -> prefile
62 :     val standard : { err: string -> unit, env: env } ->
63 :     { context: dir, spec: string } -> prefile
64 : blume 457
65 : blume 756 (* augment a prefile (naming a directory) with a list of arcs... *)
66 :     val extend : prefile -> string list -> prefile
67 :    
68 : blume 666 (* check that there is at least one arc in after the path's context *)
69 :     val file : prefile -> file
70 : blume 354
71 : blume 666 (* To be able to pickle a file, turn it into a prefile first... *)
72 :     val pre : file -> prefile
73 :    
74 :     (* directory paths (contexts) *)
75 :     val cwd : unit -> dir
76 :     val dir : file -> dir
77 :    
78 :     (* get info out of abstract paths *)
79 :     val osstring : file -> string
80 :     val osstring' : file -> string (* use relative path if shorter *)
81 :    
82 :     (* expand root anchors using given function *)
83 :     val osstring_reanchored : (anchor -> string) -> file -> string option
84 :    
85 :     (* get path relative to the file's context; this will produce an
86 :     * absolute path if the original spec was not relative (i.e., if
87 :     * it was anchored or absolute) *)
88 :     val osstring_relative : file -> string
89 :    
90 : blume 756 (* same for prefile *)
91 :     val osstring_prefile_relative : prefile -> string
92 :    
93 : blume 666 (* get name of dir *)
94 :     val osstring_dir : dir -> string
95 :    
96 : blume 678 (* get name of prefile *)
97 :     val osstring_prefile : prefile -> string
98 :    
99 : blume 666 (* get a human-readable (well, sort of) description *)
100 :     val descr : file -> string
101 :    
102 :     (* get a time stamp *)
103 :     val tstamp : file -> TStamp.t
104 :    
105 :     (* portable encodings that avoid whitespace *)
106 :     val encode : file -> string
107 :     val decode : env -> string -> file
108 :    
109 : blume 735 (* check whether encoding (result of "encode") is absolute
110 :     * (i.e., not anchored and not relative) *)
111 :     val encodingIsAbsolute : string -> bool
112 :    
113 : blume 666 val pickle : { warn: bool * string -> unit } ->
114 : mblume 1342 { file: prefile, relativeTo: file } -> string list list
115 : blume 666
116 : mblume 1342 val unpickle : env ->
117 :     { pickled: string list list, relativeTo: file } -> prefile
118 : blume 354 end
119 :    
120 :     structure SrcPath :> SRCPATH = struct
121 :    
122 : blume 666 exception Format
123 : blume 367
124 : blume 666 structure P = OS.Path
125 :     structure F = OS.FileSys
126 :     structure I = FileId
127 : blume 735 structure StringMap = RedBlackMapFn (struct type ord_key = string
128 :     val compare = String.compare
129 :     end)
130 : blume 354
131 : blume 735 fun impossible s = raise Fail ("impossible error in SrcPath: " ^ s)
132 : blume 354
133 : blume 666 type anchor = string
134 : blume 354
135 : blume 666 type stableid = int
136 : blume 354
137 : blume 666 (* A pre-path is similar to the result of P.fromString except that
138 :     * we keep the list of arcs in reversed order. This makes adding
139 :     * and removing arcs at the end easier. *)
140 :     type prepath = { revarcs: string list, vol: string, isAbs: bool }
141 : blume 354
142 : blume 759 type elab = { pp: prepath,
143 :     valid: unit -> bool,
144 :     reanchor: (anchor -> string) -> prepath option }
145 : blume 354
146 : blume 801 type anchorval = (unit -> elab) * (bool -> string)
147 : blume 666
148 :     datatype dir =
149 :     CWD of { name: string, pp: prepath }
150 : blume 801 | ANCHOR of { name: anchor, look: unit -> elab,
151 :     encode : bool -> string option }
152 : blume 666 | ROOT of string
153 :     | DIR of file0
154 :    
155 :     and file0 =
156 :     PATH of { context: dir,
157 :     arcs: string list, (* at least one arc! *)
158 :     elab: elab ref,
159 :     id: I.id option ref }
160 :    
161 :     type file = file0 * stableid
162 :    
163 :     type prefile = { context: dir, arcs: string list, err: string -> unit }
164 :    
165 :     type rebindings = { anchor: anchor, value: prefile } list
166 :    
167 : blume 801 type env =
168 :     { get_free: anchor -> elab,
169 :     set_free: anchor * prepath option -> unit,
170 :     is_set: anchor -> bool,
171 :     reset: unit -> unit,
172 :     bound: anchorval StringMap.map }
173 :    
174 : blume 666 type ord_key = file
175 :    
176 :     (* stable comparison *)
177 :     fun compare (f1: file, f2: file) = Int.compare (#2 f1, #2 f2)
178 :    
179 :     val null_pp : prepath = { revarcs = [], vol = "", isAbs = false }
180 : blume 759 val bogus_elab : elab =
181 :     { pp = null_pp, valid = fn _ => false, reanchor = fn _ => NONE }
182 : blume 666
183 :     fun string2pp n = let
184 :     val { arcs, vol, isAbs } = P.fromString n
185 :     in
186 :     { revarcs = rev arcs, vol = vol, isAbs = isAbs }
187 :     end
188 :    
189 :     val cwd_info =
190 :     let val n = F.getDir ()
191 :     in ref { name = n, pp = string2pp n }
192 :     end
193 :     val cwd_notify = ref true
194 :    
195 :     fun absElab (arcs, vol) =
196 :     { pp = { revarcs = rev arcs, vol = vol, isAbs = true },
197 : blume 759 valid = fn () => true, reanchor = fn _ => NONE }
198 : blume 666
199 :     fun unintern (f: file) = #1 f
200 :    
201 : blume 801 fun pre0 (PATH { arcs, context, ... }) =
202 :     { arcs = arcs, context = context, err = fn (_: string) => () }
203 :     val pre = pre0 o unintern
204 :    
205 :     fun encode0 bracket (pf: prefile) = let
206 : blume 1190 fun needesc c = not (Char.isPrint c) orelse Char.contains "/:\\$%()" c
207 : blume 666 fun esc c =
208 :     "\\" ^ StringCvt.padLeft #"0" 3 (Int.toString (Char.ord c))
209 :     fun tc c = if needesc c then esc c else String.str c
210 :     val ta = String.translate tc
211 :     val (dot, dotdot) = let
212 :     val ta' = String.translate esc
213 :     in
214 :     (ta' ".", ta' "..")
215 :     end
216 : blume 801 infixr 5 ::/::
217 :     fun arc ::/:: [] = [arc]
218 :     | arc ::/:: a = arc :: "/" :: a
219 : blume 666 fun arc a =
220 :     if a = P.currentArc then "."
221 :     else if a = P.parentArc then ".."
222 :     else if a = "." then dot
223 :     else if a = ".." then dotdot
224 :     else ta a
225 : blume 801 fun e_ac ([], context, _, a) = e_c (context, a, NONE)
226 :     | e_ac (arcs, context, ctxt, a) =
227 : blume 736 let val l = map arc arcs
228 :     val a0 = List.hd l
229 : blume 1190 val l' = map arc (rev l)
230 : blume 736 val l'' = if ctxt andalso bracket then
231 :     concat ["(", List.hd l', ")"] :: List.tl l'
232 :     else l'
233 : blume 1190 val a' = foldl (fn (x, l) => x ::/:: l)
234 :     (List.hd l'' :: a) (List.tl l'')
235 : blume 736 in e_c (context, a', SOME a0)
236 : blume 666 end
237 : blume 736 and e_c (ROOT "", a, _) = concat ("/" :: a)
238 : blume 801 | e_c (ROOT vol, a, _) = concat ("%" :: ta vol ::/:: a)
239 : blume 736 | e_c (CWD _, a, _) = concat a
240 : blume 801 | e_c (ANCHOR x, a, a1opt) =
241 :     (case (#encode x bracket, a1opt) of
242 :     (SOME ad, _) =>
243 :     if not bracket then concat (ad ::/:: a)
244 :     else concat ("$" :: ta (#name x) :: "(=" :: ad :: ")/" :: a)
245 :     | (NONE, NONE) => concat ("$" :: ta (#name x) ::/:: a)
246 :     | (NONE, SOME a1) => let
247 :     val a0 = ta (#name x)
248 :     in
249 :     concat (if bracket andalso a0 = a1 then "$/" :: a
250 :     else "$" :: a0 ::/:: a)
251 :     end)
252 :     | e_c (DIR (PATH { arcs, context, ... }), a, _) =
253 :     e_ac (arcs, context, true, ":" :: a)
254 : blume 666 in
255 : blume 801 e_ac (#arcs pf, #context pf, false, [])
256 : blume 666 end
257 :    
258 : blume 801 fun mk_anchor (e: env, a) =
259 :     case StringMap.find (#bound e, a) of
260 :     SOME (elaborate, encode) =>
261 :     { name = a , look = elaborate, encode = SOME o encode }
262 :     | NONE =>
263 :     { name = a, look = fn () => #get_free e a, encode = fn _ => NONE }
264 :    
265 :     val encode_prefile = encode0 false
266 :     val encode = encode_prefile o pre
267 : blume 666
268 : blume 735 val clients = ref ([] : (string -> unit) list)
269 :     fun addClientToBeNotified c = clients := c :: !clients
270 :    
271 : blume 666 fun revalidateCwd () = let
272 :     val { name = n, pp } = !cwd_info
273 :     val n' = F.getDir ()
274 :     val pp' = string2pp n'
275 :     in
276 :     if n = n' then ()
277 :     else (cwd_info := { name = n', pp = pp' };
278 :     cwd_notify := true);
279 :     if !cwd_notify then
280 : blume 801 let val pf = { arcs = rev (#revarcs pp),
281 :     context = ROOT (#vol pp),
282 :     err = fn (_: string) => () }
283 :     val ep = encode_prefile pf
284 : blume 354 in
285 : blume 735 app (fn c => c ep) (!clients);
286 : blume 666 cwd_notify := false
287 : blume 354 end
288 : blume 666 else ()
289 :     end
290 : blume 354
291 : blume 666 fun scheduleNotification () = cwd_notify := true
292 : blume 354
293 : blume 666 fun dirPP { revarcs = _ :: revarcs, vol, isAbs } =
294 :     { revarcs = revarcs, vol = vol, isAbs = isAbs }
295 :     | dirPP _ = impossible "dirPP"
296 : blume 354
297 : blume 759 fun dirElab { pp, valid, reanchor } =
298 :     { pp = dirPP pp, valid = valid,
299 :     reanchor = Option.map dirPP o reanchor }
300 : blume 666
301 :     fun augPP arcs { revarcs, vol, isAbs } =
302 :     { revarcs = List.revAppend (arcs, revarcs), vol = vol, isAbs = isAbs }
303 :    
304 : blume 759 fun augElab arcs { pp, valid, reanchor } =
305 :     { pp = augPP arcs pp, valid = valid,
306 :     reanchor = Option.map (augPP arcs) o reanchor }
307 : blume 666
308 :     fun elab_dir (CWD { name, pp }) =
309 :     let fun valid () = name = #name (!cwd_info)
310 : blume 759 fun reanchor (a: anchor -> string) = NONE
311 : blume 666 in
312 : blume 759 if valid () then { pp = null_pp, valid = valid,
313 :     reanchor = reanchor }
314 :     else { pp = pp, valid = fn () => true, reanchor = reanchor }
315 : blume 666 end
316 : blume 801 | elab_dir (ANCHOR { name, look, encode }) = look ()
317 : blume 666 | elab_dir (ROOT vol) = absElab ([], vol)
318 :     | elab_dir (DIR p) = dirElab (elab_file p)
319 :    
320 :     and elab_file (PATH { context, arcs, elab, id }) =
321 : blume 759 let val e as { pp, valid, reanchor } = !elab
322 : blume 666 in
323 :     if valid () then e
324 :     else let val e' = augElab arcs (elab_dir context)
325 :     in elab := e'; id := NONE; e'
326 :     end
327 :     end
328 :    
329 :     fun pp2name { revarcs, vol, isAbs } =
330 :     P.toString { arcs = rev revarcs, vol = vol, isAbs = isAbs }
331 :    
332 :     fun idOf (p as PATH { id, ... }) =
333 :     let val { pp, ... } = elab_file p
334 :     in
335 :     case !id of
336 :     SOME i => i
337 :     | NONE => let
338 :     val i = I.fileId (pp2name pp)
339 :     in
340 :     id := SOME i; i
341 :     end
342 :     end
343 :    
344 :     fun compare0 (f1, f2) = I.compare (idOf f1, idOf f2)
345 :    
346 : blume 735 structure F0M = RedBlackMapFn (type ord_key = file0 val compare = compare0)
347 : blume 666
348 :     local
349 :     val known = ref (F0M.empty: int F0M.map)
350 :     val next = ref 0
351 :     in
352 :     fun clear () = known := F0M.empty
353 :    
354 :     fun intern f =
355 :     case F0M.find (!known, f) of
356 :     SOME i => (f, i)
357 :     | NONE => let
358 :     val i = !next
359 :     in
360 :     next := i + 1;
361 :     known := F0M.insert (!known, f, i);
362 :     (f, i)
363 :     end
364 :    
365 :     fun sync () = let
366 :     val km = !known
367 :     fun inval (PATH { id, ... }, _) = id := NONE
368 :     fun reinsert (k, v, m) = F0M.insert (m, k, v)
369 :     in
370 :     F0M.appi inval km;
371 :     known := F0M.foldli reinsert F0M.empty km
372 :     end
373 :     end
374 :    
375 :     val dir0 = DIR
376 :     val dir = dir0 o unintern
377 :    
378 :     fun cwd () = (revalidateCwd (); CWD (!cwd_info))
379 :    
380 : blume 937 val osstring = I.canonical o pp2name o #pp o elab_file o unintern
381 : blume 666
382 : blume 678 fun osstring_prefile { context, arcs, err } =
383 : blume 937 I.canonical (pp2name (#pp (augElab arcs (elab_dir context))))
384 : blume 678
385 : blume 801 val descr = encode0 true o pre
386 : blume 666
387 : blume 671 fun osstring_dir d =
388 :     case pp2name (#pp (elab_dir d)) of
389 :     "" => P.currentArc
390 : blume 937 | s => I.canonical s
391 : blume 666
392 :     fun osstring' f = let
393 :     val oss = osstring f
394 :     in
395 :     if P.isAbsolute oss then
396 :     let val ross =
397 :     P.mkRelative { path = oss, relativeTo = #name (!cwd_info) }
398 :     in
399 :     if size ross < size oss then ross else oss
400 :     end
401 :     else oss
402 :     end
403 :    
404 :     fun newEnv () = let
405 :     val freeMap = ref StringMap.empty
406 :     fun fetch a =
407 :     case StringMap.find (!freeMap, a) of
408 :     SOME x => x
409 :     | NONE => let
410 :     val validity = ref true
411 :     val pp = { revarcs = [concat ["$Undef<", a, ">"]],
412 :     vol = "", isAbs = false }
413 :     val x = (pp, validity)
414 :     in
415 :     freeMap := StringMap.insert (!freeMap, a, x);
416 :     x
417 :     end
418 :     fun get_free a = let
419 :     val (pp, validity) = fetch a
420 : blume 759 fun reanchor cvt = SOME (string2pp (cvt a))
421 : blume 666 in
422 : blume 759 { pp = pp, valid = fn () => !validity, reanchor = reanchor }
423 : blume 666 end
424 :     fun set_free (a, ppo) = let
425 :     val (_, validity) = fetch a
426 :     in
427 :     validity := false; (* invalidate earlier elabs *)
428 :     freeMap :=
429 :     (case ppo of
430 :     NONE => #1 (StringMap.remove (!freeMap, a))
431 :     | SOME pp => StringMap.insert (!freeMap, a, (pp, ref true)))
432 :     end
433 :     fun is_set a = StringMap.inDomain (!freeMap, a)
434 :     fun reset () = let
435 :     fun invalidate (_, validity) = validity := false
436 :     in
437 :     StringMap.app invalidate (!freeMap);
438 :     freeMap := StringMap.empty
439 :     end
440 :     in
441 :     { get_free = get_free, set_free = set_free, is_set = is_set,
442 :     reset = reset, bound = StringMap.empty } : env
443 :     end
444 :    
445 :     fun get_anchor (e: env, a) =
446 :     if #is_set e a then SOME (pp2name (#pp (#get_free e a))) else NONE
447 :    
448 :     fun set0 mkAbsolute (e: env, a, so) = let
449 :     fun name2pp s = string2pp (if P.isAbsolute s then s else mkAbsolute s)
450 :     in
451 : blume 676 #set_free e (a, Option.map name2pp so)
452 : blume 666 end
453 :    
454 :     fun set_anchor x =
455 :     set0 (fn n => P.mkAbsolute { path = n, relativeTo = F.getDir () }) x
456 : blume 676 before sync ()
457 : blume 666
458 :     fun reset_anchors (e: env) = (#reset e (); sync ())
459 :    
460 : blume 735 fun processSpecFile { env = e, specfile = f, say } = let
461 : blume 666 val d = P.dir (F.fullPath f)
462 :     fun set x = set0 (fn n => P.mkAbsolute { path = n, relativeTo = d }) x
463 : mblume 1342 fun mknative true d = d
464 :     | mknative false d = let
465 :     fun return (abs, arcs) =
466 :     P.toString { vol = "", isAbs = abs, arcs = arcs }
467 :     in
468 :     case String.fields (fn c => c = #"/") d of
469 :     "" :: arcs => return (true, arcs)
470 :     | arcs => return (false, arcs)
471 :     end
472 : blume 666 fun work s = let
473 : mblume 1368 fun loop isnative =
474 :     case TextIO.inputLine s of
475 :     NONE => ()
476 :     | SOME line =>
477 :     if String.sub (line, 0) = #"#" then loop isnative
478 :     else case String.tokens Char.isSpace line of
479 :     ["!standard"] => loop false
480 :     | ["!native"] => loop true
481 :     | [a, d] =>
482 :     (set (e, a, SOME (mknative isnative d));
483 :     loop isnative)
484 :     | ["-"] => (#reset e (); loop isnative)
485 :     | [a] => (set (e, a, NONE); loop isnative)
486 :     | [] => loop isnative
487 :     | _ => (say [f, ": malformed line (ignored)\n"];
488 :     loop isnative)
489 : blume 666 in
490 : mblume 1342 loop true
491 : blume 666 end
492 :     in
493 : blume 735 work
494 : blume 666 end
495 :    
496 :     datatype stdspec =
497 :     RELATIVE of string list
498 :     | ABSOLUTE of string list
499 :     | ANCHORED of anchor * string list
500 :    
501 :     fun parseStdspec err s = let
502 :     fun delim #"/" = true
503 :     | delim #"\\" = true
504 :     | delim _ = false
505 :     fun transl ".." = P.parentArc
506 :     | transl "." = P.currentArc
507 :     | transl arc = arc
508 :     val impossible = fn s => impossible ("AbsPath.parseStdspec: " ^ s)
509 :     in
510 :     case map transl (String.fields delim s) of
511 :     [""] => impossible "zero-length name"
512 :     | [] => impossible "no fields"
513 :     | "" :: arcs => ABSOLUTE arcs
514 :     | arcs as (["$"] | "$" :: "" :: _) =>
515 :     (err (concat ["invalid zero-length anchor name in: `", s, "'"]);
516 :     RELATIVE arcs)
517 :     | "$" :: (arcs as (arc1 :: _)) => ANCHORED (arc1, arcs)
518 :     | arcs as (arc1 :: arcn) =>
519 :     if String.sub (arc1, 0) <> #"$" then RELATIVE arcs
520 :     else ANCHORED (String.extract (arc1, 1, NONE), arcn)
521 :     end
522 :    
523 : blume 801 fun bind (env: env) l = let
524 :     fun b ({ anchor, value = pf as { arcs, context, err } }, m) =
525 :     StringMap.insert (m, anchor,
526 :     (fn () => augElab arcs (elab_dir context),
527 :     fn brack => encode0 brack pf))
528 :    
529 : blume 666 in
530 : blume 801 { get_free = #get_free env, set_free = #set_free env,
531 :     reset = #reset env, is_set = #is_set env,
532 :     bound = foldl b (#bound env) l }
533 : blume 666 end
534 :    
535 :     fun file0 ({ context, arcs, err }: prefile) =
536 :     PATH { context = context, elab = ref bogus_elab, id = ref NONE,
537 :     arcs = (case arcs of
538 :     [] => (err (concat
539 :     ["path needs at least one arc relative to `",
540 :     pp2name (#pp (elab_dir context)), "'"]);
541 :     ["<bogus>"])
542 :     | _ => arcs) }
543 :    
544 :     val file = intern o file0
545 :    
546 :     fun prefile (c, l, e) = { context = c, arcs = l, err = e }
547 :    
548 :     fun native { err } { context, spec } =
549 :     case P.fromString spec of
550 :     { arcs, vol, isAbs = true } => prefile (ROOT vol, arcs, err)
551 :     | { arcs, ... } => prefile (context, arcs, err)
552 :    
553 :     fun standard { env, err } { context, spec } =
554 :     case parseStdspec err spec of
555 :     RELATIVE l => prefile (context, l, err)
556 :     | ABSOLUTE l => prefile (ROOT "", l, err)
557 :     | ANCHORED (a, l) =>
558 : blume 801 prefile (ANCHOR (mk_anchor (env, a)), l, err)
559 : blume 666
560 : blume 756 fun extend { context, arcs, err } morearcs =
561 :     { context = context, arcs = arcs @ morearcs, err = err }
562 :    
563 : blume 759 fun osstring_reanchored cvt f =
564 : blume 937 Option.map (I.canonical o pp2name)
565 :     (#reanchor (elab_file (unintern f)) cvt)
566 : blume 666
567 : blume 756 fun osstring_prefile_relative (p as { arcs, context, ... }) =
568 : blume 666 case context of
569 : blume 937 DIR _ => I.canonical
570 :     (P.toString { arcs = arcs, vol = "", isAbs = false })
571 : blume 756 | _ => osstring_prefile p
572 : blume 666
573 : blume 756 val osstring_relative = osstring_prefile_relative o pre
574 :    
575 : blume 666 fun tstamp f = TStamp.fmodTime (osstring f)
576 :    
577 :     fun pickle { warn } { file = (f: prefile), relativeTo = (gf, _) } = let
578 :     val warn =
579 :     fn flag =>
580 :     warn (flag,
581 :     (* HACK! We are cheating here, turning the prefile into
582 :     * a file even when there are no arcs. This is ok
583 :     * because of (bracket = false) for encode0. *)
584 : blume 801 encode_prefile { arcs = #arcs f,
585 :     context = #context f,
586 :     err = fn (_: string) => () })
587 : blume 666 fun p_p p = p_pf (pre0 p)
588 :     and p_pf { arcs, context, err } =
589 : mblume 1342 arcs :: p_c context
590 :     and p_c (ROOT vol) = (warn true; [[vol, "r"]])
591 : blume 666 | p_c (CWD _) = impossible "pickle: CWD"
592 : mblume 1342 | p_c (ANCHOR { name, ... }) = [[name, "a"]]
593 :     | p_c (DIR p) = if compare0 (p, gf) = EQUAL then
594 :     (warn false; [["c"]])
595 : blume 666 else p_p p
596 :     in
597 :     p_pf f
598 :     end
599 :    
600 :     fun unpickle env { pickled, relativeTo } = let
601 : mblume 1342 fun u_pf (arcs :: l) = prefile (u_c l, arcs, fn _ => raise Format)
602 : blume 666 | u_pf _ = raise Format
603 :     and u_p l = file0 (u_pf l)
604 : mblume 1342 and u_c [[vol, "r"]] = ROOT vol
605 :     | u_c [["c"]] = dir relativeTo
606 :     | u_c [[n, "a"]] = ANCHOR (mk_anchor (env, n))
607 : blume 666 | u_c l = DIR (u_p l)
608 :     in
609 :     u_pf pickled
610 :     end
611 :    
612 :     fun decode env s = let
613 :     fun isChar (c1: char) c2 = c1 = c2
614 :     fun unesc s = let
615 :     val dc = Char.chr o valOf o Int.fromString o implode
616 :     fun loop ([], r) = String.implode (rev r)
617 :     | loop (#"\\" :: d0 :: d1 :: d2 :: l, r) =
618 :     (loop (l, dc [d0, d1, d2] :: r)
619 :     handle _ => loop (l, d2 :: d1 :: d0 :: #"\\" :: r))
620 :     | loop (c :: l, r) = loop (l, c :: r)
621 :     in
622 :     loop (String.explode s, [])
623 :     end
624 :     fun arc "." = P.currentArc
625 :     | arc ".." = P.parentArc
626 :     | arc a = unesc a
627 :     fun file (c, l) =
628 :     file0 (prefile (c, l, fn s => raise Fail ("SrcPath.decode: " ^ s)))
629 :     fun addseg (seg, p) =
630 :     file (dir0 p, map arc (String.fields (isChar #"/") seg))
631 :     fun doseg0 s =
632 :     case String.fields (isChar #"/") s of
633 :     [] => impossible "decode: no fields in segment 0"
634 :     | arc0 :: arcs => let
635 :     val arcs = map arc arcs
636 :     fun xtr () = unesc (String.extract (arc0, 1, NONE))
637 : mblume 1342
638 :     fun say l = TextIO.output (TextIO.stdErr, concat l)
639 : blume 666 in
640 :     if arc0 = "" then file (ROOT "", arcs)
641 :     else
642 :     case String.sub (arc0, 0) of
643 :     #"%" => file (ROOT (xtr ()), arcs)
644 :     | #"$" => let
645 :     val n = xtr ()
646 :     in
647 : blume 801 file (ANCHOR (mk_anchor (env, n)), arcs)
648 : blume 666 end
649 :     | _ => file (cwd (), arc arc0 :: arcs)
650 :     end
651 :     in
652 :     case String.fields (isChar #":") s of
653 :     [] => impossible "decode: no segments"
654 :     | seg0 :: segs => intern (foldl addseg (doseg0 seg0) segs)
655 :     end
656 : blume 735
657 :     fun encodingIsAbsolute s =
658 :     (case String.sub (s, 0) of (#"/" | #"%") => true | _ => false)
659 :     handle _ => false
660 : blume 354 end

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