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 274, Fri May 14 05:23:02 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
16    
17        val newEra : unit -> unit
18      val revalidateCwd : unit -> unit      val revalidateCwd : unit -> unit
19    
20      val cwdContext: unit -> context      val cwdContext: unit -> context
21      val configContext: (unit -> 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        (* Replace the anchor context in the path argument with the
31         * given context. Returns NONE if there was no anchor context. *)
32        val reAnchoredName : t * string -> string option
33    
34      val native : { context: context, spec: string } -> t      val native : { context: context, spec: string } -> t
35      val standard : { context: context, spec: string } -> t      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  
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 68  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        | RELATIVE of t                             config_name: string }
86          | DIR_OF of t
87          | ROOT
88    
89      and  t =      and  t =
90          PATH of { context: context,          PATH of { context: context,
91                    spec: string,                    spec: string,
92                    cache: elaboration option ref }                    cache: elaboration option ref }
93    
94        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 96  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 117  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          fun configContext fetch =                          name = cwdName (),
136              CONFIG_ANCHOR { fetch = fetch, cache = ref NONE }                          id = cwdId () })
137    
138          fun relativeContext p = RELATIVE p          fun sameDirContext p = DIR_OF 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_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 175  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 191  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)                | "" :: arcs => mk (arcs, ROOT)
235                | arcs as (arc1 :: arcn) =>                | [] => impossible "AbsPath.standard: no fields"
236                      (case PathConfig.configAnchor arc1 of                | arcs as (arc1 :: _) =>
237                           NONE => mk (false, arcs, context)                      (case PathConfig.configAnchor mode arc1 of
238                             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 }
244                           in                           in
245                               mk (false, arcn, anchorcontext)                               mk (arcs, anchorcontext)
246                           end)                           end)
247          end          end
248    
249          (* . and .. are not permitted as file parameter *)          (* make a pickle-string *)
250          fun joinDirFile { dir = PATH { context, spec, ... }, file } =          fun pickle warn (path, gpath) = let
251              if file = P.currentArc orelse file = P.parentArc then              fun p_p (PATH { spec, context, ... }) =
252                  raise Fail "AbsPath.joinDirFile: . or .."                  spec :: p_c context
253              else fresh (context, P.joinDirFile { dir = spec, file = file })              and p_c ROOT = (warn true; ["r"])
254                  | p_c (THEN_CWD _) = impossible "AbsPath.pickle: THEN_CWD"
255          (* splitDirFile never walks past a context.                | p_c (CONFIG_ANCHOR { config_name = n, ... }) = [n, "a"]
256           * Moreover, it is an error to split something that ends in "..". *)                | p_c (DIR_OF p) =
257          fun splitDirFile (PATH { context, spec, ... }) = let                  if compare (p, gpath) = EQUAL then (warn false; ["c"])
258              fun loop "" =                  else p_p p
259                  raise Fail "AbsPath.splitDirFile: tried to split a context"          in
260                | loop spec = let              p_p path
261                      val { dir, file } = P.splitDirFile spec          end
262                  in  
263                      if file = P.currentArc then loop dir          fun unpickle mode (l, gpath) = let
264                      else if file = P.parentArc then              fun u_p (s :: l) =
265                          raise Fail "AbsPath.splitDirFile: <path>/.."                  PATH { spec = s, context = u_c l, cache = ref NONE }
266                      else (dir, file)                | u_p [] = raise Format
267                  end              and u_c ["r"] = ROOT
268              val (dir, file) = loop spec                | u_c ["c"] = DIR_OF gpath
269              val dir = if dir = "" then P.currentArc else dir                | u_c [n, "a"] =
270          in                  (case PathConfig.configAnchor mode n of
271              { dir = fresh (context, dir), file = file }                       NONE => raise BadAnchor n
272          end                     | SOME fetch =>
273                             CONFIG_ANCHOR { config_name = n,
274          val dir = #dir o splitDirFile                                           fetch = fetch,
275          val file = #file o splitDirFile                                           cache = ref NONE })
276                  | u_c l = DIR_OF (u_p l)
277          fun fileExists n = F.access (n, []) handle _ => false          in
278          fun fileModTime n = F.modTime n handle _ => Time.zeroTime              u_p l
279            end
280          val exists = fileExists o name  
281            fun tstamp p = TStamp.fmodTime (osstring p)
282          fun tstamp0 TS p = let  
283              val n = name p          fun descr (PATH { spec, context, ... }) = let
284                fun dir (x, l) =
285                    case P.dir x of
286                        "" => l
287                      | d => d :: "/" :: l
288                fun d_c (CONFIG_ANCHOR { config_name = n, ... }, l) =
289                    "$" :: n :: "/" :: l
290                  | d_c (DIR_OF (PATH { spec, context, ... }), l) =
291                    d_c (context, dir (spec, l))
292                  | 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 fileExists n then TS (fileModTime n) else TStamp.NOTSTAMP              Option.map P.mkCanonical (path p)
311          end          end
         val tstamp = tstamp0 TStamp.TSTAMP  
         val stabletstamp = tstamp0 TStamp.STABLETSTAMP  
312      end      end
313  end  end

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

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