extra/io/windows/ce/ce.factor

   1 USING: alien alien.c-types combinators
   2 io io.backend io.buffers io.files io.nonblocking io.sockets
   3 io.sockets.impl io.windows kernel libc math namespaces
   4 prettyprint qualified sequences strings threads threads.private
   5 windows windows.kernel32 ;
   6 QUALIFIED: windows.winsock
   7 IN: io.windows.ce
   8
   9 ! M: windows-ce-io normalize-pathname ( string -- string )
  10     ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
  11
  12 M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
  13 M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
  14 M: windows-ce-io io-multiplex ( ms -- ) (sleep) ;
  15 M: windows-ce-io add-completion ( port -- ? ) drop f ;
  16
  17 : port-errored ( port -- )
  18     win32-error-string swap set-port-error ;
  19
  20 GENERIC: wince-read ( port port-handle -- )
  21
  22 M: win32-file wince-read
  23     drop dup make-FileArgs dup setup-read ReadFile zero? [
  24         drop port-errored
  25     ] [
  26         FileArgs-lpNumberOfBytesRet *uint dup zero? [
  27             drop
  28             t swap set-port-eof?
  29         ] [
  30             swap n>buffer
  31         ] if
  32     ] if ;
  33
  34 TUPLE: WSAArgs
  35     s
  36     lpBuffers
  37     dwBufferCount
  38     lpNumberOfBytesRet
  39     lpFlags
  40     lpOverlapped
  41     lpCompletionRoutine ;
  42 C: <WSAArgs> WSAArgs
  43
  44 : make-WSAArgs ( port -- <WSARecv> )
  45     [ port-handle win32-file-handle ] keep
  46     delegate 1 "DWORD" <c-object> f f f <WSAArgs> ;
  47
  48 : setup-WSARecv ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
  49     [ WSAArgs-s ] keep
  50     [
  51         WSAArgs-lpBuffers [ buffer-capacity ] keep
  52         buffer-end
  53         "WSABUF" <c-object>
  54         [ windows.winsock:set-WSABUF-buf ] keep
  55         [ windows.winsock:set-WSABUF-len ] keep
  56     ] keep
  57     [ WSAArgs-dwBufferCount ] keep
  58     [ WSAArgs-lpNumberOfBytesRet ] keep
  59     [ WSAArgs-lpFlags ] keep
  60     [ WSAArgs-lpOverlapped ] keep
  61     WSAArgs-lpCompletionRoutine ;
  62
  63 ! M: win32-socket wince-read ( port port-handle -- )
  64     ! drop dup make-WSAArgs dup setup-WSARecv WSARecv zero? [
  65         ! drop port-errored
  66     ! ] [
  67         ! WSAArgs-lpNumberOfBytesRet *uint dup zero? [
  68             ! drop
  69             ! t swap set-port-eof?
  70         ! ] [
  71             ! swap n>buffer
  72         ! ] if
  73     ! ] if ;
  74
  75 M: win32-socket wince-read ( port port-handle -- )
  76     win32-file-handle over
  77     delegate [ buffer-end ] keep buffer-capacity 0
  78     windows.winsock:recv dup windows.winsock:SOCKET_ERROR = [
  79         drop port-errored
  80     ] [
  81         dup zero? [
  82             drop
  83             t swap set-port-eof?
  84         ] [
  85             swap n>buffer
  86         ] if
  87     ] if ;
  88
  89 M: input-port (wait-to-read) ( port -- )
  90     dup port-handle wince-read ;
  91
  92 GENERIC: wince-write ( port port-handle -- )
  93
  94 M: win32-file wince-write ( port port-handle -- )
  95     drop dup make-FileArgs dup setup-write WriteFile zero? [
  96         drop port-errored
  97     ] [
  98         FileArgs-lpNumberOfBytesRet *uint ! *DWORD
  99         over delegate [ buffer-consume ] keep
 100         buffer-length 0 > [
 101             flush-output
 102         ] [
 103             drop
 104         ] if
 105     ] if ;
 106
 107 : setup-WSASend ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
 108     [ WSAArgs-s ] keep
 109     [
 110         WSAArgs-lpBuffers [ buffer-length ] keep
 111         buffer@
 112         "WSABUF" <c-object>
 113         [ windows.winsock:set-WSABUF-buf ] keep
 114         [ windows.winsock:set-WSABUF-len ] keep
 115     ] keep
 116     [ WSAArgs-dwBufferCount ] keep
 117     [ WSAArgs-lpNumberOfBytesRet ] keep
 118     [ WSAArgs-lpFlags ] keep
 119     [ WSAArgs-lpOverlapped ] keep
 120     WSAArgs-lpCompletionRoutine ;
 121
 122 ! M: win32-socket wince-write ( port port-handle -- )
 123     ! drop dup make-WSAArgs dup setup-WSASend WSASend zero? [
 124         ! drop port-errored
 125     ! ] [
 126         ! FileArgs-lpNumberOfBytesRet *uint ! *DWORD
 127         ! over delegate [ buffer-consume ] keep
 128         ! buffer-length 0 > [
 129             ! flush-output
 130         ! ] [
 131             ! drop
 132         ! ] if
 133     ! ] if ;
 134
 135 M: win32-socket wince-write ( port port-handle -- )
 136     win32-file-handle over
 137     delegate [ buffer@ ] keep
 138     buffer-length 0 windows.winsock:send dup windows.winsock:SOCKET_ERROR = [
 139         drop port-errored
 140     ] [
 141         over delegate [ buffer-consume ] keep
 142         buffer-length 0 > [
 143             flush-output
 144         ] [
 145             drop
 146         ] if
 147     ] if ;
 148
 149 M: windows-ce-io flush-output ( port -- )
 150     dup port-handle wince-write ;
 151
 152 M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
 153
 154 : do-connect ( addrspec -- socket )
 155     [ tcp-socket dup ] keep
 156     make-sockaddr heap-size
 157     f f f f windows.winsock:WSAConnect zero? [
 158         winsock-error-string throw
 159     ] unless ;
 160
 161 M: windows-ce-io (client) ( addrspec -- duplex-stream )
 162     do-connect <win32-socket> dup handle>duplex-stream ;
 163
 164 M: windows-ce-io <server> ( addrspec -- duplex-stream )
 165     [
 166         windows.winsock:SOCK_STREAM server-fd
 167         dup listen-on-socket
 168         <win32-socket> f <port>
 169     ] keep <server-port> ;
 170
 171 M: windows-ce-io accept ( server -- client )
 172     dup check-server-port
 173     [
 174         [ touch-port ] keep
 175         [ port-handle win32-file-handle ] keep
 176         server-port-addr sockaddr-type heap-size
 177         [ "char" <c-array> ] keep [
 178             <int>
 179             f 0
 180             windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET = [
 181                 winsock-error-string throw
 182             ] when
 183         ] keep
 184     ] keep server-port-addr parse-sockaddr swap
 185     <win32-socket> dup handle>duplex-stream <client-stream> ;
 186
 187 T{ windows-ce-io } io-backend set-global
 188
 189 M: windows-ce-io init-io ( -- )
 190     init-winsock ;
 191
 192 M: windows-ce-io <datagram> ( addrspec -- datagram )
 193     [
 194         windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
 195     ] keep <datagram-port> ;
 196
 197 M: windows-ce-io receive ( datagram -- packet addrspec )
 198     dup check-datagram-port
 199     [
 200         port-handle delegate win32-file-handle
 201         "WSABUF" <c-object>
 202         default-buffer-size over windows.winsock:set-WSABUF-len
 203         default-buffer-size "char" <c-array> over windows.winsock:set-WSABUF-buf
 204         [
 205             1
 206             0 <uint> [
 207                 0 <uint>
 208                 64 "char" <c-array> [
 209                     64 <int>
 210                     f
 211                     f
 212                     windows.winsock:WSARecvFrom zero? [
 213                         winsock-error-string throw
 214                     ] unless
 215                 ] keep
 216             ] keep *uint
 217         ] keep
 218     ] keep
 219     ! sockaddr count buf datagram
 220     >r windows.winsock:WSABUF-buf swap memory>string swap r>
 221     datagram-port-addr parse-sockaddr ;
 222
 223 M: windows-ce-io send ( packet addrspec datagram -- )
 224     3dup check-datagram-send
 225     delegate port-handle delegate win32-file-handle
 226     rot dup length "WSABUF" <c-object>
 227     [ windows.winsock:set-WSABUF-len ] keep
 228     [ windows.winsock:set-WSABUF-buf ] keep
 229
 230     rot make-sockaddr heap-size
 231     >r >r 1 0 <uint> 0 r> r> f f
 232     windows.winsock:WSASendTo zero? [
 233         winsock-error-string throw
 234     ] unless ;
 235