uawinsocket.pas

基于Midas 技术的多层应用开发包第二版（带开发文档）

unit UAWinSocket;

interface
uses
   Windows,
   SysUtils,
   Winsock,
   Classes,
   Messages;

type

   PWinsockInfo=^TWinsockInfo; // 2.3 changed array from 0.. to 1..
   TWinsockInfo=record
     Major_Version:Byte;                 {current version}
     Minor_Version:Byte;                 {current version}
     Highest_Major_Version:Byte;         {available on disk}
     Highest_Minor_Version:Byte;         {available on disk}
     Description:array[1..256] of Char;  // C++ Char Description[256];
     SystemStatus:array[1..128] of Char; // C++ Char Description[128];
     MaxSockets:Word;                    // C++ Unsigned short MaxSockets;
     MaxUDPDatagramSize:Word;            // C++ Unsigned short MaxUDPDatagramSize;
     VendorInfo:PChar;                   // C++ Char FAR * VendorInfo;
   end;


  TWindowHandleMessageEvent = function(const Msg: Cardinal; const wParam, lParam: Integer;
      var Handled: Boolean): Integer of object;
  TWindowHandle = class;
  TWindowHandleErrorEvent = procedure(const Sender: TWindowHandle;
      const E: Exception) of object;
  TWindowHandle = class(TComponent)
  protected
    FWindowHandle : HWND;
    FTerminated   : Boolean;
    FOnMessage    : TWindowHandleMessageEvent;
    FOnException  : TWindowHandleErrorEvent;

    procedure RaiseError(const Msg: String);
    function  AllocateWindowHandle: HWND; virtual;
    function  HandleWM(const Msg: Cardinal; const wParam, lParam: Integer): Integer; virtual;

  public
    destructor Destroy; override;

    procedure DestroyWindowHandle; virtual;
    property  WindowHandle: HWND read FWindowHandle;
    function  GetWindowHandle: HWND;

    function  ProcessMessage: Boolean;
    procedure ProcessMessages;
    function  HandleMessage: Boolean;
    procedure MessageLoop;

    property  OnMessage: TWindowHandleMessageEvent read FOnMessage write FOnMessage;
    property  OnException: TWindowHandleErrorEvent read FOnException write FOnException;

    property  Terminated: Boolean read FTerminated;
    procedure Terminate; virtual;
  end;
  EWindowHandle = class(Exception);

  TTimerHandle = class;
  TTimerEvent = procedure(const Sender: TTimerHandle) of object;
  TTimerHandle = class(TWindowHandle)
  protected
    FTimerInterval : Integer;
    FTimerActive   : Boolean;
    FOnTimer       : TTimerEvent;

    function  HandleWM(const Msg: Cardinal; const wParam, lParam: Integer): Integer; override;
    function  DoSetTimer: Boolean;
    procedure TriggerTimer; virtual;
    procedure SetTimerActive(const TimerActive: Boolean); virtual;
    procedure Loaded; override;

  public
    constructor Create(AOwner: TComponent); override;
    procedure DestroyWindowHandle; override;

    property  TimerInterval: Integer read FTimerInterval write FTimerInterval;
    property  TimerActive: Boolean read FTimerActive write SetTimerActive;
    property  OnTimer: TTimerEvent read FOnTimer write FOnTimer;
  end;



var
   GlobalTimeout:TTimeVal; //6-9

function  GetLastError:Integer;
function  GetErrorDesc(ErrorCode:Integer):string;
procedure GetWinSocketVersion(WinsockInfo:PWinsockInfo);
function  MakeBytesToWord(const A,B:Byte):Word;
function  IntToCommaStr(const Number:Integer):string;
function  WSocketIsDottedIP(const S : String) : Boolean;

implementation
var
  DLLData:TWSAData;
//  StartupResult:Integer;
{$I UAWinSocketConst.inc}

function IntToCommaStr(const Number:Integer):string;
var
   StrPos:Integer;

begin
   Result:=IntToStr(Number);
   StrPos:=Length(Result)-2;
   while StrPos>1 do
   begin
      Insert(',',Result,StrPos);
      StrPos:=StrPos-3;
   end;
end;


function GetLastError:Integer;
Begin
   Result:=WSAGetLastError;
End;

function GetErrorDesc(ErrorCode:Integer):string;
begin
// If you compile and get "Undeclared Identified -
// Edit DXSock.DEF - and select a language!
   case errorCode of
      WSAEINTR:Result:=_WSAEINTR;
      WSAEBADF:Result:=_WSAEBADF;
      WSAEACCES:Result:=_WSAEACCES;
      WSAEFAULT:Result:=_WSAEFAULT;
      WSAEINVAL:Result:=_WSAEINVAL;
      WSAEMFILE:Result:=_WSAEMFILE;
      WSAEWOULDBLOCK:Result:=_WSAEWOULDBLOCK;
      WSAEINPROGRESS:Result:=_WSAEINPROGRESS;
      WSAEALREADY:Result:=_WSAEALREADY;
      WSAENOTSOCK:Result:=_WSAENOTSOCK;
      WSAEDESTADDRREQ:Result:=_WSAEDESTADDRREQ;
      WSAEMSGSIZE:Result:=_WSAEMSGSIZE;
      WSAEPROTOTYPE:Result:=_WSAEPROTOTYPE;
      WSAENOPROTOOPT:Result:=_WSAENOPROTOOPT;
      WSAEPROTONOSUPPORT:Result:=_WSAEPROTONOSUPPORT;
      WSAESOCKTNOSUPPORT:Result:=_WSAESOCKTNOSUPPORT;
      WSAEOPNOTSUPP:Result:=_WSAEOPNOTSUPP;
      WSAEPFNOSUPPORT:Result:=_WSAEPFNOSUPPORT;
      WSAEAFNOSUPPORT:Result:=_WSAEAFNOSUPPORT;
      WSAEADDRINUSE:Result:=_WSAEADDRINUSE;
      WSAEADDRNOTAVAIL:Result:=_WSAEADDRNOTAVAIL;
      WSAENETDOWN:Result:=_WSAENETDOWN;
      WSAENETUNREACH:Result:=_WSAENETUNREACH;
      WSAENETRESET:Result:=_WSAENETRESET;
      WSAECONNABORTED:Result:=_WSAECONNABORTED;
      WSAECONNRESET:Result:=_WSAECONNRESET;
      WSAENOBUFS:Result:=_WSAENOBUFS;
      WSAEISCONN:Result:=_WSAEISCONN;
      WSAENOTCONN:Result:=_WSAENOTCONN;
      WSAESHUTDOWN:Result:=_WSAESHUTDOWN;
      WSAETOOMANYREFS:Result:=_WSAETOOMANYREFS;
      WSAETIMEDOUT:Result:=_WSAETIMEDOUT;
      WSAECONNREFUSED:Result:=_WSAECONNREFUSED;
      WSAELOOP:Result:=_WSAELOOP;
      WSAENAMETOOLONG:Result:=_WSAENAMETOOLONG;
      WSAEHOSTDOWN:Result:=_WSAEHOSTDOWN;
      WSAEHOSTUNREACH:Result:=_WSAEHOSTUNREACH;
      WSAENOTEMPTY:Result:=_WSAENOTEMPTY;
      WSAEPROCLIM:Result:=_WSAEPROCLIM;
      WSAEUSERS:Result:=_WSAEUSERS;
      WSAEDQUOT:Result:=_WSAEDQUOT;
      WSAESTALE:Result:=_WSAESTALE;
      WSAEREMOTE:Result:=_WSAEREMOTE;
      WSASYSNOTREADY:Result:=_WSASYSNOTREADY;
      WSAVERNOTSUPPORTED:Result:=_WSAVERNOTSUPPORTED;
      WSANOTINITIALISED:Result:=_WSANOTINITIALISED;
      WSAHOST_NOT_FOUND:Result:=_WSAHOST_NOT_FOUND;
      WSATRY_AGAIN:Result:=_WSATRY_AGAIN;
      WSANO_RECOVERY:Result:=_WSANO_RECOVERY;
      WSANO_DATA:Result:=_WSANO_DATA;
      else Result:=_WSAUNKNOWN+' ('+IntToCommaStr(ErrorCode)+')';
   end;
end;


function MakeBytesToWord(const A,B:Byte):Word;
begin
   Result:=(A shl 8)+B;
end;

procedure GetWinSocketVersion(WinsockInfo:PWinsockInfo);
begin
   with WinsockInfo^ do
   begin
     Major_Version:=BYTE(DllData.wVersion);
     Minor_Version:=Hi(DllData.wVersion);
     Highest_Major_Version:=BYTE(DllData.wHighVersion);
     Highest_Minor_Version:=Hi(DllData.wHighVersion);
     Move(DllData.szDescription,Description,256);
     Move(DllData.szSystemStatus,SystemStatus,128);
     MaxSockets:=DllData.iMaxSockets;
     MaxUDPDatagramSize:=DllData.iMaxUdpDg;
     VendorInfo:=DllData.lpVendorInfo;
   end;
end;



function WSocketIsDottedIP(const S : String) : Boolean;
var
    I          : Integer;
    DotCount   : Integer;
    NumVal     : Integer;
begin
    Result     := FALSE;
    DotCount   := 0;
    NumVal     := 0;
    I          := 1;
    { Skip leading spaces }
    while (S[I] = ' ') and (I <= Length(S)) do
        Inc(I);
    { Can't begin with a dot }
    if (I <= Length(S)) and (S[I] = '.') then
        Exit;
    { Scan full string }
    while I <= Length(S) do begin
        if S[I] = '.' then begin
            Inc(DotCount);
            if (DotCount > 3) or (NumVal > 255) then
                Exit;
            NumVal := 0;
            { A dot must be followed by a digit }
            if (I >= Length(S)) or (not (S[I + 1] in ['0'..'9'])) then
                Exit;
        end
        else if S[I] in ['0'..'9'] then
            NumVal := NumVal * 10 + Ord(S[I]) - Ord('0')
        else begin
            { Not a digit nor a dot. Accept spaces until end of string }
            while (S[I] = ' ') and (I <= Length(S)) do
                Inc(I);
            if I <= Length(S) then
                Exit;  { Not a space, do not accept }
            break;     { Only spaces, accept        }
        end;
        Inc(I);
    end;
    { We must have excatly 3 dots }
    if (DotCount <> 3) or (NumVal > 255) then
        Exit;
    Result := TRUE;

end;


function WindowHandleMessageProc(const WindowHandle: HWND; const Msg: Cardinal;
    const wParam, lParam: Integer): Integer; stdcall;
var V : TObject;
begin
  V := TObject(GetWindowLong(WindowHandle, 0)); // Get user data
  if V is TWindowHandle then
    Result := TWindowHandle(V).HandleWM(Msg, wParam, lParam) else
    Result := DefWindowProc(WindowHandle, Msg, wParam, lParam); // Default handler
end;

var
  WindowClass: TWndClass = (
      style         : 0;
      lpfnWndProc   : @WindowHandleMessageProc;
      cbClsExtra    : 0;
      cbWndExtra    : SizeOf(Pointer); // Size of extra user data
      hInstance     : 0;
      hIcon         : 0;
      hCursor       : 0;
      hbrBackground : 0;
      lpszMenuName  : nil;
      lpszClassName : 'FundamentalsWindowClass');

Destructor TWindowHandle.Destroy;
begin
  DestroyWindowHandle;
  inherited Destroy;
end;

procedure TWindowHandle.RaiseError(const Msg: String);
begin
  raise EWindowHandle.Create(Msg);
end;

function TWindowHandle.AllocateWindowHandle: HWND;
var C : TWndClass;
begin
  WindowClass.hInstance := HInstance;
  // Register class
  if not GetClassInfo(HInstance, WindowClass.lpszClassName, C) then
    if Windows.RegisterClass(WindowClass) = 0 then
      RaiseError('Window class registration failed: Windows error #' + IntToStr(GetLastError));

  // Allocate handle
  Result := CreateWindowEx(WS_EX_TOOLWINDOW,
                            WindowClass.lpszClassName,
                            '',        { Window name   }
                            WS_POPUP,  { Window Style  }
                            0, 0,      { X, Y          }
                            0, 0,      { Width, Height }
                            0,         { hWndParent    }
                            0,         { hMenu         }
                            HInstance, { hInstance     }
                            nil);      { CreateParam   }
  if Result = 0 then
    RaiseError('Window handle allocation failed: Windows error #' + IntToStr(GetLastError));

  // Set user data
  SetWindowLong(Result, 0, Integer(self));
end;

function TWindowHandle.HandleWM(const Msg: Cardinal; const wParam, lParam: Integer): Integer;
var Handled : Boolean;
begin
  Result := 0;
  Handled := False;
  try
    if Assigned(FOnMessage) then
      Result := FOnMessage(Msg, wParam, lParam, Handled);
    if not Handled then
      Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam); // Default handler
  except
    on E : Exception do
      begin
        if Assigned(FOnException) then
          FOnException(self, E);
        exit;
      end;
  end;
end;

function TWindowHandle.GetWindowHandle: HWND;
begin
  Result := FWindowHandle;
  if Result = 0 then
    begin
      FWindowHandle := AllocateWindowHandle;
      Result := FWindowHandle;
    end;
end;

procedure TWindowHandle.DestroyWindowHandle;
begin
  if FWindowHandle = 0 then
    exit;

  // Clear user data
  SetWindowLong(FWindowHandle, 0, 0);

  DestroyWindow(FWindowHandle);
  FWindowHandle := 0;
end;

function TWindowHandle.ProcessMessage: Boolean;
var Msg : TMsg;
begin
  if FTerminated then
    begin
      Result := False;
      exit;
    end;
  Result := PeekMessage(Msg, 0, 0, 0, PM_REMOVE);
  if Result then
    if Msg.Message = WM_QUIT then
      FTerminated := True else
      if FTerminated then
        Result := False else
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;
end;

procedure TWindowHandle.ProcessMessages;
begin
  While ProcessMessage do ;
end;

function TWindowHandle.HandleMessage: Boolean;
var Msg : TMsg;
begin
  if FTerminated then
    begin
      Result := False;
      exit;
    end;
  Result := GetMessage(Msg, 0, 0, 0);
  if not Result then
    FTerminated := True else
    if FTerminated then
      Result := False else
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg)
      end;
end;

procedure TWindowHandle.MessageLoop;
begin
  While HandleMessage do ;
end;

procedure TWindowHandle.Terminate;
begin
  FTerminated := True;
end;


Constructor TTimerHandle.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTimerInterval := 1000;
end;

procedure TTimerHandle.DestroyWindowHandle;
begin
  if not (csDesigning in ComponentState) and (FWindowHandle <> 0) and
      FTimerActive then
    KillTimer(FWindowHandle, 1);
  inherited DestroyWindowHandle;
end;

function TTimerHandle.DoSetTimer: Boolean;
begin
  if FTimerInterval <= 0 then
    Result := False else
    Result := SetTimer (GetWindowHandle, 1, FTimerInterval, nil) = 0;
end;

procedure TTimerHandle.Loaded;
begin
  inherited Loaded;
  if not (csDesigning in ComponentState) and FTimerActive then
    DoSetTimer;
end;

procedure TTimerHandle.TriggerTimer;
begin
  if Assigned(FOnTimer) then
    FOnTimer(self);
end;

procedure TTimerHandle.SetTimerActive(const TimerActive: Boolean);
begin
  if FTimerActive = TimerActive then
    exit;
  if [csDesigning, csLoading] * ComponentState = [] then
    if TimerActive then
      begin
        if not DoSetTimer then
          exit;
      end else
      KillTimer(FWindowHandle, 1);
  FTimerActive := TimerActive;
end;

function TTimerHandle.HandleWM(const Msg: Cardinal; const wParam, lParam: Integer): Integer;
begin
  if Msg = WM_TIMER then
    try
      Result := 0;
      TriggerTimer;
    except
      on E: Exception do
        begin
          Result := 0;
          if Assigned(FOnException) then
            FOnException(self, E);
          exit;
        end;
    end else
    Result := inherited HandleWM(Msg, wParam, lParam);
end;







initialization

{   StartupResult:=WSAStartup(MakeBytesToWord(2,2),DLLData);
   if StartupResult=0 then
   begin
      StartupResult:=999;
      // 6-9: added to load 1 time.
      GlobalTimeout.tv_Sec:=0;
      GlobalTimeout.tv_uSec:=500; //2500;
   end
   else StartupResult:=123;
 }
finalization
end.