Universal Agent on demond SDK --UAServiceAdapter(0分)

{******************************************************************************************}
{ }
{ 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;
proceduredo
Connect;
function do
DisConnect: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: Exceptiondo
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:Exceptiondo
// 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:Exceptiondo
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;

end;

procedure TUAServiceAdapter.Update(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.Update(SrvObjName,ServiceName,DataIn,DataOut);
except
on E:Exceptiondo
begin
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;

procedure TUAServiceAdapter.SetAddress(const Value: string);
begin
if Pos('.', Value) > 0 then
FSckt.Address := Value
else
FSckt.Host := Value;
end;

procedure TUAServiceAdapter.SetDispatchObject(const Value: IDispatch);
begin
if Value = nil then
SetOleObject(Null);
end;

procedure TUAServiceAdapter.SetIntercept(const Value: string);
begin
{$ifdef Ver140}
if (Length(Value) > 0) and (Value[1] = '{') then
FSckt.InterceptGUID := Value
else
FSckt.InterceptName := Value;
{$else
}
if (Length(Value) > 0) and (Value[1] = '{') then
FSckt.InterceptGUID := Value;
{$endif}
end;

procedure TUAServiceAdapter.SetOleObject(const Value: Variant);
begin

FOleObject := Value;
// if VarType(Value) <= varNull then
// FSckt.Connected := false;
end;

procedure TUAServiceAdapter.SetPort(const Value: integer);
begin
if Trim(IntToStr(Value))<>'' then
FSckt.Port := Value
else
FSckt.Port := 211;
//default Port
end;

procedure TUAServiceAdapter.SetServer(const Value: string);
begin
if (Length(Value) > 0) and (Value[1] = '{') then
FSckt.ServerGUID := Value
else
FSckt.ServerName := Value;
end;

procedure TUAServiceAdapter.DoConnect;
begin
try
try
if FSckt.Connected = false then
FSckt.Connected := true;
FConnected := true;
OleObject := FSckt.AppServer;
except
on E:Exceptiondo
begin
Showmessage('[ Socket Connect Internal Error ]'+#13 + 'Native Error Information:'+ E.Message);
FConnected := false;
end;
end;
finally
// Result := FConnected;
end;
end;

function TUAServiceAdapter.DoDisConnect: Boolean;
begin

Result := false;
try
try
if FSckt.Connected then
begin
FSckt.Connected := false;
FConnected := false;
OleObject := varNull;
Result := true;
end;
except
on E:Exceptiondo
begin
Result := false;
FConnected := false;
Showmessage('[Socket DisConnect Internal Error]'+#13 + 'Native Error Information :'+ E.Message);
end;
end;
finally
end;

end;

function TUAServiceAdapter.GetTryConnectTimes: LongInt;
begin
Result := FTryConnectTimes;
end;

function TUAServiceAdapter.GetWaitTimes: Cardinal;
begin
Result := FWaitTimes;
end;

procedure TUAServiceAdapter.SetTryConnectTimes(const Value: LongInt);
begin
FTryConnectTimes := Value;
end;

procedure TUAServiceAdapter.SetWaitTimes(const Value: Cardinal);
begin
FWaitTimes := Value;
end;

procedure TUAServiceAdapter.SetConnected(const Value: Boolean);
begin
if Value then
begin
if Connected then
Exit
else
do
Connect ;
end
else
begin
if not Connected then
Exit
else
do
DisConnect;
end;
end;

procedure TUAServiceAdapter.Loaded;
begin
inherited;
end;


function TUAServiceAdapter.GetConnected: Boolean;
begin
Result := FConnected;
end;

procedure TUAServiceAdapter.SetDataPacketEncrypt(const Value: Boolean);
begin
FDataPacketEncrypt := Value;
end;

procedure TUAServiceAdapter.SetCompressType(const Value: TCompressType);
begin
FCompressType := Value;
end;

function TUAServiceAdapter.ReadClientSetting(Sender: TComponent):Boolean;
var
Reg: TRegINIFile;
Sections: TStringList;
// IsCurr:Boolean;
begin
{$define uaDebug}
// IsCurr := false;
Reg := TRegINIFile.Create('');
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.OpenKey(KEY_UA_Client, True);
Sections := TStringList.Create;
try
Reg.ReadSections(Sections);
if Sections.Count <> 0 then
begin
Address := Reg.ReadString(csSettings,ckIP,'127.0.0.1');
{$ifdef uaDebug}
Server := 'JTServiceSrv.JtService';
{$else
}
Server := Server;
{$endif}
Port := Reg.ReadInteger(csSettings,ckPort,211);
WaitTimes:= Reg.ReadInteger(csSettings,ckWaitTimes,3000);
TryConnectTimes := Reg.ReadInteger(csSettings,ckTryConnectTimes,1);
IsLocalNet := Reg.ReadBool(csSettings,ckIsLocalNet,false);
Result := true;
end
else
begin
Result := false;
// ExecuteNetworkSetting(Self);
end;
finally
Sections.Free;
end;
finally
Reg.Free;
end;

end;

procedure TUAServiceAdapter.SetIsLocalNet(const Value: Boolean);
begin
FIsLocalNet := Value;
end;

function TUAServiceAdapter.ExecuteNetworkSetting(Sender: TComponent): Boolean;
begin
Result := ShowNetworkSetting(Sender);
end;

function TUAServiceAdapter.GetDataPacketType: TDataPacketType;
begin
Result := FDataPacketType;
end;

procedure TUAServiceAdapter.SetDataPacketType(
const Value: TDataPacketType);
begin
FDataPacketType := Value;
end;

function TUAServiceAdapter.GetSiteId: integer;
begin
Result := FSiteId;
end;

procedure TUAServiceAdapter.SetDefaultDBName(const Value: string);
begin
FDefaultDBName := Value;
end;

procedure TUAServiceAdapter.SetActiveDBName(const Value: string);
begin
FActiveDBName := Value;
end;

initialization

finalization

end.