maclient.pas.~1~

三层cs结构实例 水平相当高的高人开发的软件 有要就留着用吧

unit MAClient;

interface

uses
  SysUtils, Classes, Windows, Variants, ADODB, IdTCPClient, IdTCPConnection,
  IdStack, MAConsts, MAClasses, MASocket, MADBIntf;

type
  TMABatchState = (bsNone, bsOpen, bsPost);

  TMAClient = class(TMAClientSocket)
  private
    FAutoConnect: Boolean;
    FBatchLevel: Integer;
    FBatchList: TList;
    FBatchState: TMABatchState;
    FConnectTimeout: Integer;
    FCatalog: string;
    FGroupID: string;
    FPassword: string;
    FEnabled: Boolean;
    FEncrypted: Boolean;
    FCompressed: Boolean;
    FTransLevel: Integer;
    FTCPClient: TIdTCPClient;
    FOnConnected: TNotifyEvent;
    FOnDisconnected: TNotifyEvent;
    FOnPacketResult: TMASocketPacketEvent;
    function GetHost: string;
    function GetPort: Integer;
    function GetCommandTimeout: Integer;
    procedure SetHost(const Value: string);
    procedure SetPort(const Value: Integer);
    procedure SetCommandTimeout(const Value: Integer);
    procedure SaveToStream(ARecordset: _Recordset; AStream: TStream);
    procedure LoadFromStream(var ARecordset: _Recordset; AStream: TStream);
  protected
    function RegisterClient(var AOptions: Integer): Word; override;
    procedure DoConnected(Sender: TObject);
    procedure DoDisconnected(Sender: TObject);
    procedure DoPacketResult(ASocket: TMASocket; APacket: TMASocketPacket); virtual;
    procedure BatchLoadData(BatchList: TList); virtual;
    procedure BatchPostData(BatchList: TList); virtual;
  public
    constructor Create; reintroduce;
    destructor Destroy; override;
    function Connected: Boolean;
    procedure Connect;
    procedure Disconnect;
    function BeginTrans: Integer;
    function Execute(const ASQL: string): Integer; virtual;
    function LoadData(const ASQL: string): _Recordset; virtual;
    procedure PostData(ARecordset: _Recordset); virtual;
    procedure PostPacket(APacket: TMASocketPacket); override;
    procedure CommitTrans;
    procedure RollbackTrans;
    procedure PostDataset(ADataset: TCustomADODataset);
    procedure OpenDataset(ADataset: TCustomADODataset; const ASQL: string = ''); overload;
    procedure BeginBatch;
    procedure CommitBatch;
    procedure RollbackBatch;
    property BatchState: TMABatchState read FBatchState;
    property Compressed: Boolean read FCompressed;
    property Encrypted: Boolean read FEncrypted;
    property CommandTimeout: Integer read GetCommandTimeout write SetCommandTimeout default 30000;
    property ConnectTimeout: Integer read FConnectTimeout write FConnectTimeout default 15000;
  published
    property AutoConnect: Boolean read FAutoConnect write FAutoConnect default True;
    property ClientInfo;
    property Enabled: Boolean read FEnabled write FEnabled default False;
    property Host: string read GetHost write SetHost;
    property Port: Integer read GetPort write SetPort default 10080;
    property Catalog: string read FCatalog write FCatalog;
    property Password: string read FPassword write FPassword;
    property GroupID: string read FGroupID write FGroupID;
    property OnConnected: TNotifyEvent read FOnConnected write FOnConnected;
    property OnDisconnected: TNotifyEvent read FOnDisconnected write FOnDisconnected;
    property OnPacketResult: TMASocketPacketEvent read FOnPacketResult write FOnPacketResult;
  end;

implementation

type
  TADODatasetCracker = class(TCustomADODataset);

resourcestring
{ Exception Message }
  SErr_BatchResult   = 'Batch operation result error!';
  SErr_BatchPostMode = 'Batch mode(Post Mode) conflict!';
  SErr_BatchOpenMode = 'Batch mode(Open Mode) conflict!';
  SErr_Session       = 'Socket session invalid!';
  SErr_Context       = 'Socket context error!';
  SErr_Unknown       = 'Command can not be identified!';
  SErr_Register      = 'Register client fail!';
  SErr_Failure       = 'Command executed fail!';
  SErr_License       = 'User License limited!';

{ TMAClient }

procedure TMAClient.BatchLoadData(BatchList: TList);
var
  I: Integer;
  SQL: string;
  Recordset: _Recordset;
  Packet: TMASocketPacket;
  MStream: TMultiStream;
begin
  for I := 0 to BatchList.Count - 1 do
  begin
    if SQL <> '' then SQL := SQL + #6;
    SQL := SQL + TADODatasetCracker(BatchList[I]).CommandText;
  end;
  I := Length(SQL);
  Packet := TMASocketPacket.Create(I);
  try
    Packet.WriteBuffer(SQL[1], I);
    Packet.Head.Command := CMD_BATCHLOAD;
    PostPacket(Packet);
    MStream := TMultiStream.Create(Packet, soReference);
    try
      if MStream.Count <> BatchList.Count then
        raise Exception.CreateRes(@SErr_BatchResult);
      for I := 0 to MStream.Count - 1 do
      begin
        MStream.Index := I;
        Recordset := nil;
        LoadFromStream(Recordset, MStream);
        TCustomADODataset(BatchList[I]).Recordset := Recordset as ADODB._Recordset;
      end;
    finally
      MStream.Free;
    end;
  finally
    Packet.Free;
  end;
end;

procedure TMAClient.BatchPostData(BatchList: TList);
var
  I: Integer;
  Recordset: _Recordset;
  Packet: TMASocketPacket;
  MStream: TMultiStream;
begin
  Packet := TMASocketPacket.Create;
  try
    MStream := TMultiStream.Create(Packet, soReference);
    try
      for I := 0 to BatchList.Count - 1 do
      begin
        MStream.Add;
        Recordset := TCustomADODataset(BatchList[I]).Recordset as _Recordset;
        SaveToStream(Recordset, MStream);
      end;
    finally
      MStream.Free;
    end;
    Packet.Head.Command := CMD_BATCHPOST;
    PostPacket(Packet);
    MStream := TMultiStream.Create(Packet, soReference);
    try
      if MStream.Count <> BatchList.Count then
        raise Exception.CreateRes(@SErr_BatchResult);
      for I := 0 to MStream.Count - 1 do
      begin
        MStream.Index := I;
        Recordset := TCustomADODataset(BatchList[I]).Recordset as _Recordset;
        LoadFromStream(Recordset, MStream);
        //TCustomADODataset(BatchList[I]).Recordset := Recordset as ADODB._Recordset;
      end;
    finally
      MStream.Free;
    end;
  finally
    Packet.Free;
  end;
end;

procedure TMAClient.BeginBatch;
begin
  if FBatchLevel = 0 then
    FBatchList := TList.Create;
  Inc(FBatchLevel);
end;

function TMAClient.BeginTrans: Integer;
begin
  if FTransLevel = 0 then
    PostCommand(CMD_BEGTRANS);
  Inc(FTransLevel);
  Result := FTransLevel;
end;

procedure TMAClient.CommitBatch;
var
  Dataset: TCustomADODataset;
begin
  if FBatchLevel > 0 then
  try
    Dec(FBatchLevel);
    if FBatchLevel = 0 then
      if FBatchList.Count = 1 then
      begin
        Dataset := FBatchList[0];
        FreeAndNil(FBatchList);
        if FBatchState = bsOpen then
          OpenDataset(Dataset)
        else
          PostDataset(Dataset);
      end else
      if FBatchList.Count > 1 then
        if FBatchState = bsOpen then
          BatchLoadData(FBatchList)
        else
          BatchPostData(FBatchList);
  finally
    if FBatchLevel = 0 then
    begin
      FreeAndNil(FBatchList);
      FBatchState := bsNone;
    end;
  end;
end;

procedure TMAClient.CommitTrans;
begin
  if FTransLevel > 0 then
  begin
    Dec(FTransLevel);
    if FTransLevel = 0 then
      PostCommand(CMD_ENDTRANS);
  end;
end;

constructor TMAClient.Create;
begin
  FAutoConnect := True;
  FCompressed := True;
  FTCPClient := TIdTCPClient.Create(nil);
  FTCPClient.OnConnected := DoConnected;
  FTCPClient.OnDisconnected := DoDisconnected;
  inherited Create(FTCPClient);
  Port := 10080;
  FConnectTimeout := 15000;
  CommandTimeout := 30000;
end;

destructor TMAClient.Destroy;
begin
  RollbackBatch;
  FTCPClient.Free;
  inherited;
end;

function TMAClient.Execute(const ASQL: string): Integer;
var
  Len: Integer;
  Packet: TMASocketPacket;
begin
  Len := Length(ASQL);
  Packet := TMASocketPacket.Create(Len);
  try
    Packet.WriteBuffer(ASQL[1], Len);
    Packet.Head.Command := CMD_EXECUTE;
    PostPacket(Packet);
    Result := Packet.Head.Param1;
  finally
    Packet.Free;
  end;
end;

function TMAClient.LoadData(const ASQL: string): _Recordset;
var
  Len: Integer;
  Packet: TMASocketPacket;
begin
  Result := nil;
  Len := Length(ASQL);
  Packet := TMASocketPacket.Create(Len);
  try
    Packet.WriteBuffer(ASQL[1], Len);
    Packet.Head.Command := CMD_LOADDATA;
    PostPacket(Packet);
    LoadFromStream(Result, Packet);
  finally
    Packet.Free;
  end;
end;

procedure TMAClient.OpenDataset(ADataset: TCustomADODataset; const ASQL: string);
var
  Recordset: _Recordset;
  SQL: string;
begin
  if FBatchList = nil then
  begin
    if ASQL = '' then
      SQL := TADODatasetCracker(ADataset).CommandText
    else
      SQL := ASQL;
    Recordset := LoadData(SQL);
    ADataset.Recordset := Recordset as ADODB._Recordset;
  end else
  if FBatchState <> bsPost then
  begin
    FBatchList.Add(ADataset);
    FBatchState := bsOpen;
  end else
    raise Exception.CreateRes(@SErr_BatchPostMode);
end;

procedure TMAClient.PostDataset(ADataset: TCustomADODataset);
var
  Recordset: _Recordset;
begin
  if FBatchList = nil then
  begin
    Recordset := ADataset.Recordset as _Recordset;
    PostData(Recordset);
    ADataset.CheckBrowseMode;
    //ADataset.Recordset := Recordset as ADODB._Recordset;
  end else
  if FBatchState <> bsOpen then
  begin
    FBatchList.Add(ADataset);
    FBatchState := bsPost;
  end else
    raise Exception.CreateRes(@SErr_BatchOpenMode);
end;

procedure TMAClient.RollbackBatch;
begin
  if FBatchLevel > 0 then
  begin
    Dec(FBatchLevel);
    if FBatchLevel = 0 then
    begin
      FreeAndNil(FBatchList);
      FBatchState := bsNone;
    end;
  end;
end;

procedure TMAClient.RollbackTrans;
begin
  if FTransLevel > 0 then
  begin
    Dec(FTransLevel);
    if FTransLevel = 0 then
      PostCommand(CMD_ROLLTRANS);
  end;
end;

procedure TMAClient.PostData(ARecordset: _Recordset);
var
  Packet: TMASocketPacket;
begin
  Packet := TMASocketPacket.Create;
  try
    SaveToStream(ARecordset, Packet);
    Packet.Head.Command := CMD_POSTDATA;
    PostPacket(Packet);
    LoadFromStream(ARecordset, Packet);
  finally
    Packet.Free;
  end;
end;

procedure TMAClient.DoConnected(Sender: TObject);
begin
  if Assigned(FOnConnected) then
    FOnConnected(Self);
end;

procedure TMAClient.DoDisconnected(Sender: TObject);
begin
  FTransLevel := 0;
  ResetCount;
  if Assigned(FOnDisconnected) then
    FOnDisconnected(Self)
end;

procedure TMAClient.PostPacket(APacket: TMASocketPacket);
begin
  //FTCPClient.CheckForGracefulDisconnect(not FAutoConnect);
  if not Connected then
    if FAutoConnect then
      Connect
    else
      FTCPClient.CheckForGracefulDisconnect;
  if Encrypted then
    APacket.Head.DataCode := APacket.Head.DataCode or DATA_ENCRYPT;
  inherited PostPacket(APacket);
  DoPacketResult(Self, APacket);
end;

function TMAClient.GetHost: string;
begin
  Result := FTCPClient.Host;
end;

function TMAClient.GetPort: Integer;
begin
  Result := FTCPClient.Port;
end;

function TMAClient.GetCommandTimeout: Integer;
begin
  Result := FTCPClient.ReadTimeout;
end;

procedure TMAClient.SetHost(const Value: string);
begin
  FTCPClient.Host := Value;
end;

procedure TMAClient.SetPort(const Value: Integer);
begin
  FTCPClient.Port := Value;
end;

procedure TMAClient.SetCommandTimeout(const Value: Integer);
begin
  FTCPClient.ReadTimeout := Value;
end;

procedure TMAClient.Connect;
var
  Opt: Integer;
begin
  FTCPClient.Connect(FConnectTimeout);
  RegisterClient(Opt);
end;

function TMAClient.Connected: Boolean;
begin
  try
    FTCPClient.CheckForGracefulDisconnect(False);
  except
    FTCPClient.Disconnect;
  end;
  Result := FTCPClient.Connected;
end;

procedure TMAClient.Disconnect;
begin
  FTCPClient.Disconnect;
end;

function TMAClient.RegisterClient(var AOptions: Integer): Word;
begin
  with TStringList.Create do
  try
    Delimiter := ';';
    DelimitedText := StringReplace(ClientInfo, ' ', '__', [rfReplaceAll]);
    Values['Catalog'] := FCatalog;
    Values['Password'] := FPassword;
    Values['GroupID'] := FGroupID;
    Values['Application'] := ExtractFileName(ParamStr(0));
    ClientInfo := StringReplace(DelimitedText, '__', ' ', [rfReplaceAll]);
  finally
    Free;
  end;
  Result := inherited RegisterClient(AOptions);
  if Result = RSP_SUCCESS then
  begin
    FCompressed := (AOptions and DATA_COMPRESS) = DATA_COMPRESS;
    FEncrypted := (AOptions and DATA_ENCRYPT) = DATA_ENCRYPT;
  end;
end;

procedure TMAClient.LoadFromStream(var ARecordset: _Recordset;
  AStream: TStream);
var
  ADOStream: TADOStream;
begin
  if AStream.Size > AStream.Position then
  begin
    ADOStream := TADOStream.Create(AStream, smRead);
    if ARecordset = nil then
      ARecordset := CoRecordset.Create
    else if ARecordset.State = adStateOpen then
      ARecordset.Close;
    ARecordset.CursorLocation := adUseClient;
    ARecordset.Open(ADOStream as IUnknown, EmptyParam, adOpenStatic,
      adLockBatchOptimistic, Integer(adOpenUnspecified));
    ADOStream.Flush;
  end;
end;

procedure TMAClient.SaveToStream(ARecordset: _Recordset; AStream: TStream);
var
  ADOStream: TADOStream;
begin
  if ARecordset.State = adStateOpen then
  begin
    ADOStream := TADOStream.Create(AStream, smWrite, FCompressed);
    ARecordset.Save(ADOStream as IUnknown, adPersistADTG);
    ADOStream.Flush;
  end;
end;

procedure TMAClient.DoPacketResult(ASocket: TMASocket;
  APacket: TMASocketPacket);
begin
  if Assigned(FOnPacketResult) then
    FOnPacketResult(ASocket, APacket)
  else
  case APacket.Head.Result of
    RSP_FAILURE: raise Exception.CreateRes(@SErr_failure);
    RSP_USRPASS: raise Exception.CreateRes(@SErr_Register);
    RSP_UNKNOWN: raise Exception.CreateRes(@SErr_Unknown);
    RSP_LICENSE: raise Exception.CreateRes(@SErr_License);
    RSP_SESSION: raise Exception.CreateRes(@SErr_Session);
    RSP_CONTEXT: raise Exception.CreateRes(@SErr_Context);
  end;
  if APacket.Head.Result = RSP_EXCEPTION then
    raise Exception.Create(APacket.DataString);
end;

end.