| 1 | (* Modified from the ML Kit 4.1.4; basislib/Path.sml |
| 2 | * by mfluet@acm.org on 2005-8-10 based on |
| 3 | * modifications from the ML Kit 3 Version; basislib/Path.sml |
| 4 | * by sweeks@research.nj.nec.com on 1999-1-5. |
| 5 | *) |
| 6 | |
| 7 | structure OS_Path: OS_PATH = |
| 8 | struct |
| 9 | |
| 10 | exception Path |
| 11 | exception InvalidArc |
| 12 | |
| 13 | (* It would make sense to use substrings for internal versions of |
| 14 | * fromString and toString, and to allocate new strings only when |
| 15 | * externalizing the strings. |
| 16 | |
| 17 | * Impossible cases: |
| 18 | UNIX: {isAbs = false, vol = _, arcs = "" :: _} |
| 19 | Mac: {isAbs = true, vol = _, arcs = "" :: _} |
| 20 | *) |
| 21 | |
| 22 | val op @ = List.@ |
| 23 | infix 9 sub |
| 24 | val op sub = String.sub |
| 25 | val substring = String.extract |
| 26 | |
| 27 | val isWindows = |
| 28 | let |
| 29 | open Primitive.MLton.Platform.OS |
| 30 | in |
| 31 | host = MinGW |
| 32 | end |
| 33 | |
| 34 | (* the path separator used in canonical paths *) |
| 35 | val slash = if isWindows then "\\" else "/" |
| 36 | |
| 37 | (* MinGW and newer Windows commands treat both / and \ as path |
| 38 | * separators. |
| 39 | * |
| 40 | * Sadly this means that toString o fromString is not the identity |
| 41 | * b/c foo/bar -> foo\bar. However, there's nothing else one can do! |
| 42 | * This diverges from the standard. |
| 43 | *) |
| 44 | fun isslash c = c = #"/" orelse (isWindows andalso c = #"\\") |
| 45 | fun iscolon c = c = #":" |
| 46 | |
| 47 | fun isVolumeName v = |
| 48 | (isWindows andalso size v = 2 andalso |
| 49 | Char.isAlpha (v sub 0) andalso iscolon (v sub 1)) |
| 50 | |
| 51 | fun volumeMatch (root, relative) = |
| 52 | relative = "" |
| 53 | orelse (isVolumeName root |
| 54 | andalso isVolumeName relative |
| 55 | andalso (Char.toUpper (root sub 0) |
| 56 | = Char.toUpper (relative sub 0))) |
| 57 | |
| 58 | fun canonName a = |
| 59 | if isWindows |
| 60 | then String.translate (str o Char.toLower) a |
| 61 | else a |
| 62 | |
| 63 | val parentArc = ".." |
| 64 | val currentArc = "." |
| 65 | |
| 66 | (* Ahh joy. The SML basis library standard and Windows paths. |
| 67 | * |
| 68 | * The big problem with windows paths is "\foo"" |
| 69 | * - It's not absolute, since chdir("A:\") may switch from "C:", thus |
| 70 | * changing the meaning of "\foo". |
| 71 | *) |
| 72 | fun validVolume {isAbs, vol} = |
| 73 | if isWindows |
| 74 | then isVolumeName vol orelse (not isAbs andalso vol = "") |
| 75 | else vol = "" |
| 76 | |
| 77 | fun fromString s = |
| 78 | let |
| 79 | val (vol, rest) = (* 4:foo has a volume of "4:" even tho invalid *) |
| 80 | if isWindows andalso size s >= 2 andalso iscolon (s sub 1) |
| 81 | then (substring (s, 0, SOME 2), substring (s, 2, NONE)) |
| 82 | else ("", s) |
| 83 | val (isAbs, arcs) = |
| 84 | case (String.fields isslash rest) of |
| 85 | "" :: [] => (false, []) |
| 86 | | "" :: r => (true, r) |
| 87 | | r => (false, r) |
| 88 | in |
| 89 | {arcs = arcs, isAbs = isAbs, vol = vol} |
| 90 | end |
| 91 | |
| 92 | val getVolume = #vol o fromString |
| 93 | val isAbsolute = #isAbs o fromString |
| 94 | val isRelative = not o isAbsolute |
| 95 | |
| 96 | fun isArc s = |
| 97 | s = "" |
| 98 | orelse (case fromString s of |
| 99 | {arcs = [_], isAbs = false, vol = ""} => true |
| 100 | | _ => false) |
| 101 | |
| 102 | fun toString {arcs, isAbs, vol} = |
| 103 | if not (validVolume {isAbs = isAbs, vol = vol}) |
| 104 | then raise Path |
| 105 | else if not isAbs andalso case arcs of ("" :: _) => true | _ => false |
| 106 | then raise Path |
| 107 | else if List.exists (not o isArc) arcs |
| 108 | then raise InvalidArc |
| 109 | else |
| 110 | concat [vol, |
| 111 | if isAbs |
| 112 | then slash |
| 113 | else "", |
| 114 | String.concatWith slash arcs] |
| 115 | |
| 116 | fun concatArcs (a1, a2) = |
| 117 | let |
| 118 | val a1 = case List.rev a1 of "" :: r => List.rev r | _ => a1 |
| 119 | in |
| 120 | a1 @ a2 |
| 121 | end |
| 122 | |
| 123 | fun concat (p1, p2) = |
| 124 | let |
| 125 | val {arcs = a1, isAbs, vol = v1} = fromString p1 |
| 126 | val {arcs = a2, isAbs = isAbs2, vol = v2} = fromString p2 |
| 127 | in |
| 128 | if isAbs2 orelse not (volumeMatch (v1, v2)) |
| 129 | then raise Path |
| 130 | else toString {arcs = concatArcs (a1, a2), isAbs = isAbs, vol = v1} |
| 131 | end |
| 132 | |
| 133 | fun getParent p = |
| 134 | let |
| 135 | val {isAbs, vol, arcs} = fromString p |
| 136 | val arcs = |
| 137 | List.rev (case List.rev arcs of |
| 138 | [] => [parentArc] |
| 139 | | "." :: r => parentArc :: r |
| 140 | | ".." :: r => parentArc :: parentArc :: r |
| 141 | | _ :: [] => if isAbs then [""] else [currentArc] |
| 142 | | "" :: r => parentArc :: r |
| 143 | | _ :: r => r) |
| 144 | in |
| 145 | toString {arcs = arcs, isAbs = isAbs, vol = vol} |
| 146 | end |
| 147 | |
| 148 | fun mkCanonical p = |
| 149 | let |
| 150 | val {arcs, isAbs, vol} = fromString p |
| 151 | fun backup l = |
| 152 | case l of |
| 153 | [] => if isAbs then [] else [parentArc] |
| 154 | | first :: res => |
| 155 | if first = ".." |
| 156 | then parentArc :: parentArc :: res |
| 157 | else res |
| 158 | fun reduce arcs = |
| 159 | let |
| 160 | fun h (l, res) = |
| 161 | case l of |
| 162 | [] => (case res of |
| 163 | [] => if isAbs then [""] else [currentArc] |
| 164 | | _ => res ) |
| 165 | | a1 :: ar => |
| 166 | if a1 = "" orelse a1 = "." |
| 167 | then h (ar, res) |
| 168 | else if a1 = ".." |
| 169 | then h (ar, backup res) |
| 170 | else h (ar, canonName a1 :: res) |
| 171 | in |
| 172 | h (arcs, []) |
| 173 | end |
| 174 | in |
| 175 | toString {arcs = List.rev (reduce arcs), |
| 176 | isAbs = isAbs, |
| 177 | vol = canonName vol} |
| 178 | end |
| 179 | |
| 180 | val rec parentize = |
| 181 | fn [] => [] |
| 182 | | _ :: ar => parentArc :: parentize ar |
| 183 | |
| 184 | fun mkRelative {path = p1, relativeTo = p2} = |
| 185 | let |
| 186 | val {arcs = arcs1, isAbs = isAbs1, vol = vol1} = fromString p1 |
| 187 | val {arcs = arcs2, isAbs = isAbs2, vol = vol2} = |
| 188 | fromString (mkCanonical p2) |
| 189 | in |
| 190 | if not isAbs2 then raise Path |
| 191 | else if not isAbs1 then p1 |
| 192 | else |
| 193 | let |
| 194 | fun h (a1, a2) = |
| 195 | case (a1, a2) of |
| 196 | ([], []) => ["."] |
| 197 | | (_, []) => a1 |
| 198 | | ([], a2) => parentize a2 |
| 199 | | (a11 :: a1r, a21 :: a2r) => |
| 200 | if canonName a11 = a21 then h (a1r, a2r) |
| 201 | else parentize a2 @ (if arcs1 = [""] then [] else a1) |
| 202 | in |
| 203 | if not (volumeMatch (vol2, vol1)) |
| 204 | then raise Path |
| 205 | else toString {arcs = h (arcs1, arcs2), |
| 206 | isAbs = false, |
| 207 | vol = ""} |
| 208 | end |
| 209 | end |
| 210 | |
| 211 | fun mkAbsolute {path = p1, relativeTo = p2} = |
| 212 | if isRelative p2 then raise Path |
| 213 | else if isAbsolute p1 then p1 |
| 214 | else mkCanonical (concat (p2, p1)) |
| 215 | |
| 216 | fun isCanonical p = mkCanonical p = p |
| 217 | |
| 218 | fun joinDirFile {dir, file} = |
| 219 | let |
| 220 | val {arcs, isAbs, vol} = fromString dir |
| 221 | val arcs = |
| 222 | case (arcs, file) of |
| 223 | ([], "") => [] |
| 224 | | _ => concatArcs (arcs, [file]) |
| 225 | in |
| 226 | toString {arcs = arcs, |
| 227 | isAbs = isAbs, |
| 228 | vol = vol} |
| 229 | end |
| 230 | |
| 231 | fun splitDirFile p = |
| 232 | let |
| 233 | open List |
| 234 | val {isAbs, vol, arcs} = fromString p |
| 235 | in |
| 236 | case rev arcs of |
| 237 | [] => {dir = p, file = ""} |
| 238 | | arcn :: farcs => |
| 239 | {dir = toString {arcs = rev farcs, isAbs = isAbs, vol = vol}, |
| 240 | file = arcn} |
| 241 | |
| 242 | end |
| 243 | |
| 244 | val dir = #dir o splitDirFile |
| 245 | |
| 246 | val file = #file o splitDirFile |
| 247 | |
| 248 | fun joinBaseExt {base, ext} = |
| 249 | case ext of |
| 250 | NONE => base |
| 251 | | SOME ex => |
| 252 | if ex = "" then base |
| 253 | else String.concat [base, ".", ex] |
| 254 | |
| 255 | fun splitBaseExt s = |
| 256 | let |
| 257 | val {dir, file} = splitDirFile s |
| 258 | open Substring |
| 259 | val (fst, snd) = splitr (fn c => c <> #".") (full file) |
| 260 | in |
| 261 | if isEmpty snd (* dot at right end *) |
| 262 | orelse isEmpty fst (* no dot *) |
| 263 | orelse size fst = 1 (* dot at left end only *) |
| 264 | then {base = s, ext = NONE} |
| 265 | else {base = joinDirFile {dir = dir, |
| 266 | file = string (trimr 1 fst)}, |
| 267 | ext = SOME (string snd)} |
| 268 | end |
| 269 | |
| 270 | val ext = #ext o splitBaseExt |
| 271 | val base = #base o splitBaseExt |
| 272 | |
| 273 | fun isRoot path = |
| 274 | case fromString path of |
| 275 | {isAbs = true, arcs=[""], ...} => true |
| 276 | | _ => false |
| 277 | |
| 278 | fun fromUnixPath s = |
| 279 | if not isWindows then s |
| 280 | else if Char.contains s (slash sub 0) then raise InvalidArc |
| 281 | else String.translate (fn c => if c = #"/" then slash else str c) s |
| 282 | |
| 283 | fun toUnixPath s = |
| 284 | if not isWindows then s |
| 285 | else |
| 286 | let |
| 287 | val {arcs, isAbs, vol} = fromString s |
| 288 | in |
| 289 | if vol <> "" |
| 290 | then raise Path |
| 291 | else (if isAbs then "/" else "") ^ String.concatWith "/" arcs |
| 292 | end |
| 293 | |
| 294 | end |