[MLton-commit] r5180
Vesa Karvonen
vesak at mlton.org
Tue Feb 13 04:33:17 PST 2007
Initial commit of Windows library.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/windows/
A mltonlib/trunk/com/ssh/windows/unstable/
A mltonlib/trunk/com/ssh/windows/unstable/LICENSE
A mltonlib/trunk/com/ssh/windows/unstable/Makefile
A mltonlib/trunk/com/ssh/windows/unstable/README
A mltonlib/trunk/com/ssh/windows/unstable/detail/
A mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/
A mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
A mltonlib/trunk/com/ssh/windows/unstable/detail/lib/
A mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c
A mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
A mltonlib/trunk/com/ssh/windows/unstable/lib.mlb
A mltonlib/trunk/com/ssh/windows/unstable/public/
A mltonlib/trunk/com/ssh/windows/unstable/public/export.sml
A mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig
----------------------------------------------------------------------
Property changes on: mltonlib/trunk/com/ssh/windows/unstable
___________________________________________________________________
Name: svn:ignore
+ .*
*.lib
generated
Copied: mltonlib/trunk/com/ssh/windows/unstable/LICENSE (from rev 5179, mltonlib/trunk/com/ssh/misc-util/unstable/LICENSE)
Added: mltonlib/trunk/com/ssh/windows/unstable/Makefile
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/Makefile 2007-02-12 23:18:58 UTC (rev 5179)
+++ mltonlib/trunk/com/ssh/windows/unstable/Makefile 2007-02-13 12:33:16 UTC (rev 5180)
@@ -0,0 +1,55 @@
+# Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+#
+# This code is released under the MLton license, a BSD-style license.
+# See the LICENSE file or http://mlton.org/License for details.
+
+target-arch := $(shell mlton -show path-map | awk '/^TARGET_ARCH/ {print $$2}')
+target-os := $(shell mlton -show path-map | awk '/^TARGET_OS/ {print $$2}')
+target-id := $(target-arch)-$(target-os)
+
+bin-dir := .bin/$(target-id)
+gen-dir := generated/$(target-id)
+
+ffi-h-files := $(wildcard detail/ffi/*.h)
+
+lib-dir := detail/lib
+lib-c-files := $(wildcard detail/lib/*.c)
+lib-o-files := $(patsubst $(lib-dir)/%.c,$(bin-dir)/%.o,$(lib-c-files))
+lib-h-files := $(wildcard $(lib-dir)/*.h)
+
+lib-file := libwin-$(target-id).lib
+
+at :=
+
+.PHONY : all clean help
+
+help :
+ @echo "Targets:"
+ @echo " all Builds the static link library and NLFFI files"
+ @echo " clean Removes generated files"
+ @echo " help Prints this message"
+
+all : $(lib-file) $(gen-dir)/nlffi/lib.mlb
+
+clean :
+ $(at)rm -rf $(bin-dir) $(gen-dir)/nlffi $(lib-file)
+
+$(lib-file) : $(lib-o-files)
+ $(at)ar cr $@ $^
+
+$(gen-dir)/nlffi/lib.mlb : $(ffi-h-files)
+ $(at)mkdir -p $(@D)
+ $(at)mlnlffigen -dir $(@D) \
+ -mlbfile $(@F) \
+ -linkage static \
+ $^
+
+$(bin-dir)/%.o : $(lib-dir)/%.c $(lib-h-files) $(ffi-h-files)
+ $(at)mkdir -p $(@D)
+ $(at)gcc -Wall \
+ -Werror \
+ -pedantic \
+ -std=c99 \
+ -c \
+ -o $@ \
+ $<
Property changes on: mltonlib/trunk/com/ssh/windows/unstable/Makefile
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/windows/unstable/README
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/README 2007-02-12 23:18:58 UTC (rev 5179)
+++ mltonlib/trunk/com/ssh/windows/unstable/README 2007-02-13 12:33:16 UTC (rev 5180)
@@ -0,0 +1,69 @@
+Windows structure
+-----------------
+
+ This library implements a Windows structure in the spirit of the
+ Windows structure specified in the Standard ML Basis Library [1].
+
+
+Info
+----
+
+ License: MLton license (a BSD-style license)
+ Portability: Windows specific, some MLton extensions may be used
+ Stability: experimental
+ Maintainer: Vesa Karvonen <vesa.karvonen at cs.helsinki.fi>
+
+
+About Library Organization
+--------------------------
+
+ public/
+
+ This directory contains the documented signature definitions (*.sig)
+ and listings of all top-level bindings exported by this library
+ (export*.sml). The contents of this directory should be sufficient
+ to understand how to use the functionality provided by this library.
+
+ libwin-$(TARGET_ARCH)-$(TARGET_OS).*
+
+ This statically linked library needs to be linked to your
+ application in order to use the Windows structure.
+
+ Makefile
+
+ This is for building the statically linked library and NLFFI
+ bindings that are part of this library. Run
+
+ make
+
+ in the directory of the Makefile for further instructions.
+
+ lib.mlb
+
+ This build file defines the Windows library. See the file for
+ further instructions.
+
+ detail/
+
+ This directory contains the implementation details of the library.
+
+
+About Motivation and Scope
+--------------------------
+
+ The main motivation for this library is the need to access certain
+ Windows specific functionality. Eventually this library should include
+ all of the functionality specified in the Standard ML Basis Library [1]
+ as well any additional functionality that is needed. If you need to
+ access some specific functionality that isn't provided, please send a
+ request, preferably with a patch, to the MLton developers or users
+ list.
+
+
+References
+----------
+
+ [1] The Standard ML Basis Library.
+ Emden R. Gansner and John H. Reppy.
+ Cambridge University Press, 2004.
+ ISBN 0521794781.
Property changes on: mltonlib/trunk/com/ssh/windows/unstable/README
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h 2007-02-12 23:18:58 UTC (rev 5179)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h 2007-02-13 12:33:16 UTC (rev 5180)
@@ -0,0 +1,131 @@
+/* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+/*
+ * Specifications of Windows utilities.
+ */
+
+#ifndef WIN_H_20070205
+#define WIN_H_20070205
+
+/************************************************************************/
+
+#ifndef WIN_TYPEDEF
+# define WIN_TYPEDEF(name, type) typedef type name
+#endif
+
+#ifndef WIN_CONST
+# define WIN_CONST(name, type) extern type win_##name
+#endif
+
+#ifndef WIN_FUNCTION
+# define WIN_FUNCTION(name, result, arity, args) extern result win_##name args
+#endif
+
+/************************************************************************/
+
+WIN_TYPEDEF(BYTE, unsigned char);
+WIN_TYPEDEF(DWORD, unsigned long);
+WIN_TYPEDEF(LONG, long);
+
+WIN_TYPEDEF(LPBYTE, BYTE *);
+WIN_TYPEDEF(LPDWORD, DWORD *);
+
+WIN_TYPEDEF(LPCTSTR, const char *);
+WIN_TYPEDEF(LPTSTR, char *);
+
+WIN_TYPEDEF(LPSECURITY_ATTRIBUTES, void *);
+WIN_TYPEDEF(PFILETIME, void *);
+
+/************************************************************************/
+
+WIN_FUNCTION(GetLastError, DWORD, 0, (void));
+
+WIN_CONST(ERROR_INSUFFICIENT_BUFFER, DWORD);
+WIN_CONST(ERROR_MORE_DATA, DWORD);
+WIN_CONST(ERROR_NO_MORE_ITEMS, DWORD);
+WIN_CONST(ERROR_SUCCESS, DWORD);
+
+/************************************************************************/
+
+WIN_TYPEDEF(HMODULE, void *);
+
+WIN_FUNCTION(GetModuleFileName, DWORD, 3, (HMODULE, LPTSTR, DWORD));
+
+/************************************************************************/
+
+WIN_FUNCTION(GetShortPathName, DWORD, 3, (LPCTSTR, LPTSTR, DWORD));
+
+/************************************************************************/
+
+WIN_TYPEDEF(HLOCAL, void *);
+
+WIN_FUNCTION(LocalFree, HLOCAL, 1, (HLOCAL));
+
+/************************************************************************/
+
+WIN_TYPEDEF(HKEY, void *);
+
+WIN_CONST(HKEY_CLASSES_ROOT, HKEY);
+WIN_CONST(HKEY_CURRENT_CONFIG, HKEY);
+WIN_CONST(HKEY_CURRENT_USER, HKEY);
+WIN_CONST(HKEY_DYN_DATA, HKEY);
+WIN_CONST(HKEY_LOCAL_MACHINE, HKEY);
+WIN_CONST(HKEY_PERFORMANCE_DATA, HKEY);
+WIN_CONST(HKEY_USERS, HKEY);
+
+WIN_TYPEDEF(PHKEY, HKEY *);
+
+WIN_TYPEDEF(REGSAM, unsigned long);
+
+WIN_CONST(KEY_ALL_ACCESS, REGSAM);
+WIN_CONST(KEY_CREATE_LINK, REGSAM);
+WIN_CONST(KEY_CREATE_SUB_KEY, REGSAM);
+WIN_CONST(KEY_ENUMERATE_SUB_KEYS, REGSAM);
+WIN_CONST(KEY_EXECUTE, REGSAM);
+WIN_CONST(KEY_NOTIFY, REGSAM);
+WIN_CONST(KEY_QUERY_VALUE, REGSAM);
+WIN_CONST(KEY_READ, REGSAM);
+WIN_CONST(KEY_SET_VALUE, REGSAM);
+WIN_CONST(KEY_WRITE, REGSAM);
+
+WIN_CONST(REG_BINARY, DWORD);
+WIN_CONST(REG_DWORD, DWORD);
+WIN_CONST(REG_DWORD_LITTLE_ENDIAN, DWORD);
+WIN_CONST(REG_DWORD_BIG_ENDIAN, DWORD);
+WIN_CONST(REG_EXPAND_SZ, DWORD);
+WIN_CONST(REG_LINK, DWORD);
+WIN_CONST(REG_MULTI_SZ, DWORD);
+WIN_CONST(REG_NONE, DWORD);
+WIN_CONST(REG_QWORD, DWORD);
+WIN_CONST(REG_QWORD_LITTLE_ENDIAN, DWORD);
+WIN_CONST(REG_SZ, DWORD);
+
+WIN_CONST(REG_CREATED_NEW_KEY, DWORD);
+WIN_CONST(REG_OPENED_EXISTING_KEY, DWORD);
+
+WIN_FUNCTION(RegCloseKey, LONG, 1, (HKEY));
+WIN_FUNCTION(RegCreateKeyEx, LONG, 9,
+ (HKEY, LPCTSTR, DWORD, LPTSTR, DWORD, REGSAM,
+ LPSECURITY_ATTRIBUTES, PHKEY, LPDWORD));
+WIN_FUNCTION(RegDeleteKey, LONG, 2, (HKEY, LPCTSTR));
+WIN_FUNCTION(RegDeleteValue, LONG, 2, (HKEY, LPCTSTR));
+WIN_FUNCTION(RegEnumKeyEx, LONG, 8,
+ (HKEY, DWORD, LPTSTR, LPDWORD, LPDWORD, LPTSTR, LPDWORD,
+ PFILETIME));
+WIN_FUNCTION(RegEnumValue, LONG, 8,
+ (HKEY, DWORD, LPTSTR, LPDWORD, LPDWORD, LPDWORD, LPBYTE, LPDWORD));
+WIN_FUNCTION(RegOpenKeyEx, LONG, 5, (HKEY, LPCTSTR, DWORD, REGSAM, PHKEY));
+WIN_FUNCTION(RegQueryValueEx, LONG, 6,
+ (HKEY, LPCTSTR, LPDWORD, LPDWORD, LPBYTE, LPDWORD));
+WIN_FUNCTION(RegSetValueEx, LONG, 6,
+ (HKEY, LPCTSTR, DWORD, DWORD, const BYTE *, DWORD));
+
+/************************************************************************/
+
+LPTSTR win_FormatErrorLocalAlloc(DWORD error);
+
+#endif
Property changes on: mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c 2007-02-12 23:18:58 UTC (rev 5179)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c 2007-02-13 12:33:16 UTC (rev 5180)
@@ -0,0 +1,102 @@
+/* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ */
+
+/*
+ * Implementation of Windows utilities according to specification.
+ */
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+
+/************************************************************************/
+
+#define WIN_TYPEDEF(name, type) CHECK_COMPATIBLE_TYPES(type, name)
+
+#define CHECK_COMPATIBLE_TYPES(type, name) \
+extern int typedef_fn_of_actual_type_##name(name); \
+extern int typedef_fn_of_assumed_type_##name(type); \
+extern name typedef_val_of_actual_type_##name; \
+extern type typedef_val_of_assumed_type_##name; \
+extern int typedef_chk_a_##name[sizeof(typedef_fn_of_assumed_type_##name \
+ (typedef_val_of_actual_type_##name))]; \
+extern int typedef_chk_b_##name[sizeof(typedef_fn_of_actual_type_##name \
+ (typedef_val_of_assumed_type_##name))]
+
+/************************************************************************/
+
+#define WIN_CONST(name, type) \
+typedef type type_of_##name; \
+const type_of_##name win_##name = name
+
+/************************************************************************/
+
+#define WIN_FUNCTION(name, result, arity, args) \
+result win_##name FORMALS##arity args \
+{ UNLESS(IS_VOID(result))(return) name ACTUALS##arity args; } \
+typedef result (type_of_##name) args
+
+#define UNLESS(c) CONCAT(UNLESS, c)
+#define UNLESS0(x) x
+#define UNLESS1(_)
+
+#define CONCAT(a, b) CONCAT_1(a, b)
+#define CONCAT_1(a, b) CONCAT_2(a, b)
+#define CONCAT_2(a, b) a##b
+
+#define APPLY(m, a) APPLY_1(m, a)
+#define APPLY_1(m, a) APPLY_2(m, a)
+#define APPLY_2(m, a) m a
+
+#define FIRST(f, _) f
+
+#define IS_VOID(s) \
+APPLY(FIRST, \
+ (APPLY(CONCAT, \
+ (IS_VOID_AUX, \
+ APPLY(IS_VOID_AUX, \
+ IS_VOID_##s)))))
+#define IS_VOID_void ()
+#define IS_VOID_AUX() 1
+#define IS_VOID_AUXIS_VOID_AUX 0,!
+#define IS_VOID_AUX1 1,!
+
+#define FORMALS0(_) (void)
+#define FORMALS1(A) (A a)
+#define FORMALS2(A,B) (A a,B b)
+#define FORMALS3(A,B,C) (A a,B b,C c)
+#define FORMALS4(A,B,C,D) (A a,B b,C c,D d)
+#define FORMALS5(A,B,C,D,E) (A a,B b,C c,D d,E e)
+#define FORMALS6(A,B,C,D,E,F) (A a,B b,C c,D d,E e,F f)
+#define FORMALS7(A,B,C,D,E,F,G) (A a,B b,C c,D d,E e,F f,G g)
+#define FORMALS8(A,B,C,D,E,F,G,H) (A a,B b,C c,D d,E e,F f,G g,H h)
+#define FORMALS9(A,B,C,D,E,F,G,H,I) (A a,B b,C c,D d,E e,F f,G g,H h,I i)
+
+#define ACTUALS0(_) ()
+#define ACTUALS1(A) (a)
+#define ACTUALS2(A,B) (a,b)
+#define ACTUALS3(A,B,C) (a,b,c)
+#define ACTUALS4(A,B,C,D) (a,b,c,d)
+#define ACTUALS5(A,B,C,D,E) (a,b,c,d,e)
+#define ACTUALS6(A,B,C,D,E,F) (a,b,c,d,e,f)
+#define ACTUALS7(A,B,C,D,E,F,G) (a,b,c,d,e,f,g)
+#define ACTUALS8(A,B,C,D,E,F,G,H) (a,b,c,d,e,f,g,h)
+#define ACTUALS9(A,B,C,D,E,F,G,H,I) (a,b,c,d,e,f,g,h,i)
+
+/************************************************************************/
+
+#include "../ffi/windows.h"
+
+/************************************************************************/
+
+LPTSTR win_FormatErrorLocalAlloc(DWORD error)
+{
+ LPTSTR msg = NULL;
+ FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER |
+ FORMAT_MESSAGE_FROM_SYSTEM |
+ FORMAT_MESSAGE_IGNORE_INSERTS,
+ NULL, error, 0, (LPTSTR)&msg, 0, NULL);
+ return msg;
+}
Property changes on: mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml 2007-02-12 23:18:58 UTC (rev 5179)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml 2007-02-13 12:33:16 UTC (rev 5180)
@@ -0,0 +1,282 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(* Implementation of Windows utilities. *)
+structure Windows :> WINDOWS = struct
+ exception Error of {function : String.t, error : Word32.t}
+
+ val op >>& = With.>>&
+
+ local
+ fun `x = C.Get.ulong' (x ())
+ in
+ val errorSuccess = `G_win_ERROR_SUCCESS.obj'
+ val errorNoMoreItems = `G_win_ERROR_NO_MORE_ITEMS.obj'
+ val errorMoreData = `G_win_ERROR_MORE_DATA.obj'
+ end
+
+ fun errorToString error =
+ With.around (fn () => F_win_FormatErrorLocalAlloc.f' error)
+ (ignore o F_win_LocalFree.f' o C.Ptr.inject')
+ ZString.toML'
+
+ val () =
+ Exn.addMessager
+ (fn Error {function, error} =>
+ SOME (concat ["Win.Error: ", function, " failed: ",
+ errorToString error])
+ | _ => NONE)
+
+ val getLastError = F_win_GetLastError.f
+
+ fun raiseError function error =
+ raise Error {function = function, error = error}
+
+ fun raiseOnError function error = let
+ val error = Word.fromInt error
+ in
+ if error = errorSuccess then () else raiseError function error
+ end
+
+ fun raiseLastError function =
+ raiseError function (getLastError ())
+
+ fun withAlloc alloc = With.around alloc C.free'
+ fun withNew size = With.around (fn () => C.new' size) C.discard'
+ fun withPtr f = withNew C.S.voidptr f
+ fun withDword f = withNew C.S.ulong f
+ fun withZs mlStr = withAlloc (fn () => ZString.dupML' mlStr)
+ fun withBuf size = withAlloc (fn () => C.alloc' C.S.uchar size)
+
+ exception InsufficientBuffer
+
+ fun withDoublingBuf size f = let
+ fun loop size = withBuf size (f /> size)
+ handle InsufficientBuffer => loop (size * 0w2 + 0w1)
+ in
+ loop size
+ end
+
+ fun onError0ElseTruncatedSize function size f =
+ (withDoublingBuf size)
+ (fn (buf, size) => let
+ val result = f (buf, size)
+ in
+ if 0w0 = result then raiseLastError function
+ else if size = result then raise InsufficientBuffer
+ else ZString.toML' buf
+ end)
+
+ fun onError0ElseRequiredSize function f = let
+ val size = f (C.Ptr.null', 0w0)
+ in
+ if 0w0 = size
+ then raiseLastError function
+ else (withBuf size)
+ (fn buf => let
+ val result = f (buf, size)
+ in
+ if 0w0 = result
+ then raiseLastError function
+ else ZString.toML' buf
+ end)
+ end
+
+ structure Key = struct
+ open BitFlags
+ local
+ fun `x = SysWord.fromWord (C.Get.ulong' (x ()))
+ in
+ val allAccess = `G_win_KEY_ALL_ACCESS.obj'
+ val createLink = `G_win_KEY_CREATE_LINK.obj'
+ val createSubKey = `G_win_KEY_CREATE_SUB_KEY.obj'
+ val enumerateSubKeys = `G_win_KEY_ENUMERATE_SUB_KEYS.obj'
+ val execute = `G_win_KEY_EXECUTE.obj'
+ val notify = `G_win_KEY_NOTIFY.obj'
+ val queryValue = `G_win_KEY_QUERY_VALUE.obj'
+ val read = `G_win_KEY_READ.obj'
+ val setValue = `G_win_KEY_SET_VALUE.obj'
+ val write = `G_win_KEY_WRITE.obj'
+ end
+ end
+
+ structure Reg = struct
+ type hkey = C.voidptr
+
+ local
+ fun `x = C.Get.voidptr' (x ())
+ in
+ val classesRoot = `G_win_HKEY_CLASSES_ROOT.obj'
+ val currentConfig = `G_win_HKEY_CURRENT_CONFIG.obj'
+ val currentUser = `G_win_HKEY_CURRENT_USER.obj'
+ val dynData = `G_win_HKEY_DYN_DATA.obj'
+ val localMachine = `G_win_HKEY_LOCAL_MACHINE.obj'
+ val performanceData = `G_win_HKEY_PERFORMANCE_DATA.obj'
+ val users = `G_win_HKEY_USERS.obj'
+ end
+
+ val closeKey = raiseOnError "RegCloseKey" o F_win_RegCloseKey.f'
+
+ datatype create_result
+ = CREATED_NEW_KEY of hkey
+ | OPENED_EXISTING_KEY of hkey
+
+ fun createKeyEx (hKey, subKey, samDesired) =
+ (withZs subKey >>& withPtr >>& withDword)
+ (fn subKey & hkResult & dwDisposition =>
+ ((raiseOnError "RegCreateKeyEx")
+ (F_win_RegCreateKeyEx.f'
+ (hKey, subKey, 0w0, C.Ptr.null', 0w0,
+ SysWord.toWord samDesired, C.Ptr.null',
+ C.Ptr.|&! hkResult, C.Ptr.|&! dwDisposition))
+ ; (if C.Get.ulong' dwDisposition =
+ C.Get.ulong' (G_win_REG_CREATED_NEW_KEY.obj' ())
+ then CREATED_NEW_KEY
+ else OPENED_EXISTING_KEY) (C.Get.voidptr' hkResult)))
+
+ fun deleteKey (hKey, subKey) =
+ (withZs subKey)
+ (fn subKey =>
+ (raiseOnError "RegDeleteKey")
+ (F_win_RegDeleteKey.f' (hKey, subKey)))
+
+ fun deleteValue (hKey, valueName) =
+ (withZs valueName)
+ (fn valueName =>
+ (raiseOnError "RegDeleteValue")
+ (F_win_RegDeleteValue.f' (hKey, valueName)))
+
+ local
+ fun mk function f (hKey, i) =
+ if i < 0
+ then raise Subscript
+ else (withDword >>& withDoublingBuf 0w255)
+ (fn dwSize & (buf, size) => let
+ val () = C.Set.ulong' (dwSize, size)
+ val error =
+ Word.fromInt
+ (f (hKey, Word.fromInt i, buf,
+ C.Ptr.|&! dwSize, C.Ptr.null',
+ C.Ptr.null', C.Ptr.null', C.Ptr.null'))
+ in
+ if error = errorMoreData then
+ raise InsufficientBuffer
+ else if error = errorNoMoreItems then
+ NONE
+ else if error = errorSuccess then
+ SOME (ZString.toML' buf)
+ else
+ raiseError function error
+ end)
+ in
+ val enumKeyEx = mk "RegEnumKeyEx" F_win_RegEnumKeyEx.f'
+ val enumValueEx = mk "RegEnumValue" F_win_RegEnumValue.f'
+ end
+
+ fun openKeyEx (hKey, subKey, samDesired) =
+ (withZs subKey >>& withPtr)
+ (fn subKey & hkResult =>
+ ((raiseOnError "RegOpenKeyEx")
+ (F_win_RegOpenKeyEx.f'
+ (hKey, subKey, 0w0, SysWord.toWord samDesired,
+ C.Ptr.|&! hkResult))
+ ; C.Get.voidptr' hkResult))
+
+ datatype value
+ = BINARY of Word8Vector.t
+ | DWORD of Word32.t
+ | EXPAND_SZ of String.t
+ | MULTI_SZ of String.t List.t
+ | QWORD of Word64.t
+ | SZ of String.t
+
+ local
+ local
+ fun `x = C.Get.ulong' (x ())
+ in
+ val binary = `G_win_REG_BINARY.obj'
+ val dword = `G_win_REG_DWORD.obj'
+ val expandSz = `G_win_REG_EXPAND_SZ.obj'
+ val multiSz = `G_win_REG_MULTI_SZ.obj'
+ val qword = `G_win_REG_QWORD.obj'
+ val sz = `G_win_REG_SZ.obj'
+ end
+
+ val toMultiSz = String.tokens (#"\000" <\ op =) o Byte.bytesToString
+ val toSz = hd o toMultiSz
+
+ fun fromBin ty =
+ if ty = binary then BINARY
+ else if ty = dword then DWORD o Word32.fromLittleBytes
+ else if ty = expandSz then EXPAND_SZ o toSz
+ else if ty = multiSz then MULTI_SZ o toMultiSz
+ else if ty = qword then QWORD o Word64.fromLittleBytes
+ else if ty = sz then SZ o toSz
+ else raise Fail "Unsupported RegQueryValueEx functionality"
+
+ val toBin =
+ fn BINARY x => (binary, x)
+ | DWORD x => (dword, Word32.toLittleBytes x)
+ | EXPAND_SZ x => (expandSz, Byte.stringToBytes (x ^ "\000"))
+ | MULTI_SZ x =>
+ (multiSz,
+ Byte.stringToBytes
+ (concat (map (op ^ /> "\000") x @ ["\000\000"])))
+ | QWORD x => (qword, Word64.toLittleBytes x)
+ | SZ x => (sz, Byte.stringToBytes (x ^ "\000"))
+ in
+ fun queryValueEx (hKey, valueName) =
+ (withZs valueName >>& withDword >>& withDword)
+ (fn valueName & dwType & dwSize => let
+ fun f buf =
+ F_win_RegQueryValueEx.f'
+ (hKey, valueName, C.Ptr.null', C.Ptr.|&! dwType,
+ buf, C.Ptr.|&! dwSize)
+ in
+ raiseOnError "RegQueryValueEx" (f C.Ptr.null')
+ ; (SOME o withBuf (C.Get.ulong' dwSize))
+ (fn buf =>
+ (raiseOnError "RegQueryValueEx" (f buf)
+ ; (fromBin (C.Get.ulong' dwType) o
+ Word8Vector.tabulate)
+ (Word.toInt (C.Get.ulong' dwSize),
+ C.Get.uchar' o buf <\ C.Ptr.sub' C.S.uchar)))
+ end)
+
+ fun setValueEx (hKey, valueName, value) = let
+ val (ty, data) = toBin value
+ val size = Word.fromInt (Word8Vector.length data)
+ in
+ (withZs valueName >>& withBuf size)
+ (fn valueName & buf =>
+ (Word8Vector.appi
+ (fn (i, x) =>
+ C.Set.uchar' (C.Ptr.sub' C.S.uchar (buf, i), x)) data
+ ; (raiseOnError "RegSetValueEx")
+ (F_win_RegSetValueEx.f'
+ (hKey, valueName, 0w0, ty, C.Ptr.ro' buf, size))))
+ end
+ end
+ end
+
+ structure Module = struct
+ type hmodule = C.voidptr
+
+ val null = C.Ptr.null'
+
+ fun getFileName module =
+ (onError0ElseTruncatedSize "GetModuleFileName" 0w255)
+ (fn (b, s) => F_win_GetModuleFileName.f' (module, b, s))
+ end
+
+ structure Path = struct
+ fun getShortName path =
+ (withZs path)
+ (fn path =>
+ (onError0ElseRequiredSize "GetShortPathName")
+ (fn (b, s) => F_win_GetShortPathName.f' (path, b, s)))
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/windows/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/lib.mlb 2007-02-12 23:18:58 UTC (rev 5179)
+++ mltonlib/trunk/com/ssh/windows/unstable/lib.mlb 2007-02-13 12:33:16 UTC (rev 5180)
@@ -0,0 +1,30 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(*
+ * In order to use this MLB file, the MLTON_LIB path variable must be
+ * added to the path map.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/misc-util/unstable/lib.mlb
+
+ $(SML_LIB)/mlnlffi-lib/mlnlffi-lib.mlb
+ generated/$(TARGET_ARCH)-$(TARGET_OS)/nlffi/lib.mlb
+in
+ ann
+ "forceUsed"
+ "warnUnused true"
+ in
+ local
+ public/windows.sig
+ detail/windows.sml
+ in
+ public/export.sml
+ end
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/windows/unstable/lib.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/windows/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/export.sml 2007-02-12 23:18:58 UTC (rev 5179)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/export.sml 2007-02-13 12:33:16 UTC (rev 5180)
@@ -0,0 +1,9 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature WINDOWS = WINDOWS
+
+structure Windows : WINDOWS = Windows
Property changes on: mltonlib/trunk/com/ssh/windows/unstable/public/export.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig 2007-02-12 23:18:58 UTC (rev 5179)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig 2007-02-13 12:33:16 UTC (rev 5180)
@@ -0,0 +1,74 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for Windows utilities.
+ *
+ * Parts of this signature follow the SML Basis Library specification:
+ *
+ * http://mlton.org/basis/windows.html .
+ *)
+signature WINDOWS = sig
+ exception Error of {function : String.t, error : Word32.t}
+
+ 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 currentConfig : hkey
+ val currentUser : hkey
+ val dynData : hkey
+ val localMachine : hkey
+ val performanceData : hkey
+ val users : hkey
+
+ datatype create_result
+ = CREATED_NEW_KEY of hkey
+ | OPENED_EXISTING_KEY of hkey
+ val closeKey : hkey Effect.t
+ val createKeyEx : hkey * String.t * Key.flags -> create_result
+ val deleteKey : (hkey * String.t) Effect.t
+ val deleteValue : (hkey * String.t) Effect.t
+ val enumKeyEx : hkey * Int.t -> String.t Option.t
+ val enumValueEx : hkey * Int.t -> String.t Option.t
+ val openKeyEx : hkey * String.t * Key.flags -> hkey
+
+ datatype value
+ = BINARY of Word8Vector.t
+ | DWORD of Word32.t
+ | EXPAND_SZ of String.t
+ | MULTI_SZ of String.t List.t
+ | QWORD of Word64.t
+ | SZ of String.t
+ val queryValueEx : hkey * String.t -> value Option.t
+ val setValueEx : (hkey * String.t * value) Effect.t
+ end
+
+ structure Module : sig
+ type hmodule
+ val null : hmodule
+ val getFileName : hmodule -> String.t
+ end
+
+ structure Path : sig
+ val getShortName : String.t UnOp.t
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list