Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/paths/abspath.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 305, Mon May 31 15:00:06 1999 UTC revision 369, Sun Jul 4 12:55:20 1999 UTC
# Line 7  Line 7 
7   *)   *)
8  signature ABSPATH = sig  signature ABSPATH = sig
9    
10        exception Format        (* if something is seriously wrong with a pickle *)
11        exception BadAnchor of string       (* if anchor cannot be resolved *)
12    
13      type context      type context
14      type t      type t
15      type ord_key = t      type ord_key = t
16    
     val revalidateCwd : unit -> unit  
17      val newEra : unit -> unit      val newEra : unit -> unit
18        val revalidateCwd : unit -> unit
19    
20      val cwdContext: unit -> context      val cwdContext: unit -> context
21      val configContext: (unit -> string) * string -> context      val sameDirContext: t -> context
     val relativeContext: t -> context  
22    
23      val name : t -> string      val osstring : t -> string
24        val descr : t -> string
25      val compare : t * t -> order      val compare : t * t -> order
26      val context : t -> context      val contextOf : t -> context
27      val spec : t -> string      val specOf : t -> string
28      val contextName : context -> string      val contextName : context -> string
29    
30      val native : { context: context, spec: string } -> t      (* Replace the anchor context in the path argument with the
31      val standard : { context: context, spec: string } -> t       * given context. Returns NONE if there was no anchor context. *)
32        val reAnchoredName : t * string -> string option
33    
34      val pickle : t -> string list      val native : { context: context, spec: string } -> t
35      val unpickle : string list -> t option      val standard : PathConfig.mode -> { context: context, spec: string } -> t
36    
37      val joinDirFile : { dir: t, file: string } -> t      (* the second path argument is the path of the group spec that
38      val splitDirFile : t -> { dir: t, file: string }       * pickling is based upon. *)
39      val dir : t -> t      val pickle : (bool -> unit) -> t * t -> string list
40      val file : t -> string      val unpickle : PathConfig.mode -> string list * t -> t
41    
     val exists : t -> bool  
42      val tstamp : t -> TStamp.t      val tstamp : t -> TStamp.t
     val stabletstamp : t -> TStamp.t  
   
     (* The open?Out functions automagically create any necessary directories  
      * and announce this activity via their string consumer argument. *)  
     val openTextIn : t -> TextIO.instream  
     val openTextOut : t -> TextIO.outstream  
     val openBinIn : t -> BinIO.instream  
     val openBinOut : t -> BinIO.outstream  
43  end  end
44    
45  structure AbsPath :> ABSPATH = struct  structure AbsPath :> ABSPATH = struct
46    
47      structure P = OS.Path      structure P = OS.Path
48      structure F = OS.FileSys      structure F = OS.FileSys
49        val impossible = GenericVC.ErrorMsg.impossible
50    
51        exception Format
52        exception BadAnchor of string
53    
54      (* unique file id that can handle absent files *)      (* unique file id that can handle absent files *)
55      datatype id =      datatype id =
# Line 80  Line 79 
79      type cwdinfo = { stamp: unit ref, name: string, id: id }      type cwdinfo = { stamp: unit ref, name: string, id: id }
80    
81      datatype context =      datatype context =
82          CUR of cwdinfo          THEN_CWD of cwdinfo
83        | CONFIG_ANCHOR of { fetch: unit -> string,        | CONFIG_ANCHOR of { fetch: unit -> string,
84                             cache: elaboration option ref,                             cache: elaboration option ref,
85                             config_name: string }                             config_name: string }
86        | RELATIVE of t        | DIR_OF of t
87          | ROOT
88    
89      and  t =      and  t =
90          PATH of { context: context,          PATH of { context: context,
# Line 94  Line 94 
94      type ord_key = t      type ord_key = t
95    
96      local      local
         val elabStamp = ref (ref ())  
97          val cwdInfoCache : cwdinfo option ref = ref NONE          val cwdInfoCache : cwdinfo option ref = ref NONE
98          fun cwdInfo () =          fun cwdInfo () =
99              case !cwdInfoCache of              case !cwdInfoCache of
# Line 111  Line 110 
110          val cwdStamp = #stamp o cwdInfo          val cwdStamp = #stamp o cwdInfo
111          val cwdName = #name o cwdInfo          val cwdName = #name o cwdInfo
112          val cwdId = #id o cwdInfo          val cwdId = #id o cwdInfo
         fun invalidateCwdInfo () = cwdInfoCache := NONE  
113      in      in
114          (* start a new era (i.e., invalidate all previous elaborations) *)          (* start a new era (i.e., invalidate all previous elaborations) *)
115          fun newEra () = elabStamp := ref ()          val newEra = Era.newEra
116    
117          (* make sure the cwd is consistent *)          (* make sure the cwd is consistent *)
118          fun revalidateCwd () =          fun revalidateCwd () =
# Line 132  Line 130 
130                  end                  end
131    
132          fun cwdContext () =          fun cwdContext () =
133              CUR { stamp = cwdStamp (), name = cwdName (), id = cwdId () }              (revalidateCwd ();
134                 THEN_CWD { stamp = cwdStamp (),
135                            name = cwdName (),
136                            id = cwdId () })
137    
138          fun configContext (f, n) =          fun sameDirContext p = DIR_OF p
             CONFIG_ANCHOR { fetch = f, cache = ref NONE, config_name = n }  
   
         fun relativeContext p = RELATIVE p  
139    
140          fun mkElab (cache, name) = let          fun mkElab (cache, name) = let
141              val e : elaboration =              val e : elaboration =
142                  { stamp = !elabStamp, name = name, id = ref NONE }                  { stamp = Era.thisEra (), name = name, id = ref NONE }
143          in          in
144              cache := SOME e; e              cache := SOME e; e
145          end          end
146    
147          fun validElab NONE = NONE          fun validElab NONE = NONE
148            | validElab (SOME (e as { stamp, name, id })) =            | validElab (SOME (e as { stamp, name, id })) =
149              if stamp = !elabStamp then SOME e else NONE              if Era.isThisEra stamp then SOME e else NONE
150    
151            val rootName = P.toString { isAbs = true, arcs = [], vol = "" }
152            val rootId = ref (NONE: id option)
153    
154          fun elabContext c =          fun elabContext c =
155              case c of              case c of
156                  CUR { stamp, name, id } =>                  THEN_CWD { stamp, name, id } =>
157                      { stamp = !elabStamp, id = ref (SOME id),                      { stamp = Era.thisEra (), id = ref (SOME id),
158                        name = if stamp = cwdStamp () orelse                        name = if stamp = cwdStamp () orelse name = cwdName ()
                                 name = cwdName ()  
159                               then P.currentArc else name }                               then P.currentArc else name }
160                | CONFIG_ANCHOR { fetch, cache, config_name } =>                | CONFIG_ANCHOR { fetch, cache, config_name } =>
161                      (case validElab (!cache) of                      (case validElab (!cache) of
162                           SOME e => e                           SOME e => e
163                         | NONE => mkElab (cache, fetch ()))                         | NONE => mkElab (cache, fetch ()))
164                | RELATIVE p => elab p                | DIR_OF p => let
165                        val { name, stamp, ... } = elab p
166                    in
167                        { name = P.dir name, stamp = stamp, id = ref NONE }
168                    end
169                  | ROOT => { stamp = Era.thisEra (),
170                              name = rootName, id = rootId }
171    
172          and elab (PATH { context, spec, cache }) =          and elab (PATH { context, spec, cache }) =
173              (case validElab (!cache) of              case validElab (!cache) of
174                   SOME e => e                   SOME e => e
175                 | NONE => let                | NONE => mkElab (cache,
176                       val name =                                  P.mkCanonical (P.concat
177                           if P.isAbsolute spec then spec                                           (#name (elabContext context), spec)))
                          else P.mkCanonical  
                              (P.concat (#name (elabContext context),  
                                         spec))  
                  in  
                      mkElab (cache, name)  
                  end)  
178    
179          (* get the file id (calls elab, so don't cache externally!) *)          (* get the file id (calls elab, so don't cache externally!) *)
180          fun id p = let          fun id p = let
# Line 190  Line 190 
190          end          end
191    
192          (* get the name as a string (calls elab, so don't cache externally!) *)          (* get the name as a string (calls elab, so don't cache externally!) *)
193          fun name p = #name (elab p)          fun osstring p = #name (elab p)
194    
195          (* get the context back *)          (* get the context back *)
196          fun context (PATH { context = c, ... }) = c          fun contextOf (PATH { context = c, ... }) = c
197          fun contextName c = #name (elabContext c)          fun contextName c = #name (elabContext c)
198    
199          (* get the spec back *)          (* get the spec back *)
200          fun spec (PATH { spec = s, ... }) = s          fun specOf (PATH { spec = s, ... }) = s
201    
202          (* compare pathnames efficiently *)          (* compare pathnames efficiently *)
203          fun compare (p1, p2) = compareId (id p1, id p2)          fun compare (p1, p2) = compareId (id p1, id p2)
# Line 206  Line 206 
206              PATH { context = context, spec = spec, cache = ref NONE }              PATH { context = context, spec = spec, cache = ref NONE }
207    
208          (* make an abstract path from a native string *)          (* make an abstract path from a native string *)
209          fun native { spec, context } = fresh (context, spec)          fun native { spec, context } = let
210                val { isAbs, vol, arcs } = P.fromString spec
211                val relSpec = P.toString { isAbs = false, vol = vol, arcs = arcs }
212            in
213                if isAbs then fresh (ROOT, relSpec)
214                else fresh (context, relSpec)
215            end
216    
217          (* make an abstract path from a standard string *)          (* make an abstract path from a standard string *)
218          fun standard { spec, context } = let          fun standard mode { spec, context } = let
219              fun delim #"/" = true              fun delim #"/" = true
220                | delim #"\\" = true              (* accept DOS-style, too *)                | delim #"\\" = true              (* accept DOS-style, too *)
221                | delim _ = false                | delim _ = false
222    
223              fun transl ".." = OS.Path.parentArc              fun transl ".." = P.parentArc
224                | transl "." = OS.Path.currentArc                | transl "." = P.currentArc
225                | transl arc = arc                | transl arc = arc
226    
227              fun mk (isAbs, arcs, context) =              fun mk (arcs, context) =
228                  fresh (context,                  fresh (context,
229                         P.toString { isAbs = isAbs, vol = "",                         P.toString { isAbs = false, vol = "",
230                                      arcs = map transl arcs })                                      arcs = map transl arcs })
231          in          in
232              case String.fields delim spec of              case String.fields delim spec of
233                  "" :: arcs => mk (true, arcs, context)                  [""] => impossible "AbsPath.standard: zero-length name"
234                | [] => mk (false, [], context) (* shouldn't happen *)                | "" :: arcs => mk (arcs, ROOT)
235                | [arc] => mk (false, [arc], context)                | [] => impossible "AbsPath.standard: no fields"
236                | arcs as (arc1 :: _) =>                | arcs as (arc1 :: _) =>
237                      (case PathConfig.configAnchor arc1 of                      (case PathConfig.configAnchor mode arc1 of
238                           NONE => mk (false, arcs, context)                           NONE => mk (arcs, context)
239                         | SOME fetch => let                         | SOME fetch => let
240                               val anchorcontext =                               val anchorcontext =
241                                   CONFIG_ANCHOR { fetch = fetch,                                   CONFIG_ANCHOR { fetch = fetch,
242                                                   cache = ref NONE,                                                   cache = ref NONE,
243                                                   config_name = arc1 }                                                   config_name = arc1 }
244                           in                           in
245                               mk (false, arcs, anchorcontext)                               mk (arcs, anchorcontext)
246                           end)                           end)
247          end          end
248    
249          (* make a pickle-string *)          (* make a pickle-string *)
250          fun pickle p = let          fun pickle warn (path, gpath) = let
251              fun p_p (PATH { context, spec, ... }) = spec :: p_c context              fun p_p (PATH { spec, context, ... }) =
252              and p_c (CUR _) = ["c"]                  spec :: p_c context
253                and p_c ROOT = (warn true; ["r"])
254                  | p_c (THEN_CWD _) = impossible "AbsPath.pickle: THEN_CWD"
255                | p_c (CONFIG_ANCHOR { config_name = n, ... }) = [n, "a"]                | p_c (CONFIG_ANCHOR { config_name = n, ... }) = [n, "a"]
256                | p_c (RELATIVE p) = p_p p                | p_c (DIR_OF p) =
257                    if compare (p, gpath) = EQUAL then (warn false; ["c"])
258                    else p_p p
259          in          in
260              p_p p              p_p path
261          end          end
262    
263          fun unpickle l = let          fun unpickle mode (l, gpath) = let
264              exception Format              fun u_p (s :: l) =
265              fun u_p (h :: t) =                  PATH { spec = s, context = u_c l, cache = ref NONE }
                 PATH { context = u_c t, spec = h, cache = ref NONE }  
266                | u_p [] = raise Format                | u_p [] = raise Format
267              and u_c ["c"] = cwdContext ()              and u_c ["r"] = ROOT
268                  | u_c ["c"] = DIR_OF gpath
269                | u_c [n, "a"] =                | u_c [n, "a"] =
270                  (case PathConfig.configAnchor n of                  (case PathConfig.configAnchor mode n of
271                       NONE => raise Format                       NONE => raise BadAnchor n
272                     | SOME fetch => CONFIG_ANCHOR { fetch = fetch,                     | SOME fetch =>
273                                                     cache = ref NONE,                           CONFIG_ANCHOR { config_name = n,
274                                                     config_name = n })                                           fetch = fetch,
275                | u_c l = RELATIVE (u_p l)                                           cache = ref NONE })
276          in                | u_c l = DIR_OF (u_p l)
277              SOME (u_p l) handle Format => NONE          in
278          end              u_p l
279            end
280          (* . and .. are not permitted as file parameter *)  
281          fun joinDirFile { dir = PATH { context, spec, ... }, file } =          fun tstamp p = TStamp.fmodTime (osstring p)
282              if file = P.currentArc orelse file = P.parentArc then  
283                  raise Fail "AbsPath.joinDirFile: . or .."          fun descr (PATH { spec, context, ... }) = let
284              else fresh (context, P.joinDirFile { dir = spec, file = file })              fun dir (x, l) =
285                    case P.dir x of
286          (* splitDirFile never walks past a context.                      "" => l
287           * Moreover, it is an error to split something that ends in "..". *)                    | d => d :: "/" :: l
288          fun splitDirFile (PATH { context, spec, ... }) = let              fun d_c (CONFIG_ANCHOR { config_name = n, ... }, l) =
289              fun loop "" =                  "$" :: n :: "/" :: l
290                  raise Fail "AbsPath.splitDirFile: tried to split a context"                | d_c (DIR_OF (PATH { spec, context, ... }), l) =
291                | loop spec = let                  d_c (context, dir (spec, l))
292                      val { dir, file } = P.splitDirFile spec                | d_c (THEN_CWD _, l) = "./" :: l
293                  | d_c (ROOT, l) = "/" :: l
294            in
295                concat (d_c (context, [spec]))
296            end
297    
298            fun reAnchoredName (p, dirstring) = let
299                fun path (PATH { context, spec, ... }) = let
300                    fun mk c = P.concat (c, spec)
301                in
302                    Option.map mk (ctxt context)
303                end
304                and ctxt (CONFIG_ANCHOR { config_name = n, ... }) =
305                    SOME (P.concat (dirstring, n))
306                  | ctxt (DIR_OF p) = Option.map P.dir (path p)
307                  | ctxt (THEN_CWD _) = (Say.say ["."]; NONE)
308                  | ctxt ROOT = (Say.say ["/"]; NONE)
309                  in                  in
310                      if file = P.currentArc then loop dir              Option.map P.mkCanonical (path p)
                     else if file = P.parentArc then  
                         raise Fail "AbsPath.splitDirFile: <path>/.."  
                     else (dir, file)  
311                  end                  end
             val (dir, file) = loop spec  
             val dir = if dir = "" then P.currentArc else dir  
         in  
             { dir = fresh (context, dir), file = file }  
         end  
   
         val dir = #dir o splitDirFile  
         val file = #file o splitDirFile  
   
         fun fileExists n = F.access (n, []) handle _ => false  
         fun fileModTime n = F.modTime n handle _ => Time.zeroTime  
   
         val exists = fileExists o name  
   
         fun tstamp0 TS p = let  
             val n = name p  
         in  
             if fileExists n then TS (fileModTime n) else TStamp.NOTSTAMP  
         end  
         val tstamp = tstamp0 TStamp.TSTAMP  
         val stabletstamp = tstamp0 TStamp.STABLETSTAMP  
   
         fun openOut fileopener ap = let  
             val p = name ap  
             fun generic (maker, pmaker, p) =  
                 maker p  
                 handle exn => let  
                     val { dir, ... } = P.splitDirFile p  
                 in  
                     if dir = "" orelse fileExists dir then raise exn  
                     else (pmaker dir; maker p)  
                 end  
             fun makedirs dir = generic (F.mkDir, makedirs, dir)  
             fun advertisemakedirs dir =  
                 (Say.vsay (concat ["[creating directory ", dir, " ...]\n"]);  
                  makedirs dir)  
         in  
             generic (fileopener, advertisemakedirs, p)  
         end  
   
         val openTextIn = TextIO.openIn o name  
         val openBinIn = BinIO.openIn o name  
         val openTextOut = openOut TextIO.openOut  
         val openBinOut = openOut BinIO.openOut  
312      end      end
313  end  end

Legend:
Removed from v.305  
changed lines
  Added in v.369

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