Annotation of gforth/unix/socket.fs, revision 1.38
1.1 pazsan 1: \ socket interface
2:
1.32 anton 3: \ Copyright (C) 1998,2000,2003,2005,2006,2007,2008,2009 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.33 pazsan 35: c-function recvfrom recvfrom n a n n a a -- n ( socket buffer count flags srcaddr addrlen -- size )
1.34 pazsan 36: c-function sendto sendto n a n n a n -- n ( socket buffer count flags srcaddr addrlen -- size )
1.25 pazsan 37: c-function listen() listen n n -- n ( socket backlog -- err )
1.28 anton 38: c-function bind bind n a n -- n ( socket sockaddr socklen --- err )
1.18 pazsan 39: c-function accept() accept n a a -- n ( socket sockaddr addrlen -- fd )
1.16 anton 40: \c #include <stdio.h>
41: c-function fdopen fdopen n a -- a ( fd fileattr -- file )
1.17 pazsan 42: \c #include <fcntl.h>
43: c-function fcntl fcntl n n n -- n ( fd n1 n2 -- ior )
1.16 anton 44: \c #include <arpa/inet.h>
45: c-function htonl htonl n -- n ( x -- x' )
46: c-function htons htons n -- n ( x -- x' )
47: c-function ntohl ntohl n -- n ( x -- x' )
1.23 pazsan 48: \c #define fileno1(file) fileno((FILE*)(file))
49: c-function fileno fileno1 a -- n ( file* -- fd )
1.35 pazsan 50: \c #include <poll.h>
51: c-function poll poll a n n -- n ( fds nfds timeout -- r )
1.36 pazsan 52: \c #include <netdb.h>
53: c-function getaddrinfo getaddrinfo a a a a -- n ( node service hints res -- r )
54: c-function freeaddrinfo freeaddrinfo a -- void ( res -- )
55: c-function gai_strerror gai_strerror n -- a ( errcode -- addr )
1.20 anton 56: end-c-library
1.4 pazsan 57:
58: 4 4 2Constant int%
1.8 pazsan 59: 2 2 2Constant short%
1.37 pazsan 60: int% 2Constant size_t%
1.1 pazsan 61:
62: struct
63: cell% field h_name
64: cell% field h_aliases
1.4 pazsan 65: int% field h_addrtype
66: int% field h_length
1.1 pazsan 67: cell% field h_addr_list
68: end-struct hostent
69:
70: struct
1.8 pazsan 71: short% field family
72: short% field port
1.4 pazsan 73: int% field sin_addr
1.1 pazsan 74: cell% 2* field padding
75: end-struct sockaddr_in
76:
1.35 pazsan 77: struct
78: int% field fd
79: short% field events
80: short% field revents
81: end-struct pollfd
82:
1.36 pazsan 83: struct
84: int% field ai_flags
85: int% field ai_family
86: int% field ai_socktype
87: int% field ai_protocol
88: size_t% field ai_addrlen
89: cell% field ai_addr
90: cell% field ai_canonname
91: cell% field ai_next
92: end-struct addrinfo
93:
1.12 anton 94: ' family alias family+port \ 0.6.2 32-bit field; used by itools
95:
1.1 pazsan 96: Create sockaddr-tmp
97: sockaddr-tmp sockaddr_in %size dup allot erase
1.38 ! pazsan 98: Create hints
! 99: hints addrinfo %size dup allot erase
! 100: Variable addrres
1.1 pazsan 101:
102: : c-string ( addr u -- addr' )
103: tuck pad swap move pad + 0 swap c! pad ;
104:
105: : host>addr ( addr u -- x )
106: \G converts a internet name into a IPv4 address
107: \G the resulting address is in network byte order
108: c-string gethostbyname dup 0= abort" address not found"
1.26 pazsan 109: [ s" os-type" environment? drop s" cygwin" str= ] [IF]
1.27 pazsan 110: &12 +
1.26 pazsan 111: [ELSE]
1.27 pazsan 112: h_addr_list
1.26 pazsan 113: [THEN]
1.31 pazsan 114: @ @ l@ ntohl ;
1.1 pazsan 115:
1.38 ! pazsan 116: 0 Constant PF_UNSPEC
1.17 pazsan 117: 2 Constant PF_INET
118: 1 Constant SOCK_STREAM
1.33 pazsan 119: 2 Constant SOCK_DGRAM
120: 1 Constant IPPROTO_ICMP
1.17 pazsan 121: 6 Constant IPPROTO_TCP
1.33 pazsan 122: 17 Constant IPPROTO_UDP
1.17 pazsan 123: 4 Constant F_SETFL
124: 11 Constant EWOULDBLOCK
125: $100 Constant MSG_WAITALL
126: $802 Constant O_NONBLOCK|O_RDWR
1.35 pazsan 127: $001 Constant POLLIN
128: $002 Constant POLLPRI
129: $004 Constant POLLOUT
130:
1.30 anton 131: 2variable socket-timeout-d 2000. socket-timeout-d 2!
1.1 pazsan 132:
1.8 pazsan 133: : new-socket ( -- socket )
1.33 pazsan 134: PF_INET SOCK_STREAM 0 socket
135: dup 0<= abort" no free socket" ;
136:
137: : new-udp-socket ( -- socket )
138: PF_INET SOCK_DGRAM 0 socket
1.8 pazsan 139: dup 0<= abort" no free socket" ;
140:
141: : >inetaddr ( ip port sockaddr -- ) >r
142: r@ sockaddr_in %size erase
143: PF_INET r@ family w!
144: htons r@ port w!
145: htonl r> sin_addr l! ;
146:
1.38 ! pazsan 147: : open-socket1 ( addr u port -- fid )
1.10 pazsan 148: -rot host>addr
149: swap sockaddr-tmp >inetaddr
1.8 pazsan 150: new-socket >r
151: r@ sockaddr-tmp sockaddr_in %size connect 0< abort" can't connect"
1.1 pazsan 152: r> s" w+" c-string fdopen ;
1.17 pazsan 153:
1.38 ! pazsan 154: : open-udp-socket1 ( addr u port -- fid )
1.33 pazsan 155: -rot host>addr
156: swap sockaddr-tmp >inetaddr
157: new-udp-socket >r
158: r@ sockaddr-tmp sockaddr_in %size connect 0< abort" can't connect"
159: r> s" w+" c-string fdopen ;
160:
1.38 ! pazsan 161: \ getaddrinfo based open-socket
! 162:
! 163: : >hints ( socktype -- )
! 164: hints addrinfo %size erase
! 165: PF_UNSPEC hints ai_family l!
! 166: hints ai_socktype l! ;
! 167:
! 168: : get-info ( addr u port -- info )
! 169: base @ >r decimal 0 <<# 0 hold #s #> r> base ! drop
! 170: >r c-string r> hints addrres getaddrinfo #>>
! 171: ?dup IF
! 172: gai_strerror cstring>sstring type
! 173: true abort" getaddrinfo failed" THEN
! 174: addrres @ ;
! 175:
! 176: : get-socket ( info -- socket ) dup >r >r
! 177: BEGIN r@ WHILE
! 178: r@ ai_family l@ r@ ai_socktype l@ r@ ai_protocol l@ socket
! 179: dup 0>= IF
! 180: dup r@ ai_addr @ r@ ai_addrlen @ connect
! 181: IF
! 182: closesocket drop
! 183: ELSE
! 184: s" w+" c-string fdopen
! 185: rdrop r> freeaddrinfo EXIT
! 186: THEN
! 187: ELSE drop THEN
! 188: r> ai_next @ >r REPEAT
! 189: rdrop r> freeaddrinfo true abort" can't connect" ;
! 190:
! 191: : open-socket ( addr u port -- fid )
! 192: SOCK_STREAM >hints get-info get-socket ;
! 193:
! 194: : open-udp-socket ( addr u port -- fid )
! 195: SOCK_DGRAM >hints get-info get-socket ;
! 196:
1.18 pazsan 197: : create-server ( port# -- lsocket )
1.33 pazsan 198: sockaddr-tmp sockaddr_in %size erase
199: PF_INET sockaddr-tmp family w!
200: htons sockaddr-tmp port w!
201: new-socket
202: dup 0< abort" no free socket" >r
203: r@ sockaddr-tmp 16 bind 0= IF r> exit ENDIF
204: r> drop true abort" bind :: failed" ;
205:
206: : create-udp-server ( port# -- lsocket )
207: sockaddr-tmp sockaddr_in %size erase
208: PF_INET sockaddr-tmp family w!
209: htons sockaddr-tmp port w!
210: new-udp-socket
1.18 pazsan 211: dup 0< abort" no free socket" >r
212: r@ sockaddr-tmp 16 bind 0= IF r> exit ENDIF
213: r> drop true abort" bind :: failed" ;
214:
1.17 pazsan 215: \ from itools.frt
216:
1.18 pazsan 217: ' open-socket Alias open-service
218:
1.17 pazsan 219: : $put ( c-addr1 u1 c-addr2 -- ) swap cmove ;
220:
221: : $+ ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
222: { c-addr1 u1 c-addr2 u2 }
223: u1 u2 + allocate throw
224: c-addr1 u1 2 pick $put
225: c-addr2 u2 2 pick u1 + $put
226: u1 u2 + ;
227:
1.19 pazsan 228: Create hostname$ 0 c, 255 chars allot
1.18 pazsan 229: Create alen 16 ,
230: Create crlf 2 c, 13 c, 10 c,
231:
232: : listen ( lsocket /queue -- )
233: listen() 0< abort" listen :: failed" ;
1.17 pazsan 234:
1.18 pazsan 235: \ This call blocks the server until a client appears. The client uses socket to
236: \ converse with the server.
237: : accept-socket ( lsocket -- socket )
238: 16 alen !
239: sockaddr-tmp alen accept()
240: dup 0< IF errno cr ." accept() :: error #" .
241: abort" accept :: failed"
242: ENDIF s" w+" c-string fdopen ;
1.17 pazsan 243:
244: : +cr ( c-addr1 u1 -- c-addr2 u2 ) crlf count $+ ;
245:
246: : blocking-mode ( socket flag -- ) >r fileno
247: f_setfl r> IF 0
248: ELSE o_nonblock|o_rdwr
249: THEN
250: fcntl 0< abort" blocking-mode failed" ;
251:
1.19 pazsan 252: : hostname ( -- c-addr u )
253: hostname$ c@ 0= IF
254: hostname$ 1+ 255 gethostname drop
255: hostname$ 1+ 255 0 scan nip 255 swap - hostname$ c!
256: THEN
257: hostname$ count ;
1.30 anton 258: : set-socket-timeout ( u -- ) 200 + s>d socket-timeout-d 2! ;
259: : get-socket-timeout ( -- u ) socket-timeout-d 2@ drop 200 - ;
1.17 pazsan 260: : write-socket ( c-addr size socket -- ) fileno -rot 0 send 0< throw ;
261: : close-socket ( socket -- ) fileno closesocket drop ;
262:
263: : (rs) ( socket c-addr maxlen -- c-addr size )
264: 2 pick >r r@ false blocking-mode rot fileno -rot
265: over >r msg_waitall recv
266: dup 0< IF 0 max
267: errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
268: THEN
269: r> swap
270: r> true blocking-mode ;
271:
272: : read-socket ( socket c-addr maxlen -- c-addr u )
1.30 anton 273: utime socket-timeout-d 2@ d+ { socket c-addr maxlen d: tmax -- c-addr size }
1.17 pazsan 274: BEGIN
275: socket c-addr maxlen (rs) dup 0=
1.30 anton 276: utime tmax d< and
1.17 pazsan 277: WHILE
278: 2drop
279: REPEAT ;
1.33 pazsan 280:
281: : (rs-from) ( socket c-addr maxlen -- c-addr size )
282: 2 pick >r r@ false blocking-mode rot fileno -rot
283: over >r msg_waitall sockaddr-tmp alen recvfrom
284: dup 0< IF 0 max
285: errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
286: THEN
287: r> swap
288: r> true blocking-mode ;
289:
290: : read-socket-from ( socket c-addr maxlen -- c-addr u )
291: utime socket-timeout-d 2@ d+ { socket c-addr maxlen d: tmax -- c-addr size }
292: BEGIN
293: socket c-addr maxlen (rs-from) dup 0=
294: utime tmax d< and
295: WHILE
296: 2drop
297: 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