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

1.1       pazsan      1: \ socket interface
                      2: 
1.51      anton       3: \ Copyright (C) 1998,2000,2003,2005,2006,2007,2008,2009,2010,2011 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>
1.17      pazsan     22: \c #include <unistd.h>
                     23: c-function gethostname gethostname a n -- n ( c-addr u -- ior )
                     24: \c #include <errno.h>
1.24      pazsan     25: \c #define get_errno() errno
                     26: c-function errno get_errno -- n ( -- value )
1.16      anton      27: \c #include <sys/types.h>
                     28: \c #include <sys/socket.h>
                     29: c-function socket socket n n n -- n ( class type proto -- fd )
1.17      pazsan     30: c-function closesocket close n -- n ( fd -- ior )
1.16      anton      31: c-function connect connect n a n -- n ( fd sock size -- err )
1.17      pazsan     32: c-function send send n a n n -- n ( socket buffer count flags -- size )
                     33: c-function recv recv n a n n -- n ( socket buffer count flags -- size )
1.33      pazsan     34: c-function recvfrom recvfrom n a n n a a -- n ( socket buffer count flags srcaddr addrlen -- size )
1.34      pazsan     35: c-function sendto sendto n a n n a n -- n ( socket buffer count flags srcaddr addrlen -- size )
1.25      pazsan     36: c-function listen() listen n n -- n ( socket backlog -- err )
1.28      anton      37: c-function bind bind n a n -- n ( socket sockaddr socklen --- err )
1.18      pazsan     38: c-function accept() accept n a a -- n ( socket sockaddr addrlen -- fd )
1.16      anton      39: \c #include <stdio.h>
                     40: c-function fdopen fdopen n a -- a ( fd fileattr -- file )
1.17      pazsan     41: \c #include <fcntl.h>
                     42: c-function fcntl fcntl n n n -- n ( fd n1 n2 -- ior )
1.16      anton      43: \c #include <arpa/inet.h>
                     44: c-function htonl htonl n -- n ( x -- x' )
                     45: c-function htons htons n -- n ( x -- x' )
                     46: c-function ntohl ntohl n -- n ( x -- x' )
1.23      pazsan     47: \c #define fileno1(file) fileno((FILE*)(file))
                     48: c-function fileno fileno1 a -- n ( file* -- fd )
1.35      pazsan     49: \c #include <poll.h>
                     50: c-function poll poll a n n -- n ( fds nfds timeout -- r )
1.42      pazsan     51: environment os-type s" linux" string-prefix? [IF]
                     52:     c-function ppoll ppoll a n a a -- n ( fds nfds timeout_ts sigmask -- r )
1.52      pazsan     53:     \c #include <sys/epoll.h>
                     54:     c-function epoll_create epoll_create n -- n ( n -- epfd )
                     55:     c-function epoll_ctl epoll_ctl n n n a -- n ( epfd op fd event -- r )
                     56:     c-function epoll_wait epoll_wait n a n n -- n ( epfd events maxevs timeout -- r )
1.53      pazsan     57:     s" uname -r" r/o open-pipe throw
                     58:     dup >r slurp-fid r> close-pipe throw drop
                     59:     2dup s" 3." string-prefix? >r drop free throw r> [IF]
                     60:        c-function recvmmsg recvmmsg n a n n a -- n ( sockfd hdr vlen flag timeout -- r )
                     61:        c-function sendmmsg sendmmsg n a n n -- n ( sockfd hdr vlen flag -- r )
                     62:     [THEN]
1.42      pazsan     63: [THEN]
1.36      pazsan     64: \c #include <netdb.h>
                     65: c-function getaddrinfo getaddrinfo a a a a -- n ( node service hints res -- r )
                     66: c-function freeaddrinfo freeaddrinfo a -- void ( res -- )
                     67: c-function gai_strerror gai_strerror n -- a ( errcode -- addr )
1.41      pazsan     68: c-function setsockopt setsockopt n n n a n -- n ( sockfd level optname optval optlen -- r )
1.20      anton      69: end-c-library
1.4       pazsan     70: 
1.49      pazsan     71: environment os-type s" darwin" string-prefix? [IF] : darwin ; [THEN]
                     72: 
1.4       pazsan     73: 4 4 2Constant int%
1.8       pazsan     74: 2 2 2Constant short%
1.37      pazsan     75: int% 2Constant size_t%
1.1       pazsan     76: 
                     77: struct
                     78:     cell% field h_name
                     79:     cell% field h_aliases
1.4       pazsan     80:     int% field h_addrtype
                     81:     int% field h_length
1.1       pazsan     82:     cell% field h_addr_list
                     83: end-struct hostent
                     84: 
                     85: struct
1.8       pazsan     86:     short% field family
                     87:     short% field port
1.4       pazsan     88:     int% field sin_addr
1.42      pazsan     89:     int% 2* field padding
1.41      pazsan     90: end-struct sockaddr_in4
                     91: 
                     92: struct
                     93:     short% field sin6_family
                     94:     short% field sin6_port
                     95:     int% field sin6_flowinfo
                     96:     int% 4 * field sin6_addr
                     97:     int% field sin6_scope_id
                     98: end-struct sockaddr_in6
                     99: 
                    100: sockaddr_in4 %alignment sockaddr_in6 %alignment max
                    101: sockaddr_in4 %size sockaddr_in6 %size max 2Constant sockaddr_in
1.1       pazsan    102: 
1.35      pazsan    103: struct
                    104:     int% field fd
                    105:     short% field events
                    106:     short% field revents
                    107: end-struct pollfd
                    108: 
1.36      pazsan    109: struct
                    110:     int% field ai_flags
                    111:     int% field ai_family
                    112:     int% field ai_socktype
                    113:     int% field ai_protocol
                    114:     size_t% field ai_addrlen
1.49      pazsan    115: [IFDEF] darwin
1.42      pazsan    116:     cell% field ai_canonname
                    117:     cell% field ai_addr
                    118: [ELSE]
1.36      pazsan    119:     cell% field ai_addr
                    120:     cell% field ai_canonname
1.42      pazsan    121: [THEN]
1.36      pazsan    122:     cell% field ai_next
                    123: end-struct addrinfo
                    124: 
1.52      pazsan    125: environment os-type s" linux" string-prefix? [IF]
                    126:     struct
                    127:        cell% field iov_base
1.53      pazsan    128:        cell% field iov_len
1.52      pazsan    129:     end-struct iovec
                    130:     struct
                    131:        cell% field msg_name
1.53      pazsan    132:        cell% field msg_namelen
1.52      pazsan    133:        cell% field msg_iov \ iovec structures
1.53      pazsan    134:        cell% field msg_iovlen
1.52      pazsan    135:        cell% field msg_control
1.53      pazsan    136:        cell% field msg_controllen
                    137:        cell% field msg_flags
                    138:        cell% field msg_len
1.52      pazsan    139:     end-struct mmsghdr
                    140: [THEN]
                    141: 
1.12      anton     142: ' family alias family+port \ 0.6.2 32-bit field; used by itools
                    143: 
1.1       pazsan    144: Create sockaddr-tmp
                    145: sockaddr-tmp sockaddr_in %size dup allot erase
1.38      pazsan    146: Create hints
                    147: hints addrinfo %size dup allot erase
                    148: Variable addrres
1.41      pazsan    149: Variable sockopt-on
1.1       pazsan    150: 
                    151: : c-string ( addr u -- addr' )
                    152:     tuck pad swap move pad + 0 swap c! pad ;
                    153: 
1.54      pazsan    154:      0 Constant PF_UNSPEC
                    155:      2 Constant PF_INET
1.46      pazsan    156: [IFDEF] darwin
1.54      pazsan    157:     30 Constant PF_INET6
                    158:  $0210 Constant AF_INET
                    159:  $1E1C Constant AF_INET6
                    160:     27 Constant IPV6_V6ONLY
                    161:     35 Constant EWOULDBLOCK
                    162:    $40 Constant MSG_WAITALL
                    163:   $006 Constant O_NONBLOCK|O_RDWR
                    164:  $1006 Constant SO_RCVTIMEO
                    165:  $FFFF Constant SOL_SOCKET
1.42      pazsan    166: [ELSE]
1.54      pazsan    167:     10 Constant PF_INET6
                    168:      2 Constant AF_INET
                    169:     10 Constant AF_INET6
                    170:     26 Constant IPV6_V6ONLY
                    171:     11 Constant EWOULDBLOCK
                    172:   $100 Constant MSG_WAITALL
1.52      pazsan    173: $10000 Constant MSG_WAITFORONE
1.54      pazsan    174:   $802 Constant O_NONBLOCK|O_RDWR
                    175:     20 Constant SO_RCVTIMEO
                    176:      1 Constant SOL_SOCKET
1.42      pazsan    177: [THEN]
1.17      pazsan    178:    1 Constant SOCK_STREAM
1.33      pazsan    179:    2 Constant SOCK_DGRAM
1.44      pazsan    180:    0 Constant IPPROTO_IP
1.41      pazsan    181:   41 Constant IPPROTO_IPV6
1.44      pazsan    182:   10 Constant IP_MTU_DISCOVER
                    183:   23 Constant IPV6_MTU_DISCOVER
1.47      pazsan    184:   67 Constant IP_DONTFRAG
1.45      pazsan    185:    2 Constant IP_PMTUDISC_DO
1.17      pazsan    186:    4 Constant F_SETFL
1.35      pazsan    187: $001 Constant POLLIN
                    188: $002 Constant POLLPRI
                    189: $004 Constant POLLOUT
                    190: 
1.30      anton     191: 2variable socket-timeout-d 2000. socket-timeout-d 2!
1.1       pazsan    192: 
1.8       pazsan    193: : new-socket ( -- socket )
1.33      pazsan    194:     PF_INET SOCK_STREAM 0 socket
                    195:     dup 0<= abort" no free socket" ;
                    196: 
1.41      pazsan    197: : new-socket6 ( -- socket )
                    198:     PF_INET6 SOCK_STREAM 0 socket
                    199:     dup 0<= abort" no free socket"
                    200:     dup IPPROTO_IPV6 IPV6_V6ONLY sockopt-on dup on 4 setsockopt drop ;
                    201: 
1.33      pazsan    202: : new-udp-socket ( -- socket )
                    203:     PF_INET SOCK_DGRAM 0 socket
1.44      pazsan    204:     dup 0<= abort" no free socket"
1.47      pazsan    205: [IFDEF] darwin
1.48      pazsan    206: \    dup IPPROTO_IP IP_DONTFRAG sockopt-on 1 over l! 4
                    207: \    setsockopt drop
1.47      pazsan    208: [ELSE]
1.46      pazsan    209:     dup IPPROTO_IP IP_MTU_DISCOVER sockopt-on IP_PMTUDISC_DO over l! 4
1.48      pazsan    210:     setsockopt drop
                    211: [THEN] ;
1.8       pazsan    212: 
1.41      pazsan    213: : new-udp-socket6 ( -- socket )
                    214:     PF_INET6 SOCK_DGRAM 0 socket
                    215:     dup 0<= abort" no free socket"
1.47      pazsan    216: [IFDEF] darwin
1.48      pazsan    217: \    dup IPPROTO_IP IP_DONTFRAG sockopt-on 1 over l! 4
                    218: \    setsockopt drop
1.47      pazsan    219: [ELSE]
1.46      pazsan    220:     dup IPPROTO_IPV6 IPV6_MTU_DISCOVER sockopt-on IP_PMTUDISC_DO over l! 4
1.48      pazsan    221:     setsockopt drop
1.47      pazsan    222: [THEN]
1.41      pazsan    223:     dup IPPROTO_IPV6 IPV6_V6ONLY sockopt-on dup on 4 setsockopt drop ;
1.33      pazsan    224: 
1.53      pazsan    225: : new-udp-socket46 ( -- socket )
                    226:     PF_INET6 SOCK_DGRAM 0 socket
                    227:     dup 0<= abort" no free socket"
                    228: [IFDEF] darwin
                    229: \    dup IPPROTO_IP IP_DONTFRAG sockopt-on 1 over l! 4
                    230: \    setsockopt drop
                    231: [ELSE]
                    232:     dup IPPROTO_IPV6 IPV6_MTU_DISCOVER sockopt-on IP_PMTUDISC_DO over l! 4
                    233:     setsockopt drop
                    234: [THEN]
                    235: ;
                    236: 
1.38      pazsan    237: \ getaddrinfo based open-socket
                    238: 
                    239: : >hints ( socktype -- )
                    240:     hints addrinfo %size erase
                    241:     PF_UNSPEC hints ai_family l!
                    242:     hints ai_socktype l! ;
                    243: 
                    244: : get-info ( addr u port -- info )
                    245:     base @ >r  decimal  0 <<# 0 hold #s #>  r> base ! drop
                    246:     >r c-string r> hints addrres getaddrinfo #>>
                    247:     ?dup IF
                    248:        gai_strerror cstring>sstring type
                    249:        true abort" getaddrinfo failed"  THEN
                    250:     addrres @ ;
                    251: 
                    252: : get-socket ( info -- socket )  dup >r >r
                    253:     BEGIN  r@  WHILE
                    254:            r@ ai_family l@ r@ ai_socktype l@ r@ ai_protocol l@ socket
                    255:            dup 0>= IF
1.43      pazsan    256:                dup r@ ai_addr @ r@ ai_addrlen l@ connect
1.38      pazsan    257:                IF
                    258:                    closesocket drop
                    259:                ELSE
                    260:                    s" w+" c-string fdopen
                    261:                    rdrop r> freeaddrinfo  EXIT
                    262:                THEN
                    263:            ELSE  drop  THEN
                    264:            r> ai_next @ >r  REPEAT
                    265:     rdrop r> freeaddrinfo true abort" can't connect" ;
                    266: 
                    267: : open-socket ( addr u port -- fid )
                    268:     SOCK_STREAM >hints  get-info  get-socket ;
                    269: 
                    270: : open-udp-socket ( addr u port -- fid )
                    271:     SOCK_DGRAM >hints  get-info  get-socket ;
                    272: 
1.18      pazsan    273: : create-server  ( port# -- lsocket )
1.33      pazsan    274:     sockaddr-tmp sockaddr_in %size erase
1.42      pazsan    275:     AF_INET sockaddr-tmp family w!
1.33      pazsan    276:     htons   sockaddr-tmp port w!
                    277:     new-socket
                    278:     dup 0< abort" no free socket" >r
1.41      pazsan    279:     r@ sockaddr-tmp sockaddr_in4 %size bind 0= IF  r> exit  ENDIF
                    280:     r> drop true abort" bind :: failed" ;
                    281: 
                    282: : create-server6  ( port# -- lsocket )
                    283:     sockaddr-tmp sockaddr_in %size erase
1.42      pazsan    284:     AF_INET6 sockaddr-tmp family w!
1.41      pazsan    285:     htons   sockaddr-tmp port w!
                    286:     new-socket6
                    287:     dup 0< abort" no free socket" >r
                    288:     r@ sockaddr-tmp sockaddr_in6 %size bind 0= IF  r> exit  ENDIF
1.33      pazsan    289:     r> drop true abort" bind :: failed" ;
                    290: 
                    291: : create-udp-server  ( port# -- lsocket )
                    292:     sockaddr-tmp sockaddr_in %size erase
1.42      pazsan    293:     AF_INET sockaddr-tmp family w!
1.33      pazsan    294:     htons   sockaddr-tmp port w!
                    295:     new-udp-socket
1.18      pazsan    296:     dup 0< abort" no free socket" >r
1.41      pazsan    297:     r@ sockaddr-tmp sockaddr_in4 %size bind 0= IF  r> exit  ENDIF
                    298:     r> drop true abort" bind :: failed" ;
                    299: 
                    300: : create-udp-server6  ( port# -- lsocket )
1.55    ! pazsan    301:     sockaddr-tmp sockaddr_in6 %size erase
1.42      pazsan    302:     AF_INET6 sockaddr-tmp family w!
1.41      pazsan    303:     htons   sockaddr-tmp port w!
                    304:     new-udp-socket6
                    305:     dup 0< abort" no free socket" >r
                    306:     r@ sockaddr-tmp sockaddr_in6 %size bind 0= IF  r> exit  ENDIF
1.18      pazsan    307:     r> drop true abort" bind :: failed" ;
                    308: 
1.53      pazsan    309: : create-udp-server46  ( port# -- lsocket )
1.55    ! pazsan    310:     sockaddr-tmp sockaddr_in6 %size erase
1.53      pazsan    311:     AF_INET6 sockaddr-tmp family w!
                    312:     htons   sockaddr-tmp port w!
                    313:     new-udp-socket46
                    314:     dup 0< abort" no free socket" >r
                    315:     r@ sockaddr-tmp sockaddr_in6 %size bind 0= IF  r> exit  ENDIF
                    316:     r> drop true abort" bind :: failed" ;
                    317: 
1.17      pazsan    318: \ from itools.frt
                    319: 
1.18      pazsan    320: ' open-socket Alias open-service
                    321: 
1.17      pazsan    322: : $put ( c-addr1 u1 c-addr2 -- ) swap cmove ;
                    323: 
                    324: : $+   ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
                    325:     { c-addr1 u1 c-addr2 u2 }
                    326:     u1 u2 + allocate throw 
                    327:     c-addr1 u1  2 pick       $put 
                    328:     c-addr2 u2  2 pick u1 +  $put  
                    329:     u1 u2 + ;
                    330: 
1.19      pazsan    331: Create hostname$ 0 c, 255 chars allot
1.18      pazsan    332: Create alen   16 ,
                    333: Create crlf 2 c, 13 c, 10 c,
                    334: 
                    335: : listen ( lsocket /queue -- )
                    336:     listen() 0< abort" listen :: failed" ;
1.17      pazsan    337: 
1.18      pazsan    338: \ This call blocks the server until a client appears. The client uses socket to
                    339: \ converse with the server.
                    340: : accept-socket ( lsocket -- socket )
                    341:     16 alen !
                    342:     sockaddr-tmp alen accept() 
                    343:     dup 0< IF  errno cr ." accept() :: error #" .  
                    344:        abort" accept :: failed"  
                    345:     ENDIF   s" w+" c-string fdopen ;
1.17      pazsan    346: 
                    347: : +cr  ( c-addr1 u1 -- c-addr2 u2 ) crlf count $+ ;
                    348: 
                    349: : blocking-mode ( socket flag -- ) >r fileno
                    350:     f_setfl r> IF  0  
                    351:     ELSE  o_nonblock|o_rdwr  
                    352:     THEN  
                    353:     fcntl 0< abort" blocking-mode failed" ;
                    354: 
1.19      pazsan    355: : hostname ( -- c-addr u )
                    356:     hostname$ c@ 0= IF
                    357:        hostname$ 1+ 255 gethostname drop
                    358:        hostname$ 1+ 255 0 scan nip 255 swap - hostname$ c!
                    359:     THEN
                    360:     hostname$ count ;
1.30      anton     361: : set-socket-timeout ( u -- ) 200 + s>d socket-timeout-d 2! ;
                    362: : get-socket-timeout ( -- u ) socket-timeout-d 2@ drop 200 - ;
1.17      pazsan    363: : write-socket ( c-addr size socket -- ) fileno -rot 0 send 0< throw ;
                    364: : close-socket ( socket -- ) fileno closesocket drop ;
                    365: 
                    366: : (rs)  ( socket c-addr maxlen -- c-addr size ) 
                    367:     2 pick >r r@ false blocking-mode  rot fileno -rot
                    368:     over >r msg_waitall recv
                    369:     dup 0<  IF  0 max
                    370:        errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
                    371:     THEN
                    372:     r> swap
                    373:     r> true blocking-mode ;
                    374: 
                    375: : read-socket ( socket c-addr maxlen -- c-addr u )
1.30      anton     376:     utime socket-timeout-d 2@ d+ { socket c-addr maxlen d: tmax -- c-addr size }
1.17      pazsan    377:     BEGIN 
                    378:        socket c-addr maxlen (rs) dup 0=
1.30      anton     379:        utime tmax d< and 
1.17      pazsan    380:     WHILE 
                    381:            2drop
                    382:     REPEAT ;
1.33      pazsan    383: 
                    384: : (rs-from)  ( socket c-addr maxlen -- c-addr size ) 
                    385:     2 pick >r  r@ false blocking-mode  rot fileno -rot
                    386:     over >r msg_waitall sockaddr-tmp alen  recvfrom
                    387:     dup 0<  IF  0 max
                    388:        errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
                    389:     THEN
                    390:     r> swap
                    391:     r> true blocking-mode ;
                    392: 
                    393: : read-socket-from ( socket c-addr maxlen -- c-addr u )
                    394:     utime socket-timeout-d 2@ d+ { socket c-addr maxlen d: tmax -- c-addr size }
                    395:     BEGIN 
                    396:        socket c-addr maxlen (rs-from) dup 0=
                    397:        utime tmax d< and 
                    398:     WHILE 
                    399:            2drop
                    400:     REPEAT ;

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