一个我只知其然,不知其所以然的问题,请高手解惑。 ( 积分: 200 )

  • 主题发起人 主题发起人 特尔斐
  • 开始时间 开始时间

特尔斐

Unregistered / Unconfirmed
GUEST, unregistred user!
请大家花点时间看看以下的代码及结尾处的说明:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ActiveX, ComObj, StdCtrls, DB, ADODB;
type
TExecutorThread = class;
TExecutorThreadCompleted = procedure(Sender: TExecutorThread) of object;
TExecutorThreadState = (etsWaiting, etsWorking, etsTerminating);
TExecutorThread = class(TThread)
private
FThreadEvent: THandle;
FReturnValue: String;
FErrorMsg: String;
FHasError: Boolean;
FOnCompleted: TExecutorThreadCompleted;
FState: TExecutorThreadState;
procedure SafeCallOnCompleted;
function StartThread: Boolean;
function EndThread: Boolean;
protected
procedure Execute;
override;
proceduredo
Working(var AReturnValue: String);
virtual;
abstract;
public
constructor Create;
destructor Destroy;
override;
procedure Activate;
property OnCompleted: TExecutorThreadCompleted read FOnCompleted write FOnCompleted;
property ReturnValue: String read FReturnValue;
property ErrorMsg: String read FErrorMsg;
property HasError: Boolean read FHasError;
property State: TExecutorThreadState read FState;
end;

TBackgroundAuditor = class(TExecutorThread)
private
FSQLCommandText: String;
//FADOConn: TADOConnection;
//FCommander: TADOQuery;
protected
procedure Execute;
override;
proceduredo
Working(var AReturnValue: String);
override;
function ExecSQL: String;
public
destructor Destroy;
override;
property SQLCommandText: String read FSQLCommandText write FSQLCommandText;
end;

type
TForm1 = class(TForm)
Memo1: TMemo;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Button1: TButton;
ADOConnection1: TADOConnection;
procedure Button1Click(Sender: TObject);
private
FChargeAuditor: TBackgroundAuditor;
FDispensingAuditor: TBackgroundAuditor;
procedure AfterBillAuditorExecute(Sender: TExecutorThread);
procedure AuditDispensingBills(S: String);
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation
{$R *.dfm}
{ TExecutorThread }
var
CriticalSection: TRTLCriticalSection;
constructor TExecutorThread.Create;
begin
FThreadEvent := CreateEvent(nil, True, False, nil);
inherited Create(True);
FreeOnTerminate := False;
Priority := tpLower;
end;

destructor TExecutorThread.Destroy;
begin
CloseHandle(FThreadEvent);
inherited;
end;

procedure TExecutorThread.Execute;
begin
while Truedo
begin
if StartThread then
begin
EnterCriticalSection(CriticalSection);
try
FReturnValue := '';
FErrorMsg := '';
FHasError := False;
try
FState := etsWorking;
do
Working(FReturnValue);
except
on E: Exceptiondo
begin
FErrorMsg := E.Message;
FHasError := True;
end;
end;
finally
LeaveCriticalSection(CriticalSection);
end;
end;
if EndThread then
begin
FState := etsTerminating;
Break;
end;
end;
end;

function TExecutorThread.StartThread: Boolean;
begin
FState := etsWaiting;
if WaitForSingleObject(FThreadEvent, INFINITE) = WAIT_OBJECT_0 then
ResetEvent(FThreadEvent);
Result := not Terminated;
end;

function TExecutorThread.EndThread: Boolean;
begin
Result := Terminated;
if not Result then
try
SafeCallOnCompleted;
except
end;
end;

procedure TExecutorThread.SafeCallOnCompleted;
begin
if Assigned(FOnCompleted) then
FOnCompleted(Self);
end;

procedure TExecutorThread.Activate;
begin
if FState = etsWaiting then
SetEvent(FThreadEvent);
end;

{ TBackgroundAuditor }
procedure TBackgroundAuditor.DoWorking(var AReturnValue: String);
begin
AReturnValue := DateTimeToStr(Now);
AReturnValue := AReturnValue + '--->' + ExecSQL;
end;

function TBackgroundAuditor.ExecSQL: String;
var
FADOConn: TADOConnection;
//此变量原为私有成员
FCommander: TADOQuery;
//此变量原为私有成员
begin
//------------------1、对象只创建一次,在对象析构时销毁-----------------------
//if FADOConn = nil then
//begin
// FADOConn := TADOConnection.Create(nil);
// FADOConn.LoginPrompt := False;
// FADOConn.KeepConnection := True;
// FADOConn.ConnectionString := 'Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=NewDrClinicNew;Data Source=192.168.0.100';
//end;

//if FCommander = nil then
//begin
// FCommander := TADOQuery.Create(nil);
// FCommander.Connection := FADOConn;
//end;
//----------------------------------------------------------------------------
//------------------2、每次执行创建新的对象,用完即销毁-----------------------
FADOConn := TADOConnection.Create(nil);
FADOConn.LoginPrompt := False;
FADOConn.KeepConnection := True;
FADOConn.ConnectionString := 'Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=NewDrClinicNew;Data Source=192.168.0.100';
FCommander := TADOQuery.Create(nil);
FCommander.Connection := FADOConn;
//----------------------------------------------------------------------------
FCommander.SQL.Text := FSQLCommandText;
FCommander.Open;
Result := FCommander.Fields[0].AsString;
FCommander.Close;
//------------------用第2种方案时销毁对象-------------------------------------
FCommander.Free;
FADOConn.Free;
//----------------------------------------------------------------------------
end;

destructor TBackgroundAuditor.Destroy;
begin
//-------------------用第1种方案时销毁对象------------------------------------
//FADOConn.Free;
//FCommander.Free;
//----------------------------------------------------------------------------
inherited;
end;

procedure TBackgroundAuditor.Execute;
begin
ActiveX.CoInitialize(nil);
try
inherited;
finally
ActiveX.CoUninitialize;
end;
end;

{ TForm1 }
procedure TForm1.AfterBillAuditorExecute(Sender: TExecutorThread);
var
S: String;
begin
if Sender.HasError then
ShowMessage(Sender.ErrorMsg)
else
begin
S := Sender.ReturnValue;
if S = '' then
Exit
else
if Sender = FChargeAuditor then
begin
Memo1.Lines.Add('FChargeAuditor: ' + S);
AuditDispensingBills(S);
end
else
if Sender = FDispensingAuditor then
Memo1.Lines.Add('FDispensingAuditor: ' + S);
end;
end;

procedure TForm1.AuditDispensingBills(S: String);
begin
if not Assigned(FDispensingAuditor) then
begin
FDispensingAuditor := TBackgroundAuditor.Create;
FDispensingAuditor.OnCompleted := AfterBillAuditorExecute;
FDispensingAuditor.Resume;
end;
FDispensingAuditor.SQLCommandText := 'select top 1 currname from goodses';
FDispensingAuditor.Activate;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(FChargeAuditor) then
begin
FChargeAuditor := TBackgroundAuditor.Create;
FChargeAuditor.OnCompleted := AfterBillAuditorExecute;
FChargeAuditor.Resume;
end;
FChargeAuditor.SQLCommandText := 'select ProvName from providers';
FChargeAuditor.Activate;
end;

initialization
InitializeCriticalSection(CriticalSection);
finalization
DeleteCriticalSection(CriticalSection);
end.

说明:
上面的代码是一个多线程程序中抽出的一部分,大家从注释中可以看到,原来是将两个
用到的ADO对象声明为成员变量,在使用中发现为nil时创建,在析构时销毁。
但是,这样却出现一个奇怪的问题:程序可以正常执行,可只要这个线程(TBackgroundAuditor类型)被创建并执行一次后,当用户通过键盘或鼠标在本程序中任一文本框中切换到中文输入法时,程序死掉(在ntdll中的某处代码调用WaitForSingleObject函数时停止,即要等待的内核对象已不能再处于有信号状态)。
后来,改用每次创建对象,用完即销毁的方案(即注释中的方案2),问题不再出现。
该问题虽然已解决,但只有治标不治本的感觉,真是百思不得其解,还望高手指点迷津。
 
请大家花点时间看看以下的代码及结尾处的说明:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ActiveX, ComObj, StdCtrls, DB, ADODB;
type
TExecutorThread = class;
TExecutorThreadCompleted = procedure(Sender: TExecutorThread) of object;
TExecutorThreadState = (etsWaiting, etsWorking, etsTerminating);
TExecutorThread = class(TThread)
private
FThreadEvent: THandle;
FReturnValue: String;
FErrorMsg: String;
FHasError: Boolean;
FOnCompleted: TExecutorThreadCompleted;
FState: TExecutorThreadState;
procedure SafeCallOnCompleted;
function StartThread: Boolean;
function EndThread: Boolean;
protected
procedure Execute;
override;
proceduredo
Working(var AReturnValue: String);
virtual;
abstract;
public
constructor Create;
destructor Destroy;
override;
procedure Activate;
property OnCompleted: TExecutorThreadCompleted read FOnCompleted write FOnCompleted;
property ReturnValue: String read FReturnValue;
property ErrorMsg: String read FErrorMsg;
property HasError: Boolean read FHasError;
property State: TExecutorThreadState read FState;
end;

TBackgroundAuditor = class(TExecutorThread)
private
FSQLCommandText: String;
//FADOConn: TADOConnection;
//FCommander: TADOQuery;
protected
procedure Execute;
override;
proceduredo
Working(var AReturnValue: String);
override;
function ExecSQL: String;
public
destructor Destroy;
override;
property SQLCommandText: String read FSQLCommandText write FSQLCommandText;
end;

type
TForm1 = class(TForm)
Memo1: TMemo;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Button1: TButton;
ADOConnection1: TADOConnection;
procedure Button1Click(Sender: TObject);
private
FChargeAuditor: TBackgroundAuditor;
FDispensingAuditor: TBackgroundAuditor;
procedure AfterBillAuditorExecute(Sender: TExecutorThread);
procedure AuditDispensingBills(S: String);
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation
{$R *.dfm}
{ TExecutorThread }
var
CriticalSection: TRTLCriticalSection;
constructor TExecutorThread.Create;
begin
FThreadEvent := CreateEvent(nil, True, False, nil);
inherited Create(True);
FreeOnTerminate := False;
Priority := tpLower;
end;

destructor TExecutorThread.Destroy;
begin
CloseHandle(FThreadEvent);
inherited;
end;

procedure TExecutorThread.Execute;
begin
while Truedo
begin
if StartThread then
begin
EnterCriticalSection(CriticalSection);
try
FReturnValue := '';
FErrorMsg := '';
FHasError := False;
try
FState := etsWorking;
do
Working(FReturnValue);
except
on E: Exceptiondo
begin
FErrorMsg := E.Message;
FHasError := True;
end;
end;
finally
LeaveCriticalSection(CriticalSection);
end;
end;
if EndThread then
begin
FState := etsTerminating;
Break;
end;
end;
end;

function TExecutorThread.StartThread: Boolean;
begin
FState := etsWaiting;
if WaitForSingleObject(FThreadEvent, INFINITE) = WAIT_OBJECT_0 then
ResetEvent(FThreadEvent);
Result := not Terminated;
end;

function TExecutorThread.EndThread: Boolean;
begin
Result := Terminated;
if not Result then
try
SafeCallOnCompleted;
except
end;
end;

procedure TExecutorThread.SafeCallOnCompleted;
begin
if Assigned(FOnCompleted) then
FOnCompleted(Self);
end;

procedure TExecutorThread.Activate;
begin
if FState = etsWaiting then
SetEvent(FThreadEvent);
end;

{ TBackgroundAuditor }
procedure TBackgroundAuditor.DoWorking(var AReturnValue: String);
begin
AReturnValue := DateTimeToStr(Now);
AReturnValue := AReturnValue + '--->' + ExecSQL;
end;

function TBackgroundAuditor.ExecSQL: String;
var
FADOConn: TADOConnection;
//此变量原为私有成员
FCommander: TADOQuery;
//此变量原为私有成员
begin
//------------------1、对象只创建一次,在对象析构时销毁-----------------------
//if FADOConn = nil then
//begin
// FADOConn := TADOConnection.Create(nil);
// FADOConn.LoginPrompt := False;
// FADOConn.KeepConnection := True;
// FADOConn.ConnectionString := 'Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=NewDrClinicNew;Data Source=192.168.0.100';
//end;

//if FCommander = nil then
//begin
// FCommander := TADOQuery.Create(nil);
// FCommander.Connection := FADOConn;
//end;
//----------------------------------------------------------------------------
//------------------2、每次执行创建新的对象,用完即销毁-----------------------
FADOConn := TADOConnection.Create(nil);
FADOConn.LoginPrompt := False;
FADOConn.KeepConnection := True;
FADOConn.ConnectionString := 'Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=NewDrClinicNew;Data Source=192.168.0.100';
FCommander := TADOQuery.Create(nil);
FCommander.Connection := FADOConn;
//----------------------------------------------------------------------------
FCommander.SQL.Text := FSQLCommandText;
FCommander.Open;
Result := FCommander.Fields[0].AsString;
FCommander.Close;
//------------------用第2种方案时销毁对象-------------------------------------
FCommander.Free;
FADOConn.Free;
//----------------------------------------------------------------------------
end;

destructor TBackgroundAuditor.Destroy;
begin
//-------------------用第1种方案时销毁对象------------------------------------
//FADOConn.Free;
//FCommander.Free;
//----------------------------------------------------------------------------
inherited;
end;

procedure TBackgroundAuditor.Execute;
begin
ActiveX.CoInitialize(nil);
try
inherited;
finally
ActiveX.CoUninitialize;
end;
end;

{ TForm1 }
procedure TForm1.AfterBillAuditorExecute(Sender: TExecutorThread);
var
S: String;
begin
if Sender.HasError then
ShowMessage(Sender.ErrorMsg)
else
begin
S := Sender.ReturnValue;
if S = '' then
Exit
else
if Sender = FChargeAuditor then
begin
Memo1.Lines.Add('FChargeAuditor: ' + S);
AuditDispensingBills(S);
end
else
if Sender = FDispensingAuditor then
Memo1.Lines.Add('FDispensingAuditor: ' + S);
end;
end;

procedure TForm1.AuditDispensingBills(S: String);
begin
if not Assigned(FDispensingAuditor) then
begin
FDispensingAuditor := TBackgroundAuditor.Create;
FDispensingAuditor.OnCompleted := AfterBillAuditorExecute;
FDispensingAuditor.Resume;
end;
FDispensingAuditor.SQLCommandText := 'select top 1 currname from goodses';
FDispensingAuditor.Activate;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(FChargeAuditor) then
begin
FChargeAuditor := TBackgroundAuditor.Create;
FChargeAuditor.OnCompleted := AfterBillAuditorExecute;
FChargeAuditor.Resume;
end;
FChargeAuditor.SQLCommandText := 'select ProvName from providers';
FChargeAuditor.Activate;
end;

initialization
InitializeCriticalSection(CriticalSection);
finalization
DeleteCriticalSection(CriticalSection);
end.

说明:
上面的代码是一个多线程程序中抽出的一部分,大家从注释中可以看到,原来是将两个
用到的ADO对象声明为成员变量,在使用中发现为nil时创建,在析构时销毁。
但是,这样却出现一个奇怪的问题:程序可以正常执行,可只要这个线程(TBackgroundAuditor类型)被创建并执行一次后,当用户通过键盘或鼠标在本程序中任一文本框中切换到中文输入法时,程序死掉(在ntdll中的某处代码调用WaitForSingleObject函数时停止,即要等待的内核对象已不能再处于有信号状态)。
后来,改用每次创建对象,用完即销毁的方案(即注释中的方案2),问题不再出现。
该问题虽然已解决,但只有治标不治本的感觉,真是百思不得其解,还望高手指点迷津。
 
constructor TExecutorThread.Create;
begin
FThreadEvent := CreateEvent(nil, True, False, nil);
inherited Create(True);
FreeOnTerminate := False;
//这里改为true.
Priority := tpLower;
end;
--------------------------------------------------------------------
粗看了一下,不知道能不能解决问题.
 
谢谢“易名烦”的回复,但看来您真的只是粗看了一下。
 
最好使用TryEnterCriticalSection替代EnterCriticalSection,因为它尝试进入临界区,如果失败立即返回一个状态,而EnterCriticalSection则会无限等待获取资源,容易出现死锁现象。
以下是msdn的参考资料
///////////////////////////////////
Remarks
The threads of a single process can use a critical section object for mutual-exclusion synchronization. The process is responsible for allocating the memory used by a critical section object, which it cando
by declaring a variable of type CRITICAL_SECTION. Before using a critical section, some thread of the process must call the InitializeCriticalSection or InitializeCriticalSectionAndSpinCount function to initialize the object.
To enable mutually exclusive use of a shared resource, each thread calls the EnterCriticalSection or TryEnterCriticalSection function to request ownership of the critical section before executing any section of code that uses the protected resource. The difference is that TryEnterCriticalSection returns immediately, regardless of whether it obtained ownership of the critical section, while EnterCriticalSection blocks until the thread can take ownership of the critical section. When it has finished executing the protected code, the thread uses the LeaveCriticalSection function to relinquish ownership, enabling another thread to become the owner and gain access to the protected resource. The thread must call LeaveCriticalSection once for each time that it entered the critical section.
Any thread of the process can use the DeleteCriticalSection function to release the system resources that were allocated when the critical section object was initialized. After this function has been called, the critical section object can no longer be used for synchronization.
If a thread terminates while it has ownership of a critical section, the state of the critical section is undefined.
 
我先测测在说。
 
to Siva
不关这个的事。[:)]
 
这个问题挂了好久了,至今没看到结果。特尔斐的例子太复杂,可能很多人没时间看。我把问题简化如下:
在一个线程中,如果创建了一个 TADOConnection 对象,并且在线程中进行任意 WIN32 同步等待,在主窗口切换输入法即会出现死锁现象。目前我测试只发现 TADOConnection 对象会出现此问题,其他如 TADOQuery, TWebBrowser 则不会。
例如:下面是是一个简单的 Thread 类,在 Form.OnCreate 中键入:TAdoThread.Create(False);
即可观察到死锁现象。

unit Unit2;
interface
uses
Classes, Windows, ADODB, ActiveX;
type
TAdoThread = class(TThread)
protected
procedure Execute;
override;
end;

implementation
procedure TAdoThread.Execute;
var
Conn: TADOConnection;
begin
ActiveX.CoInitialize(nil);
Conn := TADOConnection.Create(nil);
SleepEx(INFINITE, False);
Conn.Free;
ActiveX.CoUninitialize;
end;

end.
 
谢谢savetime帮我简化问题,我再补充一下:
savetime简化后的代码:
procedure TAdoThread.Execute;
var
Conn: TADOConnection;
begin
ActiveX.CoInitialize(nil);
Conn := TADOConnection.Create(nil);
SleepEx(INFINITE, False);
Conn.Free;
ActiveX.CoUninitialize;
end;
以上代码运行后会导致切换输入法时死锁,但改变一下创建对象和等待的两行代码的顺序后,却不再死锁了,代码如下:
procedure TAdoThread.Execute;
var
Conn: TADOConnection;
begin
ActiveX.CoInitialize(nil);
SleepEx(INFINITE, False);
Conn := TADOConnection.Create(nil);
Conn.Free;
ActiveX.CoUninitialize;
end;

期待高手现身!!!
 
 复杂,吾尚在研究中...
 
上面所说的“死锁”,其实并不是真的死了,而是输入法停留在这个线程的等待过程。如果将上例中的 SleepEx 的时间限制一下,比如暂停 5 秒,则可以看到输入法在 5 秒钟过后被切换出来了。
跟踪一段代码发现,问题可能是出现在 TADOConnection.Create 的第三行代码中。为什么第三行代码的执行和输入法的切换有关,则没有能力继续分析了。
constructor TADOConnection.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FConnectionObject := CreateADOObject(CLASS_Connection) as _Connection;
OleCheck(ConnectionPoint.Advise(Self as IUnknown, FConnEventsID));
<<
问题出在这
FCommands := TList.Create;
LoginPrompt := True;
FIsolationLevel := ilCursorStability;
CursorLocation := clUseClient;
FKeepConnection := True;
end;
 
的确如sametime大侠所说,问题可以断定是出在
OleCheck(ConnectionPoint.Advise(Self as IUnknown, FConnEventsID));
将这一行注释掉之后,重新编译生成ADODB.dcu覆盖,lib目录下的ADODB.dcu,然后编译程序进行测试就一切正常了,而且在主程序、线程中使用ADOConnection和ADOQuery进行查询也都结果正常,没有出错情况发生。IConnectionPoint接口的实现类为AxCtrls单元的TConnectionPoint,不过没有看明白Advise方法究竟怎么影响到了IME的切换。
 
另外,在程序中用代码切换输入法是没有问题的,只有用鼠标或键盘切换才有问题。Advise方法是MS ADO的方法,不知它里面搞了什么,难道只有MS才知道???
 
可能是一个漏洞,你就不可以试一下其他的办法.
 
to: oboaixoaix
我早就试了其它办法并已解决问题,所以标题就叫“只知其然不知其所以然”。但不明白其中原由,所以发上来让高手们看看。
但除了savetime大侠之外,其它高手还是三箴其口啊,是无暇及此?或不屑为之?或...?
 
advise表示Tadoconnection这个类要与ADO Com Object建立事件通信;如果你注掉这个方法的话,那么TADOConnection的事件将不能得到响应。
那么为什么会注掉之后,切换输入法就没问题呢?我也不太清楚,而且也想不出来。
 
高手们的对话真是使我知其言而不知其意啊。
 
特尔斐:
其实问题的症结savetime已经讲得很明白了,问题就是Microsoft的COM事件通知机制造成的。这个通知机制,设计为双向通讯,也就是说,COM服务器需要有COM客户端的回答,如果没有客户端的回答,服务端会被挂起。
savetime设计了一个例子证明了这种阻塞式的同步,直接导致COM服务器阻塞。下面的例子也一样直接阻塞服务器:
procedure TAdoThread.Execute;
var
Conn: TADOConnection;
FThreadEvent: THandle;
begin
ActiveX.CoInitialize(nil);
Conn := TADOConnection.Create(nil);
FThreadEvent := CreateEvent(nil, True, False, 'MYThreadEvent');
if FThreadEvent <> 0 then
if WaitForSingleObject(FThreadEvent, INFINITE) = WAIT_OBJECT_0 then
CloseHandle(FThreadEvent);
YConn.Free;
ActiveX.CoUninitialize;
end;

我们可以模仿TADOConnection构造一个COM事件接受器对象,并重现服务器阻塞:
uses
Classes, Windows, Messages, ADODB, ActiveX, DB, COMObj, ADOInt, Forms;
type
MYEvent = interface(IUnknown)
['{00000402-0000-0010-8000-00AA006D2EA4}']
end;

TMYObj = class(TCustomConnection, IUnknown, MYEvent)
protected
FConnectionObject: _Connection;
public
FConnEventsID: integer;
function ConnectionPoint: IConnectionPoint;
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
end;

TAdoThread = class(TThread)
protected
procedure Execute;
override;
end;

implementation
function TMYObj.ConnectionPoint: IConnectionPoint;
var
ConnPtContainer: IConnectionPointContainer;
begin
OleCheck(FConnectionObject.QueryInterface(IConnectionPointContainer,
ConnPtContainer));
OleCheck(ConnPtContainer.FindConnectionPoint(DIID_ConnectionEvents, Result));
end;

constructor TMYObj.Create(AOwner: TComponent);
var
Unknown: IUnknown;
begin
inherited Create(AOwner);
CoCreateInstance(CLASS_Connection, nil, CLSCTX_INPROC_SERVER or
CLSCTX_LOCAL_SERVER, IUnknown, Unknown);
FConnectionObject := Unknown as _Connection;
OleCheck(ConnectionPoint.Advise(Self as IUnknown, FConnEventsID));
end;

destructor TMYobj.Destroy;
begin
if FConnEventsID > 0 then
OleCheck(ConnectionPoint.UnAdvise(FConnEventsID));
FConnEventsID := 0;
FConnectionObject := nil;
inherited Destroy;
end;

procedure TAdoThread.Execute;
var
var
MYObj: TMYObj;
begin
ActiveX.CoInitialize(nil);
MYObj := TMYObj.Create(nil);
SleepEx(INFINITE, False);
MYObj.Free;
ActiveX.CoUninitialize;
end;

上面的线程执行,直接导致服务器阻塞,下面通过中止与服务器的事件连接来消除阻塞:
procedure TAdoThread.Execute;
var
var
MYObj: TMYObj;
begin
ActiveX.CoInitialize(nil);
MYObj := TMYObj.Create(nil);
MYObj.ConnectionPoint.UnAdvise(MYObj.FConnEventsID);
MYObj.FConnEventsID:=0;
SleepEx(INFINITE, False);
MYObj.Free;
ActiveX.CoUninitialize;
end;

这样虽然消除了阻塞,但不是我们程序想要的目的,为了避免阻塞,我们应该改换别的同步机制,比如消息同步。也就是说,带有COM事件接受器的客户,在多线程的应用中,应该避免使用阻塞模式的同步(等待),可以使用消息同步模式代替阻塞,例如:
const
MSGUSER = WM_USER + 100;
procedure TAdoThread.Execute;
var
Msg: TMsg;
LoopExecute: Boolean;
Conn: TADOConnection;
begin
ActiveX.CoInitialize(nil);
Conn := TADOConnection.Create(nil);
LoopExecute:=True;
while LoopExecutedo
begin
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE)do
begin
if Msg.message=MSGUSER then
begin
LoopExecute:=False;
Break;
end;
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;

Conn.Free;
ActiveX.CoUninitialize;
end;

至于这个现象是否是VCL机制特有的现象,因为我没有在VC里测试,所以我也不知道。
 
多谢小雨哥、savetime的分析及各位的参与,现在结贴。
 
后退
顶部