uaserviceadapter.pas

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

{******************************************************************************************}
{                                                                                          }
{       Universal Agent on demond SDK                                                      }
{                                                                                          }
{                                                                                          }
{ COPYRIGHT                                                                                }
{ =========                                                                                }
{ The UA SDK (software) is Copyright (C) 2001-2003, by vinson zeng(曾胡龙).                }
{ All rights reserved.                                                                     }
{ The authors - vinson zeng (曾胡龙),                                                      }
{ exclusively own all copyrights to the Advanced Application                               }
{ Controls (AppControls) and all other products distributed by Utilmind Solutions(R).      }
{                                                                                          }
{ LIABILITY DISCLAIMER                                                                     }
{ ====================                                                                     }
{ THIS SOFTWARE IS DISTRIBUTED "AS IS" AND WITHOUT WARRANTIES AS TO PERFORMANCE            }
{ OF MERCHANTABILITY OR ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED.                 }
{ YOU USE IT AT YOUR OWN RISK. THE AUTHOR WILL NOT BE LIABLE FOR DATA LOSS,                }
{ DAMAGES, LOSS OF PROFITS OR ANY OTHER KIND OF LOSS WHILE USING OR MISUSING THIS SOFTWARE.}
{                                                                                          }
{ RESTRICTIONS                                                                             }
{ ============                                                                             }
{ You may not attempt to reverse compile, modify,                                          }
{ translate or disassemble the software in whole or in part.                               }
{ You may not remove or modify any copyright notice or the method by which                 }
{ it may be invoked.                                                                       }
{******************************************************************************************}


unit UAServiceAdapter;

interface
uses
   SysUtils, Messages, Classes, Sconnect,Dialogs,
   Windows,Controls{$ifdef Ver140},Variants{$endif}
   ,Forms,UAUnits,Registry;
type

  TCompressType  = (ctHigh,ctNormal,ctFast);
  TDataPacketType = (dptUA,dptXML,dptBinary);


  TUAServiceAdapter  = class;


  TUAServiceAdapter = class(TComponent)
  private

    FSckt: TSocketConnection;
    FError: string;
    FWaitTimes:Cardinal;
    FTryConnectTimes:LongInt;
    FConnected:Boolean;
    FDataPacketEncrypt:Boolean;
    FCompressType: TCompressType;
    FIsLocalNet:Boolean;
    FDataPacketType:TDataPacketType;
    FOleObject:Variant;
    FDefaultDBName:string;
    FActiveDBName:string;
    function  GetAddress: string;
    function  GetIntercept: string;
    function  GetOleObject: Variant;
    function  GetServer: string;
    procedure SetAddress(const Value: string);
    procedure SetIntercept(const Value: string);
    procedure SetServer(const Value: string);
    function  GetPort: integer;
    procedure SetPort(const Value: integer);
    procedure SetOleObject(const Value: Variant);
    function  GetDispatchObject: IDispatch;
    procedure SetDispatchObject(const Value: IDispatch);

    function  GetTryConnectTimes: LongInt;
    function  GetWaitTimes: Cardinal;
    procedure SetTryConnectTimes(const Value: LongInt);
    procedure SetWaitTimes(const Value: Cardinal);
    procedure SetConnected(const Value: Boolean);
    function  GetConnected: Boolean;
    procedure SetDataPacketEncrypt(const Value: Boolean);
    procedure SetCompressType(const Value: TCompressType);
    procedure SetIsLocalNet(const Value: Boolean);
    function  GetDataPacketType: TDataPacketType;
    procedure SetDataPacketType(const Value: TDataPacketType);
    function  GetSiteId: integer;
    procedure SetDefaultDBName(const Value: string);
    procedure SetActiveDBName(const Value: string);

  protected

    FSiteId:integer;

    procedure DoConnect;
    function  DoDisConnect:Boolean;

    property OleObject: Variant read GetOleObject write SetOleObject;
    property DispatchObject: IDispatch read GetDispatchObject write SetDispatchObject;
    property Intercept: string read GetIntercept write SetIntercept;

  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure   Loaded; override;

    function  ExecuteNetworkSetting(Sender:TComponent):Boolean;
    function  ReadClientSetting(Sender:TComponent):Boolean;

    {not Support Tin Client Direct Call Server, and Developer can Call It By UAServiceClient(Component)}
    //memo 01 : by vinson zeng  for second version N-Tier Application Developer Kit
    //------------%% end of %% -------------------------------------------------------------

    procedure Request(const SrvObjName,ServiceName: WideString;DataIn: OleVariant; var DataOut: OleVariant); safecall;
    procedure Update (const SrvObjName,ServiceName: WideString;DataIn: OleVariant; var DataOut: OleVariant); safecall;
    procedure Execute(const SrvObjName,ServiceName: WideString;DataIn: OleVariant; var DataOut: OleVariant); safecall;


    property Error: string read FError;
    property IsLocalNet:Boolean read FIsLocalNet write SetIsLocalNet;
    property SiteId:integer read GetSiteId; // add by vinson zeng
    property ActiveDBName:string read FActiveDBName write SetActiveDBName;

  published

    property Address: string read GetAddress write SetAddress;
    property DataPacketEncrypt:Boolean read FDataPacketEncrypt write SetDataPacketEncrypt;
    property DataPacketCompressType:TCompressType read FCompressType write SetCompressType;

    property Port: integer read GetPort write SetPort default 211;
    property Server: string read GetServer write SetServer;
    property Connected :Boolean read GetConnected write SetConnected;
    property WaitTimes:Cardinal read GetWaitTimes write SetWaitTimes default 5000;
    property TryConnectTimes:LongInt read GetTryConnectTimes write SetTryConnectTimes default 3;
    property DataPacketType:TDataPacketType read GetDataPacketType write SetDataPacketType default dptXML;
    property DefaultDBName:string read FDefaultDBName write SetDefaultDBName;

  end;

implementation


{ TUAServiceAdapter }

constructor TUAServiceAdapter.Create(AOwner: TComponent);
begin

  inherited Create(AOwner);
  FSckt := TSocketConnection.Create(Self);
  FWaitTimes := 5000;
  FTryConnectTimes := 3;
  FSckt.Address := '127.0.0.1';
  FOleObject := varNull;

end;

destructor TUAServiceAdapter.Destroy;
begin


 if  FSckt.Connected then
    FSckt.Connected := false;
 FSckt.Free;
 inherited;

end;

function TUAServiceAdapter.GetAddress: string;
begin
  if FSckt.Address <> '' then
      Result := FSckt.Address
  else
      Result := FSckt.Host;
end;

function TUAServiceAdapter.GetDispatchObject: IDispatch;
begin
  Result := IDispatch(GetOleObject);
end;

function TUAServiceAdapter.GetIntercept: string;
begin
 {$ifdef Ver140}
  if (Length(FSckt.InterceptGUID) > 0) then
      Result := FSckt.InterceptGUID
  else
      Result := FSckt.InterceptName;
 {$else}
  if (Length(FSckt.InterceptGUID) > 0) then
      Result := FSckt.InterceptGUID;
 {$endif}
end;

function TUAServiceAdapter.GetOleObject: Variant;
begin

{  try
    if FSckt.Connected then
      Result := FSckt.AppServer;
  except
    on E: Exception do
       begin
         FError := E.Message;
       end;
  end;
 }
  Result := FOleObject;
end;

function TUAServiceAdapter.GetPort: integer;
begin
  Result  := FSckt.Port;
end;

function TUAServiceAdapter.GetServer: string;
begin
  if FSckt.ServerName <> '' then
      Result := FSckt.ServerName
  else
      Result := FSckt.ServerGuid;
end;


procedure TUAServiceAdapter.Request(const SrvObjName,ServiceName: WideString;
  DataIn: OleVariant; var DataOut: OleVariant);
var
//  sErrorCode:string;
  bConnected:Boolean;
  iConn:integer;

begin

//  iConn := FTryConnectTimes;

  bConnected := false;
  iConn := 0;
  while (iConn < FTryConnectTimes) and (not bConnected) do
  begin
    if not Connected  then
      Connected := true;
    try
      if Connected  = true then
      begin
         try
           OleObject.Request(SrvObjName,ServiceName,DataIn,DataOut);
           bConnected := true;
         except
//           on E:Exception do
//              begin
                Inc(iConn);
                bConnected := false;
                Connected  := false;

//                sErrorCode := '-31002';
//                Showmessage('error code is:'+sErrorCode + #13#10 +'error detail :'+
//                            '[Remote Service Adapter Error]'+#13 + 'Native Error Information :'+ E.Message);
//              end;
         end;
      end;
    finally

    end;
  end;
  
end;

procedure TUAServiceAdapter.Execute(const SrvObjName,ServiceName: WideString;
  DataIn: OleVariant; var DataOut: OleVariant);
var
  sErrorCode:string;
begin

  if not Connected  then
    Connected := true;

  try
    if Connected  = true then
    begin
      try
        OleObject.Execute(SrvObjName,ServiceName,DataIn,DataOut);
      except
        on E:Exception do
           begin
             sErrorCode := '-31003';
             Showmessage('error code is:'+sErrorCode + #13#10 +'error detail :'+
                         '[Remote Service Adapter Error]'+#13 + 'Native Error Information :'+ E.Message);

           end;
      end;
    end;
  finally

  end;