pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 7

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@15 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-23 20:34:31 +00:00
parent a077e1a0cc
commit ac5a713d77
3 changed files with 367 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
blcksck2.pas Normal file
View File

@ -0,0 +1,128 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.000 |
|==============================================================================|
| Content: Library base for RAW sockets |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.mlp.cz/space/gebauerl/synapse/) |
|==============================================================================}
{
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Remember, this unit work only with Winsock2! (on Win98 and WinNT 4.0 or higher)
If you must use this unit on Win95, download Wínsock2 from Microsoft
and distribute it with your application!
In spite of I use Winsock level version 1.1, RAW sockets work in this level only
if Winsock2 is installed on your computer!!!
On WinNT standardly RAW sockets work if program is running under user with
administrators provilegies. To use RAW sockets under another users, you must
create the following registry variable and set its value to DWORD 1:
HKLM\System\CurrentControlSet\Services\Afd\Parameters\DisableRawSecurity
After you change the registry, you need to restart your computer!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
}
unit blcksck2;
interface
uses
winsock, SysUtils, windows, blcksock;
type
{TICMPBlockSocket}
TICMPBlockSocket = class (TBlockSocket)
public
procedure CreateSocket; override;
end;
{TRAWBlockSocket}
TRAWBlockSocket = class (TBlockSocket)
public
procedure CreateSocket; override;
end;
TIPHeader = Record
VerLen : Byte;
TOS : Byte;
TotalLen : Word;
Identifer : Word;
FragOffsets : Word;
TTL : Byte;
Protocol : Byte;
CheckSum : Word;
SourceIp : Dword;
DestIp : Dword;
Options : Dword;
End;
function SetTimeout(Sock:TSocket;Timeout:integer):Boolean;
implementation
{======================================================================}
{TICMPBlockSocket.CreateSocket}
Procedure TICMPBlockSocket.CreateSocket;
begin
FSocket:=winsock.socket(PF_INET,SOCK_RAW,IPPROTO_ICMP);
FProtocol:=IPPROTO_ICMP;
inherited createSocket;
end;
{======================================================================}
{TRAWBlockSocket.CreateSocket}
Procedure TRAWBlockSocket.CreateSocket;
begin
FSocket:=winsock.socket(PF_INET,SOCK_RAW,IPPROTO_RAW);
FProtocol:=IPPROTO_RAW;
inherited createSocket;
end;
{======================================================================}
function SetTimeout(Sock:TSocket;Timeout:integer):Boolean;
var
len,Value,res:integer;
r1,r2:Boolean;
begin
Result:=False;
r1:=False;
r2:=False;
Value:=Timeout*1000;
len:=SizeOf(Value);
Res:=Winsock.setsockopt(sock,SOL_SOCKET,SO_RCVTIMEO,@Value,len);
r1:=res<>SOCKET_ERROR;
Res:=Winsock.setsockopt(sock,SOL_SOCKET,SO_SNDTIMEO,@Value,len);
r2:=res<>SOCKET_ERROR;
Result:=r1 and r2;
end;
end.

67
blcksock.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.001 |
| Project : Delphree - Synapse | 001.001.000 |
|==============================================================================|
| Content: Library base |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999. |
| Portions created by Lukas Gebauer are Copyright (c)1999,2000. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -30,9 +30,6 @@ interface
uses
winsock, SysUtils, windows;
const
Copyright='Synapse Library 1.0.0 (c)1999 Lukas Gebauer';
type
{TBlockSocket}
@ -69,7 +66,6 @@ public
function WaitingData:integer;
procedure SetLinger(enable:boolean;Linger:integer);
procedure GetSins;
function SockCheck(SockResult:integer):integer;
function LocalName:string;
function GetLocalSinIP:string;
@ -78,6 +74,8 @@ public
function GetRemoteSinPort:integer;
function CanRead(Timeout:integer):boolean;
function CanWrite(Timeout:integer):boolean;
procedure SendBufferTo(buffer:pointer;length:integer);
function RecvBufferFrom(buffer:pointer;length:integer):integer;
published
property socket:TSocket read FSocket write FSocket;
@ -91,8 +89,7 @@ end;
TUDPBlockSocket = class (TBlockSocket)
public
procedure CreateSocket; override;
procedure SendBufferTo(buffer:pointer;length:integer);
function RecvBufferFrom(buffer:pointer;length:integer):integer;
function EnableBroadcast(Value:Boolean):Boolean;
end;
{TTCPBlockSocket}
@ -113,7 +110,7 @@ begin
inherited create;
FSocket:=INVALID_SOCKET;
FProtocol:=IPPROTO_IP;
winsock.WSAStartup($101, FWsaData);
SockCheck(winsock.WSAStartup($101, FWsaData));
end;
{TBlockSocket.Destroy}
@ -140,12 +137,18 @@ begin
Sin.sin_port:= htons(StrToIntDef(Port,0))
else
Sin.sin_port:= ServEnt^.s_port;
if ip='255.255.255.255'
then Sin.sin_addr.s_addr:=u_long(INADDR_BROADCAST)
else
begin
Sin.sin_addr.s_addr:= inet_addr(PChar(ip));
if SIn.sin_addr.s_addr = INADDR_NONE then
if SIn.sin_addr.s_addr = u_long(INADDR_NONE) then
begin
HostEnt:= gethostbyname(PChar(ip));
if HostEnt <> nil then
SIn.sin_addr.S_addr:= longint(plongint(HostEnt^.h_addr_list^)^);
end;
end;
end;
{TBlockSocket.GetSinIP}
@ -445,6 +448,26 @@ begin
result:=x>0;
end;
{TBlockSocket.SendBufferTo}
procedure TBlockSocket.SendBufferTo(buffer:pointer;length:integer);
var
len:integer;
begin
len:=sizeof(FRemoteSin);
sockcheck(winsock.sendto(FSocket,buffer^,length,0,FRemoteSin,len));
end;
{TBlockSocket.RecvBufferFrom}
function TBlockSocket.RecvBufferFrom(buffer:pointer;length:integer):integer;
var
len:integer;
begin
len:=sizeof(FRemoteSin);
result:=winsock.recvfrom(FSocket,buffer^,length,0,FRemoteSin,len);
sockcheck(result);
end;
{======================================================================}
@ -456,23 +479,16 @@ begin
inherited createSocket;
end;
{TUDPBlockSocket.SendBufferTo}
procedure TUDPBlockSocket.SendBufferTo(buffer:pointer;length:integer);
{TUDPBlockSocket.EnableBroadcast}
function TUDPBlockSocket.EnableBroadcast(Value:Boolean):Boolean;
var
len:integer;
Opt:integer;
Res:integer;
begin
len:=sizeof(FRemoteSin);
sockcheck(winsock.sendto(FSocket,buffer^,length,0,FRemoteSin,len));
end;
{TUDPBlockSocket.RecvBufferFrom}
function TUDPBlockSocket.RecvBufferFrom(buffer:pointer;length:integer):integer;
var
len:integer;
begin
len:=sizeof(FRemoteSin);
result:=winsock.recvfrom(FSocket,buffer^,length,0,FRemoteSin,len);
sockcheck(result);
opt:=Ord(Value);
Res:=winsock.SetSockOpt(FSocket, SOL_SOCKET, SO_BROADCAST, @opt, SizeOf(opt));
SockCheck(Res);
Result:=res=0;
end;
@ -513,6 +529,7 @@ end;
function GetErrorDesc(ErrorCode:integer): string;
begin
case ErrorCode of
0 : Result:= 'OK';
WSAEINTR : Result:= 'Interrupted system call';
WSAEBADF : Result:= 'Bad file number';
WSAEACCES : Result:= 'Permission denied';

192
pingsend.pas Normal file
View File

@ -0,0 +1,192 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.000 |
|==============================================================================|
| Content: PING sender |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.mlp.cz/space/gebauerl/synapse/) |
|==============================================================================}
{
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Remember, this unit work only with Winsock2! (on Win98 and WinNT 4.0 or higher)
If you must use this unit on Win95, download Wínsock2 from Microsoft
and distribute it with your application!
In spite of I use Winsock level version 1.1, RAW sockets work in this level only
if Winsock2 is installed on your computer!!!
On WinNT standardly RAW sockets work if program is running under user with
administrators provilegies. To use RAW sockets under another users, you must
create the following registry variable and set its value to DWORD 1:
HKLM\System\CurrentControlSet\Services\Afd\Parameters\DisableRawSecurity
After you change the registry, you need to restart your computer!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
}
unit PINGsend;
interface
uses
winsock, SysUtils, windows, blcksck2, Synautil, dialogs;
const
ICMP_ECHO=8;
ICMP_ECHOREPLY=0;
type
TIcmpEchoHeader = Record
i_type : Byte;
i_code : Byte;
i_checkSum : Word;
i_Id : Word;
i_seq : Word;
TimeStamp : ULong;
End;
TPINGSend=class(TObject)
private
Sock:TICMPBlockSocket;
Buffer:string;
seq:integer;
id:integer;
function checksum:integer;
public
timeout:integer;
PacketSize:integer;
PingTime:integer;
function ping(host:string):Boolean;
constructor Create;
destructor Destroy; override;
end;
function PingHost(host:string):integer;
implementation
{==============================================================================}
{TPINGSend.Create}
Constructor TPINGSend.Create;
begin
inherited Create;
sock:=TICMPBlockSocket.create;
sock.CreateSocket;
timeout:=5;
packetsize:=32;
seq:=0;
end;
{TPINGSend.Destroy}
Destructor TPINGSend.Destroy;
begin
Sock.free;
inherited destroy;
end;
{TPINGSend.ping}
function TPINGSend.ping(host:string):Boolean;
var
PIPHeader:^TIPHeader;
IpHdrLen:Integer;
PIcmpEchoHeader:^TICMPEchoHeader;
data:string;
n,x:integer;
begin
Result:=False;
sock.connect(host,'0');
Buffer:=StringOfChar(#0,SizeOf(TICMPEchoHeader)+packetSize);
PIcmpEchoHeader := Pointer(Buffer);
With PIcmpEchoHeader^ Do Begin
i_type:=ICMP_ECHO;
i_code:=0;
i_CheckSum:=0;
id:=Random(32767);
i_Id:=id;
TimeStamp:=GetTickcount;
Inc(Seq);
i_Seq:=Seq;
for n:=Succ(SizeOf(TicmpEchoHeader)) to Length(Buffer) do
Buffer[n]:=#$55;
i_CheckSum:=CheckSum;
end;
sock.sendString(Buffer);
if sock.canread(timeout)
then begin
x:=sock.waitingdata;
setlength(Buffer,x);
sock.recvbuffer(Pointer(Buffer),x);
PIpHeader:=Pointer(Buffer);
IpHdrLen:=(PIpHeader^.VerLen and $0F)*4;
PIcmpEchoHeader:=@Buffer[IpHdrLen+1];
if (PIcmpEchoHeader^.i_type=ICMP_ECHOREPLY) then
if (PIcmpEchoHeader^.i_id=id) then
begin
PingTime:=GetTickCount-PIcmpEchoHeader^.TimeStamp;
Result:=True;
end;
end;
end;
{TPINGSend.checksum}
function TPINGSend.checksum:integer;
type
tWordArray=Array[0..0] Of Word;
var
PWordArray:^TWordArray;
CkSum:Dword;
Num,Remain:Integer;
n:Integer;
begin
Num:=length(Buffer) div 2;
Remain:=length(Buffer) mod 2;
PWordArray:=Pointer(Buffer);
CkSum := 0;
for n:=0 to Num-1 do
CkSum:=CkSum+PWordArray^[n];
if Remain<>0 then
CkSum:=CkSum+ord(Buffer[Length(Buffer)]);
CkSum:=(CkSum shr 16)+(CkSum and $FFFF);
CkSum:=CkSum+(CkSum shr 16);
Result:=Word(not CkSum);
end;
{==============================================================================}
function PingHost(host:string):integer;
var
ping:TPINGSend;
begin
ping:=TPINGSend.Create;
try
if ping.ping(host)
then Result:=ping.pingtime
else Result:=-1;
finally
ping.Free;
end;
end;
end.