Annotation of gforth/unix/socket.fs, revision 1.28

1.1       pazsan      1: \ socket interface
                      2: 
1.21      anton       3: \ Copyright (C) 1998,2000,2003,2005,2006,2007,2008 Free Software Foundation, Inc.
1.1       pazsan      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
1.15      anton       9: \ as published by the Free Software Foundation, either version 3
1.1       pazsan     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
1.15      anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1       pazsan     19: 
1.20      anton      20: c-library socket
1.16      anton      21: \c #include <netdb.h>
                     22: c-function gethostbyname gethostbyname a -- a ( name -- hostent )
1.17      pazsan     23: \c #include <unistd.h>
                     24: c-function gethostname gethostname a n -- n ( c-addr u -- ior )
                     25: \c #include <errno.h>
1.24      pazsan     26: \c #define get_errno() errno
                     27: c-function errno get_errno -- n ( -- value )
1.16      anton      28: \c #include <sys/types.h>
                     29: \c #include <sys/socket.h>
                     30: c-function socket socket n n n -- n ( class type proto -- fd )
1.17      pazsan     31: c-function closesocket close n -- n ( fd -- ior )
1.16      anton      32: c-function connect connect n a n -- n ( fd sock size -- err )
1.17      pazsan     33: c-function send send n a n n -- n ( socket buffer count flags -- size )
                     34: c-function recv recv n a n n -- n ( socket buffer count flags -- size )
1.25      pazsan     35: c-function listen() listen n n -- n ( socket backlog -- err )
1.28    ! anton      36: c-function bind bind n a n -- n ( socket sockaddr socklen --- err )
1.18      pazsan     37: c-function accept() accept n a a -- n ( socket sockaddr addrlen -- fd )
1.16      anton      38: \c #include <stdio.h>
                     39: c-function fdopen fdopen n a -- a ( fd fileattr -- file )
1.17      pazsan     40: \c #include <fcntl.h>
                     41: c-function fcntl fcntl n n n -- n ( fd n1 n2 -- ior )
1.16      anton      42: \c #include <arpa/inet.h>
                     43: c-function htonl htonl n -- n ( x -- x' )
                     44: c-function htons htons n -- n ( x -- x' )
                     45: c-function ntohl ntohl n -- n ( x -- x' )
1.23      pazsan     46: \c #define fileno1(file) fileno((FILE*)(file))
                     47: c-function fileno fileno1 a -- n ( file* -- fd )
1.20      anton      48: end-c-library
1.4       pazsan     49: 
                     50: 4 4 2Constant int%
1.8       pazsan     51: 2 2 2Constant short%
1.1       pazsan     52: 
                     53: struct
                     54:     cell% field h_name
                     55:     cell% field h_aliases
1.4       pazsan     56:     int% field h_addrtype
                     57:     int% field h_length
1.1       pazsan     58:     cell% field h_addr_list
                     59: end-struct hostent
                     60: 
                     61: struct
1.8       pazsan     62:     short% field family
                     63:     short% field port
1.4       pazsan     64:     int% field sin_addr
1.1       pazsan     65:     cell% 2* field padding
                     66: end-struct sockaddr_in
                     67: 
1.12      anton      68: ' family alias family+port \ 0.6.2 32-bit field; used by itools
                     69: 
1.1       pazsan     70: Create sockaddr-tmp
                     71: sockaddr-tmp sockaddr_in %size dup allot erase
                     72: 
                     73: : c-string ( addr u -- addr' )
                     74:     tuck pad swap move pad + 0 swap c! pad ;
                     75: 
                     76: : host>addr ( addr u -- x )
                     77:     \G converts a internet name into a IPv4 address
                     78:     \G the resulting address is in network byte order
                     79:     c-string gethostbyname dup 0= abort" address not found"
1.26      pazsan     80: [ s" os-type" environment? drop s" cygwin" str= ] [IF]
1.27      pazsan     81:     &12 +
1.26      pazsan     82: [ELSE]
1.27      pazsan     83:     h_addr_list
1.26      pazsan     84: [THEN]
1.27      pazsan     85:     @ @ @ ntohl ;
1.1       pazsan     86: 
1.17      pazsan     87:    2 Constant PF_INET
                     88:    1 Constant SOCK_STREAM
                     89:    6 Constant IPPROTO_TCP
                     90:    4 Constant F_SETFL
                     91:   11 Constant EWOULDBLOCK
                     92: $100 Constant MSG_WAITALL
                     93: $802 Constant O_NONBLOCK|O_RDWR
                     94: 2000 Value    SOCKET-TIMEOUT
1.1       pazsan     95: 
1.8       pazsan     96: : new-socket ( -- socket )
                     97:     PF_INET SOCK_STREAM IPPROTO_TCP socket
                     98:     dup 0<= abort" no free socket" ;
                     99: 
                    100: : >inetaddr ( ip port sockaddr -- ) >r
                    101:     r@ sockaddr_in %size erase
                    102:     PF_INET r@ family w!
                    103:     htons r@ port w!
                    104:     htonl r> sin_addr l! ;
                    105: 
1.1       pazsan    106: : open-socket ( addr u port -- fid )
1.10      pazsan    107:     -rot host>addr
                    108:     swap sockaddr-tmp >inetaddr
1.8       pazsan    109:     new-socket >r
                    110:     r@ sockaddr-tmp sockaddr_in %size connect 0< abort" can't connect"
1.1       pazsan    111:     r> s" w+" c-string fdopen ;
1.17      pazsan    112: 
1.18      pazsan    113: : create-server  ( port# -- lsocket )
                    114:     sockaddr-tmp 4 CELLS ERASE
                    115:     htonl PF_INET OR sockaddr-tmp !
                    116:     PF_INET SOCK_STREAM 0 socket
                    117:     dup 0< abort" no free socket" >r
                    118:     r@ sockaddr-tmp 16 bind 0= IF  r> exit  ENDIF
                    119:     r> drop true abort" bind :: failed" ;
                    120: 
1.17      pazsan    121: \ from itools.frt
                    122: 
1.18      pazsan    123: ' open-socket Alias open-service
                    124: 
1.17      pazsan    125: : ms@  utime 1000 um/mod nip ; ( -- u ) 
                    126: 
                    127: : $put ( c-addr1 u1 c-addr2 -- ) swap cmove ;
                    128: 
                    129: : $+   ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
                    130:     { c-addr1 u1 c-addr2 u2 }
                    131:     u1 u2 + allocate throw 
                    132:     c-addr1 u1  2 pick       $put 
                    133:     c-addr2 u2  2 pick u1 +  $put  
                    134:     u1 u2 + ;
                    135: 
1.19      pazsan    136: Create hostname$ 0 c, 255 chars allot
1.18      pazsan    137: Create alen   16 ,
                    138: Create crlf 2 c, 13 c, 10 c,
                    139: 
                    140: : listen ( lsocket /queue -- )
                    141:     listen() 0< abort" listen :: failed" ;
1.17      pazsan    142: 
1.18      pazsan    143: \ This call blocks the server until a client appears. The client uses socket to
                    144: \ converse with the server.
                    145: : accept-socket ( lsocket -- socket )
                    146:     16 alen !
                    147:     sockaddr-tmp alen accept() 
                    148:     dup 0< IF  errno cr ." accept() :: error #" .  
                    149:        abort" accept :: failed"  
                    150:     ENDIF   s" w+" c-string fdopen ;
1.17      pazsan    151: 
                    152: : +cr  ( c-addr1 u1 -- c-addr2 u2 ) crlf count $+ ;
                    153: 
                    154: : blocking-mode ( socket flag -- ) >r fileno
                    155:     f_setfl r> IF  0  
                    156:     ELSE  o_nonblock|o_rdwr  
                    157:     THEN  
                    158:     fcntl 0< abort" blocking-mode failed" ;
                    159: 
1.19      pazsan    160: : hostname ( -- c-addr u )
                    161:     hostname$ c@ 0= IF
                    162:        hostname$ 1+ 255 gethostname drop
                    163:        hostname$ 1+ 255 0 scan nip 255 swap - hostname$ c!
                    164:     THEN
                    165:     hostname$ count ;
1.17      pazsan    166: : set-socket-timeout ( u -- ) 200 + to socket-timeout ;
                    167: : get-socket-timeout ( -- u ) socket-timeout 200 - ;
                    168: : write-socket ( c-addr size socket -- ) fileno -rot 0 send 0< throw ;
                    169: : close-socket ( socket -- ) fileno closesocket drop ;
                    170: 
                    171: : (rs)  ( socket c-addr maxlen -- c-addr size ) 
                    172:     2 pick >r r@ false blocking-mode  rot fileno -rot
                    173:     over >r msg_waitall recv
                    174:     dup 0<  IF  0 max
                    175:        errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
                    176:     THEN
                    177:     r> swap
                    178:     r> true blocking-mode ;
                    179: 
                    180: : read-socket ( socket c-addr maxlen -- c-addr u )
                    181:     ms@ socket-timeout + { socket c-addr maxlen tmax -- c-addr size }
                    182:     BEGIN 
                    183:        socket c-addr maxlen (rs) dup 0=
                    184:        ms@ tmax u< and 
                    185:     WHILE 
                    186:            2drop
                    187:     REPEAT ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>