1(* 2 Title: Standard Basis Library: OS Structures and Signatures 3 Author: David Matthews 4 Copyright David Matthews 2000, 2005, 2015-16, 2019-20 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 where type syserror = LibrarySupport.syserror (* Don't make it abstract a second time *) = 165struct 166 type syserror = LibrarySupport.syserror (* 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 = LibrarySupport.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 LibrarySupport.syserrorToWord 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 word ref (* This is currently a volatile ref. We MUST use pointer equality. *) 916 local 917 val doIo: int*iodesc*unit -> int 918 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 919 in 920 (* Get underlying index. *) 921 fun getIndex f = doIo(69, f, ()) 922 end 923 924 (* TODO: The hash function is supposed to well distribute the 925 the values when taken modulo 2^n for any n. 926 I'm sure we can come up with something better than this. *) 927 fun hash (i: iodesc) : word = 928 let 929 open Word 930 infix xorb << 931 val w = Word.fromInt(getIndex i) 932 in 933 w xorb (w << 0w8) xorb (w << 0w16) xorb (w << 0w24) 934 end 935 936 fun compare(i, j) = Int.compare(getIndex i, getIndex j) 937 938 (* eq *)type iodesc_kind = int 939 940 structure Kind = 941 struct 942 val file : iodesc_kind = 0 943 val dir : iodesc_kind = 1 944 val symlink : iodesc_kind = 2 945 val tty : iodesc_kind = 3 946 val pipe : iodesc_kind = 4 947 val socket : iodesc_kind = 5 948 val device : iodesc_kind = 6 949 end 950 951 local 952 val doIo: int*iodesc*int -> int 953 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 954 in 955 fun kind (i: iodesc): iodesc_kind = 956 let 957 val k = doIo(21, i, 0) 958 in 959 (* Returns a negative number if the call fails, 960 otherwise one of the above numbers. 961 Returns 7 on unknown or something else. *) 962 if k < 0 orelse k > 6 963 then raise SysErr("Invalid result", NONE) 964 else k 965 end 966 end 967 968 (* The poll descriptor and the result of polling is a 969 bit map together with the io descriptor. *) 970 val inBit = 0w1 and outBit = 0w2 and priBit = 0w4 971 972 (* N.B. The implementation of poll_desc is hard-wired into 973 Socket.pollDesc. *) 974 type poll_desc = word*iodesc 975 datatype poll_info = PI of word*poll_desc 976 977 local 978 val doIo: int*iodesc*int -> word 979 = RunCall.rtsCallFull3 "PolyBasicIOGeneral" 980 in 981 fun sys_poll_test(i: iodesc) = doIo(22, i, 0) 982 end 983 984 val sysPoll:iodesc Vector.vector * word Vector.vector * int -> word Vector.vector = 985 RunCall.rtsCallFull3 "PolyPollIODescriptors" 986 987 988 fun pollDesc (i: iodesc): poll_desc option = 989 (* If the poll test returns zero then polling is 990 not allowed for any mode. *) 991 if sys_poll_test i = 0w0 992 then NONE 993 else SOME(0w0, i) 994 995 fun pollToIODesc(_, i): iodesc = i 996 997 exception Poll 998 999 (* Add the appropriate bit to the set if it is allowed. *) 1000 local 1001 fun addBit b ((bm, i)) = 1002 if Word.andb(sys_poll_test i, b) = 0w0 1003 then raise Poll 1004 else (Word.orb(bm, b), i) 1005 in 1006 val pollIn = addBit inBit 1007 and pollOut = addBit outBit 1008 and pollPri = addBit priBit 1009 end 1010 1011 fun poll (l : poll_desc list, t: Time.time Option.option) : poll_info list = 1012 let 1013 (* The original poll descriptor list may contain multiple occurrences of 1014 the same IO descriptor with the same or different flags. On Cygwin, at 1015 least, passing this directly produces funny results so we transform the 1016 request so that we make at most one request for each descriptor. *) 1017 local 1018 fun quickSort _ ([]:'a list) = [] 1019 | quickSort _ ([h]:'a list) = [h] 1020 | quickSort (leq:'a -> 'a -> bool) ((h::t) :'a list) = 1021 let 1022 val (after, befor) = List.partition (leq h) t 1023 in 1024 quickSort leq befor @ (h :: quickSort leq after) 1025 end; 1026 1027 fun leqPoll((p1, f1): poll_desc) ((p2, f2): poll_desc) = 1028 case compare(f1, f2) of 1029 EQUAL => p1 <= p2 1030 | LESS => true 1031 | GREATER => false 1032 1033 fun merge ((p1, f1) :: (p2, f2) :: rest) = 1034 if compare(f1, f2) = EQUAL 1035 then merge((Word.orb(p1, p2), f1) :: rest) 1036 else (p1, f1) :: merge((p2, f2) :: rest) 1037 | merge c = c 1038 1039 val sortedDescs = quickSort leqPoll l 1040 in 1041 val mergedDescs = merge sortedDescs 1042 end 1043 1044 (* Turn the list into vectors of io descriptors and 1045 request bits - easier for the RTS to manage. 1046 N.B. This assumes that Vector.vector creates a simple memory vector and 1047 does not wrap it in any way. *) 1048 local 1049 val (bits, ioDescs) = ListPair.unzip mergedDescs 1050 in 1051 val bitVector: word Vector.vector = Vector.fromList bits 1052 and ioVector: iodesc Vector.vector = Vector.fromList ioDescs 1053 end 1054 (* Do the actual polling. Returns a vector with bits set for the results. *) 1055 val finishTime = case t of NONE => NONE | SOME t => SOME(t + Time.now()) 1056 1057 val pollMillSeconds = 1000 (* 1 second *) 1058 fun doPoll() = 1059 let 1060 val timeToGo = 1061 case finishTime of 1062 NONE => pollMillSeconds 1063 | SOME finish => LargeInt.toInt(LargeInt.min(LargeInt.max(0, Time.toMilliseconds(finish-Time.now())), LargeInt.fromInt pollMillSeconds)) 1064 1065 (* Poll the descriptors. Returns after the timeout whether or not they are ready. *) 1066 val resV = sysPoll(ioVector, bitVector, timeToGo) 1067 in 1068 if timeToGo < pollMillSeconds orelse Vector.exists(fn w => w <> 0w0) resV 1069 then resV 1070 else doPoll() 1071 end 1072 1073 val resV : word Vector.vector = doPoll() 1074 1075 (* Process the original list to see which items are present, retaining the 1076 original order. *) 1077 fun testResults(request as (bits, iod), tl) = 1078 let 1079 val (index, _) = (* Find the IO descriptor. It must be there somewhere. *) 1080 valOf(Vector.findi (fn (_, iod1) => compare(iod, iod1) = EQUAL) ioVector) 1081 (* The result is in the corresponding index position. We need to AND this 1082 with the request because we could have separate requests asking for 1083 different bits for the same file descriptor. *) 1084 val result = Word.andb(bits, Vector.sub(resV, index)) 1085 in 1086 if result = 0w0 1087 then tl 1088 else PI(result, request) :: tl 1089 end 1090 in 1091 List.foldl testResults [] l 1092 end 1093 1094 fun isIn(PI(b, _)) = Word.andb(b, inBit) <> 0w0 1095 and isOut(PI(b, _)) = Word.andb(b, outBit) <> 0w0 1096 and isPri(PI(b, _)) = Word.andb(b, priBit) <> 0w0 1097 1098 fun infoToPollDesc (PI(_, pd)) = pd 1099 1100 end (* IO *) 1101 1102 structure Process:> OS_PROCESS = 1103 struct 1104 1105 type status = int 1106 1107 val success = RunCall.rtsCallFull0 "PolyProcessEnvSuccessValue" () 1108 and failure = RunCall.rtsCallFull0 "PolyProcessEnvFailureValue" () 1109 1110 fun isSuccess i = i = success 1111 1112 (* Run a process and wait for the result. *) 1113 val system: string -> status = RunCall.rtsCallFull1 "PolyProcessEnvSystem" 1114 1115 local 1116 val atExitList = LibrarySupport.atExitList 1117 val atExitMutex = Thread.Mutex.mutex() 1118 val exitResult = LibrarySupport.volatileOptionRef() (* Set to the exit result. *) 1119 1120 val reallyExit: int -> unit = RunCall.rtsCallFull1 "PolyFinish" 1121 in 1122 (* Register a function to be run at exit. If we are already exiting 1123 this has no effect. *) 1124 val atExit = ThreadLib.protect atExitMutex 1125 (fn f => case exitResult of ref NONE => LibrarySupport.addAtExit f | _ => ()) 1126 1127 (* Exit. Run the atExit functions and then exit with the result code. 1128 There are a few complications. If a second thread calls exit after 1129 the first one it mustn't start the exit process again. If one of the 1130 atExit functions calls exit recursively it is defined to never return. 1131 We just need to pick up the next atExit function and carry on. *) 1132 fun exit (n: int) = 1133 let 1134 open Thread 1135 open Mutex Thread 1136 (* Turn off further interrupts *) 1137 val () = setAttributes[InterruptState InterruptDefer] 1138 val () = lock atExitMutex 1139 val () = 1140 case !exitResult of 1141 SOME threadId => 1142 if threadId = self() 1143 then () 1144 else (unlock atExitMutex; Thread.exit()) 1145 | NONE => exitResult := SOME(self()) 1146 val () = unlock atExitMutex 1147 (* This is now the only thread here. 1148 Take an item off the list and update the list with the 1149 tail in case we recursively call "exit". *) 1150 fun runExit () = 1151 case !atExitList of 1152 [] => reallyExit n 1153 | (hd::tl) => (atExitList := tl; hd() handle _ => (); runExit()) 1154 in 1155 runExit(); 1156 raise Match (* Never reached but gives the 'a result. *) 1157 end 1158 end 1159 1160 (* Terminate without running the atExit list or flushing the 1161 buffers. We raise an exception to get the type right. *) 1162 local 1163 val doCall: int -> unit = RunCall.rtsCallFull1 "PolyTerminate" 1164 in 1165 fun terminate n = (doCall n; raise Fail "never") 1166 end 1167 1168 local 1169 val doCall: string -> string = RunCall.rtsCallFull1 "PolyGetEnv" 1170 in 1171 (* Get an environment string. The underlying call raises an 1172 exception if the string isn't there. *) 1173 fun getEnv s = SOME(doCall s) handle RunCall.SysErr _ => NONE 1174 end 1175 1176 (* poll is implemented so that an empty list simply waits for 1177 the time. *) 1178 fun sleep t = (IO.poll([], SOME t); ()) 1179 end (* Process. *) 1180 1181end; 1182 1183local 1184 (* Install the pretty printer for OS.IO.Kind and OS.syserror. *) 1185 fun kind_string k = 1186 if k = OS.IO.Kind.file then "file" 1187 else if k = OS.IO.Kind.dir then "dir" 1188 else if k = OS.IO.Kind.symlink then "symlink" 1189 else if k = OS.IO.Kind.tty then "tty" 1190 else if k = OS.IO.Kind.pipe then "pipe" 1191 else if k = OS.IO.Kind.socket then "socket" 1192 else if k = OS.IO.Kind.device then "device" 1193 else "unknown" 1194 1195 fun printKind _ _ x = PolyML.PrettyString(kind_string x) 1196 fun printSysError _ _ x = PolyML.PrettyString(OS.errorName x) 1197 1198 (* For the moment just make these opaque. *) 1199 fun printPollDesc _ _ (_: OS.IO.poll_desc) = PolyML.PrettyString "?" 1200 and printPollInfo _ _ (_: OS.IO.poll_info) = PolyML.PrettyString "?" 1201in 1202 val () = PolyML.addPrettyPrinter printKind 1203 val () = PolyML.addPrettyPrinter printSysError 1204 val () = PolyML.addPrettyPrinter printPollDesc 1205 val () = PolyML.addPrettyPrinter printPollInfo 1206end 1207