unit AdsNotify;
interface
uses
SysUtils, Classes, winsock, windows;
type
ESocketError =
class(EOSError);
TrcLog =
procedure(s:
string)
of object;
TrcNotifyEvent =
procedure (Sender:TObject;tables:
string)
of object;
TReceiveThread =
class(TThread)
private
{ Private declarations }
fPort:integer;
FOnReceive: TrcNotifyEvent;
FOnLog: TrcLog;
procedure SetOnLog(
const Value: TrcLog);
procedure SetOnReceive(
const Value: TrcNotifyEvent);
protected
procedure Execute;
override;
procedure DoReceive;
procedure Log(s:
string);
public
msg:
string;
constructor Create(Port:integer);
property OnReceive:TrcNotifyEvent
read FOnReceive
write SetOnReceive;
property OnLog:TrcLog
read FOnLog
write SetOnLog;
end;
tAdsNotify =
class(TComponent)
private
FPort: integer;
FOnNotification: TrcNotifyEvent;
rcThread:TReceiveThread;
procedure SetPort(
const Value: integer);
procedure SetOnNotification(
const Value: TrcNotifyEvent);
{ Private declarations }
protected
{ Protected declarations }
procedure DoNotification;
public
{ Public declarations }
constructor Create(Owner:TComponent; Port:integer=0);
reintroduce;
published
{ Published declarations }
property Port:integer
read FPort
write SetPort;
property OnNotification:TrcNotifyEvent
read FOnNotification
write SetOnNotification;
end;
resourcestring
SSocketError = '
Socket Error. Code: %d.' + sLineBreak + '
%s';
SUnkSocketError = '
A call to a socket function failed';
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('
Advantage', [tAdsNotify]);
end;
{ tAdsNotify }
constructor tAdsNotify.Create(Owner: TComponent; Port: integer=0);
begin
inherited Create(Owner);
rcThread:=nil;
SetPort(Port);
end;
procedure tAdsNotify.DoNotification;
var
tables:
string;
begin
if assigned(rcThread)
then begin
tables:=rcThread.msg;
rcthread.msg:='
';
if assigned(FOnNotification)
then FOnNotification(self,tables);
end;
end;
procedure tAdsNotify.SetOnNotification(
const Value: TrcNotifyEvent);
begin
FOnNotification := Value;
if assigned(rcThread)
then rcThread.OnReceive:=OnNotification;
end;
procedure tAdsNotify.Setport(
const Value: integer);
begin
if assigned(rcThread)
then begin
rcThread.Terminate;
end;
Fport := Value;
if FPort>0
then begin
rcThread:=TReceiveThread.Create(FPort);
rcThread.OnReceive:=OnNotification;
rcThread.FreeOnTerminate:=true;
rcThread.Resume;
end;
end;
{ TReceiveThread }
procedure RaiseSocketError(E: Integer);
var
Error: ESocketError;
begin
if E <> 0
then
Error := ESocketError.CreateResFmt(@SSocketError, [E, SysErrorMessage(E)])
else
Error := ESocketError.CreateRes(@SUnkSocketError);
Error.ErrorCode := E;
raise Error;
end;
procedure RaiseLastSocketError;
begin
RaiseSocketError(WSAGetLastError);
end;
procedure InitWinSock;
var
Data: TWSAData;
E: Integer;
begin
E := WSAStartup(1, Data);
if E <> 0
then
RaiseSocketError(E);
end;
function MachineName:
String;
var
Buf:
array[0..MAX_COMPUTERNAME_LENGTH]
of Char;
Len: Cardinal;
begin
Len := SizeOf(Buf);
if GetComputerName(Buf, Len)
then
SetString(Result, Buf, Len)
else
Result := '
?';
end;
function CreateSocket(port:integer):TSocket;
var
Sock: TSocket;
Opt: Integer;
LocalAddr:TSockAddr;
begin
InitWinSock;
Sock := socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP);
if Sock = INVALID_SOCKET
then
RaiseLastSocketError;
Opt := 1;
if setsockopt(Sock, SOL_SOCKET, SO_REUSEADDR, @Opt, SizeOf(Opt)) <> 0
then
RaiseLastSocketError;
LocalAddr.sin_family := AF_INET;
LocalAddr.sin_port := htons(port);
LocalAddr.sin_addr.S_addr := INADDR_ANY;
if bind(Sock, LocalAddr, SizeOf(LocalAddr)) <> 0
then
RaiseLastSocketError;
result:=sock;
end;
function Receive(
var Sock:TSocket;
var s:
string;
var PeerAddr:TSockAddr):boolean;
var
PeerAddrLen: Integer;
MsgBuf:
array[0..511]
of Char;
MsgLen: Integer;
begin
PeerAddrLen := SizeOf(PeerAddr);
MsgLen := recvfrom(Sock, MsgBuf, SizeOf(MsgBuf), 0, PeerAddr, PeerAddrLen);
if MsgLen>0
then begin
SetString(s, MsgBuf, MsgLen);
result:=true;
end
else begin
result:=false;
end;
end;
constructor TReceiveThread.Create(Port: integer);
begin
inherited Create(true);
fPort:=Port;
end;
procedure TReceiveThread.DoReceive;
begin
if assigned(FOnReceive)
then begin
FOnReceive(self, msg);
msg:='
';
end;
end;
procedure TReceiveThread.Execute;
var
Sock: TSocket;
PeerAddr: TSockAddr;
PeerAddrLen: Integer;
MsgBuf:
array[0..511]
of Char;
MsgLen: Integer;
begin
try
Sock:=CreateSocket(fport);
while not Suspended
do
begin
PeerAddrLen := SizeOf(PeerAddr);
MsgLen := recvfrom(Sock, MsgBuf, SizeOf(MsgBuf), 0, PeerAddr, PeerAddrLen);
if MsgLen > 0
then begin
SetString(msg, MsgBuf, MsgLen);
DoReceive;
end;
end;
except
on E:
Exception do log(e.
Message);
end;
end;
procedure TReceiveThread.Log(s:
string);
begin
end;
procedure TReceiveThread.SetOnLog(
const Value: TrcLog);
begin
FOnLog := Value;
end;
procedure TReceiveThread.SetOnReceive(
const Value: TrcNotifyEvent);
begin
FOnReceive := Value;
end;
end.