[分享]过去写的一个实用工具：也是一个多线程的使用实例----延时释放类实例 ( 积分: 0 )

  • 主题发起人 主题发起人 Another_eYes
  • 开始时间 开始时间
A

Another_eYes

Unregistered / Unconfirmed
GUEST, unregistred user!
以下的unit只导出了一个过程，procedure DelayRelease(Obj: TObject);
该过程的功能就是延时5秒后才释放一个Object（不会阻塞当前代码的运行）。该过程可以用于多线程程序中防止由于某一线程释放了某个资源而造成其它线程的冲突。
实际应用时可以将xxx.free用DelayRelease(xxx)代替。
从代码中也可以学到多线程的一种常用使用方法。
unit DelayLists;
interface
uses
SysUtils, Classes, Windows;
const
DELAY_RELEASE_TICK = 5000;
type
TDelayReleaseList = class(TThread)
protected
WaitEvent: Cardinal;
// 等待句柄
Lst: TList;
// 删除队列，Lst.Items = 进入队列时间
// Lst.Items[i+1] = 需要删除的Obj
Lock: TRTLCriticalSection;
// 同步锁，同步对Lst操作用
procedure Execute;
override;
public
constructor Create;
procedure DFree(Obj: TObject);
// 添加obj到删除队列
procedure Stop;
// 终止线程（程序退出时自动执行）
end;

procedure DelayRelease(Obj: TObject);
var
DelayList: TDelayReleaseList;
implementation
procedure DelayRelease(Obj: TObject);
begin
DelayList.DFree(Obj);
end;

{ TDelayReleaseList }
constructor TDelayReleaseList.Create;
begin
InitializeCriticalSection(Lock);
WaitEvent := CreateEvent(nil, false, false, nil);
Lst := TList.Create;
Inherited Create(false);
end;

procedure TDelayReleaseList.DFree(Obj: TObject);
begin
if obj = nil then
exit;
try
EnterCriticalSection(Lock);
try
// 添加到删除队列中
Lst.Add(Pointer(GetTickCount));
Lst.Add(Pointer(Obj));
finally
LeaveCriticalSection(Lock);
end;
except
end;
end;

type
TListRef = class
private
FList: PPointerList;
FCount: Integer;
FCapacity: Integer;
end;

procedure TDelayReleaseList.Execute;
var
b, e, c: Integer;
Tick, T2: Cardinal;
v: PPointerList;
f: Boolean;
begin
FreeOnTerminate := true;
while not Terminateddo
try
WaitForSingleObject(WaitEvent, DELAY_RELEASE_TICK);
// 每5秒检查一次队列
if terminated then
break;
Tick := GetTickCount;
T2 := Tick - DELAY_RELEASE_TICK;
f := Tick < T2;
// 是否已连续运行超过49.8天或系统启动还不到5秒的标记
dec(Tick, DELAY_RELEASE_TICK);
// 释放队列中Tick时间之前的所有obj
EnterCriticalSection(Lock);
try
b := 0;
e := Lst.Count - 2;
v := nil;
if b <= e then
begin
// 快速定位队列中Tick时间前的所有项目
if f or (cardinal(Lst.Items) > cardinal(Lst.Items[e])) then
// tickcount归过0的情况下
while b <= edo
begin
c := (b + e) shr 2 shl 1;
if Integer(Tick) < Integer(Lst.Items[c]) then
e := c - 2
else
b := c + 2;
end
else
// 连续运行未超过49.8天，tickcount未归过0
while b <= edo
begin
c := (b + e) shr 2 shl 1;
if Tick < cardinal(Lst.Items[c]) then
e := c - 2
else
b := c + 2;
end;
if b > 0 then
// 将队列中所有Tick时间前的项目移到临时内存块在中并在队列里删除这些项
if b < Lst.Count then
begin
GetMem(v, b * 4);
Move(Lst.List^, v^, b * 4);
with TListRef(Lst)do
begin
Move(FList, FList[0], (FCount - b) * 4);
Dec(FCount, b);
end;
end
else
with TListRef(Lst)do
begin
v := FList;
FList := nil;
b := fcount;
FCount := 0;
FCapacity := 0;
end
end;
finally
LeaveCriticalSection(Lock);
end;
if b > 0 then
begin
// 删除临时内存中的所有项目
c := 1;
while c < bdo
begin
try
TObject(v[c]).Free;
except
end;
inc(c, 2);
end;
freemem(v);
end;
except
end;
closehandle(WaitEvent);
Lst.Free;
deletecriticalsection(lock);
end;

procedure TDelayReleaseList.Stop;
begin
try
Terminate;
SetEvent(WaitEvent);
except
end;
end;

initialization
DelayList := TDelayReleaseList.Create;
finalization
DelayList.Stop;
end.
 
以下的unit只导出了一个过程，procedure DelayRelease(Obj: TObject);
该过程的功能就是延时5秒后才释放一个Object（不会阻塞当前代码的运行）。该过程可以用于多线程程序中防止由于某一线程释放了某个资源而造成其它线程的冲突。
实际应用时可以将xxx.free用DelayRelease(xxx)代替。
从代码中也可以学到多线程的一种常用使用方法。
unit DelayLists;
interface
uses
SysUtils, Classes, Windows;
const
DELAY_RELEASE_TICK = 5000;
type
TDelayReleaseList = class(TThread)
protected
WaitEvent: Cardinal;
// 等待句柄
Lst: TList;
// 删除队列，Lst.Items = 进入队列时间
// Lst.Items[i+1] = 需要删除的Obj
Lock: TRTLCriticalSection;
// 同步锁，同步对Lst操作用
procedure Execute;
override;
public
constructor Create;
procedure DFree(Obj: TObject);
// 添加obj到删除队列
procedure Stop;
// 终止线程（程序退出时自动执行）
end;

procedure DelayRelease(Obj: TObject);
var
DelayList: TDelayReleaseList;
implementation
procedure DelayRelease(Obj: TObject);
begin
DelayList.DFree(Obj);
end;

{ TDelayReleaseList }
constructor TDelayReleaseList.Create;
begin
InitializeCriticalSection(Lock);
WaitEvent := CreateEvent(nil, false, false, nil);
Lst := TList.Create;
Inherited Create(false);
end;

procedure TDelayReleaseList.DFree(Obj: TObject);
begin
if obj = nil then
exit;
try
EnterCriticalSection(Lock);
try
// 添加到删除队列中
Lst.Add(Pointer(GetTickCount));
Lst.Add(Pointer(Obj));
finally
LeaveCriticalSection(Lock);
end;
except
end;
end;

type
TListRef = class
private
FList: PPointerList;
FCount: Integer;
FCapacity: Integer;
end;

procedure TDelayReleaseList.Execute;
var
b, e, c: Integer;
Tick, T2: Cardinal;
v: PPointerList;
f: Boolean;
begin
FreeOnTerminate := true;
while not Terminateddo
try
WaitForSingleObject(WaitEvent, DELAY_RELEASE_TICK);
// 每5秒检查一次队列
if terminated then
break;
Tick := GetTickCount;
T2 := Tick - DELAY_RELEASE_TICK;
f := Tick < T2;
// 是否已连续运行超过49.8天或系统启动还不到5秒的标记
dec(Tick, DELAY_RELEASE_TICK);
// 释放队列中Tick时间之前的所有obj
EnterCriticalSection(Lock);
try
b := 0;
e := Lst.Count - 2;
v := nil;
if b <= e then
begin
// 快速定位队列中Tick时间前的所有项目
if f or (cardinal(Lst.Items) > cardinal(Lst.Items[e])) then
// tickcount归过0的情况下
while b <= edo
begin
c := (b + e) shr 2 shl 1;
if Integer(Tick) < Integer(Lst.Items[c]) then
e := c - 2
else
b := c + 2;
end
else
// 连续运行未超过49.8天，tickcount未归过0
while b <= edo
begin
c := (b + e) shr 2 shl 1;
if Tick < cardinal(Lst.Items[c]) then
e := c - 2
else
b := c + 2;
end;
if b > 0 then
// 将队列中所有Tick时间前的项目移到临时内存块在中并在队列里删除这些项
if b < Lst.Count then
begin
GetMem(v, b * 4);
Move(Lst.List^, v^, b * 4);
with TListRef(Lst)do
begin
Move(FList, FList[0], (FCount - b) * 4);
Dec(FCount, b);
end;
end
else
with TListRef(Lst)do
begin
v := FList;
FList := nil;
b := fcount;
FCount := 0;
FCapacity := 0;
end
end;
finally
LeaveCriticalSection(Lock);
end;
if b > 0 then
begin
// 删除临时内存中的所有项目
c := 1;
while c < bdo
begin
try
TObject(v[c]).Free;
except
end;
inc(c, 2);
end;
freemem(v);
end;
except
end;
closehandle(WaitEvent);
Lst.Free;
deletecriticalsection(lock);
end;

procedure TDelayReleaseList.Stop;
begin
try
Terminate;
SetEvent(WaitEvent);
except
end;
end;

initialization
DelayList := TDelayReleaseList.Create;
finalization
DelayList.Stop;
end.
 
谢谢大虾，这一段正好用到。
 
好,帮顶


--------签名档---------------------------

比肩国内顶尖源码下载站点 -> 源码我爱你

http://www.source520.com
http://www.source520.net
80G源码电子书免费免注册下载,大量精辟技术文档库随时更新
******************************************************************
附:为了站点持续发展,现有本站近年来收藏的大量大型商业源码低价出售,
详情请进入以下链接查看:
http://www.source520.com/building_delphi.htm

浏览商业代码请从如下URL进入查看实物:
1.商业源码库1: ftp://source520see3:browse@61.152.199.245/
2.商业源码库2: ftp://source520see2:browse@61.152.199.245/
 
您必须登录或注册才可回复。

Similar threads

I
一个数列
回复
0
查看
843
import
I
I
对Object Pascal编译器给类对象分配堆内存细节的一种大胆猜
回复
0
查看
846
import
I
X
应部分网友要求，公开 myfunctions 单元，里面有很多有用的函数(0)
回复
10
查看
4K
yczjs
Y
W
关于DELPHI中一个多线程局域网扫描组件的使用问题，新手。。没有分，见谅(20)
回复
0
查看
1K
wh445306
W
完
多线程查询数据库，偶尔会丢掉一个线程。但大部分时候是正常。苦恼中。 (问题解决，有待优化，欢迎发表意见，顶者有分，晚上结贴)(100)
回复
11
查看
1K
完美动物
完
后退
顶部