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

Annotation of /trunk/lsocket.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (hide annotations)
Sun Mar 30 00:16:07 2008 UTC (12 years ago) by beware
File size: 18996 byte(s)
the big lot of changes by beware

1 plugwash 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 beware 2
40     {$include lcoreconfig.inc}
41    
42 plugwash 1 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 beware 2
80     biniplist:tbiniplist;
81     trymoreips:boolean;
82     currentip:integer;
83     connecttimeout:tltimer;
84    
85 plugwash 1 { 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 beware 2 procedure connectionfailedhandler(error:word);
98     procedure connecttimeouthandler(sender:tobject);
99     procedure connectsuccesshandler;
100 plugwash 1 function getaddrsize:integer;
101     procedure connect; virtual;
102 beware 2 procedure realconnect;
103 plugwash 1 procedure bindsocket;
104     procedure listen;
105     function accept : longint;
106 beware 2 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 plugwash 1 //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 beware 2
132 plugwash 1 {!!!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 beware 2 result := inaddrsize(inaddr);
151 plugwash 1 end;
152    
153    
154 beware 2 procedure tlsocket.realconnect;
155 plugwash 1 var
156     a:integer;
157 beware 2
158 plugwash 1 begin
159 beware 2 // 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 plugwash 1 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 beware 2
181     eventcore.rmasterset(fdhandlein,false);
182     eventcore.wmasterclr(fdhandleout);
183 plugwash 1 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 beware 2 eventcore.rmasterset(fdhandlein,false);
192 plugwash 1 eventcore.wmasterset(fdhandleout);
193 beware 2 if trymoreips then connecttimeout.enabled := true;
194 plugwash 1 end;
195     //sendq := '';
196     except
197     on e: exception do begin
198     fdcleanup;
199     raise; //reraise the exception
200     end;
201     end;
202 beware 2
203 plugwash 1 end;
204    
205 beware 2 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    
222     biniplist := forwardlookuplist(addr,0);
223     if biniplist_getcount(biniplist) = 0 then raise exception.create('unable to resolve '+addr);
224    
225     //makeinaddrv(addr,port,inaddr);
226    
227     currentip := 0;
228     if not assigned(connecttimeout) then begin
229     connecttimeout := tltimer.create(self);
230     connecttimeout.Tag := integer(self);
231     connecttimeout.ontimer := connecttimeouthandler;
232     connecttimeout.interval := 2500;
233     connecttimeout.enabled := false;
234     end;
235     realconnect;
236     end;
237    
238 plugwash 1 procedure tlsocket.sendstr(const str : string);
239     begin
240     if udp then begin
241     send(@str[1],length(str))
242     end else begin
243     inherited sendstr(str);
244     end;
245     end;
246    
247     function tlsocket.send(data:pointer;len:integer):integer;
248     begin
249     if udp then begin
250 beware 2 // writeln('sending to '+ipbintostr(inaddrvtobinip(inaddr)),' ',htons(inaddr.inaddr.port),' ',len,' bytes');
251     result := sendto(inaddr,getaddrsize,data,len);
252    
253     // writeln('send result ',result);
254     // writeln('errno',errno);
255 plugwash 1 end else begin
256     result := inherited send(data,len);
257     end;
258     end;
259    
260    
261     function tlsocket.receive(Buf:Pointer;BufSize:integer):integer;
262     begin
263     if udp then begin
264     result := myfdread(self.fdhandlein,buf^,bufsize);
265     end else begin
266     result := inherited receive(buf,bufsize);
267     end;
268     end;
269    
270     procedure tlsocket.bindsocket;
271     var
272     a:integer;
273     inAddrtemp:TInetSockAddrV;
274     inAddrtempx:{$ifdef win32}winsock.TSockaddr{$else}TInetSockAddrV{$endif} absolute inaddrtemp;
275     inaddrtempsize:integer;
276     begin
277     try
278     if (localaddr <> '') or (localport <> '') then begin
279     if localaddr = '' then begin
280     {$ifdef ipv6}
281     if inaddr.inaddr.family = AF_INET6 then localaddr := '::' else
282     {$endif}
283     localaddr := '0.0.0.0';
284     end;
285     //gethostbyname(localaddr,host);
286    
287 beware 2 inaddrtempsize := makeinaddrv(forwardlookup(localaddr,0),localport,inaddrtemp);
288 plugwash 1
289     If Bind(fdhandlein,inaddrtempx,inaddrtempsize)<> {$ifdef win32}0{$else}true{$endif} Then begin
290     state := wsclosed;
291     lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};
292     raise ESocketException.create('unable to bind, error '+inttostr(lasterror));
293     end;
294     state := wsbound;
295     end;
296     except
297     on e: exception do begin
298     fdcleanup;
299     raise; //reraise the exception
300     end;
301     end;
302     end;
303    
304     procedure tlsocket.listen;
305     var
306     yes:longint;
307     socktype:integer;
308     biniptemp:tbinip;
309     origaddr:string;
310     begin
311     if state <> wsclosed then close;
312     udp := uppercase(proto) = 'UDP';
313     if udp then socktype := SOCK_DGRAM else socktype := SOCK_STREAM;
314     origaddr := addr;
315    
316     if addr = '' then begin
317     {$ifdef ipv6}
318     if not v4listendefault then begin
319     addr := '::';
320     end else
321     {$endif}
322     addr := '0.0.0.0';
323     end;
324     biniptemp := forwardlookup(addr,10);
325     addr := ipbintostr(biniptemp);
326     fdhandlein := socket(biniptemp.family,socktype,0);
327     {$ifdef ipv6}
328     if (addr = '::') and (origaddr = '') and (fdhandlein < 0) then begin
329     addr := '0.0.0.0';
330     fdhandlein := socket(AF_INET,socktype,0);
331     end;
332     {$endif}
333     if fdhandlein = -1 then raise ESocketException.create('unable to create socket');
334     dupnowatch(fdhandlein); // sets up maxs and copies handle to fdhandleout among other things
335     //eventcore.setfdreverse(fdhandlein,self); //already taken care of by dup
336     state := wsclosed; // then set this back as it was an undesired side effect of dup
337    
338     try
339     yes := $01010101; {Copied this from existing code. Value is empiric,
340     but works. (yes=true<>0) }
341     {$ifndef win32}
342     if SetSocketOptions(fdhandlein, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes))=-1 then begin
343     raise ESocketException.create('unable to set socket options');
344     end;
345     {$endif}
346     localaddr := addr;
347     localport := port;
348     bindsocket;
349    
350     if not udp then begin
351     {!!! allow custom queue length? default 5}
352     if listenqueue = 0 then listenqueue := 5;
353     If {$ifdef win32}winsock{$else}sockets{$endif}.Listen(fdhandlein,listenqueue)<>{$ifdef win32}0{$else}true{$endif} Then raise esocketexception.create('unable to listen');
354     state := wsListening;
355     end else begin
356     {$ifndef win32}
357     SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));
358     {$endif}
359     state := wsconnected;
360     end;
361     finally
362     if state = wsclosed then begin
363     if fdhandlein >= 0 then begin
364     {one *can* get here without fd -beware}
365     eventcore.rmasterclr(fdhandlein);
366     myfdclose(fdhandlein); // we musnt leak file discriptors
367     eventcore.setfdreverse(fdhandlein,nil);
368     fdhandlein := -1;
369     end;
370     end else begin
371 beware 2 eventcore.rmasterset(fdhandlein,not udp);
372 plugwash 1 end;
373     if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);
374     end;
375 beware 2 //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein);
376 plugwash 1 end;
377    
378     function tlsocket.accept : longint;
379     var
380     FromAddrSize : LongInt; // i don't realy know what to do with these at this
381     FromAddr : TInetSockAddrV; // at this point time will tell :)
382 beware 2 a:integer;
383 plugwash 1 begin
384    
385     FromAddrSize := Sizeof(FromAddr);
386     {$ifdef win32}
387     result := winsock.accept(fdhandlein,@fromaddr,@fromaddrsize);
388     {$else}
389     result := sockets.accept(fdhandlein,fromaddr,fromaddrsize);
390     {$endif}
391     //now we have accepted one request start monitoring for more again
392     eventcore.rmasterset(fdhandlein,true);
393    
394 beware 2 if result = -1 then begin
395     raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting');
396     end;
397 plugwash 1 if result > absoloutemaxs then begin
398     myfdclose(result);
399 beware 2 a := result;
400 plugwash 1 result := -1;
401 beware 2 raise esocketexception.create('file discriptor out of range: '+inttostr(a));
402 plugwash 1 end;
403     end;
404    
405 beware 2 function tlsocket.sendto(dest:TInetSockAddrV;destlen:integer;data:pointer;len:integer):integer;
406 plugwash 1 var
407 beware 2 destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute dest;
408 plugwash 1 begin
409     result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen);
410     end;
411    
412 beware 2 function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddrV;var srclen:integer):integer;
413 plugwash 1 var
414 beware 2 srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute src;
415 plugwash 1 begin
416     result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen);
417     end;
418    
419 beware 2 procedure tlsocket.connectionfailedhandler(error:word);
420     begin
421     if trymoreips then begin
422     // writeln('failed with error ',error);
423     connecttimeout.enabled := false;
424     destroying := true;
425     state := wsconnected;
426     self.internalclose(0);
427     destroying := false;
428     realconnect;
429     end else begin
430     state := wsconnected;
431     if assigned(onsessionconnected) then onsessionconnected(self,error);
432     self.internalclose(0);
433     recvq.del(maxlongint);
434     end;
435     end;
436    
437     procedure tlsocket.connectsuccesshandler;
438     begin
439     trymoreips := false;
440     connecttimeout.enabled := false;
441     if assigned(onsessionconnected) then onsessionconnected(self,0);
442     end;
443    
444    
445 plugwash 1 procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean);
446     var
447     tempbuf:array[0..receivebufsize-1] of byte;
448     begin
449 beware 2 // writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger,' state=',integer(state));
450 plugwash 1 if (state =wslistening) and readtrigger then begin
451     { debugout('listening socket triggered on read');}
452     eventcore.rmasterclr(fdhandlein);
453     if assigned(onsessionAvailable) then onsessionAvailable(self,0);
454     end;
455     if udp and readtrigger then begin
456     if assigned(ondataAvailable) then ondataAvailable(self,0);
457     {!!!test}
458     exit;
459     end;
460     if (state =wsconnecting) and writetrigger then begin
461     // code for dealing with the reults of a non-blocking connect is
462     // rather complex
463     // if just write is triggered it means connect suceeded
464     // if both read and write are triggered it can mean 2 things
465     // 1: connect ok and data availible
466     // 2: connect fail
467     // to find out which you must read from the socket and look for errors
468     // there if we read successfully we drop through into the code for fireing
469     // the read event
470     if not readtrigger then begin
471     state := wsconnected;
472 beware 2 connectsuccesshandler;
473 plugwash 1 end else begin
474     numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));
475     if numread <> -1 then begin
476     state := wsconnected;
477 beware 2 connectsuccesshandler;
478 plugwash 1 //connectread := true;
479     recvq.add(@tempbuf,numread);
480     end else begin
481 beware 2 connectionfailedhandler({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});
482     exit;
483 plugwash 1 end;
484     // if things went well here we are now in the state wsconnected with data sitting in our receive buffer
485     // so we drop down into the processing for data availible
486     end;
487     if fdhandlein >= 0 then begin
488     if state = wsconnected then begin
489     eventcore.rmasterset(fdhandlein,false);
490     end else begin
491     eventcore.rmasterclr(fdhandlein);
492     end;
493     end;
494     if fdhandleout >= 0 then begin
495     if sendq.size = 0 then begin
496     //don't clear the bit in fdswmaster if data is in the sendq
497     eventcore.wmasterclr(fdhandleout);
498     end;
499     end;
500    
501     end;
502     inherited handlefdtrigger(readtrigger,writetrigger);
503     end;
504    
505     constructor tlsocket.Create(AOwner: TComponent);
506     begin
507     inherited create(aowner);
508     closehandles := true;
509 beware 2 trymoreips := true;
510 plugwash 1 end;
511    
512    
513     function tlsocket.getpeername(var addr:tsockaddrin;addrlen:integer):integer;
514     var
515     addrx : {$ifdef win32}winsock.tsockaddr{$else}tsockaddrin{$endif} absolute addr;
516     begin
517     result := {$ifdef win32}winsock{$else}sockets{$endif}.getpeername(self.fdhandlein,addrx,addrlen);
518     end;
519    
520     procedure tlsocket.getxaddrbin(var binip:tbinip);
521     var
522     addr:tinetsockaddrv;
523     i:integer;
524     begin
525     i := sizeof(addr);
526     fillchar(addr,sizeof(addr),0);
527    
528     {$ifdef win32}
529     winsock.getsockname(self.fdhandlein,psockaddr(@addr)^,i);
530     {$else}
531     sockets.getsocketname(self.fdhandlein,addr,i);
532     {$endif}
533     binip.family := addr.inaddr.family;
534     {$ifdef ipv6}
535     if addr.inaddr6.sin6_family = AF_INET6 then begin
536     binip.ip6 := addr.inaddr6.sin6_addr;
537     end else
538     {$endif}
539     begin
540     binip.ip := addr.inaddr.addr;
541     end;
542     converttov4(binip);
543     end;
544    
545     procedure tlsocket.getpeeraddrbin(var binip:tbinip);
546     var
547     addr:tinetsockaddrv;
548     i:integer;
549     begin
550     i := sizeof(addr);
551     fillchar(addr,sizeof(addr),0);
552     {$ifdef win32}
553     winsock.getpeername(self.fdhandlein,psockaddr(@addr)^,i);
554     {$else}
555     sockets.getpeername(self.fdhandlein,addr,i);
556     {$endif}
557    
558     binip.family := addr.inaddr.family;
559     {$ifdef ipv6}
560     if addr.inaddr6.sin6_family = AF_INET6 then begin
561     binip.ip6 := addr.inaddr6.sin6_addr;
562     end else
563     {$endif}
564     begin
565     binip.ip := addr.inaddr.addr;
566     end;
567     converttov4(binip);
568     end;
569    
570     function tlsocket.getXaddr:string;
571     var
572     biniptemp:tbinip;
573     begin
574     getxaddrbin(biniptemp);
575     result := ipbintostr(biniptemp);
576     if result = '' then result := 'error';
577     end;
578    
579     function tlsocket.getpeeraddr:string;
580     var
581     biniptemp:tbinip;
582     begin
583     getpeeraddrbin(biniptemp);
584     result := ipbintostr(biniptemp);
585     if result = '' then result := 'error';
586     end;
587    
588     function tlsocket.getXport:string;
589     var
590     addr:tinetsockaddrv;
591     i:integer;
592     begin
593     i := sizeof(addr);
594     {$ifdef win32}
595     winsock.getsockname(self.fdhandlein,psockaddrin(@addr)^,i);
596    
597     {$else}
598     sockets.getsocketname(self.fdhandlein,addr,i);
599    
600     {$endif}
601     result := inttostr(htons(addr.InAddr.port));
602     end;
603    
604     function tlsocket.getpeerport:string;
605     var
606     addr:tinetsockaddrv;
607     i:integer;
608     begin
609     i := sizeof(addr);
610     {$ifdef win32}
611     winsock.getpeername(self.fdhandlein,psockaddrin(@addr)^,i);
612    
613     {$else}
614     sockets.getpeername(self.fdhandlein,addr,i);
615    
616     {$endif}
617     result := inttostr(htons(addr.InAddr.port));
618     end;
619    
620     {$ifdef win32}
621     procedure tlsocket.myfdclose(fd : integer);
622     begin
623     closesocket(fd);
624     end;
625     function tlsocket.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;
626     begin
627     result := winsock.send(fd,(@buf)^,size,0);
628     end;
629     function tlsocket.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;
630     begin
631     result := winsock.recv(fd,buf,size,0);
632     end;
633     {$endif}
634    
635     end.
636    

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