dmbaseservice.pas

Delphi三层原代码掩饰及补丁

{-----------------------------------------------------------------------------
  Unit: dmBaseModule
  Author:    Aleyn.wu
  Date:      2002-05-12
  Descript: Base Module Service Class
-----------------------------------------------------------------------------}
unit dmBaseService;

interface
uses
  Classes, Windows, SysUtils, Variants, dmBaseModule, hmUniKey, hmMemTools, DB,
  hmSqlTools, hmOleDataSet, hmOleVariant, hmDateTools;

type
  TReceiveDataType = (rdDefault, rdCustom, rdResult, rdNoData);
  TServiceState = (srStart, srStop, srPause);

type
  TSafeInterfacedObject = class(TObject, IUnknown)
  protected
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: integer; stdcall;
    function _Release: integer; stdcall;
  end;

type
  TBaseOle = class;

  TBaseService = class(TSafeInterfacedObject, IBaseService)
  private
    FParent: TComponent;
    FOle: TBaseOle;
    FReceiveDataType: TReceiveDataType;
    FSqlLngDB: string;
    function GetReceiveDataType: TReceiveDataType;
  protected
    procedure InnerApplyUpdates(TableName, KeyField: WideString); stdcall;
    procedure InnerApplyUpdates2(TableName, KeyField: WideString); stdcall;
  public
    constructor Create(AOwner: TComponent);
    destructor Destroy; override;
    procedure Reset;
    function GetSqlLanguage(Index: integer; var Params, Body: WideString): Boolean; stdcall;
    function InTranstion: WordBool; stdcall;
    function GetInfo: WideString; stdcall;
    procedure ShowMessage(Msg: WideString); stdcall;
    procedure OpenQuery(Sql: WideString); stdcall;
    procedure CloseQuery; stdcall;
    procedure Execute(Sql: WideString); stdcall;
    procedure GetFieldNames(TableName: WideString; var FieldNames: WideString); stdcall;
    procedure BeginTrans; stdcall;
    procedure CommitTrans; stdcall;
    procedure RollbackTrans; stdcall;
    procedure ApplyUpdates(const Delta: OleVariant; TableName, KeyField: WideString); stdcall;
    procedure ApplyUpdatesWithOle(const DeltaName, TableName, KeyField: WideString); stdcall;
    procedure ApplyUpdatesRecordInfo(const DeltaName, TableName, KeyField: WideString); stdcall;
    procedure ApplyUpdatesWithDataSet(const DataSet: integer; TableName, KeyField: WideString); stdcall;
    procedure ReceiveDataWithDefault; stdcall;
    procedure ReceiveDataWithCustom; stdcall;
    procedure ReceiveDataWithResult; stdcall;
    procedure ReceiveDataWithNoData; stdcall;
    procedure RaiseError(Msg: WideString); stdcall;
    procedure DropTable(TableName: WideString); stdcall;
    procedure AssignQueryToDataSet(DataSetIndex: integer; DataSetField, QueryField: WideString); stdcall;
    procedure AssignDataSetToQuery(DataSetIndex: integer; DataSetField, QueryField: WideString); stdcall;
    function UniKey: Widestring; stdcall;
    function GetQuery: IHMOleADOQuery; stdcall;
    function GetDataSet(Index: integer): IHMOleClientDataSet; stdcall;
    function GetOle: IBaseOle; stdcall;
    function GetParams: IHMOleVariant; stdcall;
    function GetRecordsAffected: integer; stdcall;
    property ReceiveDataType: TReceiveDataType read GetReceiveDataType;
    property SqlLngDB:string read FSqlLngDB write FSqlLngDB;
  end;

  TBaseOle = class(TSafeInterfacedObject, IBaseOle)
  private
    FParent: TComponent;
  protected
    procedure AddDspAsName(Name: WideString); stdcall;
    procedure Clear; stdcall;
    function GetValue(Name: WideString): OleVariant; stdcall;
    procedure SetValue(Name: WideString; Value: OleVariant); stdcall;
  public
    constructor Create(AOwner: TComponent);
  end;

type
  TCreateDataModule = function(const BaseService: IBaseService): IBaseDataModule; stdcall;
  TCreateDataModuleInfo = function(): IDataModuleInfo; stdcall;

  PModuleLibrary = ^TModuleLibrary;
  TModuleLibrary = record
    ModuleIndex: Integer;
    LibHandle: THandle;
    CreateDataModule: TCreateDataModule;
    CreateDataModuleInfo: TCreateDataModuleInfo;
    ModuleState: TServiceState;
    FileName: pChar;
  end;

implementation

uses DataServer_form, swModuleIndex;

{ TSafeInterfacedObject }

function TSafeInterfacedObject._AddRef: integer;
begin
  Result := -1;
end;

function TSafeInterfacedObject._Release: integer;
begin
  Result := -1;
end;

function TSafeInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
const
  E_NOINTERFACE = $80004002;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := -1; {E_NOINTERFACE}
end;

{ TBaseService }

constructor TBaseService.Create(AOwner: TComponent);
begin
  inherited Create;
  FParent := AOwner;
  FReceiveDataType := rdNoData;
  FOle := TBaseOle.Create(AOwner);
end;

destructor TBaseService.Destroy;
begin
  FOle.Free;
  inherited;
end;

procedure TBaseService.BeginTrans;
begin
  (FParent as TDataServer2).Connection.BeginTrans;
end;

procedure TBaseService.CloseQuery;
begin
  (FParent as TDataServer2).Query.Close;
end;

procedure TBaseService.CommitTrans;
begin
  (FParent as TDataServer2).Connection.CommitTrans;
end;

procedure TBaseService.Execute(Sql: WideString);
begin
  //(FParent as TDataServer2).Cmd.CommandText := Sql;
  (FParent as TDataServer2).Cmd.Execute(Sql);
end;

procedure TBaseService.GetFieldNames(TableName: WideString;
  var FieldNames: WideString);
var
  FieldList: TStringList;
begin
  FieldList := TStringList.Create;
  (FParent as TDataServer2).Connection.GetFieldNames(TableName, FieldList);
  FieldNames := FieldList.Text;
  FieldList.Free;
end;

function TBaseService.GetInfo: WideString;
begin
  Result := 'ClassName:' + (FParent as TDataServer2).ClassName + ';ComponentName:' + (FParent as TDataServer2).Name;
end;

function TBaseService.GetSqlLanguage(Index: integer; var Params,
  Body: WideString): Boolean;
begin
  with (FParent as TDataServer2) do
    begin
      SqlLang.Close;
      SqlLang.SQL.Text := 'Select * from '+Trim(FSqlLngDB)+'..sqlClient where sq_StoreKey=' + inttostr(Index);
      SqlLang.Open;
      if (SqlLang.Active) and (SqlLang.RecordCount > 0) then
        begin
          Params := SqlLang['sq_Param'];
          Body := SqlLang['sq_Body'];
          Result := True;
        end
      else
        Result := False;
    end;
end;

function TBaseService.InTranstion: WordBool;
begin
  Result := (FParent as TDataServer2).Connection.InTransaction;
end;

procedure TBaseService.OpenQuery(Sql: WideString);
begin
  with (FParent as TDataServer2) do
    begin
      Query.Close;
      Query.SQL.Text := Sql;
    end; // with
end;

procedure TBaseService.RaiseError(Msg: WideString);
begin
  raise Exception.Create(Msg);
end;

procedure TBaseService.ReceiveDataWithCustom;
begin
  FReceiveDataType := rdCustom;
end;

procedure TBaseService.ReceiveDataWithDefault;
begin
  FReceiveDataType := rdDefault;
end;

procedure TBaseService.ReceiveDataWithResult;
begin
  FReceiveDataType := rdResult;
end;

procedure TBaseService.RollbackTrans;
begin
  (FParent as TDataServer2).Connection.RollbackTrans;
end;

procedure TBaseService.ShowMessage(Msg: WideString);
begin
  //(FParent as TDataServer2).Memo1.Lines.Add(Msg);
end;

function TBaseService.GetReceiveDataType: TReceiveDataType;
begin
  Result := FReceiveDataType;
end;

procedure TBaseService.Reset;
begin
  FReceiveDataType := rdNoData;
end;

function TBaseService.GetQuery: IHMOleADOQuery;
begin
  Result := (FParent as TDataServer2).Query.IDataSet;
end;

procedure TBaseService.ReceiveDataWithNoData;
begin
  FReceiveDataType := rdNoData;
end;

function TBaseService.UniKey: Widestring;
begin
  Result := hmUniKey.UniKey((FParent as TDataServer2).UKI);
end;

function TBaseService.GetRecordsAffected: integer;
begin
  Result := (FParent as TDataServer2).Cmd.RecordsAffected;
end;

procedure TBaseService.DropTable(TableName: WideString);
begin
  (FParent as TDataServer2).Cmd.Execute('Drop Table ' + TableName);
end;

procedure TBaseService.AssignQueryToDataSet(DataSetIndex: integer; DataSetField, QueryField: WideString); stdcall;
begin
  with (FParent as TDataServer2) do
    case DataSetIndex of //
      0: Pub1[DataSetField] := Query[QueryField];
      1: Pub2[DataSetField] := Query[QueryField];
      2: Pub3[DataSetField] := Query[QueryField];
    else
      raise Exception.Create('(GetDataSet)Pub DataSet Out Bound');
    end; // case
end;

procedure TBaseService.AssignDataSetToQuery(DataSetIndex: integer; DataSetField, QueryField: WideString); stdcall;
begin
  with (FParent as TDataServer2) do
    case DataSetIndex of //
      0: Query[QueryField] := Pub1[DataSetField];
      1: Query[QueryField] := Pub2[DataSetField];
      2: Query[QueryField] := Pub3[DataSetField];
    else
      raise Exception.Create('(GetDataSet)Pub DataSet Out Bound');
    end; // case
end;

function TBaseService.GetOle: IBaseOle;
begin
  Result := FOle;
end;

procedure TBaseService.ApplyUpdatesWithOle(const DeltaName, TableName, KeyField: WideString);
var
  Flag: boolean;
begin

  with (FParent as TDataServer2) do
    begin
      if VarIsNull(OleParams[DeltaName]) then exit;
      cdsDelta.Close;
      cdsDelta.Data := OleParams[DeltaName];
      Flag := cdsDelta.FindField('SYS_STATUS') <> nil;
    end; // with
  if Flag then
    InnerApplyUpdates2(TableName, KeyField)
  else
    InnerApplyUpdates(TableName, KeyField);
end;

procedure TBaseService.ApplyUpdates(const Delta: OleVariant; TableName, KeyField: WideString);
var