[Win32forth-cvs] win32forth/src/lib Sockets.f,NONE,1.1

[Jos v.d.V. <jo...@us...>]

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