博客园_大名鼎鼎

多层数据库应用基于Delphi DataSnap方法调用的实现-----------------对象池技术

2011-05-20T16:16:00Z

之前说到中间层通过向客户端暴露方法的方式提供服务，实现数据库数据的读取和更新。方法调用的方式，其潜在的意义，就是说中间层不保存客户端状态信息，就像WEB服务一样，客户端需要自己保存自己的状态信息。进一步说，就是中间层具体提供方法的业务对象实例，不是也不应该专属于某个客户端，它应该能够为不同的客户端调用提供服务。如果我们把业务对象实例放到对象池中集中存放，调用方法时随用随取，方法结束即放回池中。这样就可以实现业务对象实例服务于不同的客户端调用请求。更重要的是，利用对象池，能够最大化服务器各种资源的使用效率，而且对客户端的响应也更快了，因为业务对象实例早就创建好了，取来即用。

其实，DataSnap构架，已经为我们的这种构想提供了现实支持。简单的说，就是改造工厂类（TDSServerClass），把LifeCycle属性改为Invocation方式；在OnCreateInstance事件中从对象池中取业务类对象实例；在OnDestroyInstance事件中把业务类对象实例放回对象池。

...
procedure TsmMainForm.dssMethodsCreateInstance(
DSCreateInstanceEventObject: TDSCreateInstanceEventObject);
begin
DSCreateInstanceEventObject.ServerClassInstance := ServerMethodsPool.LockPoolObject;
end;

procedure TsmMainForm.dssMethodsDestroyInstance(
DSDestroyInstanceEventObject: TDSDestroyInstanceEventObject);
begin
ServerMethodsPool.UnlockPoolObject(TPersistent(DSDestroyInstanceEventObject.ServerClassInstance));
end;
...
当然，还有对象池类的创建和释放，也很简单，例如：
procedure TsmMainForm.FormCreate(Sender: TObject);
begin
ServerMethodsPool := ObjPoolMgr.TPoolManager.Create;
ServerMethodsPool.InstanceClass := uServerMethods.TPooledDM;
end;

procedure TsmMainForm.FormDestroy(Sender: TObject);
begin
ServerMethodsPool.Free;
end;

下面就是如何实现对象池技术的问题。实现对象池并不复杂，另有两个问题需要注意：

１、多线程。中间层TDSTCPServerTransport对象提供的是多线程服务，允许同时有多个客户端请求。所以对象池类的实现，要考虑多线程情况下公共对象或变量的访问冲突问题。

２、内存泄漏。业务类的基类，采用TDataModule、TComponent或者TPersistent都可以，但不要采用TDSServerModule，因为若采用此基类，TDSServerClass在Invocation方式下会产生内存泄漏。

下面是对象池类最基本的实现代码：

unit ObjPoolMgr;

interface

uses
Classes, SyncObjs, SysUtils, DSServer, DateUtils;

type

PServerObject = ^TServerObject;
TServerObject = record
ServerObject: TPersistent;
InUse: Boolean;
end;

TPoolManager = class
private
    FCriticalSection: TCriticalSection;
    FServerObjects:   TList;
private
    FInstanceClass: TPersistentClass;
    function CreateNewInstance: TPersistent; inline;
    procedure SetInstanceClass(const Value: TPersistentClass);
public
    constructor Create;
    destructor Destroy; override;
    //从对象池中取出一个业务类实例对象
    function LockPoolObject: TPersistent;
    //把一个业务类实例对象放回对象池中
    procedure UnlockPoolObject(var Value: TPersistent);
public
    //指定放入池中的业务类。
    property InstanceClass: TPersistentClass read FInstanceClass write SetInstanceClass;
end;

implementation

constructor TPoolManager.Create;
begin
FServerObjects := TList.Create;
FCriticalSection := TCriticalSection.Create;
end;

destructor TPoolManager.Destroy;
var
I: Integer;
begin
for I := 0 to FServerObjects.Count - 1 do
begin
PServerObject(FServerObjects[i]).ServerObject.Free;
FreeMem(PServerObject(FServerObjects[i]));
end;
FServerObjects.Free;
FCriticalSection.Free;
inherited Destroy;
end;

procedure TPoolManager.SetInstanceClass(const Value: TPersistentClass);
begin
FInstanceClass := Value;
end;

function TPoolManager.CreateNewInstance: TPersistent;
var
p: PServerObject;
Component: TComponent;
begin
if not Assigned(FInstanceClass) then Raise Exception.Create('Not specify class of instance!');

FCriticalSection.Enter;
try
    if FInstanceClass.InheritsFrom(TComponent) then
    begin
      Component := FInstanceClass.NewInstance as TComponent;
      Component.Create(nil);
      Result := Component;
    end
    else
      Result := FInstanceClass.Create;

New(p);
    p.ServerObject := Result;
    p.InUse        := True;
    FServerObjects.Add(p);
finally
    FCriticalSection.Leave;
end;
end;

function TPoolManager.LockPoolObject: TPersistent;
var
i: Integer;
begin
FCriticalSection.Enter;
try
    for i := 0 to FServerObjects.Count - 1 do
    begin
      if not PServerObject(FServerObjects[I]).InUse then
      begin
        PServerObject(FServerObjects[I]).InUse := True;
        Result := PServerObject(FServerObjects[i]).ServerObject;
        Exit;
      end;
    end;
finally
    FCriticalSection.Leave;
end;
Result := CreateNewInstance;
end;

procedure TPoolManager.UnlockPoolObject(var Value: TPersistent);
var
i: Integer;
begin
FCriticalSection.Enter;
try
    for i := 0 to FServerObjects.Count - 1 do
    begin
      if Value = PServerObject(FServerObjects[i]).ServerObject then
      begin
        PServerObject(FServerObjects[i]).InUse := False;
        Value := nil;
        Break;
      end;
    end;
finally
    FCriticalSection.Leave;
end;
end;
...

上面的基本实现稍加修改，就可以完善更多的功能，比如设定实例数上限、定时清除超过某个时间未被使用的实例、查询当前池中对象实例数量等。

本文链接

利用DataSnap的回调功能在客户端显示服务器方法的执行进度

2011-05-20T14:15:00Z

如果DataSnap服务器方法的执行时间比较长，这时候可能需要在客户端用进度条显示当前服务器方法的执行进度。要实现这种需求，现在可以利用DataSnap的回调功能，此功能是从Delphi 2010版本开始被引入的。

要实现回调，服务器方法需要暴露给客户端一个或多个类型为TDBXCallback的参数。例如：
...
{$METHODINFO ON}
TServerMethods1 = class(TComponent)
private
    { Private declarations }
public
    { Public declarations }
    function LongTimeRunFunc(InitCallback, ProgCallback: TDBXCallback): boolean;
end;
{$METHODINFO OFF}
...
LongTimeRunFunc方法带有两个回调参数，InitCallback用来初始化客户端TProgressBar的设置，ProgCallback根据当前方法的执行进度，设置客户端TProgressBar.Position的属性。

implementation
...
function TServerMethods1.LongTimeRunFunc(InitCallback, ProgCallback: TDBXCallback): boolean;
var
Max: Integer;
I: Integer;
begin
Max := Random(120) + 1;
InitCallback.Execute(TJSONNumber.Create(Max)).Free;

for I := 0 to Max do
begin
ProgCallback.Execute(TJSONNumber.Create(I)).Free;
sleep(1000);
end;

Result := True;
end;
...
LongTimeRunFunc函数生成一个随机数，表示将执行的秒数。InitCallback和ProgCallback在execute时，将等待客户端执行完毕才继续。

而客户端这边的代码，需要申明两个继承自TDBXCallback（抽象类）的类，并且重载Execute方法，
...
TInitCallback = class(TDBXCallback)
function Execute(const Arg: TJSONValue): TJSONValue; override;
end;

TProgCallback = class(TDBXCallback)
function Execute(const Arg: TJSONValue): TJSONValue; override;
end;
...

implementation
...
function TProgCallback.Execute(const Arg: TJSONValue): TJSONValue;
begin
with Form2 do
begin
ProgressBar1.Position := TJSONNumber(Arg).AsInt;
btnStart.Enabled := (TJSONNumber(Arg).AsInt = ProgressBar1.Max);
end;
//刷新屏幕
Application.ProcessMessages;
Result := TJSONNull.Create;
end;

function TInitCallback.Execute(const Arg: TJSONValue): TJSONValue;
begin
with Form2 do
begin
    ProgressBar1.Max := TJSONNumber(Arg).AsInt;
    ProgressBar1.Step := 5;
    Edit1.Text := '总时长：' + TJSONNumber(Arg).ToString + '秒';
    btnStart.Enabled := False;
end;
Result := TJSONNull.Create;
end;

procedure TForm2.btnStartClick(Sender: TObject);
begin
ClientModule1.ServerMethods1Client.LongTimeRunFunc(InitCallback, ProgCallback);
end;

Initialization
InitCallback := TInitCallback.Create;
ProgCallback := TProgCallback.Create;
...

本文链接

利用DataSnap进行数据流(TStream)的传递

2011-05-20T14:14:00Z

DataSnap服务器可以通过方法调用向客户端返回数据流，当然，也可以从客户端向服务器上传数据流，都是通过方法调用的方式来实现的。下面以一个简单的例子来演示。

服务器端实现：

{$METHODINFO ON}
TFUService = class(TPersistent)
public
function ReplaceFile(FileName: string; FileStream: TStream): Integer;
function GetFile(schema, FileName: string): TStream;
end;
{$METHODINFO OFF}

//GetFile方法向客户端返回指定名称的文件数据流。ReplaceFile接收来自客户端的文件流，并替换服务器端的文件。

const
BufferSize = 102400; // 100 KB

implementation

function TFUService.ReplaceFile(FileName: string; FileStream: TStream): Integer;
var
fStream: TFilestream;
BytesReadCount: Integer;
Buffer: TBytes;
begin
Result := 0;
try
    if SysUtils.FileExists(FileName) then
      fStream := TFilestream.Create(FileName, fmOpenWrite or fmShareDenyNone)
    else fStream := TFilestream.Create(FileName, fmCreate);
except on E: Exception do
    Exit(-1);
end;

try
    SetLength(Buffer, BufferSize);
    fStream.Position := 0;
    repeat
      BytesReadCount := FileStream.Read(Buffer[0], BufferSize);
      if BytesReadCount > 0 then
        fStream.Write(Buffer[0], BytesReadCount);
    until BytesReadCount < BufferSize;
finally
    fStream.Free;
end;
end;

function TFUService.GetFile(FileName: string): TStream;
begin
Result := nil;

if SysUtils.FileExists(FileName) then
begin
Result := TFileStream.Create(FileName, fmOpenRead + fmShareDenyWrite);
if Result <> nil then Result.Position := 0;
end;
end;
//Result.Position := 0;这一句很关键，返回数据流之前，一定要定位到流的开始处。

客户端代码的实现，跟上述两个方法的实现类似，只是方向相反而已。

本文链接

DataSnap 2009 系列之二（方法篇）

2011-05-19T12:53:00Z

在过去客户端要调用远程服务器的方法需要通过在TLB里添加接口并且在服务器对象中实现

在DataSnap 2009中调用远程服务器的方法是基于delphi的RTTI机制的

想要一个类允许被远程调用需要做以下两点

1.把该类和DSServerClass连接在一起

procedure TMainForm.DSServerClassGetClass(DSServerClass: TDSServerClass;
  var PersistentClass: TPersistentClass);
begin
  PersistentClass := TSM;
end;

DSServerClass的OnGetClass就是用于完成此任务的

注意：DSServerClass必须设置要导出的类否则会出现SOnGetClassNotSet的异常信息

2.该类必须使用$MethodInfo编译指令生成详细的RTTI信息

{$MethodInfo ON}
  TDSServerModule = class(TProviderDataModule)
  end;
{$MethodInfo OFF}

我们查看TDSServerModule的定义发现已经完成了该步骤

所以我们使用向导添加的ServerModule 不需要再手动添加$MethodInfo开关

同样我们也可以不用继承自TDSServerModule来实现我们的ServerClass

只要从TPersistent继承一个类并且用{$MethodInfo ON}和{$MethodInfo OFF}包围就可以输出成员函数到客户端

注意：要输出的成员函数必须声明为public

客户端调用可以使用两种方法

1.使用SqlServerMethod组件

通过设置其ServerMethodName属性来进行远程调用使用Params属性来传递参数和结果值

2.使用本地代理类

选中SQLConnection组件，在右键菜单中单击Generate Datasnap client classe 生成代理类单元。

下面我们通过一个简单的DEMO来展示DataSnap 2009的远程方法调用

我们在服务端定义了4个输出的成员函数

TSM = class(TDSServerModule)
public
  function Hello(Message: String): String;
  function VariantMethod(Value: OleVariant): OleVariant;
  function StreamMethod: TStream;
  function VarOutMethod(out OutParam: OleVariant; var VarParam: OleVariant): string;
end;

由于在DataSnap内部是使用TDBXValue来管理参数列表的

所以使用string等delphi语言自带的类型将会进行相应的映射

使用TDBXValue也是效率最高的

以下是可以作为参数使用的TDBXValue列表

TDBXWideStringValue
TDBXAnsiStringValue
TDBXInt16Value
TDBXInt32Value
TDBXInt64Value
TDBXSingleValue
TDBXDoubleValue
TDBXBcdValue
TDBXTimeValue
TDBXDateValue
TDBXTimeStampValue
TDBXBooleanValue
TDBXReaderValue
TDBXStreamValue

我们分别使用SqlServerMethod和代理类完成对服务端Hello方法的调用

SqlServerMethod.ServerMethodName := 'TSM.Hello';
SqlServerMethod.Params[0].AsString := Name.Text;
SqlServerMethod.ExecuteMethod;
Memo.Lines.Add('Use SqlServerMethod: ' + SqlServerMethod.Params[1].AsString);

这里参数使用了索引值进行访问传递的顺序是从左到右添加到Params列表返回值是在列表的最后一个位置

同样也可以使用ParamByName(参数名称).Value的形式传递参数返回值的名称默认是'ReturnParameter'

使用代理类调用的方法和调用本地方法区别不大因为远程调用的具体过程已经被代理类封装

可以看下代理类中生成的Hello方法

function TSMClient.Hello(Message: string): string;
begin
  if FHelloCommand = nil then
  begin
    FHelloCommand := FDBXConnection.CreateCommand;
    FHelloCommand.CommandType := TDBXCommandTypes.DSServerMethod;
    FHelloCommand.Text := 'TSM.Hello';
    FHelloCommand.Prepare;
  end;
  FHelloCommand.Parameters[0].Value.SetWideString(Message);
  FHelloCommand.ExecuteUpdate;
  Result := FHelloCommand.Parameters[1].Value.GetWideString;
end;

我们看到代理类使用了比SqlServerMethod更低级的DBXCommand进行了封装以更友好的方式给我们使用

with TSMClient.Create(SQLConnection.DBXConnection) do
begin
  Memo.Lines.Add('Use Proxy: ' + Hello(Name.Text));
  Free;
end;

下面我们用TStream返回一个结构体并且在客户端读出

服务端部分

TName = packed record
  FirstName: array[0..99] of Char;
  LastName: array[0..99] of Char;
end;

function TSM.StreamMethod: TStream;
var
  Name: TName;
begin
  Name.FirstName := '爱新觉罗';
  Name.LastName := '玄烨';
  Result := TMemoryStream.Create;
  Result.Seek(0, soFromBeginning);
  Result.Write(Name, SizeOf(TName));
  Result.Seek(0, soFromBeginning); //返回到客户端的数据是从position开始的
end;

注意：写完数据以后需要定位到头部否则客户端得到的数据长度为0

客户端部分

procedure TMainForm.StreamTestClick(Sender: TObject);
var
  Name: TName;
begin
  if SQLConnection.Connected  then
  begin
    with TSMClient.Create(SQLConnection.DBXConnection) do
    begin
      StreamMethod.ReadBuffer(Name, SizeOf(TName));
      Memo.Lines.Add(Format('(StreamMethod)FirstName: %s LastName: %s',[Name.FirstName, Name.LastName]));
      Free; 
    end;
  end;
end;

最后一个函数演示了使用var和out关键字来返回参数

以下是可以使用这两个关键字的标量值类型

boolean
SmallInt
Integer
Int64
Single
Double
AnsiString
String
TDBXTime
TDBXDate

再加上其他的参数类型

TStream
TDataSet
TParams
TDBXReader
TDBXConnection

但是在实际测试过程中发现在使用string类型做out和var的参数时无法使用

跟踪发现源码中ansistring和string的相关代码已经被注释掉估计是有BUG存在所以不支持以后应该可以修复

以下摘自DSReflect单元的procedure TDSMethodValues.AssignParameterValues(Parameters: TDBXParameterArray);

//        TDBXDataTypes.AnsiStringType:
//        begin
//          s := Value.GetAnsiString;
//          GetMem(p, SizeOf(Pointer));
//          UniqueString(s);
//          PPointer(p)^ := Pointer(s);
//          FMethodValues[i] := MakeRefVar(varString, p);
//        end;
//        TDBXDataTypes.BytesType:
//        begin
//          SetLength(bytes, value.GetValueSize);
//          Value.GetBytes(0, bytes, 0, Length(Bytes));
//          GetMem(p, Length(bytes));
//          Move(bytes[0], p^, Length(bytes));
//          FMethodValues[i] := MakeRefVar(varByte or varArray, p);
//        end;
//        TDBXDataTypes.WideStringType:
//        begin
//          w := Value.GetWideString;
//          GetMem(p, SizeOf(Pointer));
//          UniqueString(w);
//          PPointer(p)^ := Pointer(w);
//          FMethodValues[i] := MakeRefVar(varUString, p);
//        end;

贴上效果图

附上DEMO源码 DataSnapDemo_2.rar

本文链接

DataSnap 2009 系列之三（生命周期篇）

2011-05-19T12:53:00Z

DataSnap 2009 系列之三（生命周期篇）

DataSnap 2009的服务器对象的生命周期依赖于DSServerClass组件的设置

当DSServer启动时从DSServerClass组件读取LifeCycle属性的值

注意：LifeCycle的值由于在启动时就已经读取启动后再修改LifeCycle的值将没有任何效果

LifeCycle属性的值可以是以下三种字符串之一

1.Session

该选项为默认设置

每个连接都会建立一个独立的服务器对象为客户端提供服务，服务器对象在连接关闭后释放

因此多个客户端访问的是不同的服务器对象，是线程安全的

2.Invocation

对于每次服务端方法调用建立一个独立的服务器对象为客户端提供服务，服务器对象在调用结束后释放

这个同样也是线程安全的

但是每次调用都创建和释放服务器对象对于频繁调用的系统影响很大，如果把服务端对象用对象池管理配合此种方式将是个非常不错的解决方案

3.Server

所有的客户端使用同一个服务端对象，也就是该对象是单例的

需要开发人员自己来进行同步的控制，不是线程安全的

在服务端对象创建和释放时将触发DSServerClass的两个重要的事件OnCreateInstance和OnDestroyInstance

在这里我们可以使用自定义创建和释放服务器对象同样我们可以用于服务端对象池

下面我们把上一次的DEMO稍微改动下来观察下服务端对象的生命周期

我们先将DSServer组件的AutoStart设置为False 然后拖上两个Button分别完成Start和Stop的调用

procedure TMainForm.StartClick(Sender: TObject);
begin
  DSServer.Start;
end;

procedure TMainForm.StopClick(Sender: TObject);
begin
  DSServer.Stop;
end;

在OnGetClass中记录服务启动时使用的生命周期

procedure TMainForm.DSServerClassGetClass(DSServerClass: TDSServerClass;
  var PersistentClass: TPersistentClass);
begin
  DSServerClass.LifeCycle := LifeCycles.Items.Strings[LifeCycles.ItemIndex];
  LogMessage(Memo, '生命周期：' + DSServerClass.LifeCycle);
  PersistentClass := TSM;
end;

LifeCycles是一个TRadioGroup存放了生命周期使用的三个字符串

最后在OnCreateInstance和OnDestroyInstance事件中记录服务器对象的创建和释放

procedure TMainForm.DSServerClassCreateInstance(
  DSCreateInstanceEventObject: TDSCreateInstanceEventObject);
begin
  LogMessage(Memo, '服务端对象创建');
end;

procedure TMainForm.DSServerClassDestroyInstance(
  DSDestroyInstanceEventObject: TDSDestroyInstanceEventObject);
begin
  LogMessage(Memo, '服务端对象释放');
  //DSDestroyInstanceEventObject.ServerClassInstance.Free;
end;

效果图

通过Demo我们可以明显的看出三种生命周期的区别注意切换生命周期需要先停止服务器再启动

但是在我们使用Invocation的时候会造成内存泄露

打开服务端的ReportMemoryLeaksOnShutdown 调用了两次方法后关闭服务端可以看到如下提示

可以看到服务端对象并没有释放

这里需要我们通过在OnDestroyInstance手动释放

DSDestroyInstanceEventObject.ServerClassInstance.Free;

但是我们会发现内存泄露依然存在TDSProviderDataModuleAdapter依然没有释放

这是由于DataSnap2009中继承自TProviderDataModule的类都使用了适配器模式来支持旧的IAppServer接口

在服务端对象创建的过程TDSServerClass.CreateInstance中我们可以看到

if (Instance <> nil) and Instance.InheritsFrom(TProviderDataModule) then
  CreateInstanceEventObject.ServerClassInstance := TDSProviderDataModuleAdapter.Create(Instance);

因此在服务端释放的TDSServerClass.DestroyInstance中需要释放TDSProviderDataModuleAdapter对象

    if DestroyInstanceEventObject.ServerClassInstance is TDSProviderDataModuleAdapter then
    begin
      Adapter := DestroyInstanceEventObject.ServerClassInstance as TDSProviderDataModuleAdapter;
      DestroyInstanceEventObject.ServerClassInstance := Adapter.FProviderDataModule;
      Adapter.FProviderDataModule := nil;
    end else
      Adapter := nil;

当使用Invocation生命周期时传递的ServerClassInstance并不是TDSProviderDataModuleAdapter的对象

所以尽管我们手动释放了我们的服务端对象适配器对象任然造成了内存泄露

附上DEMO源码 DataSnapDemo_3.rar

本文链接

DataSnap 2009 系列之一（连接篇）

2011-05-19T12:52:00Z

Delphi 的MIDAS出来了这么多年终于有改进的版本了

COM-FREE的DataSnap 2009真是清爽了很多

DataSnap 2009 除了不支持回调和Intercept组件以外其它的该有的都有了而且还有很多强大的特性

第一篇就先写点DataSnap 2009连接方面可能要用到的东西

以后再继续写写关于生命周期的管理对象池的应用以及远程管理远程方法调用等方面的东西吧。

首先建立个DataSnap 2009的服务器工程

一共用到三个组件

DSServer 服务配置组件用于绑定其它的组件

DSServerClass 可以看作是一个类的工厂用于导出需要远程调用的服务端模块

DSTCPServerTransport 传输组件这里使用的是indy的tcpserver

将DSServerClass和DSTCPServerTransport的Server设置成DSServer就可以了

客户端连接和断开连接时会触发DSServer的两个事件OnConnect和OnDisConnect

参数为TDSConnectEventObject

我们看下该类的定义

 1 TDSConnectEventObject = class(TDSEventObject)
 2 public
 3   constructor Create(const ADbxContext: TDBXContext; const AServer: TDSCustomServer; const ATransport: TDSServerTransport;   const AChannelInfo: TDBXChannelInfo; const ADbxConnection: TDBXConnection; const AConnectProperties: TDBXProperties);
 4 private
 5   FConnectProperties: TDBXProperties;
 6   FChannelInfo: TDBXChannelInfo;
 7 public    
 8   property ConnectProperties: TDBXProperties read FConnectProperties write FConnectProperties;
 9   property ChannelInfo: TDBXChannelInfo read FChannelInfo;
10 end;

我们可以看到其中包含了两个属性ConnectProperties和ChannelInfo

ConnectProperties包含了客户端连接所传递的参数 Params 也就是一个TStrings的内容

ChannelInfo里面有个很重的属性就是它的ID 其实是TIdTCPConnection对象的ID 所以我们可以直接强制转换成TIdTCPConnection

然后建立个DataSnap 2009的客户端工程

由于使用的DbExpress框架客户端连接用的是TSQLConnection组件

只要把Driver设置成Datasnap即可

连接的服务器地址通过HostName和Port来进行设定

下面我们就实现个简单的DEMO 客户端通过用户名和密码连接服务端如果密码不争取服务端则断开连接

客户端主要函数

 1 procedure TMainForm.ConnectClick(Sender: TObject);
 2 begin
 3   SQLConnection.Params.Values['User_Name'] := UserName.Text;
 4   SQLConnection.Params.Values['PassWord'] := Password.Text;
 5   try
 6     SQLConnection.Open;
 7     Connect.Enabled := False;
 8     DisConnect.Enabled := True;
 9   except
10     ShowMessage('连接服务器失败!');
11   end;
12 end;
13 
14 procedure TMainForm.DisConnectClick(Sender: TObject);
15 begin
16   SQLConnection.Close;
17   Connect.Enabled := True;
18   DisConnect.Enabled := False;
19 end;

服务端主要函数

 1 procedure TMainForm.DSServerConnect(DSConnectEventObject: TDSConnectEventObject);
 2 const
 3   SRemoteConnected = '远程客户端连接 %s:%d';
 4   SUserNameAndPassword = '用户名: %s 密码: %s';
 5   SAuthSuccess = '用户名密码认证成功';
 6   SAuthFailed  = '用户名密码认证失败';
 7 var
 8   Conn: TIdTCPConnection;
 9 begin
10   Conn := TIdTCPConnection(DSConnectEventObject.ChannelInfo.Id);
11   LogMessage(Memo, Format(SRemoteConnected, [Conn.Socket.Binding.PeerIP, Conn.Socket.Binding.PeerPort]));
12   with DSConnectEventObject.ConnectProperties do
13   begin
14     LogMessage(Memo, Format(SUserNameAndPassword, [Values['User_Name'], Values['PassWord']]));
15     if (Values['User_Name'] = 'Admin') and (Values['PassWord'] = '123456') then
16       LogMessage(Memo, SAuthSuccess)
17     else
18     begin
19       LogMessage(Memo, SAuthFailed);
20       Conn.Disconnect;
21     end;
22   end;
23 end;
24 
25 procedure TMainForm.DSServerDisconnect(DSConnectEventObject: TDSConnectEventObject);
26 const
27   SRemoteDisConnected = '远程客户端断开连接 %s:%d';
28 var
29   Conn: TIdTCPConnection;
30 begin
31   Conn := TIdTCPConnection(DSConnectEventObject.ChannelInfo.Id);
32   LogMessage(Memo, Format(SRemoteDisConnected, [Conn.Socket.Binding.PeerIP, Conn.Socket.Binding.PeerPort]));
33 end;

注意：OnConnect事件中还可以使用另外一种方式拒绝客户端连接

在代码中抛出个异常即可在客户端会捕捉到一个TDBXError的异常显示'Remote error ' 加上异常显示的消息。

效果图如下：

附上DEMO源码 DataSnapDemo_1.rar

本文链接

DataSnap 2009 客户端扩展

2011-05-19T12:51:00Z

DataSnap 2009的客户端采用了原始的TClientSocket组件实现了通讯层即简单效率也不错
但是如果我们想要设置连接超时怎么办？想要设置代理服务器又该怎么办呢？能不能利用我们常用的网络控件(indy ics synapse...)来替代呢？
在这里我基于synapse控件实现了一个自己的DataSnap客户端驱动
注: synapase是一套比较不错的开源的第三方控件这里我们要使用它的TCP控件来扩展支持代理服务器的使用
    synapse 官方网址 http://www.synapse.ararat.cz/doku.php
synapse svn地址 https://synalist.svn.sourceforge.net/svnroot/synalist/trunk
首先我们必须注册一个新的驱动
// 客户端驱动定义
TCfSynaTCPDatasnapDriver = class(TDBXClientDriver)
protected
  function CreateChannel: TDbxChannel; override;
public
  constructor Create(DriverDef: TDBXDriverDef); override;
end;

// 驱动名称
const SDriverName = 'CfSynaTCPDataSnap';

// 单元初始化时注册驱动
initialization
  TDBXDriverRegistry.RegisterDriverClass(SDriverName, TCfSynaTCPDatasnapDriver);
TDBXClientDriver的CreateChannel方法默认创建的是TDBXSocketChannel 所以我们要在我们的类中覆盖它并且创建一个自己的Channel
// Synapse 实现的TCP通道
TCfSynaTCPChannel = class(TDBXChannel)
private
  FTcpClient: TTCPBlockSocket; // Synapse的TCP控件
protected
  function GetChannelInfo: TDBXChannelInfo; override;
public
  destructor Destroy; override;
  procedure Open; override;
  procedure Close; override;
  function Read(const Buffer: TBytes; const Offset: Integer; const Count: Integer): Integer; override;
  function Write(const Buffer: TBytes; const Offset: Integer; const Count: Integer): Integer; override;
end;
那么我们如何读取SQLConnection设置的参数值呢比如服务器信息代理服务器信息之类的设置呢
为了减少代码量我在这里直接继承TDBXDatasnapProperties类实现了TCfSynaTCPDatasnapProperties类来设置代理服务器信息
// 包含代理服务器配置的属性类
TCfSynaTCPDatasnapProperties = class(TDBXDatasnapProperties)
strict private
  function GetProxyIP: string;
  function GetProxyPort: string;
  function GetProxyUsername: string;
  function GetProxyPassword: string;
  function GetProxyTimeout: Integer;
  function GetProxyType: TProxyType;
  procedure SetProxyIP(const Value: string);
  procedure SetProxyPort(const Value: string);
  procedure SetProxyUsername(const Value: string);
  procedure SetProxyPassword(const Value: string);
  procedure SetProxyTimeout(const Value: Integer);
  procedure SetProxyType(const Value: TProxyType);
published
  property ProxyIP: string read GetProxyIP write SetProxyIP;
  property ProxyPort: string read GetProxyPort write SetProxyPort;
  property ProxyUsername: string read GetProxyUsername write SetProxyUsername;
  property ProxyPassword: string read GetProxyPassword write SetProxyPassword;
  property ProxyTimeout: Integer read GetProxyTimeout write SetProxyTimeout;
  property ProxyType: TProxyType read GetProxyType write SetProxyType;
end;
然后通过TCfSynaTCPDatasnapDriver的构造函数传递
复制DbxDatasnap单元TDBXDatasnapDriver的代码把TDBXDatasnapProperties改成TCfSynaTCPDatasnapProperties
这样我们就可以根据参数的配置来连接服务器
procedure TCfSynaTCPChannel.Open;
begin
  Close;
  if FTcpClient = nil then
    FTcpClient := TTCPBlockSocket.Create;
  with TCfSynaTCPDatasnapProperties(DbxProperties) do
  begin
    if ProxyIP <> '' then
    begin
      case ProxyType of
        ptSocks4:
          FTcpClient.SocksType := ST_Socks4;
        ptSocks5:
          FTcpClient.SocksType := ST_Socks5;
      end;
      case ProxyType of
        ptSocks4, ptSocks5:
        begin
          FTcpClient.SocksIP       := ProxyIP;
          FTcpClient.SocksPort     := ProxyPort;
          FTcpClient.SocksUsername := ProxyUsername;
          FTcpClient.SocksPassword := ProxyPassword;
          FTcpClient.SocksTimeout  := ProxyTimeout;
        end;
        ptHTTP:
        begin
          FTcpClient.HTTPTunnelIP      := ProxyIP;
          FTcpClient.HTTPTunnelPort    := ProxyPort;
          FTcpClient.HTTPTunnelUser    := ProxyUsername;
          FTcpClient.HTTPTunnelPass    := ProxyPassword;
          FTcpClient.HTTPTunnelTimeout := ProxyTimeout;
        end;
      end;
    end;
    FTcpClient.Connect(HostName, IntToStr(Port));
  end;
  FChannelInfo := TDBXSocketChannelInfo.Create(0, FTcpClient.GetLocalSinIP);
end;
调用代码示例
with DM.SQLConnection do
begin
  Close;
  Params.Values[TCfSynaTCPNames.ProxyType]     := IntToStr(Integer(ptHTTP));
  Params.Values[TCfSynaTCPNames.ProxyIP]       := 'localhost';
  Params.Values[TCfSynaTCPNames.ProxyPort]     := '80';
  Params.Values[TCfSynaTCPNames.ProxyUsername] := 'abc';
  Params.Values[TCfSynaTCPNames.ProxyPassword] := '123';
  Params.Values[TDBXPropertyNames.HostName]    := 'localhost';
  Params.Values[TDBXPropertyNames.Port]        := '1217';
  try
    Open;
  except
  end
end;
单元实现完整代码 CfSynaTCPChannel.rar
注: 该单元可以直接引用也可以新建个包安装最好在Register函数中调用InstallSynaDriver
否则IDE中SQLConnection控件的Driver设置成CfSynaTCPDataSnap下次打开的时候可能会报错

本文链接

高性能的socket通讯服务器（完成端口模型--IOCP）[转载]

2009-10-03T17:40:00Z

WebBrowser操作Html[转]

2009-09-29T13:31:00Z

WebBrowser、MSHTML在Delphi中的使用[转]

2009-09-29T13:26:00Z

博客园_大名鼎鼎

多层数据库应用基于Delphi DataSnap方法调用的实现-----------------对象池技术

利用DataSnap的回调功能在客户端显示服务器方法的执行进度

利用DataSnap进行数据流(TStream)的传递

DataSnap 2009 系列之二 （方法篇）

DataSnap 2009 系列之三 （生命周期篇）

DataSnap 2009 系列之一 （连接篇）

DataSnap 2009 客户端扩展

高性能的socket通讯服务器（完成端口模型--IOCP）[转载]

WebBrowser操作Html[转]

WebBrowser、MSHTML在Delphi中的使用[转]

DataSnap 2009 系列之二（方法篇）

DataSnap 2009 系列之三（生命周期篇）

DataSnap 2009 系列之一（连接篇）