prettyprint sequences io strings threads win32-api
win32-io-internals io-internals ;
-TUPLE: win32-server this ;
-TUPLE: win32-client-stream host port this ;
-SYMBOL: socket
-SYMBOL: stream
-SYMBOL: timeout
-SYMBOL: cutoff
-
-: (handle-socket-error)
+TUPLE: win32-client-stream host port ;
+
+: (handle-socket-error) ( -- )
WSAGetLastError [ ERROR_IO_PENDING ERROR_SUCCESS ] member?
[ WSAGetLastError error_message throw ] unless ;
: init-winsock ( -- )
HEX: 0202 <wsadata> WSAStartup handle-socket-error!=0/f ;
-
: new-socket ( -- socket )
AF_INET SOCK_STREAM 0 f f WSA_FLAG_OVERLAPPED
WSASocket dup INVALID_SOCKET = [ (handle-socket-error) ] when ;
: bind-socket ( port socket -- )
swap setup-sockaddr "sockaddr-in" c-size wsa-bind handle-socket-error!=0/f ;
-: listen-backlog 20 ; inline
+: listen-backlog ( -- n ) 20 ; inline
: listen-socket ( socket -- )
listen-backlog wsa-listen handle-socket-error!=0/f ;
[ set-win32-client-stream-host ] keep
[ set-win32-client-stream-port ] keep ;
-M: win32-client-stream client-stream-host win32-client-stream-host ;
-M: win32-client-stream client-stream-port win32-client-stream-port ;
-
-C: win32-server ( port -- server )
- swap [
- new-socket tuck bind-socket dup listen-socket
- dup add-completion
- socket set
- dup stream set
- ] make-hash over set-win32-server-this ;
+M: win32-client-stream client-stream-host ( win32-client-stream -- host )
+ win32-client-stream-host ;
+M: win32-client-stream client-stream-port ( win32-client-stream -- port )
+ win32-client-stream-port ;
-M: win32-server stream-close
- win32-server-this [ socket get CloseHandle drop ] bind ;
-
-M: win32-server set-timeout
- win32-server-this [ timeout set ] bind ;
-
-M: win32-server expire
- win32-server-this [
- timeout get [ millis cutoff get > [ socket get CancelIo ] when ] when
- ] bind ;
+: make-win32-server ( port -- win32-stream )
+ new-socket tuck bind-socket dup listen-socket dup add-completion
+ <win32-stream> <win32-duplex-stream> ;
: client-sockaddr ( host port -- sockaddr )
setup-sockaddr [
r> set-sockaddr-in-addr
] keep ;
-IN: io
+IN: io
+
+USE: interpreter
+SYMBOL: serv
: accept ( server -- client )
- win32-server-this [
- update-timeout new-socket 64 <buffer>
+ [
+ duplex-stream-in
+ serv set
+ serv get update-timeout new-socket 64 <buffer>
[
- stream get alloc-io-callback init-overlapped
- >r >r >r socket get r> r>
+ serv get alloc-io-callback f swap init-overlapped
+ >r >r >r serv get win32-stream-handle r> r>
buffer-ptr <alien> 0 32 32 f r> AcceptEx
handle-socket-error!=0/f stop
- ] callcc1 pending-error drop
- swap dup add-completion <win32-stream> <line-reader>
+ ] callcc1 drop
+ swap dup add-completion <win32-stream> <win32-duplex-stream>
dupd <win32-client-stream> swap buffer-free
- ] bind ;
+ ] with-scope ;
: <client> ( host port -- stream )
client-sockaddr new-socket
[ swap "sockaddr-in" c-size connect handle-socket-error!=0/f ] keep
- dup add-completion <win32-stream> <line-reader> ;
+ dup add-completion <win32-stream> <win32-duplex-stream> ;
! Copyright (C) 2004, 2006 Mackenzie Straight, Doug Coleman.
IN: win32-stream
-USING: alien generic hashtables io-internals kernel
+USING: alien errors generic hashtables io-internals kernel
kernel-internals math namespaces prettyprint sequences
io strings threads win32-api win32-io-internals ;
+USE: interpreter
-TUPLE: win32-stream handle in-buffer out-buffer fileptr file-size timeout cutoff ;
+TUPLE: win32-stream handle timeout cutoff fileptr file-size ;
+TUPLE: win32-stream-reader in ;
+TUPLE: win32-stream-writer out ;
+TUPLE: win32-duplex-stream ;
+SYMBOL: stream
: win32-buffer-size 16384 ; inline
-: pending-error ( len/status -- len/status )
- dup [ win32-throw-error ] unless ;
-
: init-overlapped ( fileptr overlapped -- overlapped )
0 over set-overlapped-ext-internal
0 over set-overlapped-ext-internal-high
! Read
: fill-input ( stream -- )
dup update-timeout
- dup unit
- [
- [ alloc-io-callback ] keep
- win32-stream-fileptr swap init-overlapped >r
- ] append
- over win32-stream-handle unit append
- over win32-stream-in-buffer unit append
[
- [ buffer@ ] keep
- buffer-capacity
- ] append
- over win32-stream-file-size unit append
- over win32-stream-fileptr [ - min ] curry
- [ when* f r> ReadFile [ handle-io-error ] unless stop ]
- curry append
- callcc1 pending-error
- [ over win32-stream-in-buffer n>buffer ] keep
+ over alloc-io-callback
+ over win32-stream-fileptr swap init-overlapped >r
+ dup win32-stream-handle
+ over win32-stream-reader-in
+ [ buffer@ ] keep buffer-capacity
+ >r pick r> swap dup win32-stream-file-size
+ [ swap win32-stream-fileptr - min ] when*
+ f r> ReadFile zero? [ handle-io-error ] when stop
+ ] callcc1 [ over win32-stream-reader-in n>buffer ] keep
swap update-file-pointer ;
: consume-input ( count stream -- str )
- dup win32-stream-in-buffer buffer-length zero? [ dup fill-input ] when
- win32-stream-in-buffer
+ dup win32-stream-reader-in buffer-length zero? [ dup fill-input ] when
+ win32-stream-reader-in
[ buffer-size min ] keep
[ buffer-first-n ] 2keep
buffer-consume ;
! Write
: flush-output ( stream -- )
dup update-timeout
- dup unit
[
- [ alloc-io-callback ] keep
- win32-stream-fileptr swap init-overlapped >r
- ] append
- over win32-stream-handle unit append
- over win32-stream-out-buffer unit append
- [
+ over alloc-io-callback
+ over win32-stream-fileptr swap init-overlapped >r
+ dup win32-stream-handle
+ over win32-stream-writer-out
[ buffer@ ] keep buffer-length
- f r> WriteFile [ handle-io-error ] unless stop
- ] append
- callcc1 pending-error
- dup pick update-file-pointer
- over win32-stream-out-buffer [ buffer-consume ] keep
+ f r> WriteFile zero? [ handle-io-error ] when stop
+ ] callcc1 [ over update-file-pointer ] keep
+ over win32-stream-writer-out [ buffer-consume ] keep
buffer-length 0 > [ flush-output ] [ drop ] if ;
: maybe-flush-output ( stream -- )
- dup win32-stream-out-buffer buffer-length 0 > [ flush-output ] [ drop ] if ;
+ dup win32-stream-writer-out buffer-length 0 > [ flush-output ] [ drop ] if ;
G: do-write 1 standard-combination ;
M: integer do-write ( integer stream -- )
- dup win32-stream-out-buffer buffer-capacity zero?
+ dup win32-stream-writer-out buffer-capacity zero?
[ dup flush-output ] when
- >r ch>string r> win32-stream-out-buffer >buffer ;
+ >r ch>string r> win32-stream-writer-out >buffer ;
M: string do-write ( string stream -- )
- over length over win32-stream-out-buffer 2dup buffer-capacity <= [
- 2drop win32-stream-out-buffer >buffer
+ over length over win32-stream-writer-out 2dup buffer-capacity <= [
+ 2drop win32-stream-writer-out >buffer
] [
2dup buffer-size > [
extend-buffer
] if do-write
] if ;
-M: win32-stream stream-close ( stream -- )
- dup maybe-flush-output
- dup win32-stream-handle CloseHandle 0 = [ win32-throw-error ] when
- dup win32-stream-in-buffer buffer-free
- win32-stream-out-buffer buffer-free ;
-M: win32-stream stream-read1 ( stream -- ch/f )
+M: win32-stream-reader stream-close ( stream -- )
+ dup win32-stream-reader-in buffer-free
+ win32-stream-handle CloseHandle 0 = [ win32-throw-error ] when ;
+
+M: win32-stream-reader stream-read1 ( stream -- ch/f )
>r 1 r> consume-input >string-or-f first ;
-M: win32-stream stream-read ( n stream -- str/f )
+
+M: win32-stream-reader stream-read ( n stream -- str/f )
>r [ <sbuf> ] keep r> -rot do-read-count ;
-M: win32-stream stream-flush ( stream -- ) maybe-flush-output ;
-M: win32-stream stream-write1 ( ch stream -- ) >r >fixnum r> do-write ;
-M: win32-stream stream-write ( str stream -- ) do-write ;
+
+M: win32-stream-writer stream-close ( stream -- )
+ dup maybe-flush-output
+ dup win32-stream-writer-out buffer-free
+ win32-stream-handle CloseHandle 0 = [ win32-throw-error ] when ;
+
+M: win32-stream-writer stream-flush ( stream -- ) maybe-flush-output ;
+M: win32-stream-writer stream-write1 ( ch stream -- ) >r >fixnum r> do-write ;
+M: win32-stream-writer stream-write ( str stream -- ) do-write ;
M: win32-stream set-timeout ( n stream -- ) set-win32-stream-timeout ;
-M: win32-stream expire ( stream -- )
+: expire ( stream -- )
dup win32-stream-timeout millis pick win32-stream-cutoff > and [
win32-stream-handle CancelIo [ win32-throw-error ] unless
] [
C: win32-stream ( handle -- stream )
[ set-win32-stream-handle ] keep
- win32-buffer-size <buffer> swap [ set-win32-stream-in-buffer ] keep
- win32-buffer-size <buffer> swap [ set-win32-stream-out-buffer ] keep
- 0 swap [ set-win32-stream-fileptr ] keep
- dup win32-stream-handle f GetFileSize dup -1 = [ drop f ] when
- swap [ set-win32-stream-file-size ] keep
f swap [ set-win32-stream-timeout ] keep
- 0 swap [ set-win32-stream-cutoff ] keep ;
+ 0 swap [ set-win32-stream-cutoff ] keep
+ dup win32-stream-handle f GetFileSize dup -1 = [ drop f ] when
+ over set-win32-stream-file-size
+ 0 swap [ set-win32-stream-fileptr ] keep ;
+
+C: win32-stream-reader ( stream -- stream )
+ [ set-delegate ] keep
+ win32-buffer-size <buffer> swap [ set-win32-stream-reader-in ] keep ;
+
+C: win32-stream-writer ( stream -- stream )
+ [ set-delegate ] keep
+ win32-buffer-size <buffer> swap [ set-win32-stream-writer-out ] keep ;
+
+: make-win32-file-reader ( stream -- stream )
+ <win32-stream-reader> <line-reader> ;
: <win32-file-reader> ( path -- stream )
- t f win32-open-file <win32-stream> <line-reader> ;
+ t f win32-open-file <win32-stream> make-win32-file-reader ;
+
+: make-win32-file-writer ( stream -- stream )
+ <win32-stream-writer> <plain-writer> ;
: <win32-file-writer> ( path -- stream )
- f t win32-open-file <win32-stream> <plain-writer> ;
+ f t win32-open-file <win32-stream> make-win32-file-writer ;
+
+C: win32-duplex-stream ( stream -- stream )
+ >r [ make-win32-file-reader ] keep make-win32-file-writer <duplex-stream> r>
+ [ set-delegate ] keep ;
+
+M: win32-duplex-stream stream-close ( stream -- )
+ dup duplex-stream-out maybe-flush-output
+ dup duplex-stream-out win32-stream-writer-out buffer-free
+ dup duplex-stream-in win32-stream-reader-in buffer-free
+ duplex-stream-in
+ win32-stream-handle CloseHandle drop ; ! 0 = [ win32-throw-error ] when ;