labradwsaserverthread.pas

As science advances, novel experiments are becoming more and more complex, requiring a zoo of contro

                          try DoError('DoRead exception: ' + E.Message) except end;
                          SocketDead:=True;
                        end;
                      end;
                    end;
                    // If we got exactly nothing, the connection was closed
                    if Len=0 then SocketDead:=True;
                    // Otherwise check for errors
                    if Len<0 then begin
                      Len:=WSAGetLastError;
                      if Len<>WSAEWOULDBLOCK then begin
                        try DoError('Read failed with error code '+inttostr(Len)) except end;
                        SocketDead:=True;
                      end;
                    end;
                  end;

                  // Was it FD_CLOSE?
                  if (NetEvents.lNetworkEvents and FD_CLOSE)>0 then begin
                    SocketDead:=True;
                  end;
                end;
               end else begin
                 try DoError('EnumEvents failed with error code '+inttostr(WSAGetLastError)) except end;
                 SocketDead:=True;
              end;

              // Is the connection dead?
              if SocketDead then KillSocket(a-1);
            end;
          end;
        end;

       // Event was a wake-up call for us
       WSA_WAIT_EVENT_0+1:
         ; // We don't really need to do anything here...

       // Event was a time-out
       WSA_WAIT_TIMEOUT:
         ; // We don't really need to do anything here either...
      end;

      // Clear wake-up event flag
      WSAResetEvent(fEvents.Notify);

      // Handle any data that we need to send and all disconnect requests
      for a:=1 to length(fSockets) do begin
        if (fSockets[a-1].Socket<>INVALID_SOCKET) then begin
          if fSockets[a-1].KillMe=kmNow then begin
            // If socket is marked for disconnect, kill it
            KillSocket(a-1);
           end else begin
            // Otherwise, work through send buffers, if ready
            while assigned(fSockets[a-1].SBFirst) and fSockets[a-1].Writable do begin
              // Send as much as we can
              Len:=send(fSockets[a-1].Socket, fSockets[a-1].SBFirst.Data[fSockets[a-1].SBFirst.Pos], length(fSockets[a-1].SBFirst.Data) - fSockets[a-1].SBFirst.Pos, 0);
              if Len<0 then begin
                // If sending failed, socket is no longer ready for writing
                fSockets[a-1].Writable:=false;
                // The send buffer is full if we got WSAEWOULDBLOCK error ...
                Len:=WSAGetLastError;
                if Len<>WSAEWOULDBLOCK then begin
                  // ... otherwise, the socket must be dead, so we'll close it
                  try DoError('Write failed with error code '+inttostr(Len)) except end;
                  fSockets[a-1].KillMe:=kmNow;
                end;
               end else begin
                // If we sent something, increase data position ...
                fSockets[a-1].SBFirst.Pos:=fSockets[a-1].SBFirst.Pos + Len;
                // ... and notify application
                try
                  DoWrite(a-1, fSockets[a-1].Data, Len);
                 except
                  on E: Exception do try DoError('DoWrite exception: ' + E.Message) except end;
                end;
                if fSockets[a-1].SBFirst.Pos>=length(fSockets[a-1].SBFirst.Data) then begin
                  // If all data from this buffer has been sent, kill the buffer
                  finalize(fSockets[a-1].SBFirst.Data);
                  // Get lock on send buffers
                  fProtector.WaitFor($FFFFFFFF);
                    NextSB:=fSockets[a-1].SBFirst.Next;
                    if not assigned(NextSB) then begin
                      fSockets[a-1].SBLast:=nil;
                      if fSockets[a-1].KillMe=kmSent then fSockets[a-1].KillMe:=kmNow;
                    end;
                    Dispose(fSockets[a-1].SBFirst);
                    fSockets[a-1].SBFirst:=NextSB;
                  // Release send buffer lock
                  fProtector.SetEvent;
                end;
              end;
            end;
            // If we have a "disconnect after sending completes" request waiting,
            // and all data has been sent, change it to "disconnect now"
            if (fSockets[a-1].KillMe=kmSent) and not assigned(fSockets[a-1].SBFirst) then
              fSockets[a-1].KillMe:=kmNow;
            // If socket was marked to disconnect after sending completed, kill it now
            if fSockets[a-1].KillMe=kmNow then KillSocket(a-1);
          end;
        end;
      end;

      // Check if there is a method waiting to execute in the thread
      if assigned(fCITMethod) then begin
        try
          fCITMethod;
         except
          on E: Exception do try DoError('Method call exception: ' + E.Message) except end;
        end;
        fCITMethod:=nil;
        fCITWait.SetEvent;
      end;
    end;
   except
    on E: Exception do try DoError('Server loop exception: ' + E.Message) except end;
  end;
  fRunning:=False;

  // Close listening socket
  closesocket(Socket);
  // Close and report dead all connections
  for a:=1 to length(fSockets) do if fSockets[a-1].Socket<>INVALID_SOCKET then KillSocket(a-1);
  // Remove event objects
  WSACloseEvent(fEvents.Socket);
  WSACloseEvent(fEvents.Notify);

  // Notify completion
  try
    DoFinish;
   except
    on E: Exception do try DoError('DoFinish exception: ' + E.Message) except end;
  end;
end;


{
procedure Terminate
Since the server thread blocks on socket events, we need to notify it
before it has a chance to realize that it was terminated
}
procedure TCustomWSAServerThread.Terminate;
begin
  inherited Terminate;
  if fEvents.Notify<>WSA_INVALID_EVENT then
    WSASetEvent(fEvents.Notify);
end;


{
procedure KillSocket(SocketID)
Kills a socket, frees all send buffers, and notifies application
}
procedure TCustomWSAServerThread.KillSocket(SocketID: Integer);
var SendBuffer: PWSASendBuffer;
    NextSB:     PWSASendBuffer;
begin
  closesocket(fSockets[SocketID].Socket);

  // Get a lock on the send buffer
  fProtector.WaitFor($FFFFFFFF);
    // Mark socket as gone (prevents further writes)
    fSockets[SocketID].Socket:=INVALID_SOCKET;
    // Free all send buffers
    SendBuffer:=fSockets[SocketID].SBFirst;
    while assigned(SendBuffer) do begin
      NextSB:=SendBuffer.Next;
      finalize(SendBuffer.Data);
      Dispose(SendBuffer);
      SendBuffer:=NextSB;
    end;
    fSockets[SocketID].SBFirst:=nil;
    fSockets[SocketID].SBLast:=nil;
  // Release send buffer lock
  fProtector.SetEvent;

  // Notify application
  try
    DoDisconnect(SocketID, fSockets[SocketID].Data);
   except
    on E: Exception do try DoError('DoDisconnect exception: ' + E.Message) except end;
  end;
end;


{
procedure Write(SocketID, Buffer, Size)
Add data into the send buffer of a socket and wake up the server thread to handle it
}
function TCustomWSAServerThread.Write(SocketID: Integer; const Buffer; Size: Integer): Boolean;
var SendBuffer: PWSASendBuffer;
begin
  Result:=False;
  if SocketID>=length(fSockets) then exit;
  // Create buffer and fill with data
  New(SendBuffer);
  setlength(SendBuffer.Data, Size);
  move(Buffer, SendBuffer.Data[0], Size);
  SendBuffer.Pos:=0;
  SendBuffer.Next:=nil;

  // Get a lock on the pointers
  fProtector.WaitFor($FFFFFFFF);
    // Check if the socket is connected
    if (fSockets[SocketID].Socket<>INVALID_SOCKET) and (fSockets[SocketID].KillMe=kmNone) then begin
      if assigned(fSockets[SocketID].SBLast) then begin
        // If there are buffers queued already, add ours to the end
        fSockets[SocketID].SBLast.Next:=SendBuffer;
        fSockets[SocketID].SBLast:=SendBuffer;
       end else begin
        // If there aren't, set ours as the only one
        fSockets[SocketID].SBFirst:=SendBuffer;
        fSockets[SocketID].SBLast:=SendBuffer;
      end;
      Result:=True;
      // Wake up thread to handle write
      WSASetEvent(fEvents.Notify);
    end;
  // Release pointer lock
  fProtector.SetEvent;

  if not Result then begin
    // If something went wrong, free the buffer
    finalize(SendBuffer.Data);
    Dispose(SendBuffer);
  end;
end;

{
procedure Write(SocketID, Buffer)
Write function that takes a string as the argument
}
function TCustomWSAServerThread.Write(SocketID: Integer; const Buffer: String): Boolean;
begin
  // Call buffer write function
  Result:=Write(SocketID, Buffer[1], length(Buffer));
end;


{
procedure Disconnect(SocketID, FinishSending)
Mark a socket to be disconnected and wake up server thread to handle it
}
procedure TCustomWSAServerThread.Disconnect(SocketID: Integer; FinishSending: Boolean = True);
begin
  if SocketID>=length(fSockets) then exit;
  if FinishSending then fSockets[SocketID].KillMe:=kmSent else fSockets[SocketID].KillMe:=kmNow;
  // Wake up thread to handle disconnect
  WSASetEvent(fEvents.Notify);
end;


{
procedure CallInThread(Method)
Calls the given procedure from the server thread
}
procedure TCustomWSAServerThread.CallInThread(Method: TThreadMethod);
begin
  if not assigned(Method) then exit;
  if not fRunning then exit;
  // Make sure no other thread call is in progress
  fCITProtect.WaitFor($FFFFFFFF);
    fCITWait.ResetEvent;
    // Register method to be called
    fCITMethod:=Method;
    // Wake up thread to handle execution
    WSASetEvent(fEvents.Notify);
    // Wait for completion
    fCITWait.WaitFor($FFFFFFFF);
    // Release lock on thread calls
  fCITProtect.SetEvent;
end;





{
function WSALookupHost(Host)
Looks up the IP address of a host
}
function WSALookupHost(Host: string): TWSAAddress;
var fHostEnt: PHostEnt;
begin
  Result[0]:=0;
  Result[1]:=0;
  Result[2]:=0;
  Result[3]:=0;
  Host:=Host+#0;
  fHostEnt:=GetHostByName(@Host[1]);
  if assigned(fHostEnt) then begin
    if (fHostEnt.h_addrtype=AF_INET) and (fHostEnt.h_length=sizeOf(TIn_Addr)) then begin
      Result[0]:=ord(fHostEnt.h_addr_list^^.S_un_b.s_b1);
      Result[1]:=ord(fHostEnt.h_addr_list^^.S_un_b.s_b2);
      Result[2]:=ord(fHostEnt.h_addr_list^^.S_un_b.s_b3);
      Result[3]:=ord(fHostEnt.h_addr_list^^.S_un_b.s_b4);
    end;
  end;
end;

{
function WSALookupHost(Addr)
Reverse looks up the name of a host
}
function WSALookupHost(Addr: TWSAAddress): string;
var
  sin_addr: TIn_Addr;
  fHostEnt: PHostEnt;
begin
  Result:='';
  sin_addr.S_un_b.s_b1:=Addr[0];
  sin_addr.S_un_b.s_b2:=Addr[1];
  sin_addr.S_un_b.s_b3:=Addr[2];
  sin_addr.S_un_b.s_b4:=Addr[3];
  fHostEnt:=gethostbyaddr(@sin_addr.s_addr, 4, PF_INET);
  if assigned(fHostEnt) then Result:=fHostEnt.h_name;
  if Result='' then Result:=WSAAddressToStr(Addr);
end;

{
function WSAAddressToStr(IP)
Converts an IP address to text a.b.c.d
}
function WSAAddressToStr(IP: TWSAAddress): string;
begin
  Result:=inttostr(IP[0])+'.'+inttostr(IP[1])+'.'+inttostr(IP[2])+'.'+inttostr(IP[3]);
end;

{
function WSAStrToAddress(IP)
Converts text a.b.c.d to an IP address
}
function WSAStrToAddress(IP: string): TWSAAddress;
var a: integer;
    p: integer;
begin
  Result[0]:=0;
  Result[1]:=0;
  Result[2]:=0;
  Result[3]:=0;
  p:=0;
  for a:=1 to length(IP) do begin
    if not (IP[a] in ['0'..'9','.']) then exit;
    if IP[a]='.' then inc(p);
  end;
  if p<>3 then exit;
  p:=pos('.',IP);
  Result[0]:=strtoint(copy(IP,1,p-1));
  delete(IP,1,p);
  p:=pos('.',IP);
  Result[1]:=strtoint(copy(IP,1,p-1));
  delete(IP,1,p);
  p:=pos('.',IP);
  Result[2]:=strtoint(copy(IP,1,p-1));
  delete(IP,1,p);
  Result[3]:=strtoint(IP);
end;

{
function WSAAddressToInt(IP)
Packs an IP address into an integer
}
function WSAAddressToInt(IP: TWSAAddress): integer;
begin
  move(IP[0], Result, 4);
end;

{
function WSAIntToAddressTo(IP)
Unpacks an IP address from an integer
}
function WSAIntToAddress(IP: integer): TWSAAddress;
begin
  move(IP, Result[0], 4);
end;

// Initialize the Winsock library, making sure we have version 2.0
var fWSAData: TWSAData;

initialization
  WinsockReady:=WSAStartup($0002, fWSAData)=0;
  if WinsockReady then WinsockReady:=fWSAData.wVersion=$0002;
finalization
  WSACleanup;
end.