Chip 1999 March/Chip_1999-03_cd.bin/zkuste/delphi/INFO/DI9806JP.ZIP/Main.pas

Pascal/Delphi Source File | 1997-12-05 | 18KB | 568 lines

unit Main;

interface

uses
  Windows,  SysUtils, Classes, Controls, Forms, Dialogs,
  Winsock2, StdCtrls, Menus, ComCtrls, ExtCtrls, ComObj, WSAErr;

// Winsock version 2.2
const
 LoVer = 2;
 HiVer = 2;

type

//Record to store info from WSAEnumProtocols

  PWSProtoRec    = ^TWSProtoRec;
  TWSProtoRec    = record
                    ProtocolNo,
                    ProviderFlags :  Integer;
                    ConnectionLess,
                    MsgOriented,
                    Reliable,
                    StrmOriented,
                    GuaranteedD,
                    GuaranteedO,
                    PsuedoStrm,
                    GracefulClose,
                    Expedited,
                    ConnData,
                    DisConnData,
                    BroadCast,
                    MultiCast,
                    ControlPlaneRoot,
                    DataPlaneRoot,
                    QOS,
                    UniSend,
                    UniRecv,
                    IFSHandles,
                    PartialMsg  : BOOLEAN;
                    ProvID       : TGUID;
                    CatalogID    : DWORD;
                    Version,
                    AddrFamily,
                    MaxSockAddr,
                    MinSockAddr,
                    SocketType,
                    Protocol,
                    ProtocolOffset,
                    NetworkByteOrder,
                    SecurityScheme   : INTEGER;
                    MessageSize      : DWORD;
                    ProtocolName     : String;
                   end;


// Record to store info from WSAEnumNameSpaceProviders

  PWSNSPRec    = ^TWSNSPRec;
  TWSNSPRec    =   record
                    ProviderID : TGUID;
                    NameSpace  : DWORD;
                    Active     : BOOLEAN;
                    Version    : DWORD;
                    Identifier : String;
                   end;

  TfrmMain = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    MainMenu1: TMainMenu;
    sbStatusMsg: TStatusBar;
    File1: TMenuItem;
    Help1: TMenuItem;
    About1: TMenuItem;
    Exit1: TMenuItem;
    TabSheet2: TTabSheet;
    btnGetNPs: TButton;
    gbProtocols: TGroupBox;
    GroupBox1: TGroupBox;
    lbProtocols: TListBox;
    gbType: TGroupBox;
    cbConnLess: TCheckBox;
    cbMsgOriented: TCheckBox;
    cbStrmOriented: TCheckBox;
    cbGuaranteedD: TCheckBox;
    cbGuaranteedO: TCheckBox;
    cbPsuedoStrm: TCheckBox;
    cbGracefulClose: TCheckBox;
    cbExpedited: TCheckBox;
    cbConnData: TCheckBox;
    cbDisConnData: TCheckBox;
    cbBroadcast: TCheckBox;
    cbMulticast: TCheckBox;
    cbQOS: TCheckBox;
    cbUniSend: TCheckBox;
    cbUniRecv: TCheckBox;
    cbIFS: TCheckBox;
    cbPartialMsg: TCheckBox;
    gbMultipoint: TGroupBox;
    cbRootCtrlPlane: TCheckBox;
    cbRootDataPlane: TCheckBox;
    gbMiscellaneous: TGroupBox;
    edProtoVersion: TEdit;
    Label1: TLabel;
    edAddrFamily: TEdit;
    Label2: TLabel;
    edSocketType: TEdit;
    Label3: TLabel;
    edProtocol: TEdit;
    Label4: TLabel;
    edNetworkOrder: TEdit;
    edCatalogEID: TEdit;
    Label5: TLabel;
    Label6: TLabel;
    edNoProtocols: TEdit;
    Label7: TLabel;
    gbNameSpaces: TGroupBox;
    lbNameSpaceProviders: TListBox;
    gbMiscNSP: TGroupBox;
    ckbActive: TCheckBox;
    gbVersion: TGroupBox;
    edVersion: TEdit;
    gbIdentifier: TGroupBox;
    edIdentifier: TEdit;
    GroupBox2: TGroupBox;
    edNSPGuid: TEdit;
    gbProtocolGuid: TGroupBox;
    edProtocolGuid: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure About1Click(Sender: TObject);
    procedure lbProtocolsClick(Sender: TObject);
    procedure lbNameSpaceProvidersClick(Sender: TObject);
  private
    wsaData : TWSADATA;
    Started : Boolean;
    VerRqd  : WordRec;
    WSProtoInfo  : PWSProtoRec;
    WSProtoList  : TList;
    WSNSInfo     : PWSNSPRec;
    WSNSList     : TList;
    NoProtocols  : Integer;
    WSProtoListFreed,
    WSNSListFreed : Boolean;
    function Start : BOOLEAN;
    function GetAddrFamily(iAddressFamily : Integer) : String;
    function GetSocketType(iSocketType : Integer) : String;
    function GetProtocolType(iProtocol : Integer) : String;
    function GetNetworkOrder(iNetworkByteOrder : Integer) : String;
    procedure UpdateProtoFields;
    procedure UpdateNSPFields;
    procedure CleanUpLists;
    procedure GetProtocols;
    function  GetNameSpaceProviders(NameSpace : DWORD) : String;
    procedure GetNSProviders;
  end;

var
  frmMain: TfrmMain;

implementation

uses About;

{$R *.DFM}

// Maximum size of array for WSAEnumProtocols and WSAEnumNameSpaceProviders APIs

 const
  ArraySize  = 8192;

// This function checks for the correct WINSOCK

function TfrmMain.Start : BOOLEAN;
begin
 with VerRqd do
 begin
  Hi := HiVer;
  Lo := LoVer;
 end;
 Result := WSAStartUp(Word(VerRqd),wsaData) = 0;
end; // TfrmMain.Start

// Returns a string of address family

function TfrmMain.GetAddrFamily(iAddressFamily : Integer) : String;
begin
 case iAddressFamily of
  0 : Result := 'AF_UNSPEC';
  1 : Result := 'AF_UNIX';
  2 : Result := 'AF_INET';
  3 : Result := 'AF_IMPLINK';
  4 : Result := 'AF_PUP';
  5 : Result := 'AF_CHAOS';
  6 : Result := 'AF_IPX or AF_NS';
  7 : Result := 'AF_OSI or AF_ISO';
  8 : Result := 'AF_ECMA';
  9 : Result := 'AF_DATAKIT';
  10: Result := 'AF_CCITT';
  11: Result := 'AF_SNA';
  12: Result := 'AF_DLI';
  13: Result := 'AF_LAT';
  14: Result := 'AF_HYLINK';
  15: Result := 'AF_APPLETALK';
  16: Result := 'AF_NETBIOS';
  17: Result := 'AF_VOICEVIEW';
  18: Result := 'AF_FIREFOX';
  19: Result := 'AF_UNKNOWN1';
  20: Result := 'AF_BAN';
  21: Result := 'AF_ATM';
  22: Result := 'AF_INET6';
 end;// case
end; // TfrmMain.GetAddrFamily

// Returns a string of socket type

function TfrmMain.GetSocketType(iSocketType : Integer) : String;
begin
 case iSocketType of
  SOCK_STREAM    : Result := 'STREAM';
  SOCK_DGRAM     : Result := 'DATAGRAM';
  SOCK_RAW       : Result := 'RAW';
  SOCK_RDM       : Result := 'RDM';
  SOCK_SEQPACKET : Result := 'SPS';
 end;// case iSocketType
end; // TfrmMain.GetSocketType

// Returns a string of protocol type

function TfrmMain.GetProtocolType(iProtocol : Integer) : String;
begin
 case iProtocol of
  IPPROTO_IP    : Result := 'IP';
  IPPROTO_ICMP  : Result := 'ICMP';
  IPPROTO_IGMP  : Result := 'IGMP';
  IPPROTO_GGP   : Result := 'GATEWAY';
  IPPROTO_TCP   : Result := 'TCP';
  IPPROTO_PUP   : Result := 'PUP';
  IPPROTO_UDP   : Result := 'UDP';
  IPPROTO_IDP   : Result := 'XNS IDP';
  IPPROTO_ND    : Result := 'NDP';// Unofficial
  IPPROTO_RAW   : Result := 'RAW';
  IPPROTO_MAX   : Result := 'MAX'
  else Result   := '';
 end;// case iProtocol
end; // TfrmMain.GetProtocolType

// Returns a string of network byte order

function TfrmMain.GetNetworkOrder(iNetworkByteOrder : Integer) : String;
begin
 case iNetworkByteOrder of
  LITTLEENDIAN : Result := 'Little Endian';
  BIGENDIAN    : Result := 'Big Endian';
 end;// case iNetworkOrder
end; // TfrmMain.GetNetworkOrder

// Cleans up TLists and their objects

procedure TfrmMain.CleanUpLists;
var
 Count : Byte;
begin
 if not WSProtoListFreed then
 begin
 // Clean up WsProtoInfo items and free WSProtoList list
  if WSProtoList.Count > 0 then // we have entries
  begin
   for Count := 0 to WSProtoList.Count - 1 do
   begin
    WSProtoInfo := WSProtoList.Items[Count];
    Dispose(WSProtoInfo);
   end;
   WSProtoList.Free;
  end;
   WSProtoListFreed := TRUE;
 end;
 if not WSNSListFreed then
 begin
  if WSNSList.Count > 0 then
  begin
  // Clean up WSNSInfo items and free WSNSList list
   for Count := 0 to WSNSList.Count - 1 do
   begin
    WSNSInfo := WSNSList.Items[Count];
    Dispose(WSNSInfo);
   end;
   WSNSList.Free;
  end;
  WSNSListFreed := TRUE;
 end;
end; // TfrmMain.CleanUpLists

// Call Start and if successful initialize TLists, otherwise bomb...

procedure TfrmMain.FormCreate(Sender: TObject);
begin
 Started := Start;
 if not Started then
 begin
  ShowMessage('Cannot start Winsock 2.0!');
  Application.Terminate;
 end;
// We create a list to hold the Protocols data
 WSProtoList := TList.Create;
 WSProtoListFreed := FALSE; //
// We create a list to hold the Name Space Providers data
 WSNSList    := TList.Create;
 WSNSListFreed := FALSE;
 GetProtocols;
 GetNSProviders;
end; // TfrmMain.FormCreate

// Close the application

procedure TfrmMain.Exit1Click(Sender: TObject);
begin
// Check if we have initialized Winsock 2 DLL, and we close it down before
// we leave!
 if Started then
  WSACleanUp;
 CleanUpLists;
 Close;
end; // TfrmMain.Exit1Click

// Get the data for all Name Space Providers

procedure TfrmMain.GetNSProviders;
var
 NoNameProviders, NPCount : Integer;
 Buffer     : array[0..ArraySize] of char;
 BufferSize : PDWORD;
 lpNameSpaceProvider : PWSANAMESPACE_INFO;
 Offset, Size : Integer;
begin
 BufferSize := PDWORD(ArraySize);
 NoNameProviders := WSAEnumNameSpaceProviders(@BufferSize,@Buffer);
 if NoNameProviders = SOCKET_ERROR then
 begin
  sbStatusMsg.Panels[0].Text := 'Error : ' + WSAErrorMsg;
  ShowMessage('Call to WSAEnumNameSpaceProviders failed!');
  Exit;
 end;
 lpNameSpaceProvider :=  PWSANAMESPACE_INFO(@Buffer[0]);
 Size := SizeOf(lpNameSpaceProvider^);
 for NPCount := 0 to NoNameProviders - 1 do
 begin
// Create a new entry for a name space provider and then add the data to the list
  with lpNameSpaceProvider^ do
  begin
   New(WSNSInfo);
   with WSNSInfo^ do
   begin
    ProviderID    := NSProviderID;
    NameSpace     := dwNameSpace;
    Active        := fActive;
    Version       := dwVersion;
    Identifier    := String(lpszIdentifier);
   end;
   WSNSList.Add(WSNSInfo);
  end;// with lpNameSpaceProvider
  Offset := Size * NPCount;
  lpNameSpaceProvider := PWSANAMESPACE_INFO(@Buffer[Offset]);
 end;// for
// populate the Name Space Providers List box
 for NPCount := 0 to WSNSList.Count - 1 do
 begin
  WSNSInfo := WSNSList.Items[NPCount];
  lbNameSpaceProviders.Items.Add(GetNameSpaceProviders(WSNSInfo^.NameSpace));
 end;
 lbNameSpaceProviders.ItemIndex := 0;
// Populate other fields using lbNameSpaceProviders.ItemIndex marker to
// synchronize
 UpdateNSPFields;
end; // TfrmMain.GetNSProviders

procedure TfrmMain.UpdateProtoFields;
begin
 WSProtoInfo := WSProtoList.Items[lbProtocols.ItemIndex];
 with WSProtoInfo^ do
 begin
  cbConnLess.Checked          := ConnectionLess;
  cbMsgOriented.Checked       := MsgOriented;
  cbStrmOriented.Checked      := StrmOriented;
  cbGuaranteedD.Checked       := GuaranteedD;
  cbGuaranteedO.Checked       := GuaranteedO;
  cbPsuedoStrm.Checked        := PsuedoStrm;
  cbGracefulClose.Checked     := GracefulClose;
  cbExpedited.Checked         := Expedited;
  cbConnData.Checked          := ConnData;
  cbDisConnData.Checked       := DisConnData;
  cbBroadcast.Checked         := Broadcast;
  cbMulticast.Checked         := Multicast;
  if cbMulticast.Checked then
  begin
   cbRootCtrlPlane.Checked := ControlPlaneRoot;
   cbRootDataPlane.Checked := DataPlaneRoot;
   gbMultipoint.Visible    := TRUE;
  end else
  gbMultipoint.Visible     := FALSE;
  cbQOS.Checked            := QOS;
  cbUniSend.Checked        := UniSend;
  cbUniRecv.Checked        := UniRecv;
  cbIFS.Checked            := IFSHandles;
  cbPartialMsg.Checked     := PartialMsg;
  edCatalogEID.Text        := IntToStr(CatalogID);
  edProtocol.Text          := GetProtocolType(Protocol);
  edAddrFamily.Text        := GetAddrFamily(AddrFamily);
  edSocketType.Text        := GetSocketType(SocketType);
  edProtoVersion.Text      := IntToStr(Version);
  edNetworkOrder.Text      := GetNetworkOrder(NetworkByteOrder);
  edProtocolGUID.Text      := GuidToString(ProvID);
 end;
end; // TfrmMain.UpdateProtoFields

// Updates the contents in the controls on the NameSpaces page

procedure TfrmMain.UpdateNSPFields;
begin
 WSNSInfo := WSNSList.Items[lbNameSpaceProviders.ItemIndex];
 with WSNSInfo^ do
 begin
  ckbActive.Checked := Active;
  edVersion.Text := IntToStr(Lo(Version)) + '.' + IntToStr(Hi(Version));
  edIdentifier.Text := Identifier;
  with ProviderID do
   edNSPGuid.Text := GUIDToString(ProviderID);
 end;
end; // TfrmMain.UpdateNSPFields

// Get the data for all transport protocols

procedure TfrmMain.GetProtocols;
var
 lpProtocol : PWSAPROTOCOL_INFO;
 Buffer     : array[0..ArraySize] of char;
 BufferSize : PDWORD;
 ProtocolCount,
 Size, Offset : Integer;
begin
 NoProtocols := WSAEnumProtocols(NIL,@Buffer, @BufferSize);
 if  NoProtocols = SOCKET_ERROR then
 begin
  sbStatusMsg.Panels[0].Text := 'Error : ' + WSAErrorMsg;
  ShowMessage('Unable to enumerate protocols on this machine!');
 end else
 begin
  ProtocolCount := 0;
  lpProtocol := PWSAProtocol_Info(@Buffer[ProtocolCount]);
  Size := SizeOf(lpProtocol^);
  edNoProtocols.Text := IntToStr(NoProtocols);
  while ProtocolCount <= NoProtocols - 1 do
  begin
   with lpProtocol^ do
   begin
// Create a new entry for a protocol and then add the data to the list
    New(WSProtoInfo);
    with WSProtoInfo^ do
    begin
     ProtocolNo   := ProtocolCount + 1;
     ProtocolName := String(szProtocol);
     Version      := iVersion;
     AddrFamily   := iAddressFamily;
     SocketType   := iSocketType;
     Protocol     := iProtocol;
     NetworkByteOrder := iNetworkByteOrder;
     ProtocolOffset   := iProtocolMaxOffset;
     SecurityScheme   := iSecurityScheme;
     MaxSockAddr      := iMaxSockAddr;
     MinSockAddr      := iMinSockAddr;
     CatalogID        := dwCatalogEntryId;
     MessageSize      := dwMessageSize;
     ProvID           := ProviderID;
     ConnectionLess   := dwServiceFlags1 and XP1_CONNECTIONLESS <> 0;
     GuaranteedD      := dwServiceFlags1 and XP1_GUARANTEED_DELIVERY <> 0;
     GuaranteedO      := dwServiceFlags1 and XP1_GUARANTEED_ORDER <> 0;
     MsgOriented      := dwServiceFlags1 and XP1_MESSAGE_ORIENTED <> 0;
     PsuedoStrm       := dwServiceFlags1 and  XP1_PSEUDO_STREAM <> 0;
     GracefulClose    := dwServiceFlags1 and XP1_GRACEFUL_CLOSE <> 0;
     Expedited        := dwServiceFlags1 and XP1_EXPEDITED_DATA <> 0;
     ConnData         := dwServiceFlags1 and XP1_CONNECT_DATA <> 0;
     DisConnData      := dwServiceFlags1 and XP1_DISCONNECT_DATA <> 0;
     BroadCast        := dwServiceFlags1 and XP1_SUPPORT_BROADCAST <> 0;
     MultiCast        := dwServiceFlags1 and XP1_SUPPORT_MULTIPOINT <> 0;
     if MultiCast then
     begin
      ControlPlaneRoot := dwServiceFlags1 and XP1_MULTIPOINT_CONTROL_PLANE = 1;
      DataPlaneRoot    := dwServiceFlags1 and XP1_MULTIPOINT_DATA_PLANE = 1;
     end;
     QOS               := dwServiceFlags1 and  XP1_QOS_SUPPORTED <> 0;
     UniSend           := dwServiceFlags1 and  XP1_UNI_SEND <> 0;
     UniRecv           := dwServiceFlags1 and  XP1_UNI_RECV <> 0;
     IFSHandles        := dwServiceFlags1 and  XP1_IFS_HANDLES <> 0;
     PartialMsg        := dwServiceFlags1 and  XP1_PARTIAL_MESSAGE <> 0;
     ProviderFlags     := dwProviderFlags;
    end;
    WSProtoList.Add(WSProtoInfo);
   end;//
   inc(ProtocolCount);
   Offset := ProtocolCount * Size;
   lpProtocol  := PWSAProtocol_Info(@Buffer[Offset]);
  end;// while
//Populate Protocol Name field
  for ProtocolCount := 0 to WSProtoList.Count - 1 do
  begin
   WSProtoInfo := WSProtoList.Items[ProtocolCount];
   lbProtocols.Items.Add(WSProtoInfo^.ProtocolName);
  end;
  lbProtocols.ItemIndex := 0;
 end;
// Now populate other fields using lbProtocols.ItemIndex to synchronize the
// fields with the protocol name field
 UpDateProtoFields;
end;// TfrmMain.GetProtocols;

// Return a string of the NameSpace

function TfrmMain.GetNameSpaceProviders(NameSpace : DWORD) : String;
begin
 case NameSpace of
  NS_ALL                 : Result := 'ALL';
  NS_SAP                 : Result := 'SAP';
  NS_NDS                 : Result := 'NDS';
  NS_PEER_BROWSE         : Result := 'Peer Browse';
  NS_TCPIP_LOCAL         : Result := 'TCP/IP Local';
  NS_TCPIP_HOSTS         : Result := 'TCP/IP Hosts';
  NS_DNS                 : Result := 'DNS';
  NS_NETBT               : Result := 'NETBT';
  NS_WINS                : Result := 'WINS';
  NS_NBP                 : Result := 'NBP';
  NS_MS                  : Result := 'MS';
  NS_STDA                : Result := 'STDA';
  NS_NTDS                : Result := 'NTDS';
  NS_X500                : Result := 'X500';
  NS_NIS                 : Result := 'NIS';
  NS_NISPLUS             : Result := 'NISPLUS';
  NS_WRQ                 : Result := 'WRQ';
 end;// case NameSpace
end;// TfrmMain.GetNameSpaceProviders

// Show the About box..

procedure TfrmMain.About1Click(Sender: TObject);
begin
 frmAbout := TfrmAbout.Create(Self);
 frmAbout.ShowModal;
 frmAbout.Free;
end; // TfrmMain.About1Click

// Update the contents in the controls on the Protocols page

procedure TfrmMain.lbProtocolsClick(Sender: TObject);
begin
 UpdateProtoFields;
end; //  TfrmMain.lbProtocolsClick

// Update the contents in the controls on the NameSpaces page

procedure TfrmMain.lbNameSpaceProvidersClick(Sender: TObject);
begin
 UpdateNSPFields;
end; //TfrmMain.lbNameSpaceProvidersClick

end.