1(* 2 Title: Standard Basis Library: OS Structures and Signatures 3 Author: David Matthews 4 Copyright David Matthews 2000, 2005, 2015-16 5 6 This library is free software; you can redistribute it and/or 7 modify it under the terms of the GNU Lesser General Public 8 License version 2.1 as published by the Free Software Foundation. 9 10 This library is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 Lesser General Public License for more details. 14 15 You should have received a copy of the GNU Lesser General Public 16 License along with this library; if not, write to the Free Software 17 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18*) 19 20signature OS_FILE_SYS = 21 sig 22 type dirstream 23 val openDir : string -> dirstream 24 val readDir : dirstream -> string option 25 val rewindDir : dirstream -> unit 26 val closeDir : dirstream -> unit 27 val chDir : string -> unit 28 val getDir : unit -> string 29 val mkDir : string -> unit 30 val rmDir : string -> unit 31 val isDir : string -> bool 32 val isLink : string -> bool 33 val readLink : string -> string 34 val fullPath : string -> string 35 val realPath : string -> string 36 val modTime : string -> Time.time 37 val fileSize : string -> Position.int 38 39 val setTime : (string * Time.time Option.option) -> unit 40 val remove : string -> unit 41 val rename : {old : string, new : string} -> unit 42 43 datatype access_mode 44 = A_READ 45 | A_WRITE 46 | A_EXEC 47 48 val access : (string * access_mode list) -> bool 49 50 val tmpName : unit -> string 51 52 eqtype file_id 53 val fileId : string -> file_id 54 val hash : file_id -> word 55 val compare : (file_id * file_id) -> General.order 56 end (* OS_FILE_SYS *); 57 58 59signature OS_PATH = 60sig 61 exception Path 62 exception InvalidArc 63 val parentArc : string 64 val currentArc : string 65 66 val fromString : string -> { isAbs : bool, vol : string, arcs : string list } 67 val toString : { isAbs : bool, vol : string, arcs : string list } -> string 68 69 val validVolume : {isAbs : bool, vol : string} -> bool 70 val getVolume : string -> string 71 val getParent : string -> string 72 val splitDirFile : string -> {dir : string, file : string} 73 val joinDirFile : {dir : string, file : string} -> string 74 val dir : string -> string 75 val file : string -> string 76 val splitBaseExt : string -> {base : string, ext : string option } 77 val joinBaseExt : {base : string, ext : string option} -> string 78 val base : string -> string 79 val ext : string -> string option 80 val mkCanonical : string -> string 81 val isCanonical : string -> bool 82 val mkAbsolute : {path : string, relativeTo : string} -> string 83 val mkRelative : {path : string, relativeTo : string} -> string 84 val isAbsolute : string -> bool 85 val isRelative : string -> bool 86 val isRoot : string -> bool 87 val concat : string * string -> string 88 val toUnixPath : string -> string 89 val fromUnixPath : string -> string 90end (* OS_PATH *); 91 92 93signature OS_PROCESS = 94 sig 95 type status 96 val success : status 97 val failure : status 98 val isSuccess : status -> bool 99 val system : string -> status 100 val atExit : (unit -> unit) -> unit 101 val exit : status -> 'a 102 val terminate : status -> 'a 103 val getEnv : string -> string Option.option 104 val sleep: Time.time -> unit 105 end (* OS_PROCESS *); 106 107 108signature OS_IO = 109 sig 110 eqtype iodesc 111 val hash : iodesc -> word 112 val compare : (iodesc * iodesc) -> General.order 113 114 eqtype iodesc_kind 115 val kind : iodesc -> iodesc_kind 116 117 structure Kind: 118 sig 119 val file : iodesc_kind 120 val dir : iodesc_kind 121 val symlink : iodesc_kind 122 val tty : iodesc_kind 123 val pipe : iodesc_kind 124 val socket : iodesc_kind 125 val device : iodesc_kind 126 end 127 128 eqtype poll_desc 129 type poll_info 130 val pollDesc : iodesc -> poll_desc Option.option 131 val pollToIODesc : poll_desc -> iodesc 132 133 exception Poll 134 val pollIn : poll_desc -> poll_desc 135 val pollOut : poll_desc -> poll_desc 136 val pollPri : poll_desc -> poll_desc 137 138 val poll : (poll_desc list * Time.time Option.option) -> poll_info list 139 140 val isIn : poll_info -> bool 141 val isOut : poll_info -> bool 142 val isPri : poll_info -> bool 143 144 val infoToPollDesc : poll_info -> poll_desc 145 146 end (* OS_IO *); 147 148 149signature OS = 150 sig 151 eqtype syserror 152 exception SysErr of (string * syserror Option.option) 153 val errorMsg : syserror -> string 154 val errorName : syserror -> string 155 val syserror : string -> syserror Option.option 156 157 structure FileSys : OS_FILE_SYS 158 structure Path : OS_PATH 159 structure Process : OS_PROCESS 160 structure IO : OS_IO 161 end (* OS *); 162 163 164structure OS:> OS = 165struct 166 type syserror = SysWord.word (* Implemented as a SysWord.word value. *) 167 168 (* The calls themselves raise the SysCall exception. 169 That has to be turned into a SysError exception. *) 170 exception SysErr = RunCall.SysErr 171 172 (* Convert a numeric system error to a string. 173 Note: unlike Posix.Error.errorName and Posix.Error.sysError 174 the results are not defined other than that 175 SOME e = syserror(errorName e) nor is this defined to 176 be the same as the Posix.Error functions. Those are 177 defined to return e.g. "etoobig". Here we return "E2BIG". *) 178 val errorName: syserror -> string = RunCall.rtsCallFull1 "PolyProcessEnvErrorName" 179 and errorMsg: syserror -> string = RunCall.rtsCallFull1 "PolyProcessEnvErrorMessage" 180 181 local 182 val doCall: string -> syserror = RunCall.rtsCallFull1 "PolyProcessEnvErrorFromString" 183 in 184 (* Convert a string to an error message if possible. *) 185 fun syserror (s: string) : syserror option = 186 let 187 val n = doCall s 188 in 189 if n = 0w0 then NONE else SOME n 190 end 191 end 192 193 194 195 structure Path:> OS_PATH = 196 struct 197 (* Note: The definition of relative and absolute paths are 198 somewhat unclear and some of the examples seem contradictory. 199 The definition I would prefer to use is that an absolute path 200 is one which identifies a given file independent of any setting 201 of the current directory. Hence the examples of "\" and "\A\B" as 202 being absolute paths in DOS is in my opinion wrong. These are 203 relative since they depend on the setting of the current volume. 204 However this is a mess when it comes to fromString since if 205 we don't treat "\A" as an absolute path it looks just like an 206 absolute path with an empty arc. *) 207 exception Path 208 exception InvalidArc 209 210 local 211 val getOSCall: unit -> int = RunCall.rtsCallFast0 "PolyGetOSType" 212 val getOS: int = getOSCall() 213 in 214 val isWindows = 215 case getOS of 216 0 => false (* Posix *) 217 | 1 => true 218 | _ => raise Fail "Unknown operating system" 219 end 220 221 val isCaseSensitive = not isWindows 222 223 val isSeparator = 224 if isWindows then fn #"/" => true | #"\\" => true | _ => false 225 else fn #"/" => true | _ => false 226 227 val separator = 228 if isWindows then "\\" else "/" 229 230 231 val parentArc = ".." and currentArc = "." 232 233 val isValidArc = 234 if isWindows 235 then 236 let 237 fun invalidChars #"\000" = true 238 | invalidChars #"<" = true 239 | invalidChars #">" = true 240 | invalidChars #":" = true 241 | invalidChars #"\"" = true 242 | invalidChars #"\\" = true 243 | invalidChars #"/" = true 244 | invalidChars #"|" = true 245 | invalidChars #"?" = true 246 | invalidChars #"*" = true 247 | invalidChars _ = false 248 in 249 not o (CharVector.exists invalidChars) 250 end 251 else 252 let 253 (* Posix - only null and / are invalid. *) 254 fun invalidChars #"\000" = true 255 | invalidChars #"/" = true 256 | invalidChars _ = false 257 in 258 not o (CharVector.exists invalidChars) 259 end 260 261 local 262 (* Given a string it examines the prefix and extracts the volume 263 name if there is one. It returns the volume and also whether 264 the name is absolute. It also returns the number of characters 265 which matched so that this can be removed before treating 266 the rest as a relative path. *) 267 fun matchVolumePrefixPosix s = 268 if String.size s > 0 andalso String.sub(s, 0) = #"/" 269 then {volLen = 1, vol = "", abs = true, root = true } 270 else {volLen = 0, vol = "", abs = false, root = false } 271 272 fun matchVolumePrefixWindows s = 273 let 274 val slen = String.size s 275 in 276 if slen = 0 then { volLen = 0, vol = "", abs = false, root = false } 277 else if slen >= 2 andalso String.sub(s, 1) = #":" andalso 278 Char.isAlpha(String.sub(s, 0)) 279 then 280 if slen > 2 andalso isSeparator(String.sub(s, 2)) 281 then { volLen = 3, vol = String.substring(s, 0, 2), abs = true, root = true } (* e.g. C:\ or C:\fred *) 282 else { volLen = 2, vol = String.substring(s, 0, 2), abs = false, root = false } (* e.g. C: or C:fred *) 283 else if slen > 2 andalso isSeparator(String.sub(s, 0)) 284 andalso isSeparator(String.sub(s, 1)) 285 then (* Looks like a UNC server name. See how big it is. *) 286 let 287 val (server, rest) = 288 Substring.splitl(fn c => not (isSeparator c)) 289 (Substring.extract(s, 2, NONE)) 290 (* TODO: Is the server name actually valid? Assume yes. *) 291 in 292 if Substring.size rest = 0 293 then { volLen = 0, vol = "", abs = false, root = false } 294 else (* Must be room for a share name as well. *) 295 let 296 val shareName = 297 Substring.takel(fn c => not (isSeparator c)) 298 (Substring.triml 1 rest) 299 in 300 { volLen = Substring.size server + Substring.size shareName + 4, 301 vol = 302 separator ^ separator ^ 303 Substring.string server ^ separator ^ 304 Substring.string shareName, 305 abs = true, root = true } 306 end 307 end 308 (* Leading \ in Windows means the "root" directory on the current drive. *) 309 else if isSeparator(String.sub(s, 0)) 310 then { volLen = 1, vol = "", abs = false, root = true } 311 312 else { volLen = 0, vol = "", abs = false, root = false } 313 end 314 in 315 val matchVolumePrefix = 316 if isWindows then matchVolumePrefixWindows else matchVolumePrefixPosix 317 end 318 319 (* Internal - map the strings to the canonical case if they 320 are not case sensitive. *) 321 val toCanonicalCase = 322 if isCaseSensitive then fn s => s 323 else String.map Char.toLower 324 325 (* Internal - are the arcs equivalent? *) 326 fun equivalent (s, t) = toCanonicalCase s = toCanonicalCase t 327 328 (* See if the volume name is valid for either an absolute or 329 relative path. Windows relative paths may or may not 330 have a volume but if they have the volume must look right. 331 On Unix relative paths may not specify a volume and 332 the only volume for absolute paths is the empty string. *) 333 val validVolume = 334 if isWindows 335 then 336 fn {isAbs, vol = ""} => 337 not isAbs (* Empty volume is only valid for relative paths. *) 338 339 | {vol, ...} => 340 if size vol = 2 andalso String.sub(vol, 1) = #":" 341 andalso Char.isAlpha(String.sub(vol, 0)) 342 then true (* Drive letter e.g. C: *) 343 else if size vol > 2 andalso isSeparator(String.sub(vol, 0)) 344 then (* UNC name? \\server\share *) 345 case String.fields isSeparator vol of 346 ["", "", server, share] => server <> "" andalso share <> "" 347 | _ => false 348 else false 349 350 else (* Posix. The volume must always be empty. *) 351 fn {vol = "", ...} => true | _ => false 352 353 (* We only return an empty arcs list if the argument is the empty string. *) 354 fun fromString "" = {isAbs = false, vol = "", arcs=[]} 355 | fromString (s: string) = 356 let 357 (* Do we have a volume name? *) 358 val {volLen, vol, abs, root, ...} = matchVolumePrefix s 359 (* The remainder forms a set of arcs. *) 360 val rest = String.extract(s, volLen, NONE) 361 val arcs = String.fields isSeparator rest 362 (* If it begins with the Windows \ without a drive we 363 need to add an extra empty arc. Otherwise we can't 364 distinguish \a from a. *) 365 val allArcs = 366 if root andalso not abs then "" :: arcs else arcs 367 in 368 {isAbs = abs, vol = vol, arcs=allArcs} 369 end 370 371 (* Note: This is a mess as well. For example it says that it should 372 raise Path if there is a relative path which begins with an 373 empty arc. That's only true in Unix. What it should say is 374 that it if isAbs is false then it should raise Path if the 375 resulting path has the form of an absolute path. In Windows 376 we should raise path if given (e.g.) 377 {isAbs=false, vol="", arcs=["", "", "a", "b"]} because that 378 looks like a UNC name. *) 379 fun toString {isAbs : bool, vol : string, arcs : string list} = 380 (* Check we have a valid volume. *) 381 if not (validVolume{isAbs=isAbs, vol=vol}) 382 then raise Path 383 (* Check that each arc is valid. *) 384 else if List.exists (fn s => not (isValidArc s)) arcs 385 then raise InvalidArc 386 else 387 let 388 (* Place separators between each arc. *) 389 fun arcsToLinks [] = [] 390 | arcsToLinks [a] = [a] 391 | arcsToLinks (a::b) = 392 a :: separator :: arcsToLinks b 393 fun makePrefix(vol, false) = vol | makePrefix(vol, true) = vol ^ separator 394 val r = String.concat(makePrefix(vol, isAbs) :: arcsToLinks arcs) 395 (* Check to see whether we have turned a relative path into 396 an absolute one by including empty arcs in the wrong places. *) 397 val {abs = nowAbs, ...} = matchVolumePrefix r 398 in 399 if nowAbs <> isAbs 400 then raise Path 401 else r 402 end 403 (* Note: this is just defined to "return the volume portion" but 404 doesn't say what to do if there isn't a volume. Seems simplest 405 to define it as below. *) 406 fun getVolume s = #vol(fromString s) 407 408 (* Note: Once again this has very much a Unix view of the world, 409 most of which almost works in Windows. 410 I think the idea is that if possible it replaces the path 411 with the path to the containing directory. 412 If we're in the root directory we get the root directory. 413 If we're in a path that ends with a component 414 *) 415 fun getParent "" = parentArc 416 | getParent s = 417 let 418 val len = String.size s 419 val {volLen, ...} = matchVolumePrefix s 420 (* Split it at the last separator. *) 421 val (prefix, suffix) = 422 Substring.splitr (fn c => not (isSeparator c)) 423 (Substring.full s) 424 in 425 if volLen = len 426 then s (* We have a root. *) 427 else if Substring.size suffix = 0 428 then 429 (* If the last character is a separator just add on 430 the parent arc (..) to refer to the parent directory. 431 I don't know why we can't just remove the last component 432 in this case but the examples don't do that. The only 433 special case is where we have reached the root when 434 we just return the root. *) 435 s ^ parentArc 436 else if Substring.size prefix = 0 437 then (* No separator at all *) 438 ( 439 if s = parentArc (* .. => ../.. *) 440 then parentArc ^ (separator) ^ parentArc 441 else if s = currentArc 442 then parentArc (* . => .. *) 443 else currentArc (* abc => . *) 444 ) 445 else if Substring.size prefix = volLen 446 (* ??? If the prefix matches the volume then return 447 the whole of prefix including the separator. *) 448 then Substring.string prefix 449 else (* Return the prefix with the separator removed. *) 450 Substring.string(Substring.trimr 1 prefix) 451 end 452 453 (* Another mess defined in terms of examples for Unix from which 454 one is expected to infer a general rule. 455 It seems to split the string at the last separator and 456 return the two halves without the separator except in the 457 case where the directory is a root directory when a full 458 volume name and separator are given. *) 459 fun splitDirFile s = 460 let 461 (* Split it at the last separator. *) 462 val (prefix, suffix) = 463 Substring.splitr (fn c => not (isSeparator c)) 464 (Substring.full s) 465 val {volLen, vol, ...} = matchVolumePrefix s 466 val dirName = 467 case Substring.size prefix of 468 0 => "" 469 | 1 => Substring.string prefix (* Special case of Windows \a. *) 470 | _ => Substring.string(Substring.trimr 1 prefix) 471 and fileName = Substring.string suffix 472 in 473 if volLen <> 0 andalso vol = dirName 474 then {dir = vol ^ separator, file = fileName} 475 else {dir = dirName, file = fileName} 476 end 477 478 fun dir s = #dir(splitDirFile s) 479 and file s = #file(splitDirFile s) 480 481 (* Question: It seems from the definition of toString that the 482 arcs list can include separators. Is that true here? 483 Assume yes. *) 484 (* If the last character is already a separator we don't add one, 485 e.g. if the directory is "/". *) 486 fun joinDirFile{dir, file} = 487 if not (isValidArc file) then raise InvalidArc 488 else if dir = "" then file (* Return the file name unchanged *) 489 else if isSeparator(String.sub(dir, size dir - 1)) 490 then dir ^ file 491 else dir ^ separator ^ file 492 493 fun splitBaseExt s = 494 let 495 val slen = String.size s 496 fun getExt n = 497 if n <= 0 then NONE (* If it's at the start ignore it. *) 498 else if isSeparator(String.sub(s, n)) 499 then NONE 500 else if String.sub(s, n) = #"." 501 then (* Found a dot. *) 502 ( 503 if n = slen-1 then NONE (* Dot in last position. *) 504 else if isSeparator(String.sub(s, n-1)) 505 then NONE (* Dot immediately after separator. *) 506 else SOME n 507 ) 508 else getExt (n-1) 509 val extPos = getExt(slen - 1) 510 in 511 case extPos of 512 NONE => {base=s, ext=NONE} 513 | SOME n => {base=String.substring(s, 0, n), 514 ext=SOME(String.substring(s, n+1, slen-n-1))} 515 end 516 517 fun joinBaseExt {base : string, ext = NONE} = base 518 | joinBaseExt {base : string, ext = SOME ""} = base 519 | joinBaseExt {base : string, ext = SOME ext} = base ^ "." ^ ext 520 521 fun base s = #base(splitBaseExt s) 522 and ext s = #ext(splitBaseExt s) 523 524 val emptyArcIsRedundant = true 525 526 fun mkCanonical s = 527 let 528 val {isAbs, vol, arcs} = fromString s 529 fun collapse [] = [] 530 | collapse (a :: b) = 531 (* Work down the list removing currentArc entries and 532 null entries (if the OS treats them as redundant).. *) 533 if a = currentArc orelse (emptyArcIsRedundant andalso a = "") 534 then collapse b 535 (* Then work back up it removing parentArc entries. *) 536 else 537 case collapse b of 538 [] => [a] 539 | b' as (x :: y) => 540 if x = parentArc andalso not (a = parentArc) 541 then (* Remove "a" and "x". *) y 542 else a :: b' 543 544 val collapsed = collapse arcs 545 546 (* If this is the root we can remove leading occurrences of 547 the parent arc since the parent of the root is the root. *) 548 fun removeLeadingParent [] = [] 549 | removeLeadingParent (a::b) = 550 if a = parentArc then removeLeadingParent b else a::b 551 val newArcs = 552 if isAbs then removeLeadingParent collapsed else collapsed 553 val res = toString{isAbs=isAbs, vol=vol, arcs=newArcs} 554 in 555 (* Finally replace the empty string with "." and map to lower case 556 if it's not case sensitive. *) 557 if res = "" then currentArc 558 else toCanonicalCase res 559 end 560 561 fun isCanonical s = mkCanonical s = s handle Path => false 562 563 fun isAbsolute s = #isAbs(fromString s) 564 and isRelative s = not(#isAbs(fromString s)) 565 566 (* Concatenate two paths. The second must be relative and, if it 567 contains a volume name, refer to the same volume as the first. *) 568 fun concat(s, t) = 569 let 570 val {isAbs=absS, vol=volS, arcs=ArcsS} = fromString s 571 val {isAbs=absT, vol=volT, arcs=ArcsT} = fromString t 572 573 (* Concatenate the two lists of arcs except that a trailing 574 empty arc on the first path is removed 575 (i.e. concat("a/", "b") is the same as concat("a", "b") *) 576 fun concatArcs [] p = p 577 | concatArcs [a] p = if a = "" then p else a :: p 578 | concatArcs (a::b) p = a :: concatArcs b p 579 in 580 if absT then raise Path 581 else if volT <> "" andalso not(equivalent(volS, volT)) 582 then raise Path 583 else if #root(matchVolumePrefix t) 584 (* Special case for Windows. concat("c:\\abc\\def", "\\xyz") is "c:\\xyz". *) 585 then 586 let 587 (* Because this a relative path we have an extra empty arc here. *) 588 val ArcsT' = case ArcsT of "" :: a => a | a => a 589 in 590 toString{isAbs=absS, vol=volS, arcs=ArcsT'} 591 end 592 else toString{isAbs=absS, vol=volS, arcs=concatArcs ArcsS ArcsT} 593 end 594 595 (* Make an absolute path by treating a relative path as relative to 596 a given path. *) 597 fun mkAbsolute {path, relativeTo} = 598 let 599 val {isAbs=absP, vol=volP, ...} = fromString path 600 val {isAbs=absRT, vol=volRT, ...} = fromString relativeTo 601 in 602 if absP then path 603 else if not absRT then raise Path 604 (* If the path contained a volume it must be the 605 same as the absolute path. *) 606 else if volP <> "" andalso not(equivalent(volP, volRT)) 607 then raise Path 608 else mkCanonical(concat(relativeTo, path)) 609 end 610 611 (* Make a relative path by treating an absolute path as derived 612 from a given other absolute path. *) 613 fun mkRelative {path, relativeTo} = 614 case fromString path of 615 {isAbs=false, ...} => path (* Already relative *) 616 | {vol=volP, arcs=arcsP, ...} => 617 let 618 val {isAbs=absRT, vol=volRT, arcs=arcsRT} = 619 fromString (mkCanonical relativeTo) 620 621 (* Add as many parent arcs as there are arcs in the path. *) 622 fun addParents [] p = p 623 | addParents (_::b) p = parentArc :: addParents b p 624 625 fun matchPaths [] [] = [currentArc] (* Both equal *) 626 | matchPaths p [] = (* Absolute path is finished - return p *) p 627 | matchPaths [] r = (* Relative paths finished - add parent arcs *) 628 addParents r [] 629 | matchPaths (p :: p') (r :: r') = 630 (* Are they the same arc? Note: When arcs are 631 case insensitive I'm doing a case insensitive match 632 here. *) 633 if equivalent(p, r) 634 then matchPaths p' r' 635 else addParents (r :: r') (p :: p') 636 637 (* We have a special case with the root directory 638 (/ on Unix or c:\\ on Windows). In that case fromString returns 639 a single empty arc and we want to remove it here otherwise 640 we can end up with an empty arc in addParents. *) 641 val arcsP' = case arcsP of [""] => [] | _ => arcsP 642 val arcsRT' = case arcsRT of [""] => [] | _ => arcsRT 643 in 644 if not absRT then raise Path 645 (* If the path contained a volume it must be the 646 same as the absolute path. *) 647 else if volP <> "" andalso not(equivalent(volP, volRT)) 648 then raise Path 649 else toString{isAbs=false, vol="", arcs=matchPaths arcsP' arcsRT'} 650 end 651 652 (* Another badly defined function. What is a root? Does it have to specify 653 a volume or is \ a root in Windows? Assume that it must be absolute. *) 654 fun isRoot s = 655 let 656 val {volLen, abs, ...} = matchVolumePrefix s 657 in 658 abs andalso volLen = String.size s andalso isCanonical s 659 end 660 661 (* Question: there's no definition of what these functions mean. The crucial 662 questions are how to deal with volume names and also how to deal 663 with symbols in the paths which may be invalid (e.g. path separators) in 664 one or other system. For instance "a\b" is a valid file name in Unix 665 and 31/3/2000 is valid in MacOS. 666 Are they supposed to represent the original file system in some way? *) 667 fun toUnixPath s = 668 let 669 (* We may have occurrences of "/" in the arcs if that is not 670 a separator on this OS. Replace them by this machine's separator. *) 671 fun mapArc a = 672 if a = currentArc then "." 673 else if a = parentArc then ".." 674 else a 675 676 fun mapArcs [] = [] 677 | mapArcs [a] = [mapArc a] 678 | mapArcs (a::b) = mapArc a :: "/" :: mapArcs b 679 680 val {isAbs, vol, arcs} = fromString s 681 val volArc = if vol <> "" then vol :: arcs else arcs 682 val sl = String.concat(mapArcs volArc) 683 in 684 if String.size sl = 0 then "" 685 else if isAbs then if String.sub(sl, 0) <> #"/" then "/" ^ sl else sl 686 else (* not abs *) if String.sub(sl, 0) = #"/" then "." ^ sl else sl 687 end 688 689 fun fromUnixPath s = 690 let 691 val arcs = String.fields (fn ch => ch = #"/") s 692 (* Turn any occurrences of this OS's separator into / since 693 that can't occur within an arc. *) 694 val convArc = 695 String.translate ( 696 fn ch => if isSeparator ch then "/" else String.str ch) 697 val convArcs = List.map convArc arcs 698 in 699 case convArcs of 700 [] => "" 701 | ("" :: a :: rest) => 702 let (* We had a leading / : is the first arc a volume name? *) 703 val {volLen = n, vol, ...} = matchVolumePrefix a 704 in 705 if n = String.size a 706 then (* We have a volume name. *) 707 toString{isAbs=true, vol=vol, arcs=rest} 708 else toString{isAbs=true, vol="", arcs=convArcs} 709 end 710 | (a :: rest) => 711 let (* May be a relative volume name. *) 712 val {volLen = n, vol, ...} = matchVolumePrefix a 713 in 714 if n = String.size a 715 then toString{isAbs=false, vol=vol, arcs=rest} 716 else toString{isAbs=false, vol="", arcs=convArcs} 717 end 718 end 719 720 end (* Path *) 721 722 structure FileSys:> OS_FILE_SYS = 723 struct 724 type dirFd = int 725 (* The directory stream consists of the stream identifier 726 returned by openDir together with the original directory 727 name. We need that for rewind in Windows. *) 728 datatype dirstream = DIR of dirFd * string 729 730 local 731 val doIo: int*unit*string -> dirFd 732 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 733 in 734 fun openDir (s : string): dirstream = 735 DIR(doIo(50, (), s), s) 736 end 737 738 local 739 val doIo: int*dirFd*unit -> string 740 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 741 in 742 fun readDir (DIR(d, _)): string option = 743 let 744 (* This returns the empty string at end-of-stream. *) 745 val s = doIo(51, d, ()) 746 in 747 if s = "" then NONE else SOME s 748 end 749 end 750 751 local 752 val doIo: int*dirFd*unit -> unit 753 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 754 in 755 fun closeDir(DIR(d, _)) = 756 doIo(52, d, ()) 757 end 758 759 local 760 val doIo: int*dirFd*string -> unit 761 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 762 in 763 (* We need to pass in the string because Windows 764 has to reopen the stream. *) 765 fun rewindDir(DIR(d, s)) = 766 doIo(53, d, s) 767 end 768 769 val chDir: string -> unit = RunCall.rtsCallFull1 "PolyChDir" 770 771 local 772 val doIo: int*unit*unit -> string 773 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 774 in 775 (* Return current directory. *) 776 fun getDir() = doIo(54, (), ()) 777 (* Get a temporary file name. *) 778 fun tmpName() = doIo(67, (), ()) 779 end 780 781 local 782 val doIo: int*unit*string -> unit 783 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 784 in 785 (* Create and delete directories and remove a file. *) 786 fun mkDir s = doIo(55, (), s) 787 and rmDir s = doIo(56, (), s) 788 and remove s = doIo(64, (), s) 789 end 790 791 local 792 val doIo: int*unit*string -> bool 793 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 794 in 795 (* Test for directory and symbolic link. *) 796 fun isDir s = doIo(57, (), s) 797 and isLink s = doIo(58, (), s) 798 end 799 800 local 801 val doIo: int*unit*string -> string 802 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 803 in 804 (* Read a symbolic link. *) 805 fun readLink s = doIo(59, (), s) 806 (* Get a full canonical path name. *) 807 and fullPath s = doIo(60, (), s) 808 end 809 810 local 811 val doIo: int*unit*string -> Time.time 812 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 813 in 814 (* Get file modification time. *) 815 fun modTime s = doIo(61, (), s) 816 end 817 818 local 819 val doIo: int*unit*string -> Position.int (* This can be larger than 32-bits. *) 820 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 821 in 822 (* Get file size. *) 823 fun fileSize s = doIo(62, (), s) 824 end 825 826 local 827 val doIo: int*string*Time.time -> unit 828 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 829 in 830 (* Get file size. *) 831 fun setTime(s, NONE) = doIo(63, s, Time.now()) 832 | setTime(s, SOME t) = doIo(63, s, t) 833 end 834 835 local 836 val doIo: int*string*string -> unit 837 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 838 in 839 (* Rename a file. *) 840 fun rename {old, new} = doIo(65, old, new) 841 end 842 843 datatype access_mode 844 = A_READ 845 | A_WRITE 846 | A_EXEC 847 848 local 849 val doIo: int*string*word -> bool 850 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 851 852 fun mapAccess (A_READ, m) = Word.orb(m, 0w1) 853 | mapAccess (A_WRITE, m) = Word.orb(m, 0w2) 854 | mapAccess (A_EXEC, m) = Word.orb(m, 0w4) 855 in 856 (* Get access rights. *) 857 fun access (s, m) = doIo(66, s, List.foldl mapAccess 0w0 m) 858 end 859 860 (* file_id seems to be intended to reflect the semantics of 861 a Unix inode. That concept doesn't exist in Windows so 862 we use a canonical file name instead. *) 863 datatype file_id = 864 INODE of LargeInt.int | FILENAME of string 865 866 fun compare(INODE i, INODE j) = LargeInt.compare(i, j) 867 | compare(FILENAME s, FILENAME t) = String.compare(s, t) 868 | (* These cases shouldn't happen but we'll define them 869 anyway. *) 870 compare(INODE _, FILENAME _) = General.GREATER 871 | compare(FILENAME _, INODE _) = General.LESS 872 873 (* TODO: The hash function is supposed to well distribute the 874 the values when taken modulo 2^n for any n. 875 I'm sure we can come up with something better than this. *) 876 fun hash(INODE i) = 877 let 878 open Word 879 infix xorb << 880 val w = Word.fromLargeInt i 881 in 882 w xorb (w << 0w8) xorb (w << 0w16) xorb (w << 0w24) 883 end 884 885 | hash(FILENAME s) = 886 (* Simple hash function which multiplies the accumulator 887 by 7 and adds in the next character. *) 888 CharVector.foldl 889 (fn(c, a) => a * 0w7 + Word.fromInt(Char.ord c)) 0w0 s 890 local 891 val doIo: int*unit*string -> LargeInt.int 892 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 893 in 894 (* Get file id (inode). Returns negative value if inodes aren't 895 supported. *) 896 fun fileId s = 897 let 898 val i = doIo(68, (), s) 899 in 900 if i < 0 901 then FILENAME(fullPath s) 902 else INODE i 903 end 904 end 905 906 fun realPath p = 907 if Path.isAbsolute p 908 then fullPath p 909 else Path.mkRelative{path=fullPath p, relativeTo=fullPath(getDir())} 910 end (* FileSys *) 911 912 structure IO :> OS_IO = 913 struct 914 datatype iodesc = 915 IODESC of int (* Actually abstract. This isn't 916 the file descriptor itself, rather 917 a pointer into the io table. *) 918 local 919 val doIo: int*iodesc*unit -> int 920 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 921 in 922 (* Get underlying index. *) 923 fun getIndex f = doIo(69, f, ()) 924 end 925 926 (* TODO: The hash function is supposed to well distribute the 927 the values when taken modulo 2^n for any n. 928 I'm sure we can come up with something better than this. *) 929 fun hash (i: iodesc) : word = 930 let 931 open Word 932 infix xorb << 933 val w = Word.fromInt(getIndex i) 934 in 935 w xorb (w << 0w8) xorb (w << 0w16) xorb (w << 0w24) 936 end 937 938 fun compare(i, j) = Int.compare(getIndex i, getIndex j) 939 940 (* eq *)type iodesc_kind = int 941 942 structure Kind = 943 struct 944 val file : iodesc_kind = 0 945 val dir : iodesc_kind = 1 946 val symlink : iodesc_kind = 2 947 val tty : iodesc_kind = 3 948 val pipe : iodesc_kind = 4 949 val socket : iodesc_kind = 5 950 val device : iodesc_kind = 6 951 end 952 953 local 954 val doIo: int*iodesc*int -> int 955 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 956 in 957 fun kind (i: iodesc): iodesc_kind = 958 let 959 val k = doIo(21, i, 0) 960 in 961 (* Returns a negative number if the call fails, 962 otherwise one of the above numbers. *) 963 if k < 0 orelse k > 6 964 then raise SysErr("Invalid result", NONE) 965 else k 966 end 967 end 968 969 (* The poll descriptor and the result of polling is a 970 bit map together with the io descriptor. *) 971 val inBit = 0w1 and outBit = 0w2 and priBit = 0w4 972 973 (* N.B. The implementation of poll_desc is hard-wired into 974 Socket.pollDesc. *) 975 type poll_desc = word*iodesc 976 datatype poll_info = PI of word*poll_desc 977 978 local 979 val doIo: int*iodesc*int -> word 980 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 981 in 982 fun sys_poll_test(i: iodesc) = doIo(22, i, 0) 983 end 984 985 local 986 val doIo: int*int* 987 (iodesc Vector.vector * word Vector.vector * Time.time) -> 988 word Vector.vector 989 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 990 in 991 fun sys_poll_block(iov, wv) = doIo(23, 0, (iov, wv, Time.zeroTime)) 992 fun sys_poll_poll(iov, wv) = doIo(25, 0, (iov, wv, Time.zeroTime)) 993 and sys_poll_wait (iov, wv, t) = doIo(24, 0, (iov, wv, t)) 994 end 995 996 997 fun pollDesc (i: iodesc): poll_desc option = 998 (* If the poll test returns zero then polling is 999 not allowed for any mode. *) 1000 if sys_poll_test i = 0w0 1001 then NONE 1002 else SOME(0w0, i) 1003 1004 fun pollToIODesc(_, i): iodesc = i 1005 1006 exception Poll 1007 1008 (* Add the appropriate bit to the set if it is allowed. *) 1009 local 1010 fun addBit b ((bm, i)) = 1011 if Word.andb(sys_poll_test i, b) = 0w0 1012 then raise Poll 1013 else (Word.orb(bm, b), i) 1014 in 1015 val pollIn = addBit inBit 1016 and pollOut = addBit outBit 1017 and pollPri = addBit priBit 1018 end 1019 1020 fun poll (l : poll_desc list, t: Time.time Option.option) : 1021 poll_info list = 1022 let 1023 (* The original poll descriptor list may contain multiple occurrences of 1024 the same IO descriptor with the same or different flags. On Cygwin, at 1025 least, passing this directly produces funny results so we transform the 1026 request so that we make at most one request for each descriptor. *) 1027 local 1028 fun quickSort _ ([]:'a list) = [] 1029 | quickSort _ ([h]:'a list) = [h] 1030 | quickSort (leq:'a -> 'a -> bool) ((h::t) :'a list) = 1031 let 1032 val (after, befor) = List.partition (leq h) t 1033 in 1034 quickSort leq befor @ (h :: quickSort leq after) 1035 end; 1036 1037 fun leqPoll((p1, f1): poll_desc) ((p2, f2): poll_desc) = 1038 case compare(f1, f2) of 1039 EQUAL => p1 <= p2 1040 | LESS => true 1041 | GREATER => false 1042 1043 fun merge ((p1, f1) :: (p2, f2) :: rest) = 1044 if compare(f1, f2) = EQUAL 1045 then merge((Word.orb(p1, p2), f1) :: rest) 1046 else (p1, f1) :: merge((p2, f2) :: rest) 1047 | merge c = c 1048 1049 val sortedDescs = quickSort leqPoll l 1050 in 1051 val mergedDescs = merge sortedDescs 1052 end 1053 1054 (* Turn the list into vectors of io descriptors and 1055 request bits - easier for the RTS to manage. 1056 N.B. This assumes that Vector.vector creates a simple memory vector and 1057 does not wrap it in any way. *) 1058 local 1059 val (bits, ioDescs) = ListPair.unzip mergedDescs 1060 in 1061 val bitVector: word Vector.vector = Vector.fromList bits 1062 and ioVector: iodesc Vector.vector = Vector.fromList ioDescs 1063 end 1064 (* Do the actual polling. Returns a vector with bits 1065 set for the results. *) 1066 val resV: word Vector.vector = 1067 case t of 1068 NONE => sys_poll_block(ioVector, bitVector) 1069 | SOME tt => 1070 let 1071 open Time 1072 in 1073 if tt = Time.zeroTime 1074 then sys_poll_poll(ioVector, bitVector) 1075 else if tt < Time.zeroTime 1076 (* Must check for negative times since these can be 1077 interpreted as infinity. *) 1078 then raise SysErr("Invalid time", NONE) 1079 (* For non-zero times we convert this to a number of 1080 milliseconds since the current time. We have to 1081 pass in an absolute time rather than a relative 1082 time because the RTS may retry this call if the 1083 polled events haven't happened. *) 1084 else sys_poll_wait(ioVector, bitVector, tt + Time.now()) 1085 end 1086 (* Process the original list to see which items are present, retaining the 1087 original order. *) 1088 fun testResults(request as (bits, iod), tl) = 1089 let 1090 val (index, _) = (* Find the IO descriptor. It must be there somewhere. *) 1091 valOf(Vector.findi (fn (_, iod1) => compare(iod, iod1) = EQUAL) ioVector) 1092 (* The result is in the corresponding index position. We need to AND this 1093 with the request because we could have separate requests asking for 1094 different bits for the same file descriptor. *) 1095 val result = Word.andb(bits, Vector.sub(resV, index)) 1096 in 1097 if result = 0w0 1098 then tl 1099 else PI(result, request) :: tl 1100 end 1101 in 1102 List.foldl testResults [] l 1103 end 1104 1105 fun isIn(PI(b, _)) = Word.andb(b, inBit) <> 0w0 1106 and isOut(PI(b, _)) = Word.andb(b, outBit) <> 0w0 1107 and isPri(PI(b, _)) = Word.andb(b, priBit) <> 0w0 1108 1109 fun infoToPollDesc (PI(_, pd)) = pd 1110 1111 end (* IO *) 1112 1113 structure Process:> OS_PROCESS = 1114 struct 1115 1116 type status = int 1117 1118 local 1119 val doCall: int*unit -> int 1120 = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" 1121 in 1122 val success = doCall(15, ()) 1123 and failure = doCall(16, ()) 1124 end 1125 1126 fun isSuccess i = i = success 1127 1128 local 1129 val doCall: int*string -> status 1130 = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" 1131 in 1132 (* Run a process and wait for the result. *) 1133 fun system s = doCall(17, s) 1134 end 1135 1136 local 1137 val doCall: int*(unit->unit) -> unit 1138 = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" 1139 in 1140 (* Register a function to be run at exit. *) 1141 fun atExit f = doCall(18, f) 1142 end 1143 1144 local 1145 (* exit - supply result code and close down all threads. *) 1146 val doExit: int -> unit = RunCall.rtsCallFull1 "PolyFinish" 1147 val doCall: int*unit -> (unit->unit) = 1148 RunCall.rtsCallFull2 "PolyProcessEnvGeneral" 1149 in 1150 fun exit (n: int) = 1151 let 1152 (* Get a function from the atExit list. If that list 1153 is empty it will raise an exception and we've finished. *) 1154 val exitFun = 1155 doCall(19, ()) handle _ => (doExit n; fn () => ()) 1156 in 1157 (* Run the function and then repeat. *) 1158 exitFun() handle _ => (); (* Ignore exceptions in the function. *) 1159 exit(n) 1160 end 1161 end 1162 1163 (* Terminate without running the atExit list or flushing the 1164 buffers. We raise an exception to get the type right. *) 1165 local 1166 val doCall: int -> unit = RunCall.rtsCallFull1 "PolyTerminate" 1167 in 1168 fun terminate n = (doCall n; raise Fail "never") 1169 end 1170 1171 local 1172 val doCall: int*string -> string 1173 = RunCall.rtsCallFull2 "PolyProcessEnvGeneral" 1174 in 1175 (* Get an environment string. The underlying call raises an 1176 exception if the string isn't there. *) 1177 fun getEnv s = 1178 SOME(doCall(14, s)) handle RunCall.SysErr _ => NONE 1179 end 1180 1181 (* poll is implemented so that an empty list simply waits for 1182 the time. *) 1183 fun sleep t = (IO.poll([], SOME t); ()) 1184 end (* Process. *) 1185 1186end; 1187 1188local 1189 (* Install the pretty printer for OS.IO.Kind and OS.syserror. *) 1190 fun kind_string k = 1191 if k = OS.IO.Kind.file then "file" 1192 else if k = OS.IO.Kind.dir then "dir" 1193 else if k = OS.IO.Kind.symlink then "symlink" 1194 else if k = OS.IO.Kind.tty then "tty" 1195 else if k = OS.IO.Kind.pipe then "pipe" 1196 else if k = OS.IO.Kind.socket then "socket" 1197 else if k = OS.IO.Kind.device then "device" 1198 else "unknown" 1199 1200 fun printKind _ _ x = PolyML.PrettyString(kind_string x) 1201 fun printSysError _ _ x = PolyML.PrettyString(OS.errorName x) 1202 1203 (* For the moment just make these opaque. *) 1204 fun printPollDesc _ _ (_: OS.IO.poll_desc) = PolyML.PrettyString "?" 1205 and printPollInfo _ _ (_: OS.IO.poll_info) = PolyML.PrettyString "?" 1206in 1207 val () = PolyML.addPrettyPrinter printKind 1208 val () = PolyML.addPrettyPrinter printSysError 1209 val () = PolyML.addPrettyPrinter printPollDesc 1210 val () = PolyML.addPrettyPrinter printPollInfo 1211end 1212