/pliant/language/os/socket.pli
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	module "/pliant/install/ring2.pli"
17	module "/pliant/language/stream/openmode.pli"
18
19
20	constant uselibc os_api<>"linux"
21	if os_api="linux" or os_api="posix"
22	constant os_socket_filename os_libc_filename
23	eif os_api="win32"
24	constant os_socket_filename "wsock32.dll"
25	eif os_api="os2"
26	constant os_socket_filename "so32dll.dll"
27	constant uselibcfornames os_socket_filename<>""
28	constant os_usesendrecv os_api="win32" or os_api="os2"
29
30	if os_api="os2"
31	function dll s1 -> s2
32	arg Str s1 s2
33	has_no_side_effect
34	s2 := upper s1
35	constant os_socket_filename2 "tcp32dll.dll"
36	else
37	function dll s1 -> s2
38	arg Str s1 s2
39	has_no_side_effect
40	s2 := s1
41	constant os_socket_filename2 os_socket_filename
42
43	export os_usesendrecv
44
45
46
47
48
49	function ip_dot_notation ip -> s
50	arg uInt ip ; arg Str s
51	s := ""
52	for (var Int u) 0 3
53	if u>0
54	s := s+"."
55	s := s+(string (ip\2^(8*(3-u))).and.255)
56
57
58	function ip_match ip filter -> m
59	arg Str ip filter ; arg CBool m
60	if filter=""
61	m := true
62	eif (filter parse any:(var Str filter1) "+" any:(var Str filter2))
63	m := (ip_match ip filter1) or (ip_match ip filter2)
64	eif (ip eparse (var Int i1) "." (var Int i2) "." (var Int i3) "." (var Int i4)) and (filter eparse (var Int f1) "." (var Int f2) "." (var Int f3) "." (var Int f4))
65	m := i1=f1 and i2=f2 and i3=f3 and i4=f4
66	eif (ip eparse i1 "." i2 "." i3 "." i4) and (filter eparse f1 "." f2 "." f3 "." f4 "/"  (var Int m1) "." (var Int m2) "." (var Int m3) "." (var Int m4))
67	m := (i1 .and. m1)=(f1 .and. m1) and (i2 .and. m2)=(f2 .and. m2) and (i3 .and. m3)=(f3 .and. m3) and (i4 .and. m4)=(f4 .and. m4)
68	else
69	m := false
70
71	export ip_dot_notation ip_match
72
73
74
75
76
77	if not uselibc
78	function socketcall op args -> err
79	arg Int op err ; arg Address args
80	kernel_function 102
81
82
83	function os_socket domain type protocol -> s
84	arg Int domain type protocol s
85	if uselibc
86	external os_socket_filename dll:"socket"
87	else
88	external_calling_convention
89	s := socketcall 1 addressof:domain
90
91	public
92	if os_api="linux"
93	constant os_AF_INET 2
94	constant os_AF_INET6 10
95	constant os_SOCK_STREAM 1
96	constant os_SOCK_DGRAM 2
97	constant os_SOCK_RAW 3
98	eif os_api="posix"
99	os_constant os_AF_INET "sys/socket.h" AF_INET
100	os_constant os_AF_INET6 "sys/socket.h" AF_INET6
101	os_constant os_SOCK_STREAM "sys/socket.h" SOCK_STREAM
102	os_constant os_SOCK_DGRAM "sys/socket.h" SOCK_DGRAM
103	os_constant os_SOCK_RAW "sys/socket.h" SOCK_RAW
104	eif os_api="win32"
105	constant os_AF_INET 2
106	constant os_AF_INET6 23
107	constant os_SOCK_STREAM 1
108	constant os_SOCK_DGRAM 2
109	constant os_SOCK_RAW 3
110	eif os_api="os2"
111	constant os_AF_INET 2
112	constant os_SOCK_STREAM 1
113	constant os_SOCK_DGRAM 2
114	constant os_SOCK_RAW 3
115
116	type os_sockaddr
117	void
118
119	if os_api="linux" or os_api="win32" or os_api="os2"
120	type os_sockaddr_in
121	packed
122	field uInt16 sin_family
123	field uInt16_hi sin_port
124	field uInt32_hi sin_addr
125	field Int pad1 pad2
126	eif os_api="posix"
127	os_type os_sockaddr_in "netinet/in.h" sockaddr_in
128	field uInt sin_family
129	field uInt_hi sin_port
130	field uInt_hi sin_addr
131
132	os_sockaddr maybe os_sockaddr_in
133
134
135	function os_bind s addr addrlen -> err
136	arg Int s addrlen err ; arg os_sockaddr addr
137	if uselibc
138	external os_socket_filename dll:"bind"
139	else
140	external_calling_convention
141	err := socketcall 2 addressof:s
142
143
144	function os_connect s addr addrlen -> err
145	arg Int s addrlen err ; arg os_sockaddr addr
146	if uselibc
147	external os_socket_filename dll:"connect"
148	else
149	external_calling_convention
150	err := socketcall 3 addressof:s
151
152
153	function os_listen s backlog -> err
154	arg Int s backlog err
155	if uselibc
156	external os_socket_filename dll:"listen"
157	else
158	external_calling_convention
159	err := socketcall 4 addressof:s
160
161
162	function os_accept s addr addrlen -> err
163	arg Int s err ; arg_w os_sockaddr addr ; arg_rw Int addrlen
164	if uselibc
165	external os_socket_filename dll:"accept"
166	else
167	external_calling_convention
168	err := socketcall 5 addressof:s
169
170
171	function os_shutdown s how -> err
172	arg Int s how err
173	if uselibc
174	external os_socket_filename dll:"shutdown"
175	else
176	external_calling_convention
177	err := socketcall 13 addressof:s
178
179
180	function os_setsockopt s level optname optval optlen -> err
181	arg Int s level optname optlen err ; arg Address optval
182	if uselibc
183	external os_socket_filename dll:"setsockopt"
184	else
185	external_calling_convention
186	err := socketcall 14 addressof:s
187
188	function os_getsockopt s level optname optval optlen -> err
189	arg Int s level optname err ; arg Address optval ; arg_rw Int optlen
190	if uselibc
191	external os_socket_filename dll:"getsockopt"
192	else
193	external_calling_convention
194	err := socketcall 15 addressof:s
195
196
197	function os_getsockname s addr addrlen -> err
198	arg Int s err ; arg_w os_sockaddr addr ; arg_rw Int addrlen
199	if uselibc
200	external os_socket_filename dll:"getsockname"
201	else
202	external_calling_convention
203	err := socketcall 6 addressof:s
204
205
206	function os_getpeername s addr addrlen -> err
207	arg Int s err ; arg_w os_sockaddr addr ; arg_rw Int addrlen
208	if uselibc
209	external os_socket_filename dll:"getpeername"
210	else
211	external_calling_convention
212	err := socketcall 7 addressof:s
213
214
215	if os_usesendrecv
216
217	function os_send s buf len flags -> err
218	arg Int s len flags err ; arg Address buf
219	if uselibc
220	external os_socket_filename dll:"send"
221	else
222	external_calling_convention
223	err := socketcall 9 addressof:s
224
225	function os_recv s buf len flags -> err
226	arg Int s len flags err ; arg Address buf
227	if uselibc
228	external os_socket_filename dll:"recv"
229	else
230	external_calling_convention
231	err := socketcall 10 addressof:s
232
233	export os_send os_recv
234
235
236	function os_sendto s msg len flags to tolen -> err
237	arg Int s len flags tolen err ; arg Address msg ; arg os_sockaddr to
238	if uselibc
239	external os_socket_filename dll:"sendto"
240	else
241	external_calling_convention
242	err := socketcall 11 addressof:s
243
244	function os_recvfrom s buf len flags from fromlen -> err
245	arg Int s len flags err ; arg Address buf ; arg_rw os_sockaddr from ; arg_rw Int fromlen
246	if uselibc
247	external os_socket_filename dll:"recvfrom"
248	else
249	external_calling_convention
250	err := socketcall 12 addressof:s
251
252	export os_socket os_bind os_connect os_listen os_accept os_shutdown
253	export os_setsockopt os_getsockopt os_getsockname os_getpeername
254	export os_sendto os_recvfrom
255
256
257	if os_api="win32"
258
259	type os_timeval
260	packed
261	field Int tv_sec tv_usec
262
263	function os_win32_select n readfds writefds exceptfds timeout -> fd
264	arg Int n ; arg Address readfds writefds exceptfds ; arg_rw os_timeval timeout ; arg Int fd
265	external os_socket_filename dll:"select"
266
267	export os_win32_select
268
269
270	function os_socket_wait s mode timeout -> status
271	arg Int s ; arg Int mode ; arg Float timeout ; arg Status status
272	if (constant os_api="linux" and (os_version parse (var Int r1) "." (var Int r2) "." any) and (r1>2 or r1=2 and r2>=2)) or os_api="posix"
273	var os_pollfd fd
274	fd fd := s
275	fd events := (shunt (mode .and. in)<>0 os_POLLIN 0)+(shunt (mode .and. out)<>0 os_POLLOUT 0)+os_POLLERR+os_POLLHUP
276	var Int count := os_poll addressof:fd 1 (cast timeout*1000 Int)
277	status := shunt count>=1 success failure
278	eif os_api="win32"
279	var Int none := 0
280	var (Array Int 2) fds ; fds 0 := 1 ; fds 1 := s
281	var os_timeval time
282	time tv_sec := cast timeout-0.5 Int
283	time tv_usec := cast (timeout-time:tv_sec)*1e6 Int
284	var Int count := os_win32_select 0 (shunt (mode .and. in)<>0 addressof:fds addressof:none) (shunt(mode .and. out)<>0 addressof:fds addressof:none) addressof:fds time
285	status := shunt count>=1 success failure
286	else
287	if s<0 or s>=1024
288	return success
289	var Address fds := memory_zallocate 1024\8 null
290	(fds translate Byte s\8) map uInt8 := 2^(s%8)
291	var Address none := memory_zallocate 1024\8 null
292	var os_timeval time
293	time tv_sec := cast timeout-0.5 Int
294	time tv_usec := cast (timeout-time:tv_sec)*1e6 Int
295	var Int count := os_select s+1 (shunt (mode .and. in)<>0 fds none) (shunt(mode .and. out)<>0 fds none) fds time
296	memory_free fds
297	memory_free none
298	status := shunt count>=1 success failure
299
300	export os_socket_wait
301
302
303	public
304
305	if os_api="linux"
306	constant os_SOL_SOCKET 1
307	constant os_SO_REUSEADDR 2
308	constant os_SO_KEEPALIVE 9
309	eif os_api="posix"
310	os_constant os_SOL_SOCKET "sys/socket.h" SOL_SOCKET
311	os_constant os_SO_REUSEADDR "sys/socket.h" SO_REUSEADDR
312	os_constant os_SO_KEEPALIVE "sys/socket.h" SO_KEEPALIVE
313	eif os_api="win32" or os_api="os2"
314	constant os_SOL_SOCKET 0FFFFh
315	constant os_SO_REUSEADDR 4
316	constant os_SO_KEEPALIVE 8
317
318	if os_api="linux"
319	constant os_IPPROTO_IP 0
320	constant os_IP_TOS 1
321	constant os_IPTOS_LOWCOST 2
322	constant os_IPTOS_RELIABILITY 4
323	constant os_IPTOS_THROUGHPUT 8
324	constant os_IPTOS_LOWDELAY 16
325
326	if os_api="linux" or os_api="os2"
327	type os_hostent
328	packed
329	field Address h_name
330	field Address h_aliases
331	field Int h_addrtype
332	field Int h_length
333	field Address h_addr_list
334	eif os_api="posix"
335	os_type os_hostent "netdb.h" hostent
336	field Address h_name
337	field Address h_aliases
338	field Int h_addrtype
339	field Int h_length
340	field Address h_addr_list
341	eif os_api="win32"
342	type os_hostent
343	packed
344	field Address h_name
345	field Address h_aliases
346	field Int16 h_addrtype
347	field Int16 h_length
348	field Address h_addr_list
349
350
351	if uselibcfornames
352
353	function os_gethostbyname name -> h
354	arg CStr name ; arg_R os_hostent h
355	external os_socket_filename2 dll:"gethostbyname"
356
357	function os_gethostbyaddr addr addrlen type -> h
358	arg Address addr ; arg Int addrlen type ; arg_R os_hostent h
359	external os_socket_filename2 dll:"gethostbyaddr"
360
361	export os_gethostbyname os_gethostbyaddr
362
363
364	if os_api="win32"
365
366	type os_WSADATA
367	field Int wVersion
368	field Int wHighVersion
369	field (Array Char 257) szDescription
370	field (Array Char 129) szSystemStatus
371	field uInt16 iMaxSockets
372	field uInt16 iMaxUdpDg
373	field Address lpVendorInfo
374
375	function os_WSAStartup version data -> err
376	arg Int version ; arg_w os_WSADATA data ; arg Int err
377	external os_socket_filename "WSAStartup"
378
379	function socket_init parameter filehandle
380	arg Address parameter ; arg Int filehandle
381	os_WSAStartup 0002h (var os_WSADATA data)
382	socket_init null 0
383	gvar DelayedAction da
384	da function :> the_function socket_init Address Int
385	pliant_restore_actions append addressof:da
386
387	function os_close s -> err
388	arg Int s err
389	external os_socket_filename "closesocket"
390
391	export os_close
392
393	eif os_api="os2"
394
395	function os_close s -> err
396	arg Int s err
397	external os_socket_filename dll:"soclose"
398
399	export os_close
400
401
402
403
404
405	function dns_query_prototype name fun -> ip
406	arg Str name ip ; arg Function fun
407	indirect
408
409	function dns_query_os name -> ip
410	arg Str name ip
411	ip := ""
412	if uselibcfornames
413	var Pointer:os_hostent host :> os_gethostbyname name
414	if addressof:host=null
415	return
416	var Address h_addr := host:h_addr_list map Address
417	for (var Int i) 0 3
418	ip += (shunt i=0 "" ".")+string:(cast ((h_addr translate uInt8 i) map uInt8) Int)
419
420	gvar Link:Function dns_query_function :> the_function dns_query_os Str -> Str
421
422	export dns_query_prototype dns_query_function dns_query_os
423
424