diff --git a/basis/Windows.sml b/basis/Windows.sml index 907f4af5..121eb593 100644 --- a/basis/Windows.sml +++ b/basis/Windows.sml @@ -1,985 +1,971 @@ (* Title: Standard Basis Library: Windows signature and structure Author: David Matthews Copyright David Matthews 2000, 2005, 2012, 2018, 2019 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) signature WINDOWS = sig structure Key : sig include BIT_FLAGS val allAccess : flags val createLink : flags val createSubKey : flags val enumerateSubKeys : flags val execute : flags val notify : flags val queryValue : flags val read : flags val setValue : flags val write : flags end structure Reg : sig eqtype hkey val classesRoot : hkey val currentUser : hkey val localMachine : hkey val users : hkey val performanceData : hkey val currentConfig : hkey val dynData : hkey datatype create_result = CREATED_NEW_KEY of hkey | OPENED_EXISTING_KEY of hkey val createKeyEx : hkey * string * Key.flags -> create_result val openKeyEx : hkey * string * Key.flags -> hkey val closeKey : hkey -> unit val deleteKey : hkey * string -> unit val deleteValue : hkey * string -> unit val enumKeyEx : hkey * int -> string option val enumValueEx : hkey * int -> string option datatype value = SZ of string | DWORD of SysWord.word | BINARY of Word8Vector.vector | MULTI_SZ of string list | EXPAND_SZ of string val queryValueEx : hkey * string -> value option val setValueEx : hkey * string * value -> unit end structure Config: sig val platformWin32s : SysWord.word val platformWin32Windows : SysWord.word val platformWin32NT : SysWord.word val platformWin32CE : SysWord.word val getVersionEx: unit -> { majorVersion: SysWord.word, minorVersion: SysWord.word, buildNumber: SysWord.word, platformId: SysWord.word, csdVersion: string } val getWindowsDirectory: unit -> string val getSystemDirectory: unit -> string val getComputerName: unit -> string val getUserName: unit -> string end structure DDE : sig type info val startDialog : string * string -> info val executeString : info * string * int * Time.time -> unit val stopDialog : info -> unit end val getVolumeInformation : string -> { volumeName : string, systemName : string, serialNumber : SysWord.word, maximumComponentLength : int } val findExecutable : string -> string option val launchApplication : string * string -> unit val openDocument : string -> unit val simpleExecute : string * string -> OS.Process.status type ('a,'b) proc val execute : string * string -> ('a, 'b) proc val textInstreamOf : (TextIO.instream, 'a) proc -> TextIO.instream val binInstreamOf : (BinIO.instream, 'a) proc -> BinIO.instream val textOutstreamOf : ('a, TextIO.outstream) proc -> TextIO.outstream val binOutstreamOf : ('a, BinIO.outstream) proc -> BinIO.outstream val reap : ('a, 'b) proc -> OS.Process.status structure Status : sig type status = SysWord.word val accessViolation : status val arrayBoundsExceeded : status val breakpoint : status val controlCExit : status val datatypeMisalignment : status val floatDenormalOperand : status val floatDivideByZero : status val floatInexactResult : status val floatInvalidOperation : status val floatOverflow : status val floatStackCheck : status val floatUnderflow : status val guardPageViolation : status val integerDivideByZero : status val integerOverflow : status val illegalInstruction : status val invalidDisposition : status val invalidHandle : status val inPageError : status val noncontinuableException: status val pending : status val privilegedInstruction : status val singleStep : status val stackOverflow : status val timeout : status val userAPC : status end val fromStatus : OS.Process.status -> Status.status val exit : Status.status -> 'a end structure Windows :> WINDOWS = struct open Foreign val cDWORD = cUint32 (* Defined to be 32-bit unsigned *) (* Conversion for a fixed size char array. *) fun cCHARARRAY n : string conversion = let (* Make it a struct of chars *) val { size=sizeC, align=alignC, ffiType=ffiTypeC } = LowLevel.cTypeChar val arraySize = sizeC * Word.fromInt n fun ffiType () = LibFFI.createFFItype { size = arraySize, align = alignC, typeCode=LibFFI.ffiTypeCodeStruct, elements = List.tabulate (n, fn _ => ffiTypeC()) } val arrayType: LowLevel.ctype = { size = arraySize, align = alignC, ffiType = ffiType } open Memory fun load(v: voidStar): string = let (* It should be null-terminated but just in case... *) fun sLen i = if i = Word.fromInt n orelse get8(v, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(v, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end fun store(v: voidStar, s: string) = let (* The length must be less than the size to allow for the null *) val sLen = size s val _ = sLen < n orelse raise Fail "string too long" in CharVector.appi(fn(i, ch) => set8(v, Word.fromInt i, Word8.fromInt(Char.ord ch))) s; set8(v, Word.fromInt sLen, 0w0); fn () => () end in makeConversion { load = load, store = store, ctype = arrayType } end (* These are called XXX32.DLL on both 32-bit and 64-bit. *) fun kernel name = getSymbol(loadLibrary "kernel32.dll") name and shell sym = getSymbol(loadLibrary "shell32.DLL") sym and advapi sym = getSymbol(loadLibrary "advapi32.DLL") sym (* We need to use the Pascal calling convention on 32-bit Windows. *) val winAbi = case List.find (fn ("stdcall", _) => true | _ => false) LibFFI.abiList of SOME(_, abi) => abi | NONE => LibFFI.abiDefault (* As well as setting the abi we can also use the old argument order. *) fun winCall1 sym argConv resConv = buildCall1withAbi(winAbi, sym, argConv, resConv) and winCall2 sym argConv resConv = buildCall2withAbi(winAbi, sym, argConv, resConv) and winCall3 sym argConv resConv = buildCall3withAbi(winAbi, sym, argConv, resConv) and winCall5 sym argConv resConv = buildCall5withAbi(winAbi, sym, argConv, resConv) and winCall6 sym argConv resConv = buildCall6withAbi(winAbi, sym, argConv, resConv) and winCall8 sym argConv resConv = buildCall8withAbi(winAbi, sym, argConv, resConv) and winCall9 sym argConv resConv = buildCall9withAbi(winAbi, sym, argConv, resConv) and winCall12 sym argConv resConv = buildCall12withAbi(winAbi, sym, argConv, resConv) val MAX_PATH = 0w260 (* Convert a C string to ML. *) fun fromCstring buff = let open Memory (* We can't use #load cString because the argument is the address of the address of the string. *) fun sLen i = if get8(buff, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(buff, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end - local - (* Get constants - these can be defined here. *) - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - in - fun getConst i = SysWord.fromInt(winCall (1006, i)) - end - structure Key = struct type flags = SysWord.word fun toWord f = f fun fromWord f = f val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) val queryValue = 0wx0001 and setValue = 0wx0002 and createSubKey = 0wx0004 and enumerateSubKeys = 0wx0008 and notify = 0wx0010 and createLink = 0wx0020 val read = flags[0wx00020000, queryValue, enumerateSubKeys, notify] and write = flags[0wx00020000, setValue, createSubKey] val execute = read val allAccess = flags[0wx000f0000, queryValue, setValue, createSubKey, enumerateSubKeys, notify, createLink] (* all is probably equivalent to allAccess. *) val all = flags[allAccess, createLink, createSubKey, enumerateSubKeys, execute, notify, queryValue, read, setValue, write] val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all end structure Reg = struct datatype hkey = PREDEFINED of SysWord.word | SUBKEY of Memory.volatileRef val classesRoot = PREDEFINED 0wx80000000 and currentUser = PREDEFINED 0wx80000001 and localMachine = PREDEFINED 0wx80000002 and users = PREDEFINED 0wx80000003 and performanceData = PREDEFINED 0wx80000004 and currentConfig = PREDEFINED 0wx80000005 and dynData = PREDEFINED 0wx80000006 datatype create_result = CREATED_NEW_KEY of hkey | OPENED_EXISTING_KEY of hkey datatype value = SZ of string | DWORD of SysWord.word | BINARY of Word8Vector.vector | MULTI_SZ of string list | EXPAND_SZ of string local val invalidHandle = valOf(OS.syserror "ERROR_INVALID_HANDLE") in (* When a subkey is opened the value is stored in a volatile ref. This prevents the key from persisting. *) fun getHkeyValue(PREDEFINED w) = Memory.sysWord2VoidStar w | getHkeyValue(SUBKEY v) = let val w = Memory.getVolatileRef v in if w = 0w0 then raise OS.SysErr("ERROR_INVALID_HANDLE", SOME invalidHandle) else Memory.sysWord2VoidStar w end end (* Check the result and raise an exception if it's non-zero. *) fun checkLResult 0 = () | checkLResult nonZero = let val err = Error.fromWord(SysWord.fromInt nonZero) in raise OS.SysErr(OS.errorMsg err, SOME err) end local val openKey = winCall5 (advapi "RegOpenKeyExA") (cPointer, cString, cDWORD, cDWORD, cStar cPointer) cLong in fun openKeyEx(hkey, key, flags) = let val keyRes = ref Memory.null val result = openKey(getHkeyValue hkey, key, 0, SysWord.toInt(Key.toWord flags), keyRes) in checkLResult result; SUBKEY(Memory.volatileRef(Memory.voidStar2Sysword(!keyRes))) end end local val createKey = winCall9 (advapi "RegCreateKeyExA") (cPointer, cString, cDWORD, cPointer, cDWORD, cDWORD, cPointer, cStar cPointer, cStar cDWORD) cLong in fun createKeyEx(hkey, key, flags) = let val keyRes = ref Memory.null val disp = ref 0 val REG_OPTION_NON_VOLATILE = 0 val REG_CREATED_NEW_KEY = 1 val result = createKey(getHkeyValue hkey, key, 0, Memory.null, REG_OPTION_NON_VOLATILE, SysWord.toInt(Key.toWord flags), Memory.null, keyRes, disp) in checkLResult result; (if ! disp = REG_CREATED_NEW_KEY then CREATED_NEW_KEY else OPENED_EXISTING_KEY) (SUBKEY(Memory.volatileRef(Memory.voidStar2Sysword(!keyRes)))) end end local val regCloseKey = winCall1 (advapi "RegCloseKey") cPointer cLong in fun closeKey hkey = checkLResult(regCloseKey(getHkeyValue hkey)) end local val regDeleteValue = winCall2 (advapi "RegDeleteValueA") (cPointer, cString) cLong in fun deleteValue(hkey, key) = checkLResult(regDeleteValue(getHkeyValue hkey, key)) end local val regDeleteKey = winCall2 (advapi "RegDeleteKeyA") (cPointer, cString) cLong in fun deleteKey(hkey, key) = checkLResult(regDeleteKey(getHkeyValue hkey, key)) end local val regEnumKeyEx = winCall8 (advapi "RegEnumKeyExA") (cPointer, cDWORD, cPointer, cStar cDWORD, cPointer, cPointer, cPointer, cPointer) cLong val regEnumVal = winCall8 (advapi "RegEnumValueA") (cPointer, cDWORD, cPointer, cStar cDWORD, cPointer, cPointer, cPointer, cPointer) cLong val regQueryInfoKey = winCall12 (advapi "RegQueryInfoKeyA") (cPointer, cPointer, cPointer, cPointer, cStar cDWORD, cStar cDWORD, cPointer, cStar cDWORD, cStar cDWORD, cStar cDWORD, cPointer, cPointer) cLong fun getInfo hkey = let open Memory val nSubKeys = ref 0 and maxSubKeyLen = ref 0 and nValues = ref 0 and maxValueNameLen = ref 0 and maxValueLen = ref 0 val result = regQueryInfoKey(getHkeyValue hkey, null, null, null, nSubKeys, maxSubKeyLen, null, nValues, maxValueNameLen, maxValueLen, null, null) in checkLResult result; { nSubKeys = !nSubKeys, maxSubKeyLen = !maxSubKeyLen, nValues = ! nValues, maxValueNameLen = !maxValueNameLen, maxValueLen= !maxValueLen} end in fun enumKeyEx(hkey, n) = let val {nSubKeys, maxSubKeyLen, ...} = getInfo hkey in if n >= nSubKeys then NONE else let open Memory val buff = malloc(Word.fromInt(maxSubKeyLen + 1)) val buffLen = ref(maxSubKeyLen + 1) val result = regEnumKeyEx(getHkeyValue hkey, n, buff, buffLen, null, null, null, null) in checkLResult result handle exn as OS.SysErr _ => (free buff; raise exn); SOME(fromCstring buff) before free buff end end and enumValueEx(hkey, n) = let val {nValues, maxValueNameLen, ...} = getInfo hkey in if n >= nValues then NONE else let open Memory val buff = malloc(Word.fromInt(maxValueNameLen + 1)) val buffLen = ref(maxValueNameLen + 1) val result = regEnumVal(getHkeyValue hkey, n, buff, buffLen, null, null, null, null) in checkLResult result handle exn as OS.SysErr _ => (free buff; raise exn); SOME(fromCstring buff) before free buff end end end local val queryVal = winCall6 (advapi "RegQueryValueExA") (cPointer, cString, cPointer, cStar cDWORD, cPointer, cStar cDWORD) cLong val ERROR_MORE_DATA = 234 val ERROR_FILE_NOT_FOUND = 2 fun unpackString v = let val len = Word8Vector.length v in if len = 0 then "" else Byte.unpackStringVec(Word8VectorSlice.slice(v, 0, SOME(len -1))) end fun unpackStringList v = let val len = Word8Vector.length v fun unpack start i = if i >= len orelse Word8Vector.sub(v, i) = 0w0 then if i = start then [] else Byte.unpackStringVec(Word8VectorSlice.slice(v, start, SOME(i - start))) :: unpack (i+1) (i+1) else unpack start (i+1) in unpack 0 0 end (* Repeat allocating the buffer until it's big enough. *) fun requery(hkey, valueName, buff, buffSize) = let open Memory val buffSizeRef = ref buffSize val typeVal = ref 0 val result = queryVal(getHkeyValue hkey, valueName, Memory.null, typeVal, buff, buffSizeRef) in (* Returns 0 (success) if the buffer is null. Return ERROR_MORE_DATA if it is not null but not big enough. *) if result = ERROR_MORE_DATA orelse result = 0 andalso ! buffSizeRef > buffSize then let val () = free buff val buff = malloc(Word.fromInt(!buffSizeRef)) in requery(hkey, valueName, buff, !buffSizeRef) end else if result = 0 then (* Big enough - return result. N.B. This could be NULL. *) let val v = Word8Vector.tabulate(! buffSizeRef, fn i => get8(buff, Word.fromInt i)) val () = free buff in case !typeVal of 1 => SOME(SZ(unpackString v)) | 4 => SOME(DWORD(PackWord32Little.subVec(v, 0))) | 2 => SOME(EXPAND_SZ(unpackString v)) | 7 => SOME(MULTI_SZ(unpackStringList v)) | _ => SOME(BINARY v) end else if result = ERROR_FILE_NOT_FOUND then NONE else (free buff; checkLResult result; raise Match (* Unused: we've raised an exception *)) end in fun queryValueEx (hkey, valueName) = requery(hkey, valueName, Memory.null, 0) end local val setValue = winCall6 (advapi "RegSetValueExA") (cPointer, cString, cDWORD, cDWORD, cByteArray, cDWORD) cLong fun packString s = let val len = String.size s val arr = Word8Array.array(len+1, 0w0) in Byte.packString(arr, 0, Substring.full s); Word8Array.vector arr end fun packStringList sl = let (* The string list is packed as a set of null-terminated strings with a final null at the end. *) (* TODO: Check for nulls in the strings themselves? *) fun totalSize n [] = n | totalSize n (s::sl) = totalSize (n + String.size s + 1) sl val len = totalSize 1 sl val arr = Word8Array.array(len, 0w0) fun pack _ [] = () | pack n (s::sl) = ( Byte.packString(arr, n, Substring.full s); pack (n + String.size s + 1) sl ) in pack 0 sl; Word8Array.vector arr end fun valuesToTypeVal(SZ s) = (1, packString s) | valuesToTypeVal(EXPAND_SZ s) = (2, packString s) | valuesToTypeVal(BINARY s) = (3, s) | valuesToTypeVal(DWORD n) = let (* Pack the 32 bit value into an array, then extract that. *) val arr = Word8Array.array(4, 0w0) in PackWord32Little.update(arr, 0, n); (4, Word8Array.vector arr) end | valuesToTypeVal(MULTI_SZ s) = (7, packStringList s) in fun setValueEx(hkey, name, v) = let val (t, s) = valuesToTypeVal v val length = Word8Vector.length s val result = setValue(getHkeyValue hkey, name, 0, t, s, length) in checkLResult result end end end structure DDE = struct - type info = int (* Actually abstract. *) + type info = SysWord.word (* Actually a volatile word containing the conversation handle. *) - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - in - fun startDialog (service, topic) = - winCall(1038, (service, topic)) - end + val startDialog: string * string -> info = RunCall.rtsCallFull2 "PolyWindowsDDEStartDialogue" + and stopDialog: info -> unit = RunCall.rtsCallFull1 "PolyWindowsDDEClose" local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall: info * string -> bool = RunCall.rtsCallFull2 "PolyWindowsDDEExecute" in (* The timeout and retry count apply only in the case of a busy result. The Windows call takes a timeout parameter as the length of time to wait for a response and maybe we should use it for that as well. *) fun executeString (info, cmd, retry, delay) = let fun try n = - if winCall(1039, (info, cmd)) + if winCall(info, cmd) then () (* Succeeded. *) else if n = 0 then raise OS.SysErr("DDE Server busy", NONE) else ( OS.IO.poll([], SOME delay); try (n-1) ) in try retry end end - local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" - in - fun stopDialog (info) = winCall(1040, info) - end end (* DDE *) local val getVol = winCall8(kernel "GetVolumeInformationA") (cString, cPointer, cDWORD, cStar cDWORD, cStar cDWORD, cStar cDWORD, cPointer, cDWORD) cInt in fun getVolumeInformation root = let open Memory val volBuffer = malloc (MAX_PATH+0w1) and sysBuffer = malloc (MAX_PATH+0w1) val volSerial = ref 0 and volMaxComponent = ref 0 and fileSysFlags = ref 0 in if getVol(root, volBuffer, Word.toInt(MAX_PATH+0w1), volSerial, volMaxComponent, fileSysFlags, sysBuffer, Word.toInt(MAX_PATH+0w1)) = 0 then let val err = Error.fromWord(Error.getLastError()) in free volBuffer; free sysBuffer; raise OS.SysErr(OS.errorMsg err, SOME err) end else { volumeName = fromCstring volBuffer, systemName = fromCstring sysBuffer, serialNumber = SysWord.fromInt (!volSerial), maximumComponentLength = ! volMaxComponent} before (free volBuffer; free sysBuffer) end end local val findExeca: string * int * Memory.voidStar -> int = winCall3 (shell "FindExecutableA") (cString, cInt, cPointer) cInt in fun findExecutable s = let open Memory val buff = malloc MAX_PATH val result = if findExeca(s, 0 (* NULL *), buff) > 32 then SOME(fromCstring buff) else NONE in free buff; result end end local val shellExecuteInfo = cStruct15(cDWORD, cUlong, cPointer (*HWND*), cString, cString, cOptionPtr cString, cOptionPtr cString, cInt, cPointer (*HINSTANCE*), cPointer, cPointer (*cString*), cPointer (*HKEY*), cDWORD, cPointer (*HANDLE*), cPointer (*HANDLE*)) val {ctype={size, ...}, ...} = breakConversion shellExecuteInfo val shellExec = winCall1 (shell "ShellExecuteExA") (cStar shellExecuteInfo) cInt (* We probably want handle the error ourselves rather than popping up a UI. *) val SEE_MASK_FLAG_NO_UI = 0x00000400 in fun openDocument file = let val r = ref(Word.toInt size, SEE_MASK_FLAG_NO_UI, Memory.null, "open", file, NONE, NONE, 1 (* SW_SHOWNORMAL *), Memory.null, Memory.null, Memory.null, Memory.null, 0, Memory.null, Memory.null) in if shellExec r = 0 then let val err = Error.fromWord(Error.getLastError()) in raise OS.SysErr(OS.errorMsg err, SOME err) end else () end and launchApplication (command, arg) = let val r = ref(Word.toInt size, SEE_MASK_FLAG_NO_UI, Memory.null, "open", command, SOME arg, NONE, 1 (* SW_SHOWNORMAL *), Memory.null, Memory.null, Memory.null, Memory.null, 0, Memory.null, Memory.null) in if shellExec r = 0 then let val err = Error.fromWord(Error.getLastError()) in raise OS.SysErr(OS.errorMsg err, SOME err) end else () end end abstype pid = PID of int with end; (* Abstract *) datatype ('a,'b) proc = WinProc of { pid: pid, result: OS.Process.status option ref, closeActions: (unit->unit) list ref, lock: Thread.Mutex.mutex } (* Run a process and return a proces object which will allow us to extract the input and output streams. *) local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall = RunCall.rtsCallFull2 "PolyWindowsExecute" in fun execute(command, arg): ('a,'b) proc = let - val run: pid = winCall (1000, (command, arg)) + val run: pid = winCall (command, arg) in WinProc{ pid=run, result=ref NONE, closeActions=ref [], lock=Thread.Mutex.mutex() } end end (* Local function to protect access. *) fun winProtect f (w as WinProc{lock, ...}) = ThreadLib.protect lock f w local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_get_buffsize (strm: OS.IO.iodesc): int = doIo(15, strm, 0) end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall: pid * bool * bool -> OS.IO.iodesc = + RunCall.rtsCallFull3 "PolyWindowsOpenProcessHandle" fun textInstreamOf'(WinProc{pid, closeActions, ...}) = let (* Get the underlying file descriptor. *) - val n = winCall (1001, RunCall.unsafeCast pid) + val n = winCall(pid, true, true) val textPrimRd = LibraryIOSupport.wrapInFileDescr {fd=n, name="TextPipeInput", initBlkMode=true} val streamIo = TextIO.mkInstream(TextIO.StreamIO.mkInstream(textPrimRd, "")) fun closeThis() = TextIO.closeIn streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end fun textOutstreamOf'(WinProc{pid, closeActions, ...}) = let - val n = winCall (1002, RunCall.unsafeCast pid) + val n = winCall (pid, false, true) val buffSize = sys_get_buffsize n val textPrimWr = LibraryIOSupport.wrapOutFileDescr{fd=n, name="TextPipeOutput", appendMode=false, initBlkMode=true, chunkSize=buffSize} (* Construct a stream. *) val streamIo = TextIO.mkOutstream(TextIO.StreamIO.mkOutstream(textPrimWr, IO.LINE_BUF)) fun closeThis() = TextIO.closeOut streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end fun binInstreamOf'(WinProc{pid, closeActions, ...}) = let (* Get the underlying file descriptor. *) - val n = winCall (1003, RunCall.unsafeCast pid) + val n = winCall (pid, true, false) val binPrimRd = LibraryIOSupport.wrapBinInFileDescr {fd=n, name="BinPipeInput", initBlkMode=true} val streamIo = BinIO.mkInstream(BinIO.StreamIO.mkInstream(binPrimRd, Word8Vector.fromList [])) fun closeThis() = BinIO.closeIn streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end fun binOutstreamOf'(WinProc{pid, closeActions, ...}) = let - val n = winCall (1004, RunCall.unsafeCast pid) + val n = winCall (pid, false, false) val buffSize = sys_get_buffsize n val binPrimWr = LibraryIOSupport.wrapBinOutFileDescr{fd=n, name="BinPipeOutput", appendMode=false, initBlkMode=true, chunkSize=buffSize} (* Construct a stream. *) val streamIo = BinIO.mkOutstream(BinIO.StreamIO.mkOutstream(binPrimWr, IO.LINE_BUF)) fun closeThis() = BinIO.closeOut streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end in fun textInstreamOf w = winProtect textInstreamOf' w and textOutstreamOf w = winProtect textOutstreamOf' w and binInstreamOf w = winProtect binInstreamOf' w and binOutstreamOf w = winProtect binOutstreamOf' w end (* reap - wait until the process finishes and get the result. Note: this is defined to be able to return the result repeatedly. *) local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall: pid -> OS.Process.status = RunCall.rtsCallFull1 "PolyWindowsGetProcessResult" fun reap'(WinProc{result=ref(SOME r), ...}) = r | reap'(WinProc{pid, result, closeActions, ...}) = let val _ = List.app(fn f => f()) (!closeActions) val _ = closeActions := [] - val res: OS.Process.status = winCall (1005, RunCall.unsafeCast pid) + val res: OS.Process.status = winCall pid val _ = result := SOME res in res end in fun reap w = winProtect reap' w end local - val winCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral" + val winCall: string * string -> pid = RunCall.rtsCallFull2 "PolyWindowsSimpleExecute" in (* Run a process and wait for the result. Rather than do the whole thing as a single RTS call we first start the process and then call "reap" to get the result. This allows this to be run as a separate ML process if necessary without blocking everything. This is similar to OS.Process.system but differs in that the streams are directed to NUL and this runs the executable directly, not via cmd.exe/command.com so cannot run DOS commands. OS.Process.system waits for the result within the RTS call so the whole of ML will be blocked until the process completes. *) fun simpleExecute (command, arg) = let - val run: pid = winCall(1037, (command, arg)) + val run: pid = winCall(command, arg) val process = WinProc{ pid=run, result=ref NONE, closeActions=ref [], lock=Thread.Mutex.mutex() } in reap process end end structure Status = struct type status = SysWord.word - val accessViolation = getConst 10 - val arrayBoundsExceeded = getConst 11 - val breakpoint = getConst 12 - val controlCExit = getConst 13 - val datatypeMisalignment = getConst 14 - val floatDenormalOperand = getConst 15 - val floatDivideByZero = getConst 16 - val floatInexactResult = getConst 17 - val floatInvalidOperation = getConst 18 - val floatOverflow = getConst 19 - val floatStackCheck = getConst 20 - val floatUnderflow = getConst 21 - val guardPageViolation = getConst 22 - val integerDivideByZero = getConst 23 - val integerOverflow = getConst 24 - val illegalInstruction = getConst 25 - val invalidDisposition = getConst 26 - val invalidHandle = getConst 27 - val inPageError = getConst 28 + val accessViolation = 0wxC0000005 + val arrayBoundsExceeded = 0wxC000008C + val breakpoint = 0wx80000003 + val controlCExit = 0wxC000013A + val datatypeMisalignment = 0wx80000002 + val floatDenormalOperand = 0wxC000008D + val floatDivideByZero = 0wxC000008E + val floatInexactResult = 0wxC000008F + val floatInvalidOperation = 0wxC0000090 + val floatOverflow = 0wxC0000091 + val floatStackCheck = 0wxC0000092 + val floatUnderflow = 0wxC0000093 + val guardPageViolation = 0wx80000001 + val integerDivideByZero = 0wxC0000094 + val integerOverflow = 0wxC0000095 + val illegalInstruction = 0wxC000001D + val invalidDisposition = 0wxC0000026 + val invalidHandle = 0wxC0000008 + val inPageError = 0wxC0000006 (* This was given as nocontinuableException *) - val noncontinuableException= getConst 29 - val pending = getConst 30 - val privilegedInstruction = getConst 31 - val singleStep = getConst 32 - val stackOverflow = getConst 33 - val timeout = getConst 34 - val userAPC = getConst 35 + val noncontinuableException= 0wxC0000025 + val pending = 0wx103 + val privilegedInstruction = 0wxC0000096 + val singleStep = 0wx80000004 + val stackOverflow = 0wxC00000FD + val timeout = 0wx102 + val userAPC = 0wxC0 end (* The status is implemented as an integer. *) fun fromStatus (s: OS.Process.status): Status.status = SysWord.fromInt(RunCall.unsafeCast s); fun exit (s: Status.status) = OS.Process.exit(RunCall.unsafeCast(SysWord.toInt s)) structure Config = struct local val osVersionInfo = cStruct6(cDWORD, cDWORD, cDWORD, cDWORD, cDWORD, cCHARARRAY 128) val { ctype={size, ...}, ...} = breakConversion osVersionInfo val callGetVersion = winCall1 (kernel "GetVersionExA") (cStar osVersionInfo) cInt in fun getVersionEx () = let val r = ref(Word.toInt size, 0, 0, 0, 0, "") in if callGetVersion r = 0 then let val err = Error.fromWord(Error.getLastError()) in raise OS.SysErr(OS.errorMsg err, SOME err) end else let val (_, major, minor, build, platform, version) = !r in { majorVersion = SysWord.fromInt major, minorVersion = SysWord.fromInt minor, buildNumber = SysWord.fromInt build, platformId = SysWord.fromInt platform, csdVersion = version } end end end local (* Get Windows directory and System directory. *) val getWinDir: Memory.voidStar * int -> int = winCall2(kernel "GetWindowsDirectoryA") (cPointer, cUint) cUint and getSysDir: Memory.voidStar * int -> int = winCall2(kernel "GetSystemDirectoryA") (cPointer, cUint) cUint fun getDirectory getDir () = let open Memory val buff = malloc MAX_PATH val result = getDir(buff, Word.toInt MAX_PATH) in if result = 0 then let val err = Error.fromWord(Error.getLastError()) in free buff; raise OS.SysErr(OS.errorMsg err, SOME err) end else fromCstring buff before free buff end in val getWindowsDirectory = getDirectory getWinDir and getSystemDirectory = getDirectory getSysDir end local val getCompName: Memory.voidStar * int ref -> int = winCall2(kernel "GetComputerNameA") (cPointer, cStar cDWORD) cInt and getUsrName: Memory.voidStar * int ref -> int = winCall2(advapi "GetUserNameA") (cPointer, cStar cDWORD) cUint val MAX_COMPUTERNAME_LENGTH = 015 and UNLEN = 256 fun getName (getNm, len) () = let open Memory val buff = malloc(Word.fromInt len) val result = getNm(buff, ref len) in if result = 0 then let val err = Error.fromWord(Error.getLastError()) in free buff; raise OS.SysErr(OS.errorMsg err, SOME err) end else fromCstring buff before free buff end in val getComputerName = getName(getCompName, MAX_COMPUTERNAME_LENGTH+1) and getUserName = getName(getUsrName, UNLEN+1) end - val platformWin32s = getConst 36 - val platformWin32Windows = getConst 37 - val platformWin32NT = getConst 38 - val platformWin32CE = getConst 39 + (* All of these are long since dead *) + val platformWin32s = 0w0 + val platformWin32Windows = 0w1 + val platformWin32NT = 0w2 + val platformWin32CE = 0w3 end end; local (* Add pretty printers to hide internals. *) fun prettyRegKey _ _ (_: Windows.Reg.hkey) = PolyML.PrettyString "?" and prettyDDEInfo _ _ (_: Windows.DDE.info) = PolyML.PrettyString "?" and prettyProc _ _ (_: ('a, 'b) Windows.proc) = PolyML.PrettyString "?" in val () = PolyML.addPrettyPrinter prettyRegKey and () = PolyML.addPrettyPrinter prettyDDEInfo and () = PolyML.addPrettyPrinter prettyProc end; diff --git a/libpolyml/windows_specific.cpp b/libpolyml/windows_specific.cpp index dc738d70..9bf6e2fa 100644 --- a/libpolyml/windows_specific.cpp +++ b/libpolyml/windows_specific.cpp @@ -1,582 +1,538 @@ /* Title: Operating Specific functions: Windows version. Copyright (c) 2000, 2015, 2018, 2019 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #include #include #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_TCHAR_H #include #endif #ifdef HAVE_IO_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #include #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include #include "globals.h" #include "arb.h" #include "gc.h" #include "run_time.h" #include "io_internal.h" #include "os_specific.h" #include "sys.h" #include "processes.h" #include "winguiconsole.h" #include "mpoly.h" #include "diagnostics.h" #include "scanaddrs.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "machine_dep.h" #include "rtsentry.h" #include "winstartup.h" #define SAVE(x) taskData->saveVec.push(x) #define SIZEOF(x) (sizeof(x)/sizeof(word)) extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsExecute(FirstArgument threadId, PolyWord command, PolyWord argument); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsOpenProcessHandle(FirstArgument threadId, PolyWord arg, PolyWord isRead, PolyWord isText); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsGetProcessResult(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsSimpleExecute(FirstArgument threadId, PolyWord command, PolyWord argument); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEStartDialogue(FirstArgument threadId, PolyWord service, PolyWord topic); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEExecute(FirstArgument threadId, PolyWord info, PolyWord commd); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEClose(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetOSType(); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsGetCodePage(); } -typedef enum -{ - HE_UNUSED, - HE_PROCESS -} HANDENTRYTYPE; - typedef struct { HANDLE hProcess, hInput, hOutput; } PROCESSDATA; -static Handle execute(TaskData *taskData, Handle pname); -static Handle simpleExecute(TaskData *taskData, Handle args); -static Handle openProcessHandle(TaskData *taskData, Handle args, bool fIsRead, bool fIsText); - -// Vector of constants returned by call1006 -static POLYUNSIGNED winConstVec[] = +// Start DDE dialogue. +POLYUNSIGNED PolyWindowsDDEStartDialogue(FirstArgument threadId, PolyWord service, PolyWord topic) { - KEY_ALL_ACCESS, // 0 - KEY_CREATE_LINK, - KEY_CREATE_SUB_KEY, - KEY_ENUMERATE_SUB_KEYS, - KEY_EXECUTE, - KEY_NOTIFY, - KEY_QUERY_VALUE, - KEY_READ, - KEY_SET_VALUE, - KEY_WRITE, // 9 - - STATUS_ACCESS_VIOLATION, // 10 - STATUS_ARRAY_BOUNDS_EXCEEDED, - STATUS_BREAKPOINT, - STATUS_CONTROL_C_EXIT, - STATUS_DATATYPE_MISALIGNMENT, - STATUS_FLOAT_DENORMAL_OPERAND, - STATUS_FLOAT_DIVIDE_BY_ZERO, - STATUS_FLOAT_INEXACT_RESULT, - STATUS_FLOAT_INVALID_OPERATION, - STATUS_FLOAT_OVERFLOW, - STATUS_FLOAT_STACK_CHECK, - STATUS_FLOAT_UNDERFLOW, - STATUS_GUARD_PAGE_VIOLATION, - STATUS_INTEGER_DIVIDE_BY_ZERO, - STATUS_INTEGER_OVERFLOW, - STATUS_ILLEGAL_INSTRUCTION, - STATUS_INVALID_DISPOSITION, -#ifdef STATUS_INVALID_HANDLE - STATUS_INVALID_HANDLE, -#else - 0, // Not defined in Win CE -#endif - STATUS_IN_PAGE_ERROR, - STATUS_NONCONTINUABLE_EXCEPTION, - STATUS_PENDING, - STATUS_PRIVILEGED_INSTRUCTION, - STATUS_SINGLE_STEP, - STATUS_STACK_OVERFLOW, - STATUS_TIMEOUT, - STATUS_USER_APC, // 35 - - VER_PLATFORM_WIN32s, // 36 - VER_PLATFORM_WIN32_WINDOWS, - VER_PLATFORM_WIN32_NT, // 38 - // VER_PLATFORM_WIN32_CE is only defined in the Windows CE headers -#ifdef VER_PLATFORM_WIN32_CE - VER_PLATFORM_WIN32_CE, // 39 -#else - 3, // 39 -#endif -}; - -HKEY hkPredefinedKeyTab[] = -{ - HKEY_CLASSES_ROOT, - HKEY_CURRENT_USER, - HKEY_LOCAL_MACHINE, - HKEY_USERS, -#ifdef HKEY_PERFORMANCE_DATA - HKEY_PERFORMANCE_DATA, -#else - 0, // Not defined in Win CE -#endif -#ifdef HKEY_CURRENT_CONFIG - HKEY_CURRENT_CONFIG, -#else - 0, -#endif -#ifdef HKEY_DYN_DATA - HKEY_DYN_DATA -#else - 0 -#endif -}; - - -Handle OS_spec_dispatch_c(TaskData *taskData, Handle args, Handle code) -{ - unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); - switch (c) - { - case 0: /* Return our OS type. Not in any structure. */ - return Make_fixed_precision(taskData, 1); /* 1 for Windows. */ - - /* Windows-specific functions. */ - case 1000: /* execute */ - return execute(taskData, args); - - case 1001: /* Get input stream as text. */ - return openProcessHandle(taskData, args, true, true); - - case 1002: /* Get output stream as text. */ - return openProcessHandle(taskData, args, false, true); - - case 1003: /* Get input stream as binary. */ - return openProcessHandle(taskData, args, true, false); - - case 1004: /* Get output stream as binary. */ - return openProcessHandle(taskData, args, false, false); - - case 1005: /* Get result of process. */ - { - PROCESSDATA *hnd = *(PROCESSDATA**)(args->WordP()); - *(PROCESSDATA**)(args->WordP()) = 0; // Mark as inaccessible. - if (hnd == 0) - raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); - // Close the streams. Either of them may have been - // passed to the stream package. - if (hnd->hInput != INVALID_HANDLE_VALUE) - CloseHandle(hnd->hInput); - hnd->hInput = INVALID_HANDLE_VALUE; - if (hnd->hOutput != INVALID_HANDLE_VALUE) - CloseHandle(hnd->hOutput); - hnd->hOutput = INVALID_HANDLE_VALUE; - - // See if it's finished. - while (true) { - DWORD dwResult; - if (GetExitCodeProcess(hnd->hProcess, &dwResult) == 0) - raise_syscall(taskData, "GetExitCodeProcess failed", GetLastError()); - if (dwResult != STILL_ACTIVE) { - // Finished - return the result. - // Remove the process object. The result is cached in ML. - free(hnd); - return Make_fixed_precision(taskData, dwResult); - } - // Block and try again. - WaitHandle waiter(hnd->hProcess, 1000); - processes->ThreadPauseForIO(taskData, &waiter); - } - } - - case 1006: /* Return a constant. */ - { - unsigned i = get_C_unsigned(taskData, DEREFWORD(args)); - if (i >= sizeof(winConstVec)/sizeof(winConstVec[0])) - raise_syscall(taskData, "Invalid index", 0); - return Make_arbitrary_precision(taskData, winConstVec[i]); - } - - case 1037: // Simple execute. - return simpleExecute(taskData, args); - - // DDE - case 1038: // Start DDE dialogue. - { - TCHAR *serviceName = Poly_string_to_T_alloc(args->WordP()->Get(0)); - TCHAR *topicName = Poly_string_to_T_alloc(args->WordP()->Get(1)); - /* Send a request to the main thread to do the work. */ - HCONV hcDDEConv = StartDDEConversation(serviceName, topicName); - free(serviceName); free(topicName); - if (hcDDEConv == 0) raise_syscall(taskData, "DdeConnect failed", 0); - // Create an entry to return the conversation. - return MakeVolatileWord(taskData, hcDDEConv); - } - - case 1039: // Send DDE execute request. - { - HCONV hcDDEConv = *(HCONV*)(args->WordP()->Get(0).AsObjPtr()); - if (hcDDEConv == 0) raise_syscall(taskData, "DDE Conversation is closed", 0); - char *command = Poly_string_to_C_alloc(args->WordP()->Get(1)); - /* Send a request to the main thread to do the work. */ - LRESULT res = ExecuteDDE(command, hcDDEConv); - free(command); - if (res == -1) raise_syscall(taskData, "DdeClientTransaction failed", 0); - else return Make_arbitrary_precision(taskData, res); - } - - case 1040: // Close a DDE conversation. - { - HCONV hcDDEConv = *(HCONV*)(args->WordP()->Get(0).AsObjPtr()); - if (hcDDEConv != 0) - { - CloseDDEConversation(hcDDEConv); - *(void**)(args->WordP()->Get(0).AsObjPtr()) = 0; - } - return Make_fixed_precision(taskData, 0); - } + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; - case 1101: // Wait for a message. - Used in Windows GUI library - { - HWND hwnd = *(HWND*)(DEREFWORDHANDLE(args)->Get(0).AsCodePtr()); - UINT wMsgFilterMin = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); - UINT wMsgFilterMax = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); - while (1) - { - MSG msg; - processes->ThreadReleaseMLMemory(taskData); - // N.B. PeekMessage may directly call the window proc resulting in a - // callback to ML. For this to work a callback must not overwrite "args". - BOOL result = PeekMessage(&msg, hwnd, wMsgFilterMin, wMsgFilterMax, PM_NOREMOVE); - processes->ThreadUseMLMemory(taskData); - if (result) return Make_fixed_precision(taskData, 0); - // Pause until a message arrives. - processes->ThreadPause(taskData); - } - } + try { + TCHAR* serviceName = Poly_string_to_T_alloc(service); + TCHAR* topicName = Poly_string_to_T_alloc(topic); + /* Send a request to the main thread to do the work. */ + HCONV hcDDEConv = StartDDEConversation(serviceName, topicName); + free(serviceName); free(topicName); + if (hcDDEConv == 0) raise_syscall(taskData, "DdeConnect failed", 0); + // Create an entry to return the conversation. + result = MakeVolatileWord(taskData, hcDDEConv); - // case 1102: // Return the address of the window callback function. + } + catch (KillException&) { + processes->ThreadExit(taskData); // Call 1005 may test for kill + } + catch (...) {} // If an ML exception is raised - case 1103: // Return the application instance. - Used in Windows GUI library - { - Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ); - *(HINSTANCE*)(result->Word().AsCodePtr()) = hApplicationInstance; - return result; - } + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} - case 1104: // Return the main window handle - Used in Windows GUI library - { - Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ); - *(HWND*)(result->Word().AsCodePtr()) = hMainWindow; - return result; - } +// Send DDE execute request. +POLYUNSIGNED PolyWindowsDDEExecute(FirstArgument threadId, PolyWord info, PolyWord commd) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + LRESULT res = 0; -// case 1105: // Set the callback function + try { + HCONV hcDDEConv = *(HCONV*)(info.AsObjPtr()); + if (hcDDEConv == 0) raise_syscall(taskData, "DDE Conversation is closed", 0); + char* command = Poly_string_to_C_alloc(commd); + // Send a request to the main thread to do the work. + // The result is -1 if an error, 0 if busy, 1 if success + res = ExecuteDDE(command, hcDDEConv); + free(command); + if (res == -1) raise_syscall(taskData, "DdeClientTransaction failed", 0); - default: - { - char msg[100]; - sprintf(msg, "Unknown windows-specific function: %d", c); - raise_exception_string(taskData, EXC_Fail, msg); - return 0; - } } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + return TAGGED(res == 1 ? 1 : 0).AsUnsigned(); } -// General interface to Windows OS-specific. Ideally the various cases will be made into -// separate functions. -POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyWindowsDDEClose(FirstArgument threadId, PolyWord arg) { - TaskData *taskData = TaskData::FindTaskForId(threadId); + TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); - Handle pushedCode = taskData->saveVec.push(code); - Handle pushedArg = taskData->saveVec.push(arg); - Handle result = 0; try { - result = OS_spec_dispatch_c(taskData, pushedArg, pushedCode); - } - catch (KillException &) { - processes->ThreadExit(taskData); // Call 1005 may test for kill + HCONV hcDDEConv = *(HCONV*)(arg.AsObjPtr()); + if (hcDDEConv != 0) + { + CloseDDEConversation(hcDDEConv); + *(void**)(arg.AsObjPtr()) = 0; + } } - catch (...) { } // If an ML exception is raised + catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); - if (result == 0) return TAGGED(0).AsUnsigned(); - else return result->Word().AsUnsigned(); + return TAGGED(0).AsUnsigned(); } POLYUNSIGNED PolyGetOSType() { return TAGGED(1).AsUnsigned(); // Return 1 for Windows } +// Return the current code page set by the --codepage argument. +// This allows Unicode conversions to use same conversions as everything else. +POLYUNSIGNED PolyWindowsGetCodePage() +{ +#if defined(UNICODE) + return TAGGED(codePage).AsUnsigned(); +#else + return TAGGED(CP_ACP).AsUnsigned(); +#endif +} + + /* The Windows version of this is more complicated than the Unix version because we can't manipulate the pipe handles in the child process. Everything has to be set up in the parent. As with Unix we create two pipes and pass one end of each pipe to the child. The end we pass to the child is "inheritable" (i.e. duplicated in the child as with Unix file descriptors) while the ends we keep in the parent are non-inheritable (i.e. not duplicated in the child). DCJM: December 1999. This now uses overlapped IO for the streams. */ -static Handle execute(TaskData *taskData, Handle args) +static Handle execute(TaskData *taskData, PolyWord command, PolyWord argument) { LPCSTR lpszError = ""; HANDLE hWriteToChild = INVALID_HANDLE_VALUE, hReadFromParent = INVALID_HANDLE_VALUE, hWriteToParent = INVALID_HANDLE_VALUE, hReadFromChild = INVALID_HANDLE_VALUE; STARTUPINFO startupInfo; PROCESS_INFORMATION processInfo; PROCESSDATA *pProcData = 0; - LPTSTR commandName = Poly_string_to_T_alloc(args->WordP()->Get(0)); - LPTSTR arguments = Poly_string_to_T_alloc(args->WordP()->Get(1)); + LPTSTR commandName = Poly_string_to_T_alloc(command); + LPTSTR arguments = Poly_string_to_T_alloc(argument); TCHAR toChildPipeName[MAX_PATH], fromChildPipeName[MAX_PATH]; newPipeName(toChildPipeName); newPipeName(fromChildPipeName); // Create the pipes as inheritable handles. These will be passed to the child. SECURITY_ATTRIBUTES secure; secure.nLength = sizeof(SECURITY_ATTRIBUTES); secure.lpSecurityDescriptor = NULL; secure.bInheritHandle = TRUE; hReadFromParent = CreateNamedPipe(toChildPipeName, PIPE_ACCESS_INBOUND | FILE_FLAG_FIRST_PIPE_INSTANCE, PIPE_READMODE_BYTE | PIPE_WAIT | PIPE_REJECT_REMOTE_CLIENTS, 1, 4096, 4096, 0, &secure); if (hReadFromParent == INVALID_HANDLE_VALUE) { lpszError = "CreateNamedPipe failed"; goto error; } hWriteToChild = CreateFile(toChildPipeName, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OVERLAPPED, NULL); if (hWriteToChild == INVALID_HANDLE_VALUE) { lpszError = "CreateFile failed"; goto error; } hWriteToParent = CreateNamedPipe(fromChildPipeName, PIPE_ACCESS_OUTBOUND | FILE_FLAG_FIRST_PIPE_INSTANCE, PIPE_READMODE_BYTE | PIPE_WAIT | PIPE_REJECT_REMOTE_CLIENTS, 1, 4096, 4096, 0, &secure); if (hWriteToParent == INVALID_HANDLE_VALUE) { lpszError = "CreateNamedPipe failed"; goto error; } hReadFromChild = CreateFile(fromChildPipeName, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OVERLAPPED, NULL); if (hReadFromChild == INVALID_HANDLE_VALUE) { lpszError = "CreateFile failed"; goto error; } // Create a STARTUPINFO structure in which to pass the pipes as stdin // and stdout to the new process. memset(&startupInfo, 0, sizeof(startupInfo)); startupInfo.cb = sizeof(startupInfo); startupInfo.dwFlags = STARTF_USESTDHANDLES; startupInfo.hStdInput = hReadFromParent; startupInfo.hStdOutput = hWriteToParent; // What should we do about the stderr? For the moment, inherit the original. startupInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE); // Treat the empty string as NULL. This is non-standard. if (!CreateProcess(commandName[0] == 0 ? NULL: commandName, arguments[0] == 0 ? NULL: arguments, // Command line NULL, NULL, TRUE, // Security attributes. Inherit handles CREATE_NO_WINDOW, // creation flags NULL, NULL, // Inherit our environment and directory &startupInfo, &processInfo)) { lpszError = "Could not create process"; goto error; } pProcData = (PROCESSDATA *)malloc(sizeof(PROCESSDATA)); if (pProcData == 0) { lpszError = "Insufficient memory"; SetLastError(ERROR_NOT_ENOUGH_MEMORY); goto error; } pProcData->hProcess = processInfo.hProcess; pProcData->hInput = hReadFromChild; pProcData->hOutput = hWriteToChild; // Everything has gone well - remove what we don't want free(commandName); free(arguments); /* Close thread handle since we don't need it. */ CloseHandle(processInfo.hThread); /* Close the sides of the pipes we don't use in the parent. */ CloseHandle(hReadFromParent); CloseHandle(hWriteToParent); return(MakeVolatileWord(taskData, pProcData)); error: { int err = GetLastError(); free(commandName); free(arguments); free(pProcData); // Close all the pipe handles. if (hWriteToChild != INVALID_HANDLE_VALUE) CloseHandle(hWriteToChild); if (hReadFromParent != INVALID_HANDLE_VALUE) CloseHandle(hReadFromParent); if (hWriteToParent != INVALID_HANDLE_VALUE) CloseHandle(hWriteToParent); if (hReadFromChild != INVALID_HANDLE_VALUE) CloseHandle(hReadFromChild); raise_syscall(taskData, lpszError, err); return NULL; // Never reached. } } -static Handle simpleExecute(TaskData *taskData, Handle args) +// Execute a command. +POLYUNSIGNED PolyWindowsExecute(FirstArgument threadId, PolyWord command, PolyWord argument) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = execute(taskData, command, argument); + } + catch (KillException&) { + processes->ThreadExit(taskData); // Call 1005 may test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +static Handle simpleExecute(TaskData *taskData, PolyWord command, PolyWord argument) { HANDLE hNull = INVALID_HANDLE_VALUE; PROCESS_INFORMATION processInfo; - TCHAR *commandName = Poly_string_to_T_alloc(args->WordP()->Get(0)); - TCHAR *arguments = Poly_string_to_T_alloc(args->WordP()->Get(1)); + TCHAR *commandName = Poly_string_to_T_alloc(command); + TCHAR *arguments = Poly_string_to_T_alloc(argument); STARTUPINFO startupInfo; // Open a handle to NUL for input and output. hNull = CreateFile(_T("NUL"), GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); // Create a STARTUPINFO structure in which to pass hNULL as stdin // and stdout to the new process. // TODO: The handles should really be open on "NUL". memset(&startupInfo, 0, sizeof(startupInfo)); startupInfo.cb = sizeof(startupInfo); startupInfo.dwFlags = STARTF_USESTDHANDLES; startupInfo.hStdInput = hNull; startupInfo.hStdOutput = hNull; startupInfo.hStdError = hNull; STARTUPINFO *start = &startupInfo; // Treat the empty string as NULL. This is non-standard. if (!CreateProcess(commandName[0] == 0 ? NULL : commandName, arguments[0] == 0 ? NULL : arguments, // Command line NULL, NULL, // Security attributes TRUE, CREATE_NO_WINDOW, // Inherit handles, creation flags NULL, NULL, // Inherit our environment and directory start, &processInfo)) { int nErr = GetLastError(); // Clean up free(commandName); free(arguments); CloseHandle(hNull); raise_syscall(taskData, "CreateProcess failed", nErr); } free(commandName); free(arguments); /* Close thread handle since we don't need it. */ CloseHandle(processInfo.hThread); #ifndef _WIN32_WCE CloseHandle(hNull); // We no longer need this #endif PROCESSDATA *pProcData = (PROCESSDATA *)malloc(sizeof(PROCESSDATA)); if (pProcData == 0) raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); pProcData->hProcess = processInfo.hProcess; // We only use the process handle entry. pProcData->hInput = INVALID_HANDLE_VALUE; pProcData->hOutput = INVALID_HANDLE_VALUE; return(MakeVolatileWord(taskData, pProcData)); } +POLYUNSIGNED PolyWindowsSimpleExecute(FirstArgument threadId, PolyWord command, PolyWord argument) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle result = 0; + + try { + result = simpleExecute(taskData, command, argument); + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + /* Return a stream, either text or binary, connected to an open process. */ -static Handle openProcessHandle(TaskData *taskData, Handle args, bool fIsRead, bool fIsText) +POLYUNSIGNED PolyWindowsOpenProcessHandle(FirstArgument threadId, PolyWord arg, PolyWord isRead, PolyWord isText) { - PROCESSDATA *hnd = *(PROCESSDATA**)(args->WordP()); - if (hnd == 0) - raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); - // We allow multiple streams on the handles. Since they are duplicated by openHandle that's safe. - // A consequence is that closing the stream does not close the pipe as far as the child is - // concerned. That only happens when we close the final handle in reap. - try - { - WinInOutStream *stream = new WinInOutStream; - bool result; - if (fIsRead) result = stream->openHandle(hnd->hInput, OPENREAD, fIsText); - else result = stream->openHandle(hnd->hOutput, OPENWRITE, fIsText); - if (!result) + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedCode = taskData->saveVec.push(TAGGED(1001)); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; + + try { + PROCESSDATA* hnd = *(PROCESSDATA * *)(arg.AsObjPtr()); + if (hnd == 0) + raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); + // We allow multiple streams on the handles. Since they are duplicated by openHandle that's safe. + // A consequence is that closing the stream does not close the pipe as far as the child is + // concerned. That only happens when we close the final handle in reap. + try + { + WinInOutStream* stream = new WinInOutStream; + bool fResult; + if (isRead.UnTagged()) fResult = stream->openHandle(hnd->hInput, OPENREAD, isText.UnTagged()); + else fResult = stream->openHandle(hnd->hOutput, OPENWRITE, isText.UnTagged()); + if (!fResult) + { + delete(stream); + raise_syscall(taskData, "openHandle failed", GetLastError()); + } + + result = MakeVolatileWord(taskData, stream); + } + catch (std::bad_alloc&) { - delete(stream); - raise_syscall(taskData, "openHandle failed", GetLastError()); + raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); } - return MakeVolatileWord(taskData, stream); } - catch (std::bad_alloc&) - { - raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); + catch (KillException&) { + processes->ThreadExit(taskData); // Call 1005 may test for kill + } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); +} + +/* Get result of process. */ +POLYUNSIGNED PolyWindowsGetProcessResult(FirstArgument threadId, PolyWord arg) +{ + TaskData* taskData = TaskData::FindTaskForId(threadId); + ASSERT(taskData != 0); + taskData->PreRTSCall(); + Handle reset = taskData->saveVec.mark(); + Handle pushedCode = taskData->saveVec.push(TAGGED(1005)); + Handle pushedArg = taskData->saveVec.push(arg); + Handle result = 0; + + try { + PROCESSDATA* hnd = *(PROCESSDATA * *)(arg.AsObjPtr()); + *(PROCESSDATA * *)(arg.AsObjPtr()) = 0; // Mark as inaccessible. + if (hnd == 0) + raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); + // Close the streams. Either of them may have been + // passed to the stream package. + if (hnd->hInput != INVALID_HANDLE_VALUE) + CloseHandle(hnd->hInput); + hnd->hInput = INVALID_HANDLE_VALUE; + if (hnd->hOutput != INVALID_HANDLE_VALUE) + CloseHandle(hnd->hOutput); + hnd->hOutput = INVALID_HANDLE_VALUE; + + // See if it's finished. + while (true) { + DWORD dwResult; + if (GetExitCodeProcess(hnd->hProcess, &dwResult) == 0) + raise_syscall(taskData, "GetExitCodeProcess failed", GetLastError()); + if (dwResult != STILL_ACTIVE) { + // Finished - return the result. + // Remove the process object. The result is cached in ML. + free(hnd); + result = Make_fixed_precision(taskData, dwResult); + break; + } + // Block and try again. + WaitHandle waiter(hnd->hProcess, 1000); + processes->ThreadPauseForIO(taskData, &waiter); + } + + } + catch (KillException&) { + processes->ThreadExit(taskData); // May test for kill } + catch (...) {} // If an ML exception is raised + + taskData->saveVec.reset(reset); // Ensure the save vec is reset + taskData->PostRTSCall(); + if (result == 0) return TAGGED(0).AsUnsigned(); + else return result->Word().AsUnsigned(); } struct _entrypts osSpecificEPT[] = { { "PolyGetOSType", (polyRTSFunction)&PolyGetOSType}, - { "PolyOSSpecificGeneral", (polyRTSFunction)&PolyOSSpecificGeneral}, + { "PolyWindowsExecute", (polyRTSFunction)& PolyWindowsExecute}, + { "PolyWindowsOpenProcessHandle", (polyRTSFunction)& PolyWindowsOpenProcessHandle}, + { "PolyWindowsGetProcessResult", (polyRTSFunction)& PolyWindowsGetProcessResult}, + { "PolyWindowsSimpleExecute", (polyRTSFunction)& PolyWindowsSimpleExecute}, + { "PolyWindowsDDEStartDialogue", (polyRTSFunction)& PolyWindowsDDEStartDialogue}, + { "PolyWindowsDDEExecute", (polyRTSFunction)& PolyWindowsDDEExecute}, + { "PolyWindowsDDEClose", (polyRTSFunction)& PolyWindowsDDEClose}, + { "PolyWindowsGetCodePage", (polyRTSFunction)& PolyWindowsGetCodePage}, { NULL, NULL} // End of list. };