/[lcore]/trunk/lsocket.pas
ViewVC logotype

Contents of /trunk/lsocket.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 10 - (show annotations)
Sun Mar 30 21:39:57 2008 UTC (11 years, 10 months ago) by plugwash
File size: 19110 byte(s)
* make disabling/enabling a timer on windows reset it like on linux
* fix some line ending issues

1 {lsocket.pas}
2
3 {socket code by plugwash}
4
5 { Copyright (C) 2005 Bas Steendijk and Peter Green
6 For conditions of distribution and use, see copyright notice in zlib_license.txt
7 which is included in the package
8 ----------------------------------------------------------------------------- }
9 {
10 changes by plugwash (20030728)
11 * created handlefdtrigger virtual method in tlasio (overridden in tlsocket) and moved a lot of code from messageloop into it
12 * changed tlasio to tlasio
13 * split fdhandle into fdhandlein and fdhandleout
14 * i now use fdsrmaster and fdswmaster instead of rebuilding the lists every loop
15 * split lsocket.pas into lsocket.pas and lcore.pas
16
17
18 changes by beware (20030903)
19 * added getxaddr, getxport (local addr, port, as string)
20 * added getpeername, remote addr+port as binary
21 * added htons and htonl functions (endian swap, same interface as windows API)
22
23 beware (20030905)
24 * if connect failed (conn refused) set state to connected and call internalclose, to get closed handler (instead of fdclose)
25 * (lcore) if closing the fd's in internalcose, set fd's to -1 because closing an fd makes it invalid
26
27 beware (20030927)
28 * fixed: on connect failed, tried to close fdhandle's which were already set to -1, added check
29
30 beware (20031017)
31 * added getpeeraddr, getpeerport, remote addr+port as string
32 }
33
34
35 unit lsocket;
36 {$ifdef fpc}
37 {$mode delphi}
38 {$endif}
39
40 {$include lcoreconfig.inc}
41
42 interface
43 uses
44 sysutils,
45 {$ifdef win32}
46 windows,winsock,
47 {$else}
48
49 {$ifdef VER1_0}
50 linux,
51 {$else}
52 baseunix,unix,unixutil,
53 {$endif}
54 sockets,
55 {$endif}
56 classes,{pgdebugout,}pgtypes,lcore,fd_utils,binipstuff,dnssync;
57 type
58 sunB = packed record
59 s_b1, s_b2, s_b3, s_b4: byte;
60 end;
61
62 SunW = packed record
63 s_w1, s_w2: word;
64 end;
65
66 TInAddr = packed record
67 case integer of
68 0: (S_un_b: SunB);
69 1: (S_un_w: SunW);
70 2: (S_addr: cardinal);
71 end;
72
73 type
74 TLsocket = class(tlasio)
75 public
76 //a: string;
77
78 inAddr : TInetSockAddrV;
79
80 biniplist:tbiniplist;
81 trymoreips:boolean;
82 currentip:integer;
83 connecttimeout:tltimer;
84
85 { inAddrSize:integer;}
86
87 //host : THostentry ;
88
89 //mainthread : boolean ; //for debuggin only
90 addr:string;
91 port:string;
92 localaddr:string;
93 localport:string;
94 proto:string;
95 udp:boolean;
96 listenqueue:integer;
97 procedure connectionfailedhandler(error:word);
98 procedure connecttimeouthandler(sender:tobject);
99 procedure connectsuccesshandler;
100 function getaddrsize:integer;
101 procedure connect; virtual;
102 procedure realconnect;
103 procedure bindsocket;
104 procedure listen;
105 function accept : longint;
106 function sendto(dest:TInetSockAddrV;destlen:integer;data:pointer;len:integer):integer; virtual;
107 function receivefrom(data:pointer;len:integer;var src:TInetSockAddrV;var srclen:integer):integer; virtual;
108 //procedure internalclose(error:word);override;
109 procedure handlefdtrigger(readtrigger,writetrigger:boolean); override;
110 function send(data:pointer;len:integer):integer;override;
111 procedure sendstr(const str : string);override;
112 function Receive(Buf:Pointer;BufSize:integer):integer; override;
113 function getpeername(var addr:tsockaddrin;addrlen:integer):integer; virtual;
114 procedure getXaddrbin(var binip:tbinip); virtual;
115 procedure getpeeraddrbin(var binip:tbinip); virtual;
116 function getXaddr:string; virtual;
117 function getpeeraddr:string; virtual;
118 function getXport:string; virtual;
119 function getpeerport:string; virtual;
120 constructor Create(AOwner: TComponent); override;
121 {$ifdef win32}
122 procedure myfdclose(fd : integer); override;
123 function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; override;
124 function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; override;
125 {$endif}
126 end;
127 tsocket=longint; // for compatibility with twsocket
128
129 twsocket=tlsocket; {easy}
130
131
132 {!!!function longipdns(s:string):longint;}
133
134 {$ifdef ipv6}
135 const
136 v4listendefault:boolean=false;
137 {$endif}
138
139
140 const
141 TCP_NODELAY=1;
142 IPPROTO_TCP=6;
143
144 implementation
145 {$include unixstuff.inc}
146
147
148 function tlsocket.getaddrsize:integer;
149 begin
150 result := inaddrsize(inaddr);
151 end;
152
153
154 procedure tlsocket.realconnect;
155 var
156 a:integer;
157
158 begin
159 // writeln('trying to connect to ',ipbintostr(biniplist_get(biniplist,currentip)),'#',port);
160 makeinaddrv(biniplist_get(biniplist,currentip),port,inaddr);
161 inc(currentip);
162 if (currentip >= biniplist_getcount(biniplist)) then trymoreips := false;
163 udp := uppercase(proto) = 'UDP';
164 if udp then a := SOCK_DGRAM else a := SOCK_STREAM;
165 a := Socket(inaddr.inaddr.family,a,0);
166 //writeln(ord(inaddr.inaddr.family));
167 if a = -1 then begin
168 lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};
169 raise esocketexception.create('unable to create socket');
170 end;
171 try
172 dup(a);
173 bindsocket;
174 if udp then begin
175 {$ifndef win32}
176 SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));
177 {$endif}
178 state := wsconnected;
179 if assigned(onsessionconnected) then onsessionconnected(self,0);
180
181 eventcore.rmasterset(fdhandlein,false);
182 eventcore.wmasterclr(fdhandleout);
183 end else begin
184 state :=wsconnecting;
185 {$ifdef win32}
186 //writeln(inaddr.inaddr.port);
187 winsock.Connect(fdhandlein,winsock.psockaddr(@inADDR)^,getaddrsize);
188 {$else}
189 sockets.Connect(fdhandlein,inADDR,getaddrsize);
190 {$endif}
191 eventcore.rmasterset(fdhandlein,false);
192 eventcore.wmasterset(fdhandleout);
193 if trymoreips then connecttimeout.enabled := true;
194 end;
195 //sendq := '';
196 except
197 on e: exception do begin
198 fdcleanup;
199 raise; //reraise the exception
200 end;
201 end;
202
203 end;
204
205 procedure tlsocket.connecttimeouthandler(sender:tobject);
206 begin
207 connecttimeout.enabled := false;
208 destroying := true; //hack to not cause handler to trigger
209 internalclose(0);
210 destroying := false;
211 realconnect;
212 end;
213
214 procedure tlsocket.connect;
215 var
216 a:integer;
217 ip:tbinip;
218 begin
219 if state <> wsclosed then close;
220 //prevtime := 0;
221 if isbiniplist(addr) then biniplist := addr else biniplist := forwardlookuplist(addr,0);
222 if biniplist_getcount(biniplist) = 0 then raise exception.create('unable to resolve '+addr);
223
224 //makeinaddrv(addr,port,inaddr);
225
226 currentip := 0;
227 if not assigned(connecttimeout) then begin
228 connecttimeout := tltimer.create(self);
229 connecttimeout.Tag := integer(self);
230 connecttimeout.ontimer := connecttimeouthandler;
231 connecttimeout.interval := 2500;
232 connecttimeout.enabled := false;
233 end;
234 realconnect;
235 end;
236
237 procedure tlsocket.sendstr(const str : string);
238 begin
239 if udp then begin
240 send(@str[1],length(str))
241 end else begin
242 inherited sendstr(str);
243 end;
244 end;
245
246 function tlsocket.send(data:pointer;len:integer):integer;
247 begin
248 if udp then begin
249 // writeln('sending to '+ipbintostr(inaddrvtobinip(inaddr)),' ',htons(inaddr.inaddr.port),' ',len,' bytes');
250 result := sendto(inaddr,getaddrsize,data,len);
251
252 // writeln('send result ',result);
253 // writeln('errno',errno);
254 end else begin
255 result := inherited send(data,len);
256 end;
257 end;
258
259
260 function tlsocket.receive(Buf:Pointer;BufSize:integer):integer;
261 begin
262 if udp then begin
263 result := myfdread(self.fdhandlein,buf^,bufsize);
264 end else begin
265 result := inherited receive(buf,bufsize);
266 end;
267 end;
268
269 procedure tlsocket.bindsocket;
270 var
271 a:integer;
272 inAddrtemp:TInetSockAddrV;
273 inAddrtempx:{$ifdef win32}winsock.TSockaddr{$else}TInetSockAddrV{$endif} absolute inaddrtemp;
274 inaddrtempsize:integer;
275 begin
276 try
277 if (localaddr <> '') or (localport <> '') then begin
278 if localaddr = '' then begin
279 {$ifdef ipv6}
280 if inaddr.inaddr.family = AF_INET6 then localaddr := '::' else
281 {$endif}
282 localaddr := '0.0.0.0';
283 end;
284 //gethostbyname(localaddr,host);
285
286 inaddrtempsize := makeinaddrv(forwardlookup(localaddr,0),localport,inaddrtemp);
287
288 If Bind(fdhandlein,inaddrtempx,inaddrtempsize)<> {$ifdef win32}0{$else}true{$endif} Then begin
289 state := wsclosed;
290 lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};
291 raise ESocketException.create('unable to bind, error '+inttostr(lasterror));
292 end;
293 state := wsbound;
294 end;
295 except
296 on e: exception do begin
297 fdcleanup;
298 raise; //reraise the exception
299 end;
300 end;
301 end;
302
303 procedure tlsocket.listen;
304 var
305 yes:longint;
306 socktype:integer;
307 biniptemp:tbinip;
308 origaddr:string;
309 begin
310 if state <> wsclosed then close;
311 udp := uppercase(proto) = 'UDP';
312 if udp then socktype := SOCK_DGRAM else socktype := SOCK_STREAM;
313 origaddr := addr;
314
315 if addr = '' then begin
316 {$ifdef ipv6}
317 if not v4listendefault then begin
318 addr := '::';
319 end else
320 {$endif}
321 addr := '0.0.0.0';
322 end;
323 if isbiniplist(addr) then biniptemp := biniplist_get(addr,0) else biniptemp := forwardlookup(addr,10);
324 addr := ipbintostr(biniptemp);
325 fdhandlein := socket(biniptemp.family,socktype,0);
326 {$ifdef ipv6}
327 if (addr = '::') and (origaddr = '') and (fdhandlein < 0) then begin
328 addr := '0.0.0.0';
329 fdhandlein := socket(AF_INET,socktype,0);
330 end;
331 {$endif}
332 if fdhandlein = -1 then raise ESocketException.create('unable to create socket');
333 dupnowatch(fdhandlein); // sets up maxs and copies handle to fdhandleout among other things
334 //eventcore.setfdreverse(fdhandlein,self); //already taken care of by dup
335 state := wsclosed; // then set this back as it was an undesired side effect of dup
336
337 try
338 yes := $01010101; {Copied this from existing code. Value is empiric,
339 but works. (yes=true<>0) }
340 {$ifndef win32}
341 if SetSocketOptions(fdhandlein, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes))=-1 then begin
342 raise ESocketException.create('unable to set socket options');
343 end;
344 {$endif}
345 localaddr := addr;
346 localport := port;
347 bindsocket;
348
349 if not udp then begin
350 {!!! allow custom queue length? default 5}
351 if listenqueue = 0 then listenqueue := 5;
352 If {$ifdef win32}winsock{$else}sockets{$endif}.Listen(fdhandlein,listenqueue)<>{$ifdef win32}0{$else}true{$endif} Then raise esocketexception.create('unable to listen');
353 state := wsListening;
354 end else begin
355 {$ifndef win32}
356 SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));
357 {$endif}
358 state := wsconnected;
359 end;
360 finally
361 if state = wsclosed then begin
362 if fdhandlein >= 0 then begin
363 {one *can* get here without fd -beware}
364 eventcore.rmasterclr(fdhandlein);
365 myfdclose(fdhandlein); // we musnt leak file discriptors
366 eventcore.setfdreverse(fdhandlein,nil);
367 fdhandlein := -1;
368 end;
369 end else begin
370 eventcore.rmasterset(fdhandlein,not udp);
371 end;
372 if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);
373 end;
374 //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein);
375 end;
376
377 function tlsocket.accept : longint;
378 var
379 FromAddrSize : LongInt; // i don't realy know what to do with these at this
380 FromAddr : TInetSockAddrV; // at this point time will tell :)
381 a:integer;
382 begin
383
384 FromAddrSize := Sizeof(FromAddr);
385 {$ifdef win32}
386 result := winsock.accept(fdhandlein,@fromaddr,@fromaddrsize);
387 {$else}
388 result := sockets.accept(fdhandlein,fromaddr,fromaddrsize);
389 {$endif}
390 //now we have accepted one request start monitoring for more again
391 eventcore.rmasterset(fdhandlein,true);
392
393 if result = -1 then begin
394 raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting');
395 end;
396 if result > absoloutemaxs then begin
397 myfdclose(result);
398 a := result;
399 result := -1;
400 raise esocketexception.create('file discriptor out of range: '+inttostr(a));
401 end;
402 end;
403
404 function tlsocket.sendto(dest:TInetSockAddrV;destlen:integer;data:pointer;len:integer):integer;
405 var
406 destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute dest;
407 begin
408 result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen);
409 end;
410
411 function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddrV;var srclen:integer):integer;
412 var
413 srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute src;
414 begin
415 result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen);
416 end;
417
418 procedure tlsocket.connectionfailedhandler(error:word);
419 begin
420 if trymoreips then begin
421 // writeln('failed with error ',error);
422 connecttimeout.enabled := false;
423 destroying := true;
424 state := wsconnected;
425 self.internalclose(0);
426 destroying := false;
427 realconnect;
428 end else begin
429 state := wsconnected;
430 if assigned(onsessionconnected) then onsessionconnected(self,error);
431 self.internalclose(0);
432 recvq.del(maxlongint);
433 end;
434 end;
435
436 procedure tlsocket.connectsuccesshandler;
437 begin
438 trymoreips := false;
439 connecttimeout.enabled := false;
440 if assigned(onsessionconnected) then onsessionconnected(self,0);
441 end;
442
443
444 procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean);
445 var
446 tempbuf:array[0..receivebufsize-1] of byte;
447 begin
448 // writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger,' state=',integer(state));
449 if (state =wslistening) and readtrigger then begin
450 { debugout('listening socket triggered on read');}
451 eventcore.rmasterclr(fdhandlein);
452 if assigned(onsessionAvailable) then onsessionAvailable(self,0);
453 end;
454 if udp and readtrigger then begin
455 if assigned(ondataAvailable) then ondataAvailable(self,0);
456 {!!!test}
457 exit;
458 end;
459 if (state =wsconnecting) and writetrigger then begin
460 // code for dealing with the reults of a non-blocking connect is
461 // rather complex
462 // if just write is triggered it means connect suceeded
463 // if both read and write are triggered it can mean 2 things
464 // 1: connect ok and data availible
465 // 2: connect fail
466 // to find out which you must read from the socket and look for errors
467 // there if we read successfully we drop through into the code for fireing
468 // the read event
469 if not readtrigger then begin
470 state := wsconnected;
471 connectsuccesshandler;
472 end else begin
473 numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));
474 if numread <> -1 then begin
475 state := wsconnected;
476 connectsuccesshandler;
477 //connectread := true;
478 recvq.add(@tempbuf,numread);
479 end else begin
480 connectionfailedhandler({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});
481 exit;
482 end;
483 // if things went well here we are now in the state wsconnected with data sitting in our receive buffer
484 // so we drop down into the processing for data availible
485 end;
486 if fdhandlein >= 0 then begin
487 if state = wsconnected then begin
488 eventcore.rmasterset(fdhandlein,false);
489 end else begin
490 eventcore.rmasterclr(fdhandlein);
491 end;
492 end;
493 if fdhandleout >= 0 then begin
494 if sendq.size = 0 then begin
495 //don't clear the bit in fdswmaster if data is in the sendq
496 eventcore.wmasterclr(fdhandleout);
497 end;
498 end;
499
500 end;
501 inherited handlefdtrigger(readtrigger,writetrigger);
502 end;
503
504 constructor tlsocket.Create(AOwner: TComponent);
505 begin
506 inherited create(aowner);
507 closehandles := true;
508 trymoreips := true;
509 end;
510
511
512 function tlsocket.getpeername(var addr:tsockaddrin;addrlen:integer):integer;
513 var
514 addrx : {$ifdef win32}winsock.tsockaddr{$else}tsockaddrin{$endif} absolute addr;
515 begin
516 result := {$ifdef win32}winsock{$else}sockets{$endif}.getpeername(self.fdhandlein,addrx,addrlen);
517 end;
518
519 procedure tlsocket.getxaddrbin(var binip:tbinip);
520 var
521 addr:tinetsockaddrv;
522 i:integer;
523 begin
524 i := sizeof(addr);
525 fillchar(addr,sizeof(addr),0);
526
527 {$ifdef win32}
528 winsock.getsockname(self.fdhandlein,psockaddr(@addr)^,i);
529 {$else}
530 sockets.getsocketname(self.fdhandlein,addr,i);
531 {$endif}
532 binip.family := addr.inaddr.family;
533 {$ifdef ipv6}
534 if addr.inaddr6.sin6_family = AF_INET6 then begin
535 binip.ip6 := addr.inaddr6.sin6_addr;
536 end else
537 {$endif}
538 begin
539 binip.ip := addr.inaddr.addr;
540 end;
541 converttov4(binip);
542 end;
543
544 procedure tlsocket.getpeeraddrbin(var binip:tbinip);
545 var
546 addr:tinetsockaddrv;
547 i:integer;
548 begin
549 i := sizeof(addr);
550 fillchar(addr,sizeof(addr),0);
551 {$ifdef win32}
552 winsock.getpeername(self.fdhandlein,psockaddr(@addr)^,i);
553 {$else}
554 sockets.getpeername(self.fdhandlein,addr,i);
555 {$endif}
556
557 binip.family := addr.inaddr.family;
558 {$ifdef ipv6}
559 if addr.inaddr6.sin6_family = AF_INET6 then begin
560 binip.ip6 := addr.inaddr6.sin6_addr;
561 end else
562 {$endif}
563 begin
564 binip.ip := addr.inaddr.addr;
565 end;
566 converttov4(binip);
567 end;
568
569 function tlsocket.getXaddr:string;
570 var
571 biniptemp:tbinip;
572 begin
573 getxaddrbin(biniptemp);
574 result := ipbintostr(biniptemp);
575 if result = '' then result := 'error';
576 end;
577
578 function tlsocket.getpeeraddr:string;
579 var
580 biniptemp:tbinip;
581 begin
582 getpeeraddrbin(biniptemp);
583 result := ipbintostr(biniptemp);
584 if result = '' then result := 'error';
585 end;
586
587 function tlsocket.getXport:string;
588 var
589 addr:tinetsockaddrv;
590 i:integer;
591 begin
592 i := sizeof(addr);
593 {$ifdef win32}
594 winsock.getsockname(self.fdhandlein,psockaddrin(@addr)^,i);
595
596 {$else}
597 sockets.getsocketname(self.fdhandlein,addr,i);
598
599 {$endif}
600 result := inttostr(htons(addr.InAddr.port));
601 end;
602
603 function tlsocket.getpeerport:string;
604 var
605 addr:tinetsockaddrv;
606 i:integer;
607 begin
608 i := sizeof(addr);
609 {$ifdef win32}
610 winsock.getpeername(self.fdhandlein,psockaddrin(@addr)^,i);
611
612 {$else}
613 sockets.getpeername(self.fdhandlein,addr,i);
614
615 {$endif}
616 result := inttostr(htons(addr.InAddr.port));
617 end;
618
619 {$ifdef win32}
620 procedure tlsocket.myfdclose(fd : integer);
621 begin
622 closesocket(fd);
623 end;
624 function tlsocket.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;
625 begin
626 result := winsock.send(fd,(@buf)^,size,0);
627 end;
628 function tlsocket.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;
629 begin
630 result := winsock.recv(fd,buf,size,0);
631 end;
632 {$endif}
633
634 end.
635

Properties

Name Value
svn:executable

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.22