Delphi-PRAXiS - Delphi 2 UDP server auf demselben Port ?

Zitat:
Zitat von th_bone
gibt es einen Weg 2 UDP server (auf einem Rechner) zu erlauben über den selben Port lauschen ?
Du darfst den Port nicht exklusiv binden. Ich habe mal sowas für die Notification in ADS in eine Komponente (Komponente kapselt einen Empfangs-Thread) gepackt. Die kannst Du Dir für Deine Zwecke abändern. Verantwortlich ist in CreateSocket das SO_REUSEADDR.
Delphi-Quellcode:
			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.