[MLton-commit] r5463

Vesa Karvonen vesak at mlton.org
Fri Mar 23 05:05:43 PST 2007


Added EventLog functionality and Debug.output.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
U   mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
U   mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h	2007-03-21 16:30:32 UTC (rev 5462)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h	2007-03-23 13:05:42 UTC (rev 5463)
@@ -137,18 +137,25 @@
 
 /************************************************************************/
 
+WIN_TYPEDEF(HANDLE, void *)
+
+WIN_FUNCTION(CloseHandle, BOOL, 1, (HANDLE))
+
+/************************************************************************/
+
 WIN_CONST(EVENTLOG_ERROR_TYPE, WORD)
 WIN_CONST(EVENTLOG_AUDIT_FAILURE, WORD)
 WIN_CONST(EVENTLOG_AUDIT_SUCCESS, WORD)
 WIN_CONST(EVENTLOG_INFORMATION_TYPE, WORD)
 WIN_CONST(EVENTLOG_WARNING_TYPE, WORD)
 
-/************************************************************************/
+WIN_TYPEDEF(PSID, void *)
 
-WIN_TYPEDEF(HANDLE, void *)
+WIN_FUNCTION(RegisterEventSource, HANDLE, 2, (LPCTSTR, LPCTSTR))
+WIN_FUNCTION(DeregisterEventSource, BOOL, 1, (HANDLE))
+WIN_FUNCTION(ReportEvent, BOOL, 9,
+             (HANDLE, WORD, WORD, DWORD, PSID, WORD, DWORD, LPCTSTR *, LPVOID))
 
-WIN_FUNCTION(CloseHandle, BOOL, 1, (HANDLE))
-
 /************************************************************************/
 
 WIN_CONST(WAIT_OBJECT_0, DWORD)
@@ -227,6 +234,10 @@
 
 /************************************************************************/
 
+WIN_FUNCTION(OutputDebugString, void, 1, (LPCTSTR))
+
+/************************************************************************/
+
 C_CODE(LPTSTR win_FormatErrorLocalAlloc(DWORD error))
 
 #endif

Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-03-21 16:30:32 UTC (rev 5462)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-03-23 13:05:42 UTC (rev 5463)
@@ -8,6 +8,8 @@
 
 (* Implementation of Windows utilities. *)
 structure Windows :> WINDOWS_EX = struct
+   structure W8V = Word8Vector
+
    open Windows
 
    local
@@ -28,6 +30,7 @@
                     end
       val opt = option
       val int = int
+      val w16 = word16
       val w32 = word32
       val bool = bool
       val time = iso largeReal (Time.toReal, Time.fromReal)
@@ -36,9 +39,13 @@
    local
       open With
    in
+      val around = around
+      val for = for
       val one = one
-      val around = around
       val op >>& = Monad.>>&
+      val op >>= = op >>=
+      val return = return
+      val seqWith = Monad.seqWith
    end
 
    val success     = wc_ERROR_SUCCESS
@@ -97,8 +104,13 @@
    val withDword = withNew C.S.ulong
    val withLong = withNew C.S.slong
    fun withZs mlStr = withAlloc (fn () => ZString.dupML' mlStr)
-   val withOptZs = fn NONE => With.return null | SOME s => withZs s
-   fun withBuf size = withAlloc (fn () => C.alloc' C.S.uchar size)
+   fun withArray size length = withAlloc (fn () => C.alloc' size length)
+   fun withBuf length = withAlloc (fn () => C.alloc' C.S.uchar length)
+   fun withData v =
+       withBuf (Word.fromInt (W8V.length v)) >>= (fn b =>
+       (W8V.appi (fn (i, x) => C.Set.uchar' (C.Ptr.sub' C.S.uchar (b, i), x)) v
+      ; return b))
+   fun withOpt wit = fn NONE => With.return null | SOME arg => wit arg
 
    exception InsufficientBuffer
 
@@ -222,7 +234,7 @@
                  ; C.Get.voidptr' r))
 
       datatype value
-        = BINARY of Word8Vector.t
+        = BINARY of W8V.t
         | DWORD of Word32.t
         | EXPAND_SZ of String.t
         | MULTI_SZ of String.t List.t
@@ -274,30 +286,32 @@
                            (fn b =>
                                (f b
                               ; (fromBin (C.Get.ulong' t) o
-                                 Word8Vector.tabulate)
+                                 W8V.tabulate)
                                    (Word.toInt (C.Get.ulong' s),
                                     C.Get.uchar' o b <\ C.Ptr.sub' C.S.uchar)))
                      end)
 
          fun setValueEx (h, n, v) = let
             val (t, d) = toBin v
-            val s = Word.fromInt (Word8Vector.length d)
          in
-            one (withZs n >>& withBuf s)
+            one (withZs n >>& withData d)
                 (fn n' & b =>
-                    (Word8Vector.appi
-                        (fn (i, x) =>
-                            C.Set.uchar' (C.Ptr.sub' C.S.uchar (b, i), x))
-                        d
-                      ; raiseOnError
-                           (fn () => F"Reg.setValueEx"[A ptr h, A str n,
-                                                       Prettier.txt "<value>"])
-                           F_win_RegSetValueEx.f'
-                           (h, n', 0w0, t, C.Ptr.ro' b, s)))
+                    raiseOnError
+                       (fn () => F"Reg.setValueEx"
+                                  [A ptr h, A str n, Prettier.txt "<value>"])
+                       F_win_RegSetValueEx.f'
+                       (h, n', 0w0, t, C.Ptr.ro' b,
+                        Word.fromInt (W8V.length d)))
          end
       end
    end
 
+   structure Authorization = struct
+      structure SID = struct
+         type t = C.voidptr
+      end
+   end
+
    structure EventLog = struct
       structure Type = struct
          open Word16Flags
@@ -308,6 +322,45 @@
          val information  = wc_EVENTLOG_INFORMATION_TYPE
          val warning      = wc_EVENTLOG_WARNING_TYPE
       end
+
+      structure Source = struct
+         type t = C.voidptr
+         fun create {server, source} =
+             one (withOpt withZs server >>& withZs source)
+                 (fn server' & source' =>
+                     raiseOnNull
+                        (fn () => F"EventLog.Source.create"
+                                   [A (opt str) server, A str source])
+                        F_win_RegisterEventSource.f' (server', source'))
+         fun close t =
+             raiseOnFalse
+                (fn () => F"EventLog.Source.close"[A ptr t])
+                F_win_DeregisterEventSource.f' t
+         fun report {source, typ, sid, category, event, strings, data} =
+             for (withOpt withData data >>&
+                  withOpt (withArray C.S.ptr)
+                     let val n = length strings
+                     in if 0=n then NONE else SOME (Word.fromInt n)
+                     end >>&
+                  seqWith withZs strings)
+                 (fn data' & arr' & strs' =>
+                     (List.appi
+                         (fn (i, x) =>
+                             C.Set.ptr' (C.Ptr.sub' C.S.ptr (arr', i), x)) strs'
+                    ; raiseOnFalse
+                         (fn () => F"EventLog.Source.report"
+                                    [A ptr source, A w16 typ, A w16 category,
+                                     A w32 event, A (opt ptr) sid,
+                                     A (lst str) strings,
+                                     Prettier.txt "<data>"])
+                         F_win_ReportEvent.f'
+                         (source, typ, category, event, getOpt (sid, null),
+                          Word16.fromInt (length strings),
+                          getOpt (Option.map (Word.fromInt o W8V.length) data,
+                                  0w0),
+                          arr',
+                          C.Ptr.inject' data')))
+      end
    end
 
    structure Module = struct
@@ -396,7 +449,7 @@
    structure Semaphore = struct
       type t = C.voidptr
       fun create {init, max, name} =
-          one (withOptZs name)
+          one (withOpt withZs name)
               (fn name' =>
                   raiseOnNull
                      (fn () => F"Semaphore.create"
@@ -416,7 +469,7 @@
    structure Mutex = struct
       type t = C.voidptr
       fun create {name, own} =
-          one (withOptZs name)
+          one (withOpt withZs name)
               (fn name' =>
                   raiseOnNull
                      (fn () => F"Mutex.create"[A (opt str) name, A bool own])
@@ -429,7 +482,7 @@
    structure Timer = struct
       type t = C.voidptr
       fun create {manual, name} =
-          one (withOptZs name)
+          one (withOpt withZs name)
               (fn n' =>
                   raiseOnNull
                      (fn () => F"Timer.create"[A bool manual, A (opt str) name])
@@ -482,7 +535,7 @@
       type t = C.voidptr
 
       fun find {class, window} =
-          one (withOptZs class >>& withOptZs window)
+          one (withOpt withZs class >>& withOpt withZs window)
               (fn c & w =>
                   raiseOnNullIfErrorElseNone
                      (fn () => F"Window.find"
@@ -512,4 +565,8 @@
    structure Console = struct
       val free = raiseOnFalse (fn () => F"Console.free" []) F_win_FreeConsole.f'
    end
+
+   structure Debug = struct
+      fun output s = one (withZs s) F_win_OutputDebugString.f'
+   end
 end

Modified: mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-03-21 16:30:32 UTC (rev 5462)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-03-23 13:05:42 UTC (rev 5463)
@@ -10,6 +10,12 @@
 signature WINDOWS_EX = sig
    include WINDOWS
 
+   structure Authorization : sig
+      structure SID : sig
+         type t
+      end
+   end
+
    structure EventLog : sig
       structure Type : sig
          include FLAGS where type flags_word = Word16.t
@@ -20,6 +26,19 @@
          val information : t
          val warning : t
       end
+
+      structure Source : sig
+         type t
+         val create : {server : String.t Option.t, source : String.t} -> t
+         val close : t Effect.t
+         val report : {source : t,
+                       typ : Type.t,
+                       sid : Authorization.SID.t Option.t,
+                       category : Word16.t,
+                       event : Word32.t,
+                       strings : String.t List.t,
+                       data : Word8Vector.t Option.t} Effect.t
+      end
    end
 
    structure Module : sig
@@ -126,4 +145,8 @@
    structure Console : sig
       val free : Unit.t Effect.t
    end
+
+   structure Debug : sig
+      val output : String.t Effect.t
+   end
 end




More information about the MLton-commit mailing list