rdm2unit.pas

三层的通用架构

unit RDM2Unit;

{$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
  TDefaultRDM2 = class(TRemoteDataModule, IDefaultRDM2)
    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 ConnectNewObject(const TheClassName: WideString): WordBool;
      safecall;
    function Get_CustomObject: OleVariant; 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;
    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;

implementation

uses
  MainUnit, ShareUnit, RDMUnit;

{$R *.DFM}

class procedure TDefaultRDM2.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 TDefaultRDM2.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 TDefaultRDM2.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 TDefaultRDM2.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;

function TDefaultRDM2.AddSQL(ClearFlag: WordBool; const SQLString: WideString;
  ExecFlag: WordBool): WordBool;
var
  ViewString, ErrorString: string;
  Flag: Boolean;
begin
  ViewString := '[' + GetCurrentDateTime + '] 用户 ' + FName + ' ';
  Result := False;
  Flag := False;
  ErrorString := '尚未登录';
  if FLogin and not FSelf then
  begin
    with DefaultRDMADOQuery do
      try
        Active := False;
        if ClearFlag then
          SQL.Clear;
        SQL.Add(SQLString);
        if ExecFlag then
        begin
          DefaultRDMADOQuery.ExecSQL;
          Flag := True;
          ViewString := ViewString + '成功执行以下SQL语句:'#13#10'{'#13#10 + SQL.Text + '}';
        end;
        Result := True;
        ErrorString := '';
      except
        on E: exception do
        begin
          ErrorString := E.Message;
          Flag := True;
          ViewString := ViewString + '执行以下SQL语句时失败:'#13#10'{'#13#10 + SQL.Text + '}'#13#10'出错信息为: ' + ErrorString;
        end;
      end;
    if Flag then
    begin
      Lock;
      TheMainForm.DoAddViewString(ViewString);
      Unlock;
    end;
  end;
  if FLogin and FSelf then
    ErrorString := '不允许执行!';
  FErrorStrings.Add(ErrorString);
end;

procedure TDefaultRDM2.DefaultRDMADOConnectionBeforeConnect(
  Sender: TObject);
begin
  if FLogin and not FSelf then
  begin
    Lock;
    with TADOConnection(Sender) do
      ConnectionString := TheMainForm.GetADOConnectionString(FUserRealName);
    Unlock;
  end;
end;

procedure TDefaultRDM2.DefaultRDMADOConnectionAfterConnect(Sender: TObject);
begin
  if not Flogin or FSelf then
    TADOConnection(Sender).Connected := False;
end;

procedure TDefaultRDM2.DefaultRDMADOConnectionBeforeDisconnect(
  Sender: TObject);
begin
  if FLogin and not FSelf then
    while TADOConnection(Sender).InTransaction do
      try
        TADOConnection(Sender).CommitTrans;
      except
        try
          TADOConnection(Sender).RollbackTrans;
        except
        end;
      end;
end;

function TDefaultRDM2.ChangePassword(const OldPassword,
  NewPassword: WideString; EncryptFlag: WordBool): WordBool;
var
  ViewString, ErrorString, UserName, UserRealName, UserAliasName: string;
begin
  ViewString := '[' + GetCurrentDateTime + '] 用户 ' + FName + ' ';
  ErrorString := '尚未登录';
  if FLogin then
    ErrorString := '原密码不正确';
  Lock;
  Result := WordBool(FLogin and TheMainForm.CheckUser(FUserName, string(OldPassword), UserName, UserRealName, UserAliasName, Boolean(EncryptFlag)));
  if Result then
    ErrorString := '无法更改密码';
  Result := Result and WordBool(TheMainForm.ChangeCurrentPassword(FUserName, FUserRealName, string(NewPassword), Boolean(EncryptFlag)));
  if FLogin then
  begin
    if Result then
      ViewString := ViewString + '成功更改密码'
    else
      ViewString := ViewString + '更改密码失败';
    if not FSelf then
      TheMainForm.DoAddViewString(ViewString);
  end;
  Unlock;
  if Result then
    ErrorString := '';
  FErrorStrings.Add(ErrorString);
end;

function TDefaultRDM2.GetErrorString(Index: Integer): WideString;
var
  i: Integer;
begin
  Result := '';
  if FErrorStrings.Count > 0 then
  begin
    i := Index;
    if (i <= 0) or (i > FErrorStrings.Count) then
      i := FErrorStrings.Count;
    Result := WideString(FErrorStrings[i - 1]);
  end;
end;

procedure TDefaultRDM2.DefaultRDMProviderGetData(Sender: TObject;
  DataSet: TCustomClientDataSet);
var
  ViewString: string;
begin
  ViewString := '[' + GetCurrentDateTime + '] 用户 ' + FName + ' ';
  if FLogin and not FSelf then
  begin
    ViewString := ViewString + '查询数据:'#13#10'{'#13#10 + DefaultRDMADOQuery.SQL.Text + '}';
    Lock;
    TheMainForm.DoAddViewString(ViewString);
    Unlock;
  end
  else
    with DataSet do
    begin
     ClearFields;
     Post;
    end;
end;

procedure TDefaultRDM2.DefaultRDMProviderUpdateData(Sender: TObject;
  DataSet: TCustomClientDataSet);
var
  ViewString: string;
begin
  ViewString := '[' + GetCurrentDateTime + '] 用户 ' + FName + ' ';
  if FLogin and not FSelf then
  begin
    ViewString := ViewString + '更新数据:'#13#10'{'#13#10 + DefaultRDMADOQuery.SQL.Text + '}';
    Lock;
    while FFieldIndexs.Count > 0 do
      try
        DataSet.Fields[StrToInt(FFieldIndexs[0])].ProviderFlags := [];
        TDataSetProvider(Sender).DataSet.Fields[StrToInt(FFieldIndexs[0])].ProviderFlags := [];
      finally
        FFieldIndexs.Delete(0);
      end;
    TheMainForm.DoAddViewString(ViewString);
    Unlock;
  end;
end;

procedure TDefaultRDM2.DefaultRDMProviderGetTableName(Sender: TObject;
  DataSet: TDataSet; var TableName: String);
begin
  if FTableName <> '' then
    TableName := FTableName;
end;

procedure TDefaultRDM2.DefaultRDMProviderUpdateError(Sender: TObject;
  DataSet: TCustomClientDataSet; E: EUpdateError; UpdateKind: TUpdateKind;
  var Response: TResolverResponse);
var
  ViewString: string;
begin
  ViewString := '[' + GetCurrentDateTime + '] 用户 ' + FName + ' ';
  if FLogin and not FSelf then
  begin
    ViewString := ViewString + '更新数据时出错:'#13#10'{'#13#10 + DefaultRDMADOQuery.SQL.Text + '}'#13#10'出错信息为: ' + E.Message;
    Lock;
    TheMainForm.DoAddViewString(ViewString);
    Unlock;
  end;
end;

procedure TDefaultRDM2.DefaultRDMProviderBeforeUpdateRecord(Sender: TObject;
  SourceDS: TDataSet; DeltaDS: TCustomClientDataSet;
  UpdateKind: TUpdateKind; var Applied: Boolean);
begin
  Applied := not FLogin;
end;

procedure TDefaultRDM2.SetUpdateTableName(const TableName, FieldIndexs: WideString);
var
  ErrorString: string;
begin
  ErrorString := '尚未登录';
  if FLogin and not FSelf then