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/system/Basis/Implementation/OS/os-path-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/Basis/Implementation/OS/os-path-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1240 - (view) (download)

1 : monnier 416 (* os-path-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * A functorized implementation of the OS.Path structure.
6 :     *
7 :     * NOTE: these operations are currently not very efficient, since they
8 :     * explode the path into its volume and arcs. A better implementation
9 :     * would work "in situ."
10 :     *
11 :     *)
12 :    
13 :     local
14 :     structure String = StringImp
15 :     in
16 :     functor OS_PathFn (OSPathBase : sig
17 :    
18 :     exception Path
19 :    
20 :     datatype arc_kind = Null | Parent | Current | Arc of string
21 :     val classify : string -> arc_kind
22 :     val parentArc : string
23 :     val currentArc : string
24 :     val validVolume : (bool * Substring.substring) -> bool
25 :     val splitVolPath : string -> (bool * Substring.substring * Substring.substring)
26 :     (* Split a string into the volume part and arcs part and note whether it
27 :     * is absolute.
28 :     * Note: it is guaranteed that this is never called with "".
29 :     *)
30 :     val joinVolPath : (bool * string * string) -> string
31 :     (* join a volume and path; raise Path on invalid volumes *)
32 :     val arcSepChar : char
33 :     (* the character used to separate arcs (e.g., #"/" on UNIX) *)
34 :    
35 :     end) : OS_PATH = struct
36 :    
37 :     structure P = OSPathBase
38 :     structure SS = Substring
39 :    
40 :     exception Path = P.Path
41 :    
42 :     val arcSepStr = String.str P.arcSepChar
43 :    
44 :     val parentArc = P.parentArc
45 :     val currentArc = P.currentArc
46 :    
47 :     (* concatArcs is like List.@, except that a trailing empty arc in the
48 :     * first argument is dropped.
49 :     *)
50 :     fun concatArcs ([], al2) = al2
51 :     | concatArcs ([""], al2) = al2
52 :     | concatArcs (a::al1, al2) = a :: concatArcs(al1, al2)
53 :    
54 :     fun validVolume {isAbs, vol} = P.validVolume(isAbs, SS.all vol)
55 :    
56 :     fun fromString "" = {isAbs = false, vol = "", arcs = []}
57 :     | fromString p = let
58 :     val fields = SS.fields (fn c => (c = P.arcSepChar))
59 :     val (isAbs, vol, rest) = P.splitVolPath p
60 :     in
61 :     { isAbs = isAbs,
62 :     vol = SS.string vol,
63 :     arcs = List.map SS.string (fields rest)
64 :     }
65 :     end
66 :    
67 :     fun toString {isAbs=false, vol, arcs="" :: _} = raise Path
68 :     | toString {isAbs, vol, arcs} = let
69 :     fun f [] = [""]
70 :     | f [a] = [a]
71 :     | f (a :: al) = a :: arcSepStr :: (f al)
72 :     in
73 :     String.concat(P.joinVolPath(isAbs, vol, "") :: f arcs)
74 :     end
75 :    
76 :     fun getVolume p = #vol(fromString p)
77 :     fun getParent p = let
78 :     fun getParent' [] = [parentArc]
79 :     | getParent' [a] = (case (P.classify a)
80 :     of P.Current => [parentArc]
81 :     | P.Parent => [parentArc, parentArc]
82 :     | P.Null => [parentArc]
83 :     | _ => []
84 :     (* end case *))
85 :     | getParent' (a :: al) = a :: getParent' al
86 :     in
87 :     case (fromString p)
88 :     of {isAbs=true, vol, arcs=[""]} => p
89 :     | {isAbs=true, vol, arcs} =>
90 :     toString{isAbs = true, vol = vol, arcs = getParent' arcs}
91 :     | {isAbs=false, vol, arcs} => (case (getParent' arcs)
92 :     of [] => toString{isAbs=false, vol=vol, arcs=[currentArc]}
93 :     | al' => toString{isAbs=false, vol=vol, arcs=al'}
94 :     (* end case *))
95 :     (* end case *)
96 :     end
97 :    
98 :     fun splitDirFile p = let
99 :     val {isAbs, vol, arcs} = fromString p
100 :     fun split [] = ([], "")
101 :     | split [f] = ([], f)
102 :     | split (a :: al) = let val (d, f) = split al
103 :     in
104 :     (a :: d, f)
105 :     end
106 :     fun split' p = let val (d, f) = split p
107 :     in
108 :     {dir=toString{isAbs=isAbs, vol=vol, arcs=d}, file=f}
109 :     end
110 :     in
111 :     split' arcs
112 :     end
113 :     fun joinDirFile {dir="", file} = file
114 :     | joinDirFile {dir, file} = let
115 :     val {isAbs, vol, arcs} = fromString dir
116 :     in
117 :     toString {isAbs=isAbs, vol=vol, arcs = concatArcs(arcs, [file])}
118 :     end
119 :     fun dir p = #dir(splitDirFile p)
120 :     fun file p = #file(splitDirFile p)
121 :    
122 :     fun splitBaseExt p = let
123 :     val {dir, file} = splitDirFile p
124 :     val (file', ext') = SS.splitr (fn c => c <> #".") (SS.all file)
125 :     val fileLen = SS.size file'
126 :     val (file, ext) =
127 :     if (fileLen <= 1) orelse (SS.isEmpty ext')
128 :     then (file, NONE)
129 :     else (SS.string(SS.trimr 1 file'), SOME(SS.string ext'))
130 :     in
131 :     {base = joinDirFile{dir=dir, file=file}, ext = ext}
132 :     end
133 :     fun joinBaseExt {base, ext=NONE} = base
134 :     | joinBaseExt {base, ext=SOME ""} = base
135 :     | joinBaseExt {base, ext=SOME ext} = let
136 :     val {dir, file} = splitDirFile base
137 :     in
138 :     joinDirFile{dir=dir, file=String.concat[file, ".", ext]}
139 :     end
140 :     fun base p = #base(splitBaseExt p)
141 :     fun ext p = #ext(splitBaseExt p)
142 :    
143 :     fun mkCanonical "" = currentArc
144 :     | mkCanonical p = let
145 :     fun scanArcs ([], []) = [P.Current]
146 :     | scanArcs (l, []) = List.rev l
147 :     | scanArcs ([], [""]) = [P.Null]
148 :     | scanArcs (l, a::al) = (case (P.classify a)
149 :     of P.Null => scanArcs(l, al)
150 :     | P.Current => scanArcs(l, al)
151 :     | P.Parent => (case l
152 :     of (P.Arc _ :: r) => scanArcs(r, al)
153 :     | _ => scanArcs(P.Parent::l, al)
154 :     (* end case *))
155 :     | a' => scanArcs(a' :: l, al)
156 :     (* end case *))
157 :     fun scanPath relPath = scanArcs([], relPath)
158 :     fun mkArc (P.Arc a) = a
159 :     | mkArc (P.Parent) = parentArc
160 :     | mkArc _ = raise Fail "mkCanonical: impossible"
161 :     fun filterArcs (true, P.Parent::r) = filterArcs (true, r)
162 :     | filterArcs (true, []) = [""]
163 :     | filterArcs (true, [P.Null]) = [""]
164 :     | filterArcs (true, [P.Current]) = [""]
165 :     | filterArcs (false, [P.Current]) = [currentArc]
166 :     | filterArcs (_, al) = List.map mkArc al
167 :     val {isAbs, vol, arcs} = fromString p
168 :     in
169 :     toString{
170 :     isAbs=isAbs, vol=vol, arcs=filterArcs(isAbs, scanPath arcs)
171 :     }
172 :     end
173 :    
174 :     fun isCanonical p = (p = mkCanonical p)
175 :    
176 :     fun isAbsolute p = #isAbs(fromString p)
177 :     fun isRelative p = Bool.not(#isAbs(fromString p))
178 :    
179 :     fun mkAbsolute {path, relativeTo} = (
180 :     case (fromString path, fromString relativeTo)
181 :     of (_, {isAbs=false, ...}) => raise Path
182 :     | ({isAbs=true, ...}, _) => path
183 :     | ({vol=v1, arcs=al1, ...}, {vol=v2, arcs=al2, ...}) => let
184 :     fun mkCanon vol = mkCanonical(toString{
185 :     isAbs=true, vol=vol, arcs=List.@(al2, al1)
186 :     })
187 :     in
188 :     if (v1 = v2) then mkCanon v1
189 :     else if (v1 = "") then mkCanon v2
190 :     else if (v2 = "") then mkCanon v1
191 :     else raise Path
192 :     end
193 :     (* end case *))
194 :     fun mkRelative {path, relativeTo} =
195 :     if (isAbsolute relativeTo)
196 :     then if (isRelative path)
197 :     then path
198 :     else let
199 :     val {vol=v1, arcs=al1, ...} = fromString path
200 :     val {vol=v2, arcs=al2, ...} = fromString(mkCanonical relativeTo)
201 :     fun strip (l, []) = mkArcs l
202 :     | strip ([], l) = dotDot([], l)
203 :     | strip (l1 as (x1::r1), l2 as (x2::r2)) = if (x1 = x2)
204 :     then strip (r1, r2)
205 :     else dotDot (l1, l2)
206 :     and dotDot (al, []) = al
207 :     | dotDot (al, _::r) = dotDot(parentArc :: al, r)
208 :     and mkArcs [] = [currentArc]
209 :     | mkArcs al = al
210 :     in
211 :     if (v1 <> v2)
212 :     then raise Path
213 :     else (case (al1, al2)
214 :     of ([""], [""]) => currentArc
215 :     | ([""], _) =>
216 :     toString{isAbs=false, vol="", arcs=dotDot([], al2)}
217 :     | _ =>
218 :     toString{isAbs=false, vol="", arcs=strip(al1, al2)}
219 :     (* end case *))
220 :     end
221 :     else raise Path
222 :    
223 :     fun isRoot path = (case (fromString path)
224 :     of {isAbs=true, arcs=[""], ...} => true
225 :     | _ => false
226 :     (* end case *))
227 :    
228 :     fun concat (p1, p2) = (case (fromString p1, fromString p2)
229 :     of (_, {isAbs=true, ...}) => raise Path
230 :     | ({isAbs, vol=v1, arcs=al1}, {vol=v2, arcs=al2, ...}) =>
231 :     if ((v2 = "") orelse (v1 = v2))
232 :     then toString{isAbs=isAbs, vol=v1, arcs=concatArcs(al1, al2)}
233 :     else raise Path
234 :     (* end case *))
235 :    
236 : blume 1240 local
237 :     fun fromUnixPath' up = let
238 :     fun tr "." = P.currentArc
239 :     | tr ".." = P.parentArc
240 :     | tr arc = arc
241 :     in
242 :     case String.fields (fn c => c = #"/") up of
243 :     "" :: arcs => { isAbs = true, vol = "", arcs = map tr arcs }
244 :     | arcs => { isAbs = false, vol = "", arcs = map tr arcs }
245 :     end
246 :    
247 :     fun toUnixPath' { isAbs, vol = "", arcs } =
248 :     let fun tr arc =
249 :     if arc = P.currentArc then "."
250 :     else if arc = P.parentArc then ".."
251 :     else if Char.contains arc #"/" then raise Path
252 :     else arc
253 :     in
254 :     String.concatWith "/" (if isAbs then "" :: arcs else arcs)
255 :     end
256 :     | toUnixPath' _ = raise Path
257 :     in
258 :     val fromUnixPath = toString o fromUnixPath'
259 :     val toUnixPath = toUnixPath' o fromString
260 :     end
261 : monnier 416 end
262 :     end
263 :    

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