Annotation of gforth/unix/socket.fs, revision 1.53
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.38 pazsan 154: 0 Constant PF_UNSPEC
1.17 pazsan 155: 2 Constant PF_INET
1.46 pazsan 156: [IFDEF] darwin
1.42 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: [ELSE]
1.41 pazsan 165: 10 Constant PF_INET6
1.42 pazsan 166: 2 Constant AF_INET
167: 10 Constant AF_INET6
168: 26 Constant IPV6_V6ONLY
169: 11 Constant EWOULDBLOCK
170: $100 Constant MSG_WAITALL
1.52 pazsan 171: $10000 Constant MSG_WAITFORONE
1.42 pazsan 172: $802 Constant O_NONBLOCK|O_RDWR
173: [THEN]
1.17 pazsan 174: 1 Constant SOCK_STREAM
1.33 pazsan 175: 2 Constant SOCK_DGRAM
1.44 pazsan 176: 0 Constant IPPROTO_IP
1.41 pazsan 177: 41 Constant IPPROTO_IPV6
1.44 pazsan 178: 10 Constant IP_MTU_DISCOVER
179: 23 Constant IPV6_MTU_DISCOVER
1.47 pazsan 180: 67 Constant IP_DONTFRAG
1.45 pazsan 181: 2 Constant IP_PMTUDISC_DO
1.17 pazsan 182: 4 Constant F_SETFL
1.35 pazsan 183: $001 Constant POLLIN
184: $002 Constant POLLPRI
185: $004 Constant POLLOUT
186:
1.30 anton 187: 2variable socket-timeout-d 2000. socket-timeout-d 2!
1.1 pazsan 188:
1.8 pazsan 189: : new-socket ( -- socket )
1.33 pazsan 190: PF_INET SOCK_STREAM 0 socket
191: dup 0<= abort" no free socket" ;
192:
1.41 pazsan 193: : new-socket6 ( -- socket )
194: PF_INET6 SOCK_STREAM 0 socket
195: dup 0<= abort" no free socket"
196: dup IPPROTO_IPV6 IPV6_V6ONLY sockopt-on dup on 4 setsockopt drop ;
197:
1.33 pazsan 198: : new-udp-socket ( -- socket )
199: PF_INET SOCK_DGRAM 0 socket
1.44 pazsan 200: dup 0<= abort" no free socket"
1.47 pazsan 201: [IFDEF] darwin
1.48 pazsan 202: \ dup IPPROTO_IP IP_DONTFRAG sockopt-on 1 over l! 4
203: \ setsockopt drop
1.47 pazsan 204: [ELSE]
1.46 pazsan 205: dup IPPROTO_IP IP_MTU_DISCOVER sockopt-on IP_PMTUDISC_DO over l! 4
1.48 pazsan 206: setsockopt drop
207: [THEN] ;
1.8 pazsan 208:
1.41 pazsan 209: : new-udp-socket6 ( -- socket )
210: PF_INET6 SOCK_DGRAM 0 socket
211: dup 0<= abort" no free socket"
1.47 pazsan 212: [IFDEF] darwin
1.48 pazsan 213: \ dup IPPROTO_IP IP_DONTFRAG sockopt-on 1 over l! 4
214: \ setsockopt drop
1.47 pazsan 215: [ELSE]
1.46 pazsan 216: dup IPPROTO_IPV6 IPV6_MTU_DISCOVER sockopt-on IP_PMTUDISC_DO over l! 4
1.48 pazsan 217: setsockopt drop
1.47 pazsan 218: [THEN]
1.41 pazsan 219: dup IPPROTO_IPV6 IPV6_V6ONLY sockopt-on dup on 4 setsockopt drop ;
1.33 pazsan 220:
1.53 ! pazsan 221: : new-udp-socket46 ( -- socket )
! 222: PF_INET6 SOCK_DGRAM 0 socket
! 223: dup 0<= abort" no free socket"
! 224: [IFDEF] darwin
! 225: \ dup IPPROTO_IP IP_DONTFRAG sockopt-on 1 over l! 4
! 226: \ setsockopt drop
! 227: [ELSE]
! 228: dup IPPROTO_IPV6 IPV6_MTU_DISCOVER sockopt-on IP_PMTUDISC_DO over l! 4
! 229: setsockopt drop
! 230: [THEN]
! 231: ;
! 232:
1.38 pazsan 233: \ getaddrinfo based open-socket
234:
235: : >hints ( socktype -- )
236: hints addrinfo %size erase
237: PF_UNSPEC hints ai_family l!
238: hints ai_socktype l! ;
239:
240: : get-info ( addr u port -- info )
241: base @ >r decimal 0 <<# 0 hold #s #> r> base ! drop
242: >r c-string r> hints addrres getaddrinfo #>>
243: ?dup IF
244: gai_strerror cstring>sstring type
245: true abort" getaddrinfo failed" THEN
246: addrres @ ;
247:
248: : get-socket ( info -- socket ) dup >r >r
249: BEGIN r@ WHILE
250: r@ ai_family l@ r@ ai_socktype l@ r@ ai_protocol l@ socket
251: dup 0>= IF
1.43 pazsan 252: dup r@ ai_addr @ r@ ai_addrlen l@ connect
1.38 pazsan 253: IF
254: closesocket drop
255: ELSE
256: s" w+" c-string fdopen
257: rdrop r> freeaddrinfo EXIT
258: THEN
259: ELSE drop THEN
260: r> ai_next @ >r REPEAT
261: rdrop r> freeaddrinfo true abort" can't connect" ;
262:
263: : open-socket ( addr u port -- fid )
264: SOCK_STREAM >hints get-info get-socket ;
265:
266: : open-udp-socket ( addr u port -- fid )
267: SOCK_DGRAM >hints get-info get-socket ;
268:
1.18 pazsan 269: : create-server ( port# -- lsocket )
1.33 pazsan 270: sockaddr-tmp sockaddr_in %size erase
1.42 pazsan 271: AF_INET sockaddr-tmp family w!
1.33 pazsan 272: htons sockaddr-tmp port w!
273: new-socket
274: dup 0< abort" no free socket" >r
1.41 pazsan 275: r@ sockaddr-tmp sockaddr_in4 %size bind 0= IF r> exit ENDIF
276: r> drop true abort" bind :: failed" ;
277:
278: : create-server6 ( port# -- lsocket )
279: sockaddr-tmp sockaddr_in %size erase
1.42 pazsan 280: AF_INET6 sockaddr-tmp family w!
1.41 pazsan 281: htons sockaddr-tmp port w!
282: new-socket6
283: dup 0< abort" no free socket" >r
284: r@ sockaddr-tmp sockaddr_in6 %size bind 0= IF r> exit ENDIF
1.33 pazsan 285: r> drop true abort" bind :: failed" ;
286:
287: : create-udp-server ( port# -- lsocket )
288: sockaddr-tmp sockaddr_in %size erase
1.42 pazsan 289: AF_INET sockaddr-tmp family w!
1.33 pazsan 290: htons sockaddr-tmp port w!
291: new-udp-socket
1.18 pazsan 292: dup 0< abort" no free socket" >r
1.41 pazsan 293: r@ sockaddr-tmp sockaddr_in4 %size bind 0= IF r> exit ENDIF
294: r> drop true abort" bind :: failed" ;
295:
296: : create-udp-server6 ( port# -- lsocket )
297: sockaddr-tmp sockaddr_in %size erase
1.42 pazsan 298: AF_INET6 sockaddr-tmp family w!
1.41 pazsan 299: htons sockaddr-tmp port w!
300: new-udp-socket6
301: dup 0< abort" no free socket" >r
302: r@ sockaddr-tmp sockaddr_in6 %size bind 0= IF r> exit ENDIF
1.18 pazsan 303: r> drop true abort" bind :: failed" ;
304:
1.53 ! pazsan 305: : create-udp-server46 ( port# -- lsocket )
! 306: sockaddr-tmp sockaddr_in %size erase
! 307: AF_INET6 sockaddr-tmp family w!
! 308: htons sockaddr-tmp port w!
! 309: new-udp-socket46
! 310: dup 0< abort" no free socket" >r
! 311: r@ sockaddr-tmp sockaddr_in6 %size bind 0= IF r> exit ENDIF
! 312: r> drop true abort" bind :: failed" ;
! 313:
1.17 pazsan 314: \ from itools.frt
315:
1.18 pazsan 316: ' open-socket Alias open-service
317:
1.17 pazsan 318: : $put ( c-addr1 u1 c-addr2 -- ) swap cmove ;
319:
320: : $+ ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
321: { c-addr1 u1 c-addr2 u2 }
322: u1 u2 + allocate throw
323: c-addr1 u1 2 pick $put
324: c-addr2 u2 2 pick u1 + $put
325: u1 u2 + ;
326:
1.19 pazsan 327: Create hostname$ 0 c, 255 chars allot
1.18 pazsan 328: Create alen 16 ,
329: Create crlf 2 c, 13 c, 10 c,
330:
331: : listen ( lsocket /queue -- )
332: listen() 0< abort" listen :: failed" ;
1.17 pazsan 333:
1.18 pazsan 334: \ This call blocks the server until a client appears. The client uses socket to
335: \ converse with the server.
336: : accept-socket ( lsocket -- socket )
337: 16 alen !
338: sockaddr-tmp alen accept()
339: dup 0< IF errno cr ." accept() :: error #" .
340: abort" accept :: failed"
341: ENDIF s" w+" c-string fdopen ;
1.17 pazsan 342:
343: : +cr ( c-addr1 u1 -- c-addr2 u2 ) crlf count $+ ;
344:
345: : blocking-mode ( socket flag -- ) >r fileno
346: f_setfl r> IF 0
347: ELSE o_nonblock|o_rdwr
348: THEN
349: fcntl 0< abort" blocking-mode failed" ;
350:
1.19 pazsan 351: : hostname ( -- c-addr u )
352: hostname$ c@ 0= IF
353: hostname$ 1+ 255 gethostname drop
354: hostname$ 1+ 255 0 scan nip 255 swap - hostname$ c!
355: THEN
356: hostname$ count ;
1.30 anton 357: : set-socket-timeout ( u -- ) 200 + s>d socket-timeout-d 2! ;
358: : get-socket-timeout ( -- u ) socket-timeout-d 2@ drop 200 - ;
1.17 pazsan 359: : write-socket ( c-addr size socket -- ) fileno -rot 0 send 0< throw ;
360: : close-socket ( socket -- ) fileno closesocket drop ;
361:
362: : (rs) ( socket c-addr maxlen -- c-addr size )
363: 2 pick >r r@ false blocking-mode rot fileno -rot
364: over >r msg_waitall recv
365: dup 0< IF 0 max
366: errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
367: THEN
368: r> swap
369: r> true blocking-mode ;
370:
371: : read-socket ( socket c-addr maxlen -- c-addr u )
1.30 anton 372: utime socket-timeout-d 2@ d+ { socket c-addr maxlen d: tmax -- c-addr size }
1.17 pazsan 373: BEGIN
374: socket c-addr maxlen (rs) dup 0=
1.30 anton 375: utime tmax d< and
1.17 pazsan 376: WHILE
377: 2drop
378: REPEAT ;
1.33 pazsan 379:
380: : (rs-from) ( socket c-addr maxlen -- c-addr size )
381: 2 pick >r r@ false blocking-mode rot fileno -rot
382: over >r msg_waitall sockaddr-tmp alen recvfrom
383: dup 0< IF 0 max
384: errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
385: THEN
386: r> swap
387: r> true blocking-mode ;
388:
389: : read-socket-from ( socket c-addr maxlen -- c-addr u )
390: utime socket-timeout-d 2@ d+ { socket c-addr maxlen d: tmax -- c-addr size }
391: BEGIN
392: socket c-addr maxlen (rs-from) dup 0=
393: utime tmax d< and
394: WHILE
395: 2drop
396: REPEAT ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to socket.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / unix