今天看cnpack时发现一文件名为CnMemProf.pas
打开一看原来就是ShenNewMemMgr的改写
加了点注释屏蔽掉了内存"泄漏"时弹出的对话框
新建一个单元文件将下面的代码贴过去,保存名为CnMemProf.pas
然后新建一个工程什么都不要做(就是我说的只有一个主窗体啦
),保存工程到一文件夹下
然后将上面的那个CnMemProf.pas文件copy到工程文件夹下
在工程文件的第一个uses位置处引用上这个单元,怕新手不了解代码如下
program Project1;
uses
CnMemProf,<<<<<<<<引用的位置
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
现在运行一下工程,然后再关闭它,你会发现在工程文件夹下多了一个Memory.Log文件
用记事本打开它,内容如下
:::::::::::::::::::::::::::::::::::::::::::::::::::::
2003-11-20 23:40:36
程序运行时间: 0 小时 0 分 6 秒。
可用地址空间: 1024 千字节
未提交部分: 1008 千字节
已提交部分: 16 千字节
空闲部分: 13 千字节
已分配部分: 2 千字节
地址空间载入: 0%
全部小空闲内存块: 4 千字节
全部大空闲内存块: 0 千字节
其它未用内存块: 9 千字节
内存管理器消耗: 0 千字节
内存对象数目: 8<<<<<<<<注意这儿,它说内存中有8处对象未获得"解放"
如果我们用下面的代码再来测试一下
先删除掉那个Memory.Log文件
声明一个全局变量
h
char;
在窗体的create事件中写上一句
new(h);
再运行,关闭工程
再看那个Memory.Log文件会发现8变成了9,
这多出来的1就是我们故意
泄漏的new(h),因为我们没有释放这个指针
如果在new(h);下再加上一句dispose(h);
再测试那个9变成了8
但是一个delphi6的工程我们只是新建一个工程什么都不做,这个8处内存泄漏从何而来呢?
可能是我的delphi6有问题,大家自己做做试验,希望将结果贴出来让我看看
实际做项目的时候可以使用此法做内存的监测,我们就把8看成是0吧
如果到了9了,就得自己好好反省了
{******************************************************************************}
{ CnPack For Delphi/C++Builder }
{ 中国人自己的免费第三方开发包 }
{ (C)Copyright 2001, 2003 CnPack开发组 }
{ ------------------------------------ }
{ }
{ 这一开发包是自由软件，您可以遵照自由软体基金会出版的GNU 较 }
{ 宽松通用公共许可证条款来修改和重新发布这一程序，或者用许可证的 }
{ 第二版，或者（根据您的选择）用任何更新的版本。 }
{ }
{ 发布这一开发包的目的是希望它有用，但没有任何担保。甚至没有 }
{ 适合特定目的而隐含的担保。更详细的情况请参阅 GNU 较宽松通用公 }
{ 共许可证。 }
{ }
{ 您应该已经和开发包一起收到一份 GNU 较宽松通用公共许可证的 }
{ 副本。如果还没有，写信给： }
{ Free Software Foundation, Inc., 59 Temple Place - Suite }
{ 330, Boston, MA 02111-1307, USA. }
{ }
{ 原始文件名：CnMemProf.pas }
{ 单元作者：Chinbo(Chinbo) }
{ 下载地址：http://www.cnvcl.org }
{ 电子邮件：cnpack@163.com }
{ 备注：从Delphi技术手册增强而来的内存管理器 }
{ }
{******************************************************************************}
unit CnMemProf;
{* |<PRE>
================================================================================
* 软件名称：开发包基础库
* 单元名称：内存防护单元
* 单元作者：Chinbo(Shenloqi@hotmail.com)
* 备 注：使用它的时候要把它放到Project文件的Uses的第一个，不然会出现误报。
* 然后在工程中加上
* - mmPopupMsgDlg := True;
* 如果有内存泄漏，就弹出对话框
* - mmShowObjectInfo := True;
* 有内存泄漏，且有RTTI，就会报告对象的类型
* - 如果觉得程序的运行速度慢，可以设定
* mmUseObjectList := False;
* 不能够报告详细的内存泄漏的地址以及对象信息，即使设定了
* mmShowObjectInfo，这样经测试速度跟Delphi自带的速度相仿
* - 如果不需要内存检查报告，可以设定
* mmSaveToLogFile := False;
* - 如果要自定义记录文件，可以设定
* mmErrLogFile := '你的记录文件名';
* 默认文件名为exe文件的目录下的memory.log
* - 可以使用SnapToFile过程抓取内存运行状态到指定文件。
* 在程序终止时会OutputDebugString出内存使用状况。
* 开发平台：PWin98SE + Delphi 5.0
* 兼容测试：PWin9X/2000/XP + Delphi 5/6
* 本 地 化：该单元中的字符串暂不符合本地化处理方式
* 更新记录：2002.08.06 V1.0
* 创建单元
================================================================================
|</PRE>}
{
单元本地化处理任务：
请将该单元中用到的字符串，重新定义到CnConsts.pas单元中（资源字符串）
存放位置在CnConsts.pas单元的尾部
方法：
查找字符串，比如'内存管理监视器指针列表溢出，请增大列表项数！'，将它放到
CnConsts.pas单元中，定义
SCnMemMgrOutflow = '内存管理监视器指针列表溢出，请增大列表项数！';
并用SCnMemMgrOutflow来替换原字符串
注意：
CnConsts中使用了预编译指令，还应定义一份英文的字符串
如果定义在resourcestrings中的字符串编译通不过，把它放到consts中
重复出现的字符串用同一个常量代替
纯符号的字符串不用本地化处理，如') '
Format函数中的字符串也应进行处理
处理完后请修改相关的单元版本号、本地化说明
}
interface
var
GetMemCount: Integer = 0;
FreeMemCount: Integer = 0;
ReallocMemCount: Integer = 0;
mmPopupMsgDlg: Boolean = False;
mmShowObjectInfo: Boolean = False;
mmUseObjectList: Boolean = True;
mmSaveToLogFile: Boolean = True;
mmErrLogFile: string = '';
procedure SnapToFile(Filename: string);
implementation
uses
Windows, SysUtils, TypInfo;
const
MaxCount = High(Word);
var
OldMemMgr: TMemoryManager;
ObjList: array[0..MaxCount] of Pointer;
FreeInList: Integer = 0;
StartTime: DWORD;
{-----------------------------------------------------------------------------
Procedure: AddToList
Author: Chinbo(Chinbo)
Date: 06-八月-2002
Arguments: P: Pointer
Result: None
添加指针
-----------------------------------------------------------------------------}
procedure AddToList(P: Pointer);
begin
if FreeInList > High(ObjList) then
begin
MessageBox(0, '内存管理监视器指针列表溢出，请增大列表项数！',
'内存管理监视器', mb_ok + mb_iconError);
Exit;
end;
ObjList[FreeInList] := P;
Inc(FreeInList);
end;
{-----------------------------------------------------------------------------
Procedure: RemoveFromList
Author: Chinbo(Chinbo)
Date: 06-八月-2002
Arguments: P: Pointer
Result: None
移除指针
-----------------------------------------------------------------------------}
procedure RemoveFromList(P: Pointer);
var
I: Integer;
begin
for I := Pred(FreeInList) downto 0 do
if ObjList
= P then
begin
Dec(FreeInList);
Move(ObjList[I + 1], ObjList, (FreeInList - I) * SizeOf(Pointer));
Exit;
end;
end;
{-----------------------------------------------------------------------------
Procedure: SnapToFile
Author: Chinbo(Chinbo)
Date: 06-八月-2002
Arguments: Filename: string
Result: None
Modify: 与月共舞(yygw@yygw.net) 2002.08.06
为方便本地化处理，进行了一些调整
代码可读性比原来下降 :-(
抓取快照
-----------------------------------------------------------------------------}
procedure SnapToFile(Filename: string);
var
OutFile: TextFile;
I,
CurrFree,
BlockSize: Integer;
HeapStatus: THeapStatus;
Item: TObject;
ptd: PTypeData;
ppi: PPropInfo;
NowTime: DWORD;
{-----------------------------------------------------------------------------
Procedure: MSELToTime
Author: Chinbo(Chinbo)
Date: 06-八月-2002
Arguments: const MSEL: DWORD
Result: string
转换时间
-----------------------------------------------------------------------------}
function MSELToTime(const MSEL: DWORD): string;
begin
Result := Format('%d 小时 %d 分 %d 秒。', [MSEL div 3600000, MSEL div 60000,
MSEL div 1000]);
end;
begin
AssignFile(OutFile, Filename);
try
if FileExists(Filename) then
Append(OutFile)
else
Rewrite(OutFile);
NowTime := GetTickCount - StartTime;
HeapStatus := GetHeapStatus;
with HeapStatus do
begin
Writeln(OutFile, ':::::::::::::::::::::::::::::::::::::::::::::::::::::');
Writeln(OutFile, DateTimeToStr(Now));
Writeln(OutFile);
Writeln(OutFile, '程序运行时间: ' + MSELToTime(NowTime));
Writeln(OutFile, Format('可用地址空间: %d 千字节', [TotalAddrSpace div 1024]));
Writeln(OutFile, Format('未提交部分: %d 千字节', [TotalUncommitted div 1024]));
Writeln(OutFile, Format('已提交部分: %d 千字节', [TotalCommitted div 1024]));
Writeln(OutFile, Format('空闲部分: %d 千字节', [TotalFree div 1024]));
Writeln(OutFile, Format('已分配部分: %d 千字节', [TotalAllocated div 1024]));
Writeln(OutFile, Format('地址空间载入: %d%%', [TotalAllocated div (TotalAddrSpace div 100)]));
Writeln(OutFile, Format('全部小空闲内存块: %d 千字节', [FreeSmall div 1024]));
Writeln(OutFile, Format('全部大空闲内存块: %d 千字节', [FreeBig div 1024]));
Writeln(OutFile, Format('其它未用内存块: %d 千字节', [Unused div 1024]));
Writeln(OutFile, Format('内存管理器消耗: %d 千字节', [Overhead div 1024]));
end
//end with HeapStatus
CurrFree := FreeInList;
Writeln(OutFile);
Write(OutFile, '内存对象数目: ');
if mmUseObjectList then
begin
Write(OutFile, CurrFree);
end
else
begin
Write(OutFile, GetMemCount - FreeMemCount);
if GetMemCount = FreeMemCount then
Write(OutFile, '，没有内存泄漏。')
else
Write(OutFile, '。');
Writeln(OutFile);
end
//end if mmUseObjectList
if mmUseObjectList and mmShowObjectInfo then
begin
if CurrFree = 0 then
begin
Write(OutFile, '，没有内存泄漏。');
Writeln(OutFile);
end
else
begin
Writeln(OutFile);
for I := 0 to CurrFree - 1 do
begin
BlockSize := PDWORD(DWORD(ObjList) - 4)^;
Write(OutFile, Format('%4d) %s - %4d', [I + 1,
IntToHex(Cardinal(ObjList), 16), BlockSize]));
Write(OutFile, Format('($%s)字节 - ', [IntToHex(BlockSize, 4)]));
try
Item := TObject(ObjList);
//Use RTTI, in IDE may raise exception, But not problems
if PTypeInfo(Item.ClassInfo).Kind <> tkClass then
Write(OutFile, '不是对象')
else
begin
ptd := GetTypeData(PTypeInfo(Item.ClassInfo));
//是否具有名称
ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), 'Name');
if ppi <> nil then
begin
Write(OutFile, GetStrProp(Item, ppi));
Write(OutFile, ' : ');
end
else
Write(OutFile, '(未命名): ');
Write(OutFile, PTypeInfo(Item.ClassInfo).Name);
Write(OutFile, Format(' (%d 字节) - In %s.pas',
[ptd.ClassType.InstanceSize, ptd.UnitName]));
end
//end if GET RTTI
except
on Exception do
Write(OutFile, '不是对象');
end
//end try
Writeln(OutFile);
end;
end
//end if CurrFree
end
//end if mmUseObjectList and mmShowObjectInfo
finally
CloseFile(OutFile);
end
//end try
end;
{-----------------------------------------------------------------------------
Procedure: NewGetMem
Author: Chinbo(Chinbo)
Date: 06-八月-2002
Arguments: Size: Integer
Result: Pointer
分配内存
-----------------------------------------------------------------------------}
function NewGetMem(Size: Integer): Pointer;
begin
Inc(GetMemCount);
Result := OldMemMgr.GetMem(Size);
if mmUseObjectList then
AddToList(Result);
end;
{-----------------------------------------------------------------------------
Procedure: NewFreeMem
Author: Chinbo(Chinbo)
Date: 06-八月-2002
Arguments: P: Pointer
Result: Integer
释放内存
-----------------------------------------------------------------------------}
function NewFreeMem(P: Pointer): Integer;
begin
Inc(FreeMemCount);
Result := OldMemMgr.FreeMem(P);
if mmUseObjectList then
RemoveFromList(P);
end;
{-----------------------------------------------------------------------------
Procedure: NewReallocMem
Author: Chinbo(Chinbo)
Date: 06-八月-2002
Arguments: P: Pointer
Size: Integer
Result: Pointer
重新分配
-----------------------------------------------------------------------------}
function NewReallocMem(P: Pointer
Size: Integer): Pointer;
begin
Inc(ReallocMemCount);
Result := OldMemMgr.ReallocMem(P, Size);
if mmUseObjectList then
begin
RemoveFromList(P);
AddToList(Result);
end;
end;
const
NewMemMgr: TMemoryManager = (
GetMem: NewGetMem;
FreeMem: NewFreeMem;
ReallocMem: NewReallocMem);
initialization
StartTime := GetTickCount;
GetMemoryManager(OldMemMgr);
SetMemoryManager(NewMemMgr);
finalization
SetMemoryManager(OldMemMgr);
if (GetMemCount - FreeMemCount) <> 0 then
begin
if mmPopupMsgDlg then
MessageBox(0, PChar(Format('出现 %d 处内存漏洞。',
[GetMemCount - FreeMemCount])), '内存管理监视器', MB_OK)
else
OutputDebugString(PChar(Format('出现 %d 处内存漏洞。', [GetMemCount -
FreeMemCount])));
end;
OutputDebugString(PChar(Format('Get = %d Free = %d Realloc = %d',
[GetMemCount,
FreeMemCount, ReallocMemCount])));
if mmErrLogFile = '' then
mmErrLogFile := ExtractFileDir(ParamStr(0)) + '/Memory.Log';
if mmSaveToLogFile then
SnapToFile(mmErrLogFile);
end.
