Неосвобождается com сервер.

← →
Erik (2003-07-01 13:39) [0]

Я создал com сервер и клиент с некоторыми особеностями. Которые заключаются в создании списка инстанций сервера и клиента. Для каждого отдельно! Разумеется с маршалингом для того чтобы сервер мог перебрать всех своих клиентов. И еще реализован CallBack.
Код сервера:
TProtocol = class(TRemoteDataModule, IProtocol)
.....
procedure RemoteDataModuleCreate(Sender: TObject);
procedure RemoteDataModuleDestroy(Sender: TObject);
....
private
DBMain: TMainData;
fLoggedIn: Boolean;
fUserID: Integer;
fUserName: String;
fKohtID: Integer;
Kuupaev: Cardinal;
FMarshaler: TInterThreadMarshaler; // Callback
procedure CreateUserData;
protected
procedure SetCallBack(AValue: OleVariant); safecall;
function Login(const User, Password: WideString; var ID: Integer): RetStatus; safecall;
function SetKoht(Koht_ID: Integer): WordBool; safecall;
public
constructor Create(AOwner: TComponent); override;
function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override;
procedure CallBack(StTerminate: Boolean);
end;

Function AllReady(const User_ID, Koht_ID: Integer; var Index: Integer): RKohtStatus;

Var
Protocol: TProtocol;
ReservAeg: TReservAeg = nil;
List: TThreadSafeList = nil;
Count: Integer = 0;
...
constructor TProtocol.Create(AOwner: TComponent);
begin
if Count = 0 then begin
if not Assigned(MainData) then begin
MainData := TMainData.Create(nil);
inherited Create(AOwner);
DBMain := MainData;
end;
end else
inherited Create(AOwner);
end;

procedure TProtocol.RemoteDataModuleCreate(Sender: TObject);
begin
Inc(Count);
FMarshaler := TInterThreadMarshaler.Create(IDispatch);
FLoggedIn := False;
List.Add(Sender);
fUserID := Count; //List.Count;
if Assigned(Alarm) and Alarm.Suspended then
Alarm.Resume;
end;

procedure TProtocol.RemoteDataModuleDestroy(Sender: TObject);
begin
Dec(Count);
LogTimeStop;
if Assigned(List) then
List.Remove(Self);

ReservAeg.DelUser(fUserID);
if Assigned(DBMain) then
Sysutils.FreeAndNil(DBMain);
if Count = 0 then
MainData := nil;
end;

function TProtocol.Login(const User, Password: WideString; var ID: Integer): RetStatus;
begin
CreateUserData;
try
DBMain.Database.Connected := False;
DBMain.Database.LogonUsername := User;
DBMain.Database.LogonPassword := Password;
DBMain.Database.Connected := True;
except on E: Exception do begin
FreeAndNil(DBMain);
Result := rtError;
raise E;
end;
end;

fUserName := User;
if ID < 1 then
ID := fUserID
else fUserID := ID;
fLoggedIn := True;
Result := rtOk;
end;

Function AllReady(const User_ID, Koht_ID: Integer; var Index: Integer): RKohtStatus;
Var i: Integer;
Server: TProtocol;
begin
Result := kohtFree;
List.BeginRead;
try
for I := 0 to List.Count-1 do begin
Server := List[i];
with Server do begin
if fKohtID = 0 then
Continue;
if (fUserID = User_ID) and (fKohtID = Koht_ID) then begin
Index := i;
Result := kohtAbort;
Break;
end else if (fUserID <> User_ID) and (fKohtID = Koht_ID) then begin
Index := i;
Result := kohtExist;
Break;
end;
end;
end;
finally
List.EndRead;
end;

end;

function TProtocol.SetKoht(Koht_ID: Integer): WordBool;
var Status: RKohtStatus;
Index: Integer;
begin
Result := True;
if Koht_ID = 0 then
exit;
Status := AllReady(fUserID, Koht_ID, Index);
if Status = kohtAbort then
TProtocol(List[Index]).CallBack(Status = kohtAbort)
else
Result := Status = kohtFree;

fKohtID := Koht_ID;
LogTimeStart;
end;

procedure TProtocol.CallBack(StTerminate: Boolean);
var Intf: Variant;
User_ID, Koht_ID: Integer;
begin
if not Assigned(FMarshaler.Unknown) then
exit;
Intf := IDispatch(FMarshaler.Unknown);
if StTerminate then
FMarshaler.Clear;
Intf.DoExists(User_ID, Koht_ID, StTerminate);

if not StTerminate and (fKohtID<>0) and ((User_ID <> fUserID) or (Koht_ID <> fKohtID)) then
begin
StTerminate := True;
Intf.DoExists(User_ID, Koht_ID, True);
end;

if StTerminate then
FMarshaler.Clear;
end;

.....

initialization
ReservAeg := TReservAeg.Create;
List := TThreadSafeList.Create;

DataLockup.Lookup := DataLockup.TDataLookup.Create(nil);
TComponentFactory.Create(ComServer, TProtocol, Class_Protocol, ciMultiInstance, tmApartment); //tmApartment tmBoth tmSingle
ComServer.UIInteractive := False;

finalization
if Assigned(List) then
FreeAndNil(List);
FreeAndNil(ReservAeg);
FreeAndNil(DataLockup.Lookup);

CallBack - снимает задачу но счетчик сылок неуменьшается!
При простом выходе их клиента и закрытии DCOMСonnection тоже самое!

← →
Erik (2003-07-01 13:44) [1]

Привожу еще код класса TThreadSafeList.
TThreadSafeList = class
private
FLock: TMultiReadExclusiveWriteSynchronizer;
FItems: TList;
FEmptyHandle, FNotEmptyHandle: THandle;
function GetCount: Integer;
function GetItem(Index: Integer): Pointer;
procedure SetEmpty(Value: Boolean);
public
constructor Create;
destructor Destroy; override;
procedure BeginRead;
procedure EndRead;
procedure BeginWrite;
procedure EndWrite;
function IndexOf(Item: Pointer): Integer;
function Add(Item: Pointer): Integer;
procedure Delete(Index: Integer);
procedure Insert(Index: Integer; Item: Pointer);
procedure Remove(Item: Pointer);
procedure Clear;
property Count: Integer read GetCount;
property Items[Index: Integer]: Pointer read GetItem; default;
property EmptyHandle: THandle read FEmptyHandle;
property NotEmptyHandle: THandle read FNotEmptyHandle;
end;

{ TThreadSafeList }
constructor TThreadSafeList.Create;
begin
FLock := TMultiReadExclusiveWriteSynchronizer.Create;
FEmptyHandle := CreateEvent(nil, True, True, nil);
FNotEmptyHandle := CreateEvent(nil, True, False, nil);
end;

destructor TThreadSafeList.Destroy;
begin
Clear;
FLock.Free;
CloseHandle(FEmptyHandle);
CloseHandle(FNotEmptyHandle);
inherited;
end;

procedure TThreadSafeList.SetEmpty(Value: Boolean);
begin
if Value then
begin
SetEvent(FEmptyHandle);
ResetEvent(FNotEmptyHandle);
end else begin
ResetEvent(FEmptyHandle);
SetEvent(FNotEmptyHandle);
end
end;

function TThreadSafeList.GetCount: Integer;
begin
BeginRead;
try
Result := ListCount(FItems);
finally
EndRead;
end;
end;

function TThreadSafeList.GetItem(Index: Integer): Pointer;
begin
BeginRead;
try
Result := ListItem(FItems, Index);
finally
EndRead;
end;
end;

function TThreadSafeList.IndexOf(Item: Pointer): Integer;
begin
BeginRead;
try
Result := ListIndexOf(FItems, Item);
finally
EndRead;
end;
end;

procedure TThreadSafeList.BeginRead;
begin
FLock.BeginRead;
end;

procedure TThreadSafeList.EndRead;
begin
FLock.EndRead;
end;

procedure TThreadSafeList.BeginWrite;
begin
FLock.BeginWrite;
end;

procedure TThreadSafeList.EndWrite;
begin
FLock.EndWrite;
end;

function TThreadSafeList.Add(Item: Pointer): Integer;
begin
BeginWrite;
try
Result := Count;
Insert(Result, Item);
finally
EndWrite;
end;
end;

procedure TThreadSafeList.Delete(Index: Integer);
begin
BeginWrite;
try
ListDelete(FItems, Index);
finally
EndWrite;
end;
end;

procedure TThreadSafeList.Insert(Index: Integer; Item: Pointer);
begin
BeginWrite;
try
ListInsert(FItems, Index, Item);
SetEmpty(False);
finally
EndWrite;
end;
end;

procedure TThreadSafeList.Clear;
begin
BeginWrite;
try
ListClear(FItems);
SetEmpty(True);
finally
EndWrite;
end;
end;

procedure TThreadSafeList.Remove(Item: Pointer);
begin
BeginWrite;
try
if ListIndexOf(FItems, Item) >= 0 then
begin
ListRemove(FItems, Item);
SetEmpty(FItems = nil);
end;
finally
EndWrite;
end;
end;

Неосвобождается com сервер. Найти похожие ветки