uasrvobj.~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 Name: uaSrvObj
 Author:    vinson zeng
 Purpose:
 History:
-----------------------------------------------------------------------------}


/// Bug report...
// EnableBCD 错误

/// Modify History...
/// add UA Exception Degine   2003-12-4 9:30
/// can not support blob data field process 2003-12-4 9:31
/// 对于 Null , 0 等临界值处理有陷阱漏洞出现 vinson zeng 2004-08-29..etc 
/// 对于SqlServer 发生事务处理异常时候，UA 应该根据扑捉到的异常级别来进行底层处理

unit uaSrvObj;

interface
uses
  Windows, Messages, SysUtils, Classes, DataBkr,DBClient,
  StdVcl,AdoDb,Contnrs,Variants,Provider,Forms,Db,SyncObjs,
  uaSrvObjDbConn,UADataPacket,UAServiceObjectPool,UAUnits;

type

  TuaServerObject = class(TComponent)
  private

    FPrepare:Boolean;
    FOperationTypes:TOperationType;
    FCurrServiceName:string;
    FAliasSrvObjName: string;

    FDBName:string;  // add by vinson zeng 2004-3-16

    procedure SetPrepare(const Value: Boolean);
    procedure SetOperationType(const Value: TOperationType);
    procedure SetCurrServiceName(const Value: string);
    function  GetCurrServiceName: string;
    procedure SetAliasSrvObjName(const Value: string);
    procedure SetDBName(const Value: string);

  protected

    FUARequestDataInPacket:TUARequestDataInPacket;
    FUARequestDataOutPacket:TUARequestDataOutPacket;

    FUAUpdateDataInPacket:TUAUpdateDataInPacket;
    FUAUpdateDataOutPacket:TUAUpdateDataOutPacket;

    FUAExecuteDataInPacket:TUAExecuteDataInPacket;
    FUAExecuteDataOutPacket:TUAExecuteDataOutPacket;



    function SubmitDelta(lAdoConn:TAdoConnection;sTblName:string;cdsSrc:TClientDataSet;
                         lFieldKeys:array of string;UpdateType:TUAUpdateTypes;
                         iFailMax:integer;var uaOut:TUAUpdateDataOutPacket):integer;virtual;


    //---------分析不好--------------------
    procedure AfterTriggerForDataSet(TableName:string;SrcDS:TDataSet;DestDS:TDataSet;var bHandle:Boolean);virtual;
    procedure BeforeTriggerForDataSet(TableName:string;SrcDS:TDataSet;DestDS:TDataSet;var bHandle:Boolean);virtual;

    //---------%% end of %% --------------

    procedure BeforeRequest(Sender:TObject;var bHandle:Boolean);virtual;
    procedure AfterRequest(Sender:TObject;var bContinue:Boolean);virtual;
    procedure BeforeUpdate(Sender:TObject;var bHandle:Boolean);virtual;
    procedure AfterUpdate(Sender:TObject;var bContinue:Boolean);virtual;
    procedure BeforeExecute(Sender:TObject;var bHandle:Boolean);virtual;
    procedure AfterExecute(Sender:TObject;var bContinue:Boolean);virtual;

    procedure StartSyncTrans;
    procedure CommitSyncTrans;
    procedure RollbackSyncTrans;
    function  InSyncTrans:Boolean;

    procedure ExLockDbConnection; // add by vinson zeng 2004-3-16
    procedure ExUnlockDbConnection;  // add by vinson zeng 2004-3-16

    function  SubmitAllDelta(bStartTrans:Boolean;AllDelta:OleVariant):integer;

    function  BuildDeltaArray(aUAUpdateDataInPacket:TUAUpdateDataInPacket):Variant;

    function  GetAllRecCount(var TableName:string;const sWhere:string= ''):integer;

    function  RequestData(Sender:TObject;var vOutData:OleVariant):integer;

    function  GetTableStru(vDataIn:OleVariant;var vOutData:OleVariant):integer; //fix by vinson zeng at 2003-10-03

    function  BuildMasterLinkSqlScript(aUARequestInPacket:TUARequestDataInPacket):string;
    function  BuildRowSheetSqlScript(aUARequestInPacket:TUARequestDataInPacket):string;

    function  ReleaseAllDS(adoDS:TAdoDataSet;Dsp:TDataSetProvider;Cds:TClientDataSet):integer;

    function  RefreshData(Sender:TObject;var vOutData:OleVariant):integer;
    function  QueryData(Sender:TObject;var vOutData:OleVariant):integer;

    function  OpenSrvData(adoDS:TAdoDataSet;Dsp:TDataSetProvider;Cds:TClientDataSet):integer;
    function  ExecAnySql(OperationType:TOperationType;sSql:string):integer;

    function  QueryViewData(sSqlScript:string;var vOutData:OleVariant):integer;

    function  ExecuteStoredProc(ProcName: string;VarValue: Variant;var VarReturn:Variant
                                ;const bStartTrans: Boolean = false;const bReturnRecordSet:Boolean = false):integer; virtual; //add on 2003-10-16

    function  GetUAErrorCount(OperationType:TOperationType):integer;

    function  RequestCustomData(ServiceName:WideString;vcInData:OleVariant;var vcOutData:OleVariant):integer;virtual;abstract;
    function  UpdateCustomDelta(ServiceName:WideString;vcInData:OleVariant;var vcOutData:OleVariant):integer;virtual;abstract;

    procedure InitForRequest(var DataIn:OleVariant;var DataOut:OleVariant);virtual;
    procedure InitForUpdate (var DataIn:OleVariant;var DataOut:OleVariant);virtual;
    procedure InitForExecute(var DataIn:OleVariant;var DataOut:OleVariant);virtual;

    //----- add by vinson zeng 2004-07-30...etc
    function  GetMsSqlLastError(const bRefresh:Boolean = false):string;
    //----- %% end of %% ----------------------

    //---- add by vinson zeng 2004-09-02...etc
  //  function  CalcDataPage(sTableName:string;sWhere:string;const RecPacketCount = 300):integer;
    //---- %% end of %% -----------------------------

  public

    FSyncTransaction:Boolean;
    DbConnection:TAdoConnection;


    constructor Create; virtual;
    destructor  Destroy; override;

    function  MakeUAExceptionMsg(UAExcepions: TUAExcepions;EMsg:Exception;const ExtMsg:string =''):integer;

    procedure Request(ServiceName: WideString; DataIn: OleVariant;var DataOut: OleVariant); virtual;
    procedure Update (ServiceName: WideString; DataIn: OleVariant;var DataOut: OleVariant); virtual;
    procedure Execute(ServiceName: WideString; DataIn: OleVariant;var DataOut: OleVariant); virtual;

    property  Prepare:Boolean read FPrepare  write SetPrepare default false;
    property  OperationTypes:TOperationType read FOperationTypes write SetOperationType;
    property  CurrServiceName:string read GetCurrServiceName write SetCurrServiceName;
    property  AliasSrvObjName:string read FAliasSrvObjName write SetAliasSrvObjName;
    property  DBName:string read FDBName write SetDBName;

  end;


function xStrSplit(str:string; chars:CharSet; tsStrs:TStrings;AutoClear: Boolean; bTrim:Boolean):integer;


implementation
uses UASystem;


function xStrSplit(str:string; chars:CharSet; tsStrs:TStrings;AutoClear: Boolean; bTrim:Boolean):integer;
var
    n, i, k : integer;
    s : string;
begin
  Result := 0;
  if chars=[] then
  	chars := [',',';'];
  if tsStrs=nil then Exit;
  if AutoClear then
	  tsStrs.Clear;
  k := Length(str);
  if (k=0) then Exit;
  i := 1;
  for n:=1 to k do
    if str[n] in chars then begin
      s := Copy(Str, i, n-i);
      if bTrim then s:=Trim(s);
      tsStrs.Add(s);
      i := n+1;
      Inc(Result);
    end;
  if i<=k then begin
    s := Copy(Str, i, n-i);
    if bTrim then s:=Trim(s);
    tsStrs.Add(s);
    Inc(Result);
  end;
end;


{ TuaServerObject }

procedure TuaServerObject.AfterExecute(Sender: TObject;var bContinue:Boolean);
begin

end;

procedure TuaServerObject.AfterRequest(Sender: TObject;var bContinue:Boolean);
begin

end;

procedure TuaServerObject.AfterUpdate(Sender: TObject;var bContinue:Boolean);
begin

end;


procedure TuaServerObject.BeforeExecute(Sender: TObject;
  var bHandle: Boolean);
begin

end;

procedure TuaServerObject.BeforeRequest(Sender: TObject;
  var bHandle: Boolean);
begin

end;

procedure TuaServerObject.BeforeUpdate(Sender: TObject;
  var bHandle: Boolean);
begin

end;

function TuaServerObject.BuildDeltaArray(aUAUpdateDataInPacket: TUAUpdateDataInPacket): Variant;
var
  i,iCount:integer;
  aDeltaParam:TDeltaParam;
begin

  if aUAUpdateDataInPacket = nil then Exit;

  iCount := aUAUpdateDataInPacket.CountItemDelta;
  Result := VarArrayCreate([0,iCount-1], varVariant);

  VarArrayLock(Result);
  try
    for i := 0 to iCount -1 do
    begin
      aDeltaParam := aUAUpdateDataInPacket.GetItemDelta(i);
      Result[i] := aDeltaParam.UAData;
    end;
  finally
    VarArrayUnlock(Result);
  end;

end;

function TuaServerObject.BuildMasterLinkSqlScript(aUARequestInPacket: TUARequestDataInPacket): string;
var
  i:integer;
  aMasterLinkParam:TMasterLinkParam;

begin

  Result := '';

  if not Assigned(aUARequestInPacket) then Exit;

  for i := 0 to aUARequestInPacket.CountMasterLink -1 do
  begin
    try
      aMasterLinkParam := aUARequestInPacket.GetItemMasterLink(i);
      if Trim(Result) <> '' then Result := Result +' and ';
      Result := Result + ' ('+ aMasterLinkParam.MasterField+'='+ FieldValueToSqlStr(aMasterLinkParam.DataType,aMasterLinkParam.MasterFieldValue)+' )';
    finally
    end;
  end;

  if Trim(Result) <> '' then
  begin
    Result := ' ('+ Result +' )';
  end;

end;

function TuaServerObject.BuildRowSheetSqlScript(aUARequestInPacket: TUARequestDataInPacket): string;
var
  i:integer;
  aRowSheetParam:TRowSheetParam;
begin
  Result := '';

  if not Assigned(aUARequestInPacket) then Exit;

  for i := 0 to aUARequestInPacket.CountRowSheet -1 do
  begin
    try
      aRowSheetParam  := aUARequestInPacket.GetItemRowSheet(i);
      if Trim(Result) <> '' then Result := Result +' and ';
      Result := Result + ' ('+ aRowSheetParam.FieldName + '<>' + FieldValueToSqlStr(aRowSheetParam.FieldType,aRowSheetParam.CurrValue)+' )';
    finally
    end;
  end;

  if Trim(Result) <> '' then
  begin
    Result := ' ('+ Result +' )';
  end;

end;

procedure TuaServerObject.CommitSyncTrans;
begin
  if InSyncTrans and (not FSyncTransaction) then
  begin
    DbConnection.CommitTrans;
    UADebugEx(ddCommitTrans,Now(),DbConnection,'Commit Transaction');
  end;
end;

constructor TuaServerObject.Create;
begin

  FSyncTransaction := false;

  FUARequestDataInPacket := TUARequestDataInPacket.Create;
  FUARequestDataOutPacket:= TUARequestDataOutPacket.Create;

  FUAUpdateDataInPacket := TUAUpdateDataInPacket.Create;
  FUAUpdateDataOutPacket:= TUAUpdateDataOutPacket.Create;

  FUAExecuteDataInPacket:= TUAExecuteDataInPacket.Create;
  FUAExecuteDataOutPacket:= TUAExecuteDataOutPacket.Create;


end;


destructor TuaServerObject.Destroy;
begin

  FUAUpdateDataInPacket.Free;
  FUAUpdateDataOutPacket.Free;

  FUAExecuteDataInPacket.Free;
  FUAExecuteDataOutPacket.Free;

  Inherited;

end;

function TuaServerObject.ExecAnySql(OperationType:TOperationType;sSql: string):integer;
var
  adoQry:TAdoQuery;

begin

  Result := -1;

  if trim(sSql) = '' then Exit;
  if DbConnection = nil then Exit;
  adoQry := TAdoQuery.Create(Self);
  adoQry.Name := UniqueName(adoQry,'ado_Qry_Tmp',Self);
  try
    try
      adoQry.Connection := DbConnection;
      adoQry.Close;
      adoQry.SQL.Clear;
      adoQry.SQL.Add(sSql);
      Result := adoQry.ExecSQL;
    except
      on E:Exception do
         begin
           Result := MakeUAExceptionMsg(UA_E_EXEC_SQL_STATEMENTS,E,GetMsSqlLastError());
         end;
    end;
  finally