Annotation of gforth/unix/socket.fs, revision 1.18
1.1 pazsan 1: \ socket interface
2:
1.14 anton 3: \ Copyright (C) 1998,2000,2003,2005,2006,2007 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.16 anton 20: \c #include <netdb.h>
21: c-function gethostbyname gethostbyname a -- a ( name -- hostent )
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>
25: c-function 'errno __errno_location -- a ( -- addr )
1.16 anton 26: \c #include <sys/types.h>
27: \c #include <sys/socket.h>
28: c-function socket socket n n n -- n ( class type proto -- fd )
1.17 pazsan 29: c-function closesocket close n -- n ( fd -- ior )
1.16 anton 30: c-function connect connect n a n -- n ( fd sock size -- err )
1.17 pazsan 31: c-function send send n a n n -- n ( socket buffer count flags -- size )
32: c-function recv recv n a n n -- n ( socket buffer count flags -- size )
1.18 ! pazsan 33: c-function listen() n n -- n ( socket backlog -- err )
! 34: c-function bind n a a -- n ( socket sockaddr socklen --- err )
! 35: c-function accept() accept n a a -- n ( socket sockaddr addrlen -- fd )
1.16 anton 36: \c #include <stdio.h>
37: c-function fdopen fdopen n a -- a ( fd fileattr -- file )
1.17 pazsan 38: \c #include <fcntl.h>
39: c-function fcntl fcntl n n n -- n ( fd n1 n2 -- ior )
1.16 anton 40: \c #include <arpa/inet.h>
41: c-function htonl htonl n -- n ( x -- x' )
42: c-function htons htons n -- n ( x -- x' )
43: c-function ntohl ntohl n -- n ( x -- x' )
1.17 pazsan 44: c-function fileno fileno a -- n ( file* -- fd )
1.4 pazsan 45:
46: 4 4 2Constant int%
1.8 pazsan 47: 2 2 2Constant short%
1.1 pazsan 48:
49: struct
50: cell% field h_name
51: cell% field h_aliases
1.4 pazsan 52: int% field h_addrtype
53: int% field h_length
1.1 pazsan 54: cell% field h_addr_list
55: end-struct hostent
56:
57: struct
1.8 pazsan 58: short% field family
59: short% field port
1.4 pazsan 60: int% field sin_addr
1.1 pazsan 61: cell% 2* field padding
62: end-struct sockaddr_in
63:
1.12 anton 64: ' family alias family+port \ 0.6.2 32-bit field; used by itools
65:
1.1 pazsan 66: Create sockaddr-tmp
67: sockaddr-tmp sockaddr_in %size dup allot erase
68:
69: : c-string ( addr u -- addr' )
70: tuck pad swap move pad + 0 swap c! pad ;
71:
72: : host>addr ( addr u -- x )
73: \G converts a internet name into a IPv4 address
74: \G the resulting address is in network byte order
75: c-string gethostbyname dup 0= abort" address not found"
1.10 pazsan 76: h_addr_list @ @ @ ntohl ;
1.1 pazsan 77:
1.17 pazsan 78: 2 Constant PF_INET
79: 1 Constant SOCK_STREAM
80: 6 Constant IPPROTO_TCP
81: 4 Constant F_SETFL
82: 11 Constant EWOULDBLOCK
83: $100 Constant MSG_WAITALL
84: $802 Constant O_NONBLOCK|O_RDWR
85: 2000 Value SOCKET-TIMEOUT
1.1 pazsan 86:
1.8 pazsan 87: : new-socket ( -- socket )
88: PF_INET SOCK_STREAM IPPROTO_TCP socket
89: dup 0<= abort" no free socket" ;
90:
91: : >inetaddr ( ip port sockaddr -- ) >r
92: r@ sockaddr_in %size erase
93: PF_INET r@ family w!
94: htons r@ port w!
95: htonl r> sin_addr l! ;
96:
1.1 pazsan 97: : open-socket ( addr u port -- fid )
1.10 pazsan 98: -rot host>addr
99: swap sockaddr-tmp >inetaddr
1.8 pazsan 100: new-socket >r
101: r@ sockaddr-tmp sockaddr_in %size connect 0< abort" can't connect"
1.1 pazsan 102: r> s" w+" c-string fdopen ;
1.17 pazsan 103:
1.18 ! pazsan 104: : create-server ( port# -- lsocket )
! 105: sockaddr-tmp 4 CELLS ERASE
! 106: htonl PF_INET OR sockaddr-tmp !
! 107: PF_INET SOCK_STREAM 0 socket
! 108: dup 0< abort" no free socket" >r
! 109: r@ sockaddr-tmp 16 bind 0= IF r> exit ENDIF
! 110: r> drop true abort" bind :: failed" ;
! 111:
1.17 pazsan 112: \ from itools.frt
113:
1.18 ! pazsan 114: ' open-socket Alias open-service
! 115:
1.17 pazsan 116: : ms@ utime 1000 um/mod nip ; ( -- u )
117:
118: : $put ( c-addr1 u1 c-addr2 -- ) swap cmove ;
119:
120: : $+ ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
121: { c-addr1 u1 c-addr2 u2 }
122: u1 u2 + allocate throw
123: c-addr1 u1 2 pick $put
124: c-addr2 u2 2 pick u1 + $put
125: u1 u2 + ;
126:
127: Create hostname$ 256 chars allot
1.18 ! pazsan 128: Create alen 16 ,
! 129: Create crlf 2 c, 13 c, 10 c,
! 130:
! 131: : errno ( -- #error ) 'errno @ ;
! 132:
! 133: : listen ( lsocket /queue -- )
! 134: listen() 0< abort" listen :: failed" ;
1.17 pazsan 135:
1.18 ! pazsan 136: \ This call blocks the server until a client appears. The client uses socket to
! 137: \ converse with the server.
! 138: : accept-socket ( lsocket -- socket )
! 139: 16 alen !
! 140: sockaddr-tmp alen accept()
! 141: dup 0< IF errno cr ." accept() :: error #" .
! 142: abort" accept :: failed"
! 143: ENDIF s" w+" c-string fdopen ;
1.17 pazsan 144:
145: : +cr ( c-addr1 u1 -- c-addr2 u2 ) crlf count $+ ;
146:
147: : blocking-mode ( socket flag -- ) >r fileno
148: f_setfl r> IF 0
149: ELSE o_nonblock|o_rdwr
150: THEN
151: fcntl 0< abort" blocking-mode failed" ;
152:
153: : hostname ( -- c-addr u ) hostname$ count ;
154: : set-socket-timeout ( u -- ) 200 + to socket-timeout ;
155: : get-socket-timeout ( -- u ) socket-timeout 200 - ;
156: : write-socket ( c-addr size socket -- ) fileno -rot 0 send 0< throw ;
157: : close-socket ( socket -- ) fileno closesocket drop ;
158:
159: : (rs) ( socket c-addr maxlen -- c-addr size )
160: 2 pick >r r@ false blocking-mode rot fileno -rot
161: over >r msg_waitall recv
162: dup 0< IF 0 max
163: errno dup 0<> swap ewouldblock <> and abort" (rs) :: socket read error"
164: THEN
165: r> swap
166: r> true blocking-mode ;
167:
168: : read-socket ( socket c-addr maxlen -- c-addr u )
169: ms@ socket-timeout + { socket c-addr maxlen tmax -- c-addr size }
170: BEGIN
171: socket c-addr maxlen (rs) dup 0=
172: ms@ tmax u< and
173: WHILE
174: 2drop
175: REPEAT ;
176:
177: hostname$ 1+ 255 gethostname drop
178: hostname$ 1+ 255 0 scan nip 255 swap - hostname$ c!
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