Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13257
Added Files:
Sockets.f
Log Message:
Jos: Update from jmdrake
--- NEW FILE: Sockets.f ---
\ Windows Sockets of Andrey Cherezov
\ January 6th, 2007: Adapted for Win32Forth version 6.11.10
anew sockets.f
winlibrary wsock32.dll
1 CONSTANT SOCK_STREAM
-1 CONSTANT INVALID_SOCKET
-1 CONSTANT SOCKET_ERROR
2 CONSTANT PF_INET
2 CONSTANT AF_INET
6 CONSTANT IPPROTO_TCP
NOSTACK \ A tip from: Alex McDonald October 16th, 2002
0
2 FIELD+ sin_family
2 FIELD+ sin_port
4 FIELD+ sin_addr
8 FIELD+ sin_zero
CONSTANT /sockaddr_in
CREATE sock_addr HERE /sockaddr_in DUP ALLOT ERASE
AF_INET sock_addr sin_family W!
CHECKSTACK
: ASCIIZ> 100 2dup 0 scan nip - ;
: ztype ( z"a -- )
ASCIIZ> type ;
: CreateSocket ( -- socket ior )
IPPROTO_TCP SOCK_STREAM PF_INET
call socket DUP INVALID_SOCKET =
IF call WSAGetLastError
ELSE 0 THEN
;
: ToRead ( socket -- n ior )
\ ñêîëüêî áàéò ìîæíî ñåé÷àñ ïðî÷åñòü èç ñîêåòà
\ ìîæíî èñïîëüçîâàòü ïåðåä ReadSocket äëÿ òîãî ÷òîáû
\ èçáåæàòü áëîêèðîâàíèÿ ïðè n=0
0 >r
rp@ [ HEX ] 4004667F [ DECIMAL ] ROT
call ioctlsocket SOCKET_ERROR =
IF r>drop 0 call WSAGetLastError ELSE r> 0 THEN
;
: ConnectSocket ( IP port socket -- ior )
>R
256 /MOD SWAP 256 * +
sock_addr sin_port W!
sock_addr sin_addr !
/sockaddr_in sock_addr R> call connect SOCKET_ERROR =
IF call WSAGetLastError ELSE 0 THEN
;
: CloseSocket ( s -- ior )
call closesocket SOCKET_ERROR =
IF call WSAGetLastError ELSE 0 THEN
;
: WriteSocket ( addr u s -- ior )
>r 0 swap rot r> \ 0 u addr s
call send SOCKET_ERROR =
IF call WSAGetLastError ELSE 0 THEN
;
: SWrite ( addr u s -- wlen )
>r 0 swap rot r> \ 0 u addr s
call send
;
: WriteSocketLine ( addr u s -- ior )
DUP >R WriteSocket ?DUP IF R> DROP EXIT THEN
crlf$ COUNT R> WriteSocket
;
: WriteSocketCRLF ( s -- ior )
HERE 0 ROT WriteSocketLine
;
: ReadSocket ( addr u s -- rlen ior )
>r 0 swap rot r> \ 0 u addr s
call recv DUP SOCKET_ERROR =
IF call WSAGetLastError ELSE 0 THEN
OVER 0= IF DROP -1002 THEN
( åñëè ïðèíÿòî 0, òî îáðûâ ñîåäèíåíèÿ )
;
: SRead ( addr u s -- r )
>r 0 swap rot r> \ 0 u addr s
call recv
;
CODE a>r@ ( a1 -- n1 )
mov ebx, 0 [ebx]
next c;
: GetHostName ( IP -- addr u ior )
>r PF_INET 4 rp@ call gethostbyaddr
?DUP IF A>R@ ASCIIZ> 0
ELSE HERE 0 call WSAGetLastError
THEN r>drop
;
: Get.Host.Name ( addr u -- addr u ior )
DROP call inet_addr GetHostName
;
: zGetHostIP ( z" -- IP ior )
dup c@ [char] 0 [char] 9 between over and
if call inet_addr 0
else dup if then call gethostbyname DUP
IF 3 CELLS + A>R@ A>R@ A>R@ 0
ELSE call WSAGetLastError
THEN
then
;
\ changed Samstag, Mai 15 2004 - 13:20 dbu
create my-ip-addr-buf 256 allot
0 my-ip-addr-buf !
: my-ip-addr ( -- IP )
my-ip-addr-buf zGetHostIP drop ;
: GetHostIP ( addr len -- IP ior )
RP@ 265 - RP!
RP@ 265 ERASE
RP@ SWAP 265 UMIN CMOVE
RP@ zGetHostIP
RP@ 265 + RP!
;
CREATE sock_addr2 HERE /sockaddr_in DUP ALLOT ERASE
AF_INET sock_addr2 sin_family W!
: GetPeerName ( s -- addr u ior )
/sockaddr_in >r
rp@ sock_addr2 ROT call getpeername SOCKET_ERROR =
IF HERE 0 call WSAGetLastError
ELSE sock_addr2 sin_addr @ GetHostName THEN r>drop
;
: SocketsStartup ( -- ior )
HERE 257 call WSAStartup
;
: SocketsCleanup ( -- ior )
call WSACleanup
;
: BindSocket ( port s -- ior )
>R /sockaddr_in ALLOCATE ?DUP IF NIP R> DROP EXIT THEN
>R
256 /MOD SWAP 256 * +
R@ sin_port W!
AF_INET R@ sin_family W!
R@
0 R@ sin_addr !
/sockaddr_in R> R> call bind SWAP FREE DROP SOCKET_ERROR =
IF call WSAGetLastError ELSE 0 THEN
;
: ListenSocket ( s -- ior )
2 SWAP call listen SOCKET_ERROR =
IF call WSAGetLastError ELSE 0 THEN
;
CREATE SINLEN /sockaddr_in ,
: SOCKET-ACCEPT { ADDR ALEN FH -- s2 ior }
&OF ALEN ADDR FH call accept
DUP INVALID_SOCKET =
IF call WSAGetLastError ELSE 0 THEN
;
: #IP ( du -- 0 )
#S [CHAR] . HOLD 2DROP 0
;
: (.IP) ( IP -- addr u )
0 256 UM/MOD 0 256 UM/MOD 0 256 UM/MOD
0 <# \ 0 HOLD
#IP #IP #IP #S #> ;
: NtoA (.IP) ;
: CLIENT-OPEN ( addr u port -- s )
>r GetHostIP abort" Server not available "
r> CreateSocket DROP DUP >r
ConnectSocket abort" Can't connect " r>
;
\s
SocketsStartup [if] cr .( SocketsStartup error) abort [then]
create my-ip-name
cr my-ip-addr cr dup NtoA type GetHostName drop space type
\ dup 1+ allot my-ip-name place
\s
|
