rdmunit.pas

三层的通用架构

unit RDMUnit;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, Forms, ComServ, ComObj, VCLCom,
  DataBkr, DBClient, bckj_TLB, StdVcl, Provider, DB, ADODB, ExtCtrls,
  ActiveX, Variants;

type
  TDefaultRDM = class(TRemoteDataModule, IDefaultRDM)
    DefaultRDMADOConnection: TADOConnection;
    DefaultRDMADOQuery: TADOQuery;
    DefaultRDMProvider: TDataSetProvider;
    Timer1: TTimer;
    procedure RemoteDataModuleCreate(Sender: TObject);
    procedure RemoteDataModuleDestroy(Sender: TObject);
    procedure DefaultRDMADOConnectionBeforeConnect(Sender: TObject);
    procedure DefaultRDMADOConnectionAfterConnect(Sender: TObject);
    procedure DefaultRDMADOConnectionBeforeDisconnect(Sender: TObject);
    procedure DefaultRDMProviderGetData(Sender: TObject;
      DataSet: TCustomClientDataSet);
    procedure DefaultRDMProviderUpdateData(Sender: TObject;
      DataSet: TCustomClientDataSet);
    procedure DefaultRDMProviderGetTableName(Sender: TObject;
      DataSet: TDataSet; var TableName: String);
    procedure DefaultRDMProviderUpdateError(Sender: TObject;
      DataSet: TCustomClientDataSet; E: EUpdateError;
      UpdateKind: TUpdateKind; var Response: TResolverResponse);
    procedure DefaultRDMProviderBeforeUpdateRecord(Sender: TObject;
      SourceDS: TDataSet; DeltaDS: TCustomClientDataSet;
      UpdateKind: TUpdateKind; var Applied: Boolean);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    FMins: Integer;
    FLogin, FSelf: Boolean;
    FUserName, FUserRealName, FUserAliasName, FName, FTableName: string;
    FLoginTimes: Byte;
    FErrorStrings, FFieldIndexs: TStringList;
    FCOMLib: array[0..9] of Cardinal;
    FObj: array[0..9] of OleVariant;
    FCustomObj: OleVariant;
    FClassName: string;
  protected
    class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
    function Login(const UserName, Password: WideString;
      EncryptFlag: WordBool): WordBool; safecall;
    function AddSQL(ClearFlag: WordBool; const SQLString: WideString;
      ExecFlag: WordBool): WordBool; safecall;
    function ChangePassword(const OldPassword, NewPassword: WideString;
      EncryptFlag: WordBool): WordBool; safecall;
    function GetErrorString(Index: Integer): WideString; safecall;
    procedure SetUpdateTableName(const TableName, FieldIndexs: WideString ); safecall;
    function GetUserInfo(AllUsersFlag: WordBool): WideString; safecall;
    function ProcessPassword(const BasicStr, Value: WideString;
      ToNatural: WordBool): WideString; safecall;
    function GetProcedureNames: WideString; safecall;
    function GetTableNames(SystemTables: WordBool): WideString; safecall;
    function GetFieldNames(const TableName: WideString): WideString; safecall;
    function GetRegisterUser: WideString; safecall;
    function SetUserValue(const UserName, Value: WideString): WordBool;
      safecall;
    function GetDateTime: TDateTime; safecall;
    procedure BeginTrans; safecall;
    procedure CommitTrans(RollbackFlag: WordBool); safecall;
    procedure RollbackTrans; safecall;
    function Get_Object0: OleVariant; safecall;
    function Get_Object1: OleVariant; safecall;
    function Get_Object2: OleVariant; safecall;
    function Get_Object3: OleVariant; safecall;
    function Get_Object4: OleVariant; safecall;
    function Get_Object5: OleVariant; safecall;
    function Get_Object6: OleVariant; safecall;
    function Get_Object7: OleVariant; safecall;
    function Get_Object8: OleVariant; safecall;
    function Get_Object9: OleVariant; safecall;
    function Get_CustomObject: OleVariant; safecall;
    function ConnectNewObject(const TheClassName: WideString): WordBool; safecall;
    procedure DisConnectObject; safecall;
    function ProcessPassword2(const BasicStr, Value: WideString): WideString;
      safecall;
    function StringEncrypt(const SourceString, Password: WideString;
      EncryptFlag: WordBool): WideString; safecall;
    function StringCompress(const SourceString: WideString;
      CompressFlag: WordBool): WideString; safecall;
  public
    { Public declarations }
  end;

function CshComserver: Boolean;

var
  CurrentRDM: Byte = 10;
  RDM: Cardinal;
  FFactory: TComponentFactory;
  Instancing: TClassInstancing = ciMultiInstance;
  CurrentThreadModel: TThreadingModel = tmApartment;
  CanConnectMins: Integer;
  SelfString: string;

implementation

uses
  MainUnit, ShareUnit, RDM1Unit, RDM2Unit, RDM3Unit, RDM4Unit, RDM5Unit, RDM6Unit, RDM7Unit, RDM8Unit, RDM9Unit;

{$R *.DFM}

function CshComserver: Boolean;
begin
  if FCshSuccess then
  begin
    if CurrentRDM > 9 then
      Instancing := ciInternal
    else
      Instancing := ciMultiInstance;
    try
      case CurrentRDM of
        1:
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM1,
            Class_DefaultRDM1, Instancing, CurrentThreadModel);
        2:
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM2,
            Class_DefaultRDM2, Instancing, CurrentThreadModel);
        3:
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM3,
            Class_DefaultRDM3, Instancing, CurrentThreadModel);
        4:
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM4,
            Class_DefaultRDM4, Instancing, CurrentThreadModel);
        5:
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM5,
             Class_DefaultRDM5, Instancing, CurrentThreadModel);
        6:
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM6,
            Class_DefaultRDM6, Instancing, CurrentThreadModel);
        7:
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM7,
            Class_DefaultRDM7, Instancing, CurrentThreadModel);
        8:
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM8,
            Class_DefaultRDM8, Instancing, CurrentThreadModel);
        9:
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM9,
            Class_DefaultRDM9, Instancing, CurrentThreadModel);
        else
          FFactory := TComponentFactory.Create(ComServer, TDefaultRDM,
            Class_DefaultRDM, Instancing, CurrentThreadModel);
      end;
      ComServer.UIInteractive := False;
      if ComServer.StartMode = smAutomation then
        SystemParams.Values['Automation'] := 'Y';
    except
      FCshSuccess := False;
    end;
  end;
  Result := FCshSuccess;
end;

class procedure TDefaultRDM.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
begin
  if Register then
  begin
    inherited UpdateRegistry(Register, ClassID, ProgID);
    EnableSocketTransport(ClassID);
    EnableWebTransport(ClassID);
  end else
  begin
    DisableSocketTransport(ClassID);
    DisableWebTransport(ClassID);
    inherited UpdateRegistry(Register, ClassID, ProgID);
  end;
end;

procedure TDefaultRDM.RemoteDataModuleCreate(Sender: TObject);
var
  i: Integer;
  DLL, FUN: string;
  ComFun: TCOMDLLFunction;
begin
  FLogin := False;
  FSelf := False;
  FName := '<尚未登录>';
  FUserName := '';
  FUserRealName := '';
  FUserAliasName := '';
  FTableName := '';
  FLoginTimes := 0;
  FMins := 0;
  Lock;
  for i := 0 to 9 do
  begin
    TheMainForm.GetCOMFun(i, DLL, FUN);
    FCOMLib[i] := 0;
    FObj[i] := Unassigned;
    if DLL <> '' then
      FCOMLib[i] := LoadLibrary(PChar(DLL));
    @ComFun := nil;
    if FCOMLib[i] > 0 then
      @ComFun := GetProcAddress(FCOMLib[i], PChar(FUN));
    if @ComFun <> nil then
      try
        FObj[i] := ComFun;
        FObj[i].ADOConnection := Integer(Pointer(DefaultRDMADOConnection));
      except
      end;
  end;
  FCustomObj := Unassigned;
  FClassName := '';
  FErrorStrings := TStringList.Create;
  FFieldIndexs := TStringList.Create;
  if RDM < High(Cardinal) then
    RDM := RDM + 1;
  if RDM > 0 then
    TheMainForm.DoSetStatusBar;
  Connections.Values[IntToStr(Integer(Pointer(Self)))] := FName;
  TheMainForm.Timer3.Enabled := True;
  Unlock;
end;

procedure TDefaultRDM.RemoteDataModuleDestroy(Sender: TObject);
var
  ViewString: string;
  i: Integer;
begin
  if FLogin then
    ViewString := '[' + GetCurrentDateTime + '] 用户 ' + FName + ' 断开连接';
  for i := 0 to 9 do
  begin
    FObj[i] := Unassigned;
    Sleep(0);
    if FCOMLib[i] > 0 then
      FreeLibrary(FCOMLib[i]);
  end;
  FCustomObj := Unassigned;
  FClassName := '';
  FFieldIndexs.Free;
  FErrorStrings.Free;
  DefaultRDMADOQuery.Active := False;
  DefaultRDMADOConnection.Connected := False;
  Lock;
  if RDM > 0 then
    RDM := RDM - 1;
  if RDM > 0 then
    TheMainForm.DoSetStatusBar;
  if FLogin and not FSelf then
    TheMainForm.DoAddViewString(ViewString);
  if Connections.IndexOfName(IntToStr(Integer(Pointer(Self)))) <> -1 then
    Connections.Delete(Connections.IndexOfName(IntToStr(Integer(Pointer(Self)))));
  Unlock;
end;

function TDefaultRDM.Login(const UserName, Password: WideString;
  EncryptFlag: WordBool): WordBool;
var
  ViewString, ErrorString: string;
begin
  FCustomObj := Unassigned;
  FClassName := '';
  if (UserName <> '') and (UserName = SelfString) then
  begin
    FSelf := True;
    Lock;
    if Connections.IndexOfName(IntToStr(Integer(Pointer(Self)))) <> -1 then
      Connections.Delete(Connections.IndexOfName(IntToStr(Integer(Pointer(Self)))));
    Unlock;
    Exit;
  end;
  if FSelf then
  begin
    FLogin := TheMainForm.CheckCurrentUser(string(UserName), string(Password), FUserName, FUserRealName, FUserAliasName, Boolean(EncryptFlag));
    Result := FLogin;
    if FLogin then
    begin
      FClassName := TheMainForm.GetCustomObjectClassName(FUserRealName);
      if FClassName <> '' then
        try
          FCustomObj := CreateOleObject(FClassName);
        except
          FClassName := '';
        end;
    end;
    Exit;
  end;
  if FLogin then
  begin
    ViewString := '[' + GetCurrentDateTime + '] 用户 ' + FName + ' 退出';
    DefaultRDMADOQuery.Prepared := False;
    DefaultRDMADOConnection.Connected := False;
    DefaultRDMADOConnection.ConnectionString := '';
    FLoginTimes := 0;
  end
  else
    ViewString := '[' + GetCurrentDateTime + '] 用户 ' + string(UserName) + ' ';
  FLoginTimes := FLoginTimes + 1;
  if FLoginTimes > 3 then
    ErrorString := '尝试登录3次不成功,必须重新建立连接才允许登录'
  else
    ErrorString := '用户名或密码不正确';
  Lock;
  if FLogin then
  begin
    TheMainForm.DoAddViewString(ViewString);
    ViewString := '[' + GetCurrentDateTime + '] 用户 ' + string(UserName) + ' ';
  end;
  FLogin := (FLoginTimes < 4) and TheMainForm.CheckUser(string(UserName), string(Password), FUserName, FUserRealName, FUserAliasName, Boolean(EncryptFlag));
  if FLogin then
  begin
    FClassName := TheMainForm.GetCustomObjectClassName(FUserRealName);
    if FClassName <> '' then
      try
        FCustomObj := CreateOleObject(FClassName);
      except
        FClassName := '';
      end;
    FName := string(UserName);
    ViewString := ViewString + '登录成功';
    if UpperCase(FName) <> UpperCase(FUserRealName) then
    begin
      FName := FName + '(' + FUserRealName + ')';
      ViewString := ViewString + '(' + FUserRealName + ')';
    end;
  end
  else begin
    FName := '<尚未登录>';
    ViewString := ViewString + '登录失败';
  end;
  TheMainForm.DoAddViewString(ViewString);
  Connections.Values[IntToStr(Integer(Pointer(Self)))] := FName;
  Unlock;
  Result := WordBool(FLogin);
  if Result then
  begin
    try
      DefaultRDMADOConnection.Connected := True;
      DefaultRDMADOQuery.Prepared := True;
    except
    end;
    ErrorString := '';
  end;
  FErrorStrings.Add(ErrorString);
end;