You can subscribe to this list here.
2006 |
Jan
|
Feb
|
Mar
|
Apr
(20) |
May
(48) |
Jun
(8) |
Jul
(23) |
Aug
(41) |
Sep
(42) |
Oct
(22) |
Nov
(17) |
Dec
(36) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2007 |
Jan
(43) |
Feb
(42) |
Mar
(17) |
Apr
(39) |
May
(16) |
Jun
(35) |
Jul
(37) |
Aug
(47) |
Sep
(49) |
Oct
(9) |
Nov
(52) |
Dec
(37) |
2008 |
Jan
(48) |
Feb
(21) |
Mar
(7) |
Apr
(2) |
May
(5) |
Jun
(17) |
Jul
(17) |
Aug
(40) |
Sep
(58) |
Oct
(38) |
Nov
(19) |
Dec
(32) |
2009 |
Jan
(67) |
Feb
(46) |
Mar
(54) |
Apr
(34) |
May
(37) |
Jun
(52) |
Jul
(67) |
Aug
(72) |
Sep
(48) |
Oct
(35) |
Nov
(27) |
Dec
(12) |
2010 |
Jan
(56) |
Feb
(46) |
Mar
(19) |
Apr
(14) |
May
(21) |
Jun
(3) |
Jul
(13) |
Aug
(48) |
Sep
(34) |
Oct
(51) |
Nov
(16) |
Dec
(32) |
2011 |
Jan
(36) |
Feb
(14) |
Mar
(12) |
Apr
(3) |
May
(5) |
Jun
(24) |
Jul
(15) |
Aug
(30) |
Sep
(21) |
Oct
(4) |
Nov
(25) |
Dec
(23) |
2012 |
Jan
(45) |
Feb
(42) |
Mar
(19) |
Apr
(14) |
May
(13) |
Jun
(7) |
Jul
(3) |
Aug
(46) |
Sep
(21) |
Oct
(10) |
Nov
(2) |
Dec
|
2013 |
Jan
(5) |
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
From: <ou...@us...> - 2009-06-06 10:05:02
|
Revision: 2792 http://jcl.svn.sourceforge.net/jcl/?rev=2792&view=rev Author: outchy Date: 2009-06-06 10:04:54 +0000 (Sat, 06 Jun 2009) Log Message: ----------- Mantis 4771: crash: TJclDebugInfoSymbols and SymLoadModuleFunc (possible fix) Modified Paths: -------------- trunk/jcl/source/windows/JclDebug.pas Modified: trunk/jcl/source/windows/JclDebug.pas =================================================================== --- trunk/jcl/source/windows/JclDebug.pas 2009-06-05 21:52:55 UTC (rev 2791) +++ trunk/jcl/source/windows/JclDebug.pas 2009-06-06 10:04:54 UTC (rev 2792) @@ -3126,11 +3126,16 @@ SearchPath := StrRemoveEmptyPaths(SearchPath); end; + // in Windows NT, first argument is a process handle if IsWinNT and Assigned(SymInitializeWFunc) then - Result := SymInitializeWFunc(GetCurrentProcessId, PWideChar(WideString(SearchPath)), False) + Result := SymInitializeWFunc(GetCurrentProcess, PWideChar(WideString(SearchPath)), False) else if IsWinNT and Assigned(SymInitializeAFunc) then - Result := SymInitializeAFunc(GetCurrentProcess, PAnsiChar(AnsiString(SearchPath)), False); + Result := SymInitializeAFunc(GetCurrentProcess, PAnsiChar(AnsiString(SearchPath)), False) + else + // in Windows 95, 98, ME, first argument is a process identifier + if Assigned(SymInitializeAFunc) then + Result := SymInitializeAFunc(GetCurrentProcessId, PAnsiChar(AnsiString(SearchPath)), False); if Result then begin SymOptions := SymGetOptionsFunc or SYMOPT_DEFERRED_LOADS This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ah...@us...> - 2009-06-05 21:53:21
|
Revision: 2791 http://jcl.svn.sourceforge.net/jcl/?rev=2791&view=rev Author: ahuser Date: 2009-06-05 21:52:55 +0000 (Fri, 05 Jun 2009) Log Message: ----------- Changed SyncObjs.TMutex to JclSynch.TJclMutex Fixed compiler warnings Removed UTF8 BOM Modified Paths: -------------- trunk/jcl/source/common/JclCompression.pas trunk/jcl/source/common/JclResources.pas trunk/jcl/source/common/JclUnitVersioning.pas Modified: trunk/jcl/source/common/JclCompression.pas =================================================================== --- trunk/jcl/source/common/JclCompression.pas 2009-06-03 22:43:38 UTC (rev 2790) +++ trunk/jcl/source/common/JclCompression.pas 2009-06-05 21:52:55 UTC (rev 2791) @@ -51,6 +51,10 @@ {$I jcl.inc} +{$IFDEF SUPPORTS_PLATFORM_WARNINGS} + {$WARN SYMBOL_PLATFORM OFF} +{$ENDIF SUPPORTS_PLATFORM_WARNINGS} + interface uses Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2009-06-03 22:43:38 UTC (rev 2790) +++ trunk/jcl/source/common/JclResources.pas 2009-06-05 21:52:55 UTC (rev 2791) @@ -1,4 +1,4 @@ -{**************************************************************************************************} +{**************************************************************************************************} { } { Project JEDI Code Library (JCL) } { } Modified: trunk/jcl/source/common/JclUnitVersioning.pas =================================================================== --- trunk/jcl/source/common/JclUnitVersioning.pas 2009-06-03 22:43:38 UTC (rev 2790) +++ trunk/jcl/source/common/JclUnitVersioning.pas 2009-06-05 21:52:55 UTC (rev 2791) @@ -146,13 +146,8 @@ implementation uses - JclSysUtils, SyncObjs; + JclSysUtils, JclSynch; -{$IFNDEF COMPILER11_UP} -type - DWORD_PTR = DWORD; -{$ENDIF ~COMPILER11_UP} - // Delphi 5 does not know this function //(usc) D6/7 Per does have StartsWith // a fast version of Pos(SubStr, S) = 1 function StartsWith(const SubStr, S: string): Boolean; @@ -573,7 +568,7 @@ UnitVersioningOwner: Boolean = False; GlobalUnitVersioning: TUnitVersioning = nil; UnitVersioningNPA: PUnitVersioning = nil; - UnitVersioningMutex: TMutex; + UnitVersioningMutex: TJclMutex; UnitVersioningFinalized: Boolean = False; function GetUnitVersioning: TUnitVersioning; @@ -585,11 +580,11 @@ end; if UnitVersioningMutex = nil then - UnitVersioningMutex := TMutex.Create(nil, False, 'MutexNPA_UnitVersioning_' + IntToStr(GetCurrentProcessId)); + UnitVersioningMutex := TJclMutex.Create(nil, False, 'MutexNPA_UnitVersioning_' + IntToStr(GetCurrentProcessId)); if GlobalUnitVersioning = nil then begin - UnitVersioningMutex.Acquire; + UnitVersioningMutex.WaitFor(INFINITE); try if UnitVersioningNPA = nil then SharedGetMem(UnitVersioningNPA, 'ShmNPA_UnitVersioning_' + IntToStr(GetCurrentProcessId), SizeOf(TUnitVersioning)); @@ -615,7 +610,7 @@ else if UnitVersioningNPA <> nil then begin - UnitVersioningMutex.Acquire; + UnitVersioningMutex.WaitFor(INFINITE); try GlobalUnitVersioning := UnitVersioningNPA^; // update (maybe the owner has destroyed the instance) finally @@ -631,7 +626,7 @@ try if UnitVersioningNPA <> nil then begin - UnitVersioningMutex.Acquire; + UnitVersioningMutex.WaitFor(INFINITE); try UnitVersioningNPA^ := nil; SharedCloseMem(UnitVersioningNPA); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <usc...@us...> - 2009-06-03 22:43:40
|
Revision: 2790 http://jcl.svn.sourceforge.net/jcl/?rev=2790&view=rev Author: uschuster Date: 2009-06-03 22:43:38 +0000 (Wed, 03 Jun 2009) Log Message: ----------- new solution for the global TUnitVersioning instance to fix the issue with FastMM FullDebugMode (solution by Andy) (Mantis #4783) Modified Paths: -------------- trunk/jcl/source/common/JclUnitVersioning.pas Modified: trunk/jcl/source/common/JclUnitVersioning.pas =================================================================== --- trunk/jcl/source/common/JclUnitVersioning.pas 2009-06-01 20:20:10 UTC (rev 2789) +++ trunk/jcl/source/common/JclUnitVersioning.pas 2009-06-03 22:43:38 UTC (rev 2790) @@ -145,6 +145,9 @@ implementation +uses + JclSysUtils, SyncObjs; + {$IFNDEF COMPILER11_UP} type DWORD_PTR = DWORD; @@ -563,223 +566,86 @@ TCustomUnitVersioningProvider(FProviders[I]).LoadModuleUnitVersioningInfo(Instance); end; -function GetNamedProcessAddress(const Id: ShortString; out RefCount: Integer): Pointer; forward; - // Returns a 3820 Bytes large block [= 4096 - 276 = 4096 - (8+256+4+8)] - // max 20 blocks can be allocated -function ReleaseNamedProcessAddress(P: Pointer): Integer; forward; - -// (rom) PAGE_OFFSET is clearly Linux specific -{$IFDEF LINUX} -const - PAGE_OFFSET = $C0000000; // from linux/include/asm-i386/page.h -{$ENDIF LINUX} - -const - Signature1 = $ABCDEF0123456789; - Signature2 = $9876543210FEDCBA; - type - PNPARecord = ^TNPARecord; - TNPARecord = record - Signature1: Int64; - Id: ShortString; - RefCount: Integer; - Signature2: Int64; - Data: record end; - end; - -function GetNamedProcessAddress(const Id: ShortString; out RefCount: Integer): Pointer; -const - MaxPages = 20; -var - {$IFDEF MSWINDOWS} - SysInfo: TSystemInfo; - MemInfo: TMemoryBasicInformation; - pid: THandle; - {$ENDIF MSWINDOWS} - {$IFDEF LINUX} - pid: __pid_t; - {$ENDIF LINUX} - Requested, Allocated: PNPARecord; - Pages: Integer; - PageSize, PageMask: Cardinal; - MaximumApplicationAddress: Pointer; -begin - RefCount := 0; - {$IFDEF MSWINDOWS} - GetSystemInfo(SysInfo); - PageSize := SysInfo.dwPageSize; - pid := GetCurrentProcessId; - MaximumApplicationAddress := SysInfo.lpMaximumApplicationAddress; - {$ENDIF MSWINDOWS} - {$IFDEF UNIX} - PageSize := getpagesize; - pid := getpid; - MaximumApplicationAddress := Pointer(PAGE_OFFSET - 1); - {$ENDIF UNIX} - Pages := 0; - repeat - Requested := MaximumApplicationAddress; - Requested := Pointer(DWORD_PTR(Requested) and $FFFF0000); - Dec(Cardinal(Requested), Pages shl 16); - PageMask := (not PageSize) + 1; // assuming a power of two allocation granularity - Requested := Pointer(DWORD_PTR(Requested) and PageMask); - {$IFDEF MSWINDOWS} - Allocated := VirtualAlloc(Requested, PageSize, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE); - if Assigned(Allocated) and (Requested <> Allocated) then - begin - // We got relocated (should not happen at all) - VirtualFree(Allocated, 0, MEM_RELEASE); - Inc(Pages); - Continue; - end; - {$ENDIF MSWINDOWS} - {$IFDEF UNIX} - // Do not use MAP_FIXED because it replaces the already allocated map by a - // new map. - Allocated := mmap(Requested, PageSize, PROT_READ or PROT_WRITE, - MAP_PRIVATE or MAP_ANONYMOUS, 0, 0); - if Allocated = MAP_FAILED then - begin - // Prevent SEGV by signature-test code and try the next memory page. - Inc(Pages); - Continue; - end - else - if Allocated <> Requested then - begin - // It was relocated, means the requested address is already allocated - munmap(Allocated, PageSize); - Allocated := nil; - end; - {$ENDIF UNIX} - - if Assigned(Allocated) then - Break // new block allocated - else - begin - {$IFDEF MSWINDOWS} - VirtualQuery(Requested, MemInfo, SizeOf(MemInfo)); - if (MemInfo.RegionSize >= SizeOf(TNPARecord)) and - (MemInfo.Protect and PAGE_READWRITE = PAGE_READWRITE) then - {$ENDIF MSWINDOWS} - {$IFDEF UNIX} - try - {$ENDIF UNIX} - if (Requested.Signature1 = Signature1 xor pid) and - (Requested.Signature2 = Signature2 xor pid) and - (Requested.Id = Id) then - Break; // Found correct, already existing block. - {$IFDEF UNIX} - except - // ignore - end; - {$ENDIF UNIX} - end; - - Inc(Pages); - Requested := nil; - until Pages > MaxPages; - - Result := nil; - if Allocated <> nil then - begin - if Requested = Allocated then - begin - // initialize the block - Requested.Signature1 := Signature1 xor pid; - Requested.Id := Id; - Requested.Signature2 := Signature2 xor pid; - Requested.RefCount := 1; - Result := @Requested.Data; - RefCount := 1; - end; - end - else - if Requested <> nil then - begin - Inc(Requested.RefCount); - Result := @Requested.Data; - RefCount := Requested.RefCount; - end; -end; - -function ReleaseNamedProcessAddress(P: Pointer): Integer; -var - Requested: PNPARecord; -begin - Result := 0; - if P <> nil then - begin - Requested := PNPARecord(DWORD_PTR(P) - SizeOf(TNPARecord)); - Dec(Requested.RefCount); - Result := Requested.RefCount; - if Requested.RefCount = 0 then - {$IFDEF MSWINDOWS} - VirtualFree(Requested, 0, MEM_RELEASE); - {$ENDIF MSWINDOWS} - {$IFDEF UNIX} - munmap(Requested, getpagesize); - {$ENDIF UNIX} - end; -end; - -type PUnitVersioning = ^TUnitVersioning; var UnitVersioningOwner: Boolean = False; GlobalUnitVersioning: TUnitVersioning = nil; UnitVersioningNPA: PUnitVersioning = nil; + UnitVersioningMutex: TMutex; + UnitVersioningFinalized: Boolean = False; function GetUnitVersioning: TUnitVersioning; -var - RefCount: Integer; begin + if UnitVersioningFinalized then + begin + Result := nil; + Exit; + end; + + if UnitVersioningMutex = nil then + UnitVersioningMutex := TMutex.Create(nil, False, 'MutexNPA_UnitVersioning_' + IntToStr(GetCurrentProcessId)); + if GlobalUnitVersioning = nil then begin - UnitVersioningNPA := GetNamedProcessAddress('UnitVersioning', RefCount); - if UnitVersioningNPA <> nil then - begin - GlobalUnitVersioning := UnitVersioningNPA^; - if (GlobalUnitVersioning = nil) or (RefCount = 1) then + UnitVersioningMutex.Acquire; + try + if UnitVersioningNPA = nil then + SharedGetMem(UnitVersioningNPA, 'ShmNPA_UnitVersioning_' + IntToStr(GetCurrentProcessId), SizeOf(TUnitVersioning)); + if UnitVersioningNPA <> nil then begin + GlobalUnitVersioning := UnitVersioningNPA^; + if GlobalUnitVersioning = nil then + begin + GlobalUnitVersioning := TUnitVersioning.Create; + UnitVersioningNPA^ := GlobalUnitVersioning; + UnitVersioningOwner := True; + end; + end + else + begin GlobalUnitVersioning := TUnitVersioning.Create; - UnitVersioningNPA^ := GlobalUnitVersioning; UnitVersioningOwner := True; end; - end - else - begin - GlobalUnitVersioning := TUnitVersioning.Create; - UnitVersioningOwner := True; + finally + UnitVersioningMutex.Release; end; end else if UnitVersioningNPA <> nil then - GlobalUnitVersioning := UnitVersioningNPA^; // update (maybe the owner has destroyed the instance) + begin + UnitVersioningMutex.Acquire; + try + GlobalUnitVersioning := UnitVersioningNPA^; // update (maybe the owner has destroyed the instance) + finally + UnitVersioningMutex.Release; + end; + end; Result := GlobalUnitVersioning; end; procedure FinalizeUnitVersioning; -var - RefCount: Integer; begin + UnitVersioningFinalized := True; try - if GlobalUnitVersioning <> nil then + if UnitVersioningNPA <> nil then begin - RefCount := ReleaseNamedProcessAddress(UnitVersioningNPA); - if UnitVersioningOwner then - begin - if RefCount > 0 then - UnitVersioningNPA^ := nil; - GlobalUnitVersioning.Free; + UnitVersioningMutex.Acquire; + try + UnitVersioningNPA^ := nil; + SharedCloseMem(UnitVersioningNPA); + finally + UnitVersioningMutex.Release; end; - GlobalUnitVersioning := nil; end; + if (GlobalUnitVersioning <> nil) and UnitVersioningOwner then + GlobalUnitVersioning.Free; + GlobalUnitVersioning := nil; except // ignore - should never happen end; + FreeAndNil(UnitVersioningMutex); end; procedure RegisterUnitVersion(Instance: THandle; const Info: TUnitVersionInfo); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-06-01 20:20:18
|
Revision: 2789 http://jcl.svn.sourceforge.net/jcl/?rev=2789&view=rev Author: outchy Date: 2009-06-01 20:20:10 +0000 (Mon, 01 Jun 2009) Log Message: ----------- Refactored all default buffer sizes to a single constant. Modified Paths: -------------- trunk/jcl/source/common/JclStreams.pas Modified: trunk/jcl/source/common/JclStreams.pas =================================================================== --- trunk/jcl/source/common/JclStreams.pas 2009-06-01 20:14:22 UTC (rev 2788) +++ trunk/jcl/source/common/JclStreams.pas 2009-06-01 20:20:10 UTC (rev 2789) @@ -55,6 +55,9 @@ {$ENDIF HAS_UNIT_CONTNRS} JclBase, JclStringConversions; +const + StreamDefaultBufferSize = 4096; + type {$IFDEF COMPILER5} TSeekOrigin = (soBeginning, soCurrent, soEnd); @@ -77,10 +80,10 @@ {$ENDIF ~CLR} function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; {$IFDEF COMPILER5} reintroduce; overload; virtual; {$ELSE} overload; override; {$ENDIF} - procedure LoadFromStream(Source: TStream; BufferSize: Longint = 4096); virtual; - procedure LoadFromFile(const FileName: TFileName; BufferSize: Longint = 4096); virtual; - procedure SaveToStream(Dest: TStream; BufferSize: Longint = 4096); virtual; - procedure SaveToFile(const FileName: TFileName; BufferSize: Longint = 4096); virtual; + procedure LoadFromStream(Source: TStream; BufferSize: Longint = StreamDefaultBufferSize); virtual; + procedure LoadFromFile(const FileName: TFileName; BufferSize: Longint = StreamDefaultBufferSize); virtual; + procedure SaveToStream(Dest: TStream; BufferSize: Longint = StreamDefaultBufferSize); virtual; + procedure SaveToFile(const FileName: TFileName; BufferSize: Longint = StreamDefaultBufferSize); virtual; end; //=== VCL stream replacements === @@ -539,11 +542,11 @@ constructor Create(AStream: TStream; AOwnsStream: Boolean = False); virtual; function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; function ReadString(var Buffer: string; Start, Count: Longint): Longint; overload; - function ReadString(BufferSize: Longint = 4096): string; overload; + function ReadString(BufferSize: Longint = StreamDefaultBufferSize): string; overload; function ReadAnsiString(var Buffer: AnsiString; Start, Count: Longint): Longint; overload; - function ReadAnsiString(BufferSize: Longint = 4096): AnsiString; overload; + function ReadAnsiString(BufferSize: Longint = StreamDefaultBufferSize): AnsiString; overload; function ReadWideString(var Buffer: WideString; Start, Count: Longint): Longint; overload; - function ReadWideString(BufferSize: Longint = 4096): WideString; overload; + function ReadWideString(BufferSize: Longint = StreamDefaultBufferSize): WideString; overload; function WriteString(const Buffer: string; Start, Count: Longint): Longint; function WriteAnsiString(const Buffer: AnsiString; Start, Count: Longint): Longint; function WriteWideString(const Buffer: WideString; Start, Count: Longint): Longint; @@ -595,18 +598,18 @@ // buffered copy of all available bytes from Source to Dest // returns the number of bytes that were copied -function StreamCopy(Source: TStream; Dest: TStream; BufferSize: Longint = 4096): Int64; +function StreamCopy(Source: TStream; Dest: TStream; BufferSize: Longint = StreamDefaultBufferSize): Int64; // buffered copy of all available characters from Source to Dest // retuns the number of characters (in specified encoding) that were copied -function StringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = 4096): Int64; -function AnsiStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = 4096): Int64; -function WideStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = 4096): Int64; +function StringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = StreamDefaultBufferSize): Int64; +function AnsiStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = StreamDefaultBufferSize): Int64; +function WideStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = StreamDefaultBufferSize): Int64; // compares 2 streams for differencies -function CompareStreams(A, B : TStream; BufferSize: Longint = 4096): Boolean; +function CompareStreams(A, B : TStream; BufferSize: Longint = StreamDefaultBufferSize): Boolean; // compares 2 files for differencies (calling CompareStreams) -function CompareFiles(const FileA, FileB: TFileName; BufferSize: Longint = 4096): Boolean; +function CompareFiles(const FileA, FileB: TFileName; BufferSize: Longint = StreamDefaultBufferSize): Boolean; {$IFDEF UNITVERSIONING} const @@ -674,7 +677,7 @@ until ByteCount < BufferSize; end; -function StringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = 4096): Int64; +function StringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint): Int64; var Buffer: string; CharCount: Longint; @@ -688,7 +691,7 @@ until CharCount = 0; end; -function AnsiStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = 4096): Int64; +function AnsiStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint): Int64; var Buffer: AnsiString; CharCount: Longint; @@ -702,7 +705,7 @@ until CharCount = 0; end; -function WideStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = 4096): Int64; +function WideStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint): Int64; var Buffer: WideString; CharCount: Longint; @@ -716,7 +719,7 @@ until CharCount = 0; end; -function CompareStreams(A, B : TStream; BufferSize: Longint = 4096): Boolean; +function CompareStreams(A, B : TStream; BufferSize: Longint): Boolean; var BufferA, BufferB: array of Byte; ByteCountA, ByteCountB: Longint; @@ -758,7 +761,7 @@ end; end; -function CompareFiles(const FileA, FileB: TFileName; BufferSize: Longint = 4096): Boolean; +function CompareFiles(const FileA, FileB: TFileName; BufferSize: Longint): Boolean; var A, B: TStream; begin @@ -1412,7 +1415,7 @@ inherited Create(AStream, AOwnsStream); if Stream <> nil then FPosition := Stream.Position; - BufferSize := 4096; + BufferSize := StreamDefaultBufferSize; end; destructor TJclBufferedStream.Destroy; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-06-01 20:14:26
|
Revision: 2788 http://jcl.svn.sourceforge.net/jcl/?rev=2788&view=rev Author: outchy Date: 2009-06-01 20:14:22 +0000 (Mon, 01 Jun 2009) Log Message: ----------- Mantis 4797: Add helper method to TJclDecompressStream. Modified Paths: -------------- trunk/jcl/source/common/JclStreams.pas Modified: trunk/jcl/source/common/JclStreams.pas =================================================================== --- trunk/jcl/source/common/JclStreams.pas 2009-05-31 19:12:07 UTC (rev 2787) +++ trunk/jcl/source/common/JclStreams.pas 2009-06-01 20:14:22 UTC (rev 2788) @@ -77,6 +77,10 @@ {$ENDIF ~CLR} function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; {$IFDEF COMPILER5} reintroduce; overload; virtual; {$ELSE} overload; override; {$ENDIF} + procedure LoadFromStream(Source: TStream; BufferSize: Longint = 4096); virtual; + procedure LoadFromFile(const FileName: TFileName; BufferSize: Longint = 4096); virtual; + procedure SaveToStream(Dest: TStream; BufferSize: Longint = 4096); virtual; + procedure SaveToFile(const FileName: TFileName; BufferSize: Longint = 4096); virtual; end; //=== VCL stream replacements === @@ -794,6 +798,41 @@ end; {$ENDIF ~CLR} +procedure TJclStream.LoadFromFile(const FileName: TFileName; + BufferSize: Integer); +var + FS: TStream; +begin + FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(FS, BufferSize); + finally + FS.Free; + end; +end; + +procedure TJclStream.LoadFromStream(Source: TStream; BufferSize: Integer); +begin + StreamCopy(Source, Self, BufferSize); +end; + +procedure TJclStream.SaveToFile(const FileName: TFileName; BufferSize: Integer); +var + FS: TStream; +begin + FS := TFileStream.Create(FileName, fmCreate or fmShareExclusive); + try + SaveToStream(FS); + finally + FS.Free; + end; +end; + +procedure TJclStream.SaveToStream(Dest: TStream; BufferSize: Integer); +begin + StreamCopy(Self, Dest, BufferSize); +end; + function TJclStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; begin // override to customize This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-31 19:12:14
|
Revision: 2787 http://jcl.svn.sourceforge.net/jcl/?rev=2787&view=rev Author: outchy Date: 2009-05-31 19:12:07 +0000 (Sun, 31 May 2009) Log Message: ----------- Parameter whose types are String, Int64 and Extended shall be constant for speed reasons. Modified Paths: -------------- trunk/jcl/source/common/JclSimpleXml.pas Modified: trunk/jcl/source/common/JclSimpleXml.pas =================================================================== --- trunk/jcl/source/common/JclSimpleXml.pas 2009-05-31 18:49:27 UTC (rev 2786) +++ trunk/jcl/source/common/JclSimpleXml.pas 2009-05-31 19:12:07 UTC (rev 2787) @@ -78,8 +78,8 @@ TJclSimpleXMLElemHeader = class; TJclSimpleXMLElemSheet = class; TJclSimpleXMLElemMSOApplication = class; - TJclOnSimpleXMLParsed = procedure(Sender: TObject; Name: string) of object; - TJclOnValueParsed = procedure(Sender: TObject; Name, Value: string) of object; + TJclOnSimpleXMLParsed = procedure(Sender: TObject; const Name: string) of object; + TJclOnValueParsed = procedure(Sender: TObject; const Name, Value: string) of object; TJclOnSimpleProgress = procedure(Sender: TObject; const Position, Total: Integer) of object; //Those hash stuffs are for future use only @@ -191,10 +191,10 @@ procedure Clear; virtual; procedure Delete(const Index: Integer); overload; procedure Delete(const Name: string); overload; - function Value(const Name: string; Default: string = ''): string; - function IntValue(const Name: string; Default: Int64 = -1): Int64; + function Value(const Name: string; const Default: string = ''): string; + function IntValue(const Name: string; const Default: Int64 = -1): Int64; function BoolValue(const Name: string; Default: Boolean = True): Boolean; - function FloatValue(const Name: string; Default: Extended = 0): Extended; + function FloatValue(const Name: string; const Default: Extended = 0): Extended; procedure LoadFromStringStream(StringStream: TJclStringStream); procedure SaveToStringStream(StringStream: TJclStringStream); property Item[const Index: Integer]: TJclSimpleXMLProp read GetItem; default; @@ -223,8 +223,8 @@ function AddComment(const AValue: string): TJclSimpleXMLElemComment; function AddDocType(const AValue: string): TJclSimpleXMLElemDocType; procedure Clear; - function AddStyleSheet(AType, AHRef: string): TJclSimpleXMLElemSheet; - function AddMSOApplication(AProgId : string): TJclSimpleXMLElemMSOApplication; + function AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; + function AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; procedure LoadFromStringStream(StringStream: TJclStringStream; AParent: TJclSimpleXML = nil); procedure SaveToStringStream(StringStream: TJclStringStream; AParent: TJclSimpleXML = nil); property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; @@ -316,9 +316,9 @@ procedure Move(const CurIndex, NewIndex: Integer); function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload; function IndexOf(const Name: string): Integer; overload; - function Value(const Name: string; Default: string = ''): string; - function IntValue(const Name: string; Default: Int64 = -1): Int64; - function FloatValue(const Name: string; Default: Extended = 0): Extended; + function Value(const Name: string; const Default: string = ''): string; + function IntValue(const Name: string; const Default: Int64 = -1): Int64; + function FloatValue(const Name: string; const Default: Extended = 0): Extended; function BoolValue(const Name: string; Default: Boolean = True): Boolean; procedure BinaryValue(const Name: string; Stream: TStream); procedure LoadFromStringStream(StringStream: TJclStringStream; AParent: TJclSimpleXML = nil); @@ -1999,7 +1999,7 @@ end; function TJclSimpleXMLElems.FloatValue(const Name: string; - Default: Extended): Extended; + const Default: Extended): Extended; var Elem: TJclSimpleXMLElem; begin @@ -2070,7 +2070,7 @@ Result := GetItemNamedDefault(Name, ''); end; -function TJclSimpleXMLElems.IntValue(const Name: string; Default: Int64): Int64; +function TJclSimpleXMLElems.IntValue(const Name: string; const Default: Int64): Int64; var Elem: TJclSimpleXMLElem; begin @@ -2233,7 +2233,7 @@ Item[I].SaveToStringStream(StringStream, Level, AParent); end; -function TJclSimpleXMLElems.Value(const Name: string; Default: string): string; +function TJclSimpleXMLElems.Value(const Name, Default: string): string; var Elem: TJclSimpleXMLElem; begin @@ -2472,7 +2472,7 @@ end; function TJclSimpleXMLProps.FloatValue(const Name: string; - Default: Extended): Extended; + const Default: Extended): Extended; var Prop: TJclSimpleXMLProp; begin @@ -2539,7 +2539,7 @@ Result := nil; end; -function TJclSimpleXMLProps.IntValue(const Name: string; Default: Int64): Int64; +function TJclSimpleXMLProps.IntValue(const Name: string; const Default: Int64): Int64; var Prop: TJclSimpleXMLProp; begin @@ -2678,7 +2678,7 @@ Item[I].SaveToStringStream(StringStream); end; -function TJclSimpleXMLProps.Value(const Name: string; Default: string): string; +function TJclSimpleXMLProps.Value(const Name, Default: string): string; var Prop: TJclSimpleXMLProp; begin @@ -4044,7 +4044,7 @@ FElems.AddObject('', Result); end; -function TJclSimpleXMLElemsProlog.AddStyleSheet(AType, AHRef: string): TJclSimpleXMLElemSheet; +function TJclSimpleXMLElemsProlog.AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet; begin // make sure there is an xml header FindHeader; @@ -4055,7 +4055,7 @@ FElems.AddObject('xml-stylesheet', Result); end; -function TJclSimpleXMLElemsProlog.AddMSOApplication(AProgId : string): TJclSimpleXMLElemMSOApplication; +function TJclSimpleXMLElemsProlog.AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication; begin // make sure there is an xml header FindHeader; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-31 18:49:30
|
Revision: 2786 http://jcl.svn.sourceforge.net/jcl/?rev=2786&view=rev Author: outchy Date: 2009-05-31 18:49:27 +0000 (Sun, 31 May 2009) Log Message: ----------- Mantis 4770: unable to read MS Word xml document. new class to parse and write <?mso-application ?> header elements. Modified Paths: -------------- trunk/jcl/source/common/JclResources.pas trunk/jcl/source/common/JclSimpleXml.pas Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2009-05-30 15:04:29 UTC (rev 2785) +++ trunk/jcl/source/common/JclResources.pas 2009-05-31 18:49:27 UTC (rev 2786) @@ -1,4 +1,4 @@ -{**************************************************************************************************} +{**************************************************************************************************} { } { Project JEDI Code Library (JCL) } { } @@ -1757,6 +1757,8 @@ RsEInvalidHeaderExpectedsButFounds = 'Invalid Header: expected "%0:s" but found "%1:s"'; RsEInvalidStylesheetExpectedsButFounds = 'Invalid Stylesheet: expected "%0:s" but found "%1:s"'; RsEInvalidStylesheetUnexpectedEndOfDat = 'Invalid Stylesheet: Unexpected end of data'; + RsEInvalidMSOExpectedsButFounds = 'Invalid MSO: expected "%0:s" but found "%1:s"'; + RsEInvalidMSOUnexpectedEndOfDat = 'Invalid MSO: Unexpected end of data'; RsEInvalidDocumentUnexpectedTextInFile = 'Invalid Document: Unexpected text in file prolog'; //=== JclStatistics ========================================================== Modified: trunk/jcl/source/common/JclSimpleXml.pas =================================================================== --- trunk/jcl/source/common/JclSimpleXml.pas 2009-05-30 15:04:29 UTC (rev 2785) +++ trunk/jcl/source/common/JclSimpleXml.pas 2009-05-31 18:49:27 UTC (rev 2786) @@ -77,6 +77,7 @@ TJclSimpleXMLElemText = class; TJclSimpleXMLElemHeader = class; TJclSimpleXMLElemSheet = class; + TJclSimpleXMLElemMSOApplication = class; TJclOnSimpleXMLParsed = procedure(Sender: TObject; Name: string) of object; TJclOnValueParsed = procedure(Sender: TObject; Name, Value: string) of object; TJclOnSimpleProgress = procedure(Sender: TObject; const Position, Total: Integer) of object; @@ -223,6 +224,7 @@ function AddDocType(const AValue: string): TJclSimpleXMLElemDocType; procedure Clear; function AddStyleSheet(AType, AHRef: string): TJclSimpleXMLElemSheet; + function AddMSOApplication(AProgId : string): TJclSimpleXMLElemMSOApplication; procedure LoadFromStringStream(StringStream: TJclStringStream; AParent: TJclSimpleXML = nil); procedure SaveToStringStream(StringStream: TJclStringStream; AParent: TJclSimpleXML = nil); property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default; @@ -444,6 +446,12 @@ procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''; AParent: TJclSimpleXML = nil); override; end; + TJclSimpleXMLElemMSOApplication = class(TJclSimpleXMLElem) + public + procedure LoadFromStringStream(StringStream: TJclStringStream; AParent: TJclSimpleXML = nil); override; + procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''; AParent: TJclSimpleXML = nil); override; + end; + TJclSimpleXMLOptions = set of (sxoAutoCreate, sxoAutoIndent, sxoAutoEncodeValue, sxoAutoEncodeEntity, sxoDoNotSaveProlog, sxoTrimPrecedingTextWhitespace); TJclSimpleXMLEncodeEvent = procedure(Sender: TObject; var Value: string) of object; @@ -3453,6 +3461,83 @@ AParent.DoSaveProgress; end; +//=== { TJclSimpleXMLElemMSOApplication } ============================================= + +procedure TJclSimpleXMLElemMSOApplication.LoadFromStringStream(StringStream: TJclStringStream; + AParent: TJclSimpleXML); +//<?mso-application progid="Word.Document"?> +const + CS_START_PI = '<?mso-application'; + CS_STOP_PI = ' ?>'; +var + lPos: Integer; + lOk: Boolean; + Ch: Char; +begin + lPos := 1; + lOk := False; + + if AParent <> nil then + AParent.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size); + + while StringStream.ReadChar(Ch) do + begin + case lPos of + 1..16: //<?mso-applicatio + if Ch = CS_START_PI[lPos] then + Inc(lPos) + else + if not CharIsWhiteSpace(Ch) then + FmtError(RsEInvalidMSOExpectedsButFounds, [CS_START_PI[lPos], Ch]); + 17: //n + if Ch = CS_START_PI[lPos] then + begin + Properties.LoadFromStringStream(StringStream); + Inc(lPos); + end + else + FmtError(RsEInvalidMSOExpectedsButFounds, [CS_START_PI[lPos], Ch]); + 18: //? + if Ch = CS_STOP_PI[lPos] then + Inc(lPos) + else + if CharIsWhiteSpace(Ch) then + // space after properties + else + FmtError(RsEInvalidMSOExpectedsButFounds, [CS_STOP_PI[lPos], Ch]); + 19: //> + if Ch = CS_STOP_PI[lPos] then + begin + lOk := True; + Break; //End if + end + else + FmtError(RsEInvalidMSOExpectedsButFounds, [CS_STOP_PI[lPos], Ch]); + end; + end; + + if not lOk then + Error(RsEInvalidMSOUnexpectedEndOfDat); + + Name := ''; +end; + +procedure TJclSimpleXMLElemMSOApplication.SaveToStringStream(StringStream: TJclStringStream; + const Level: string; AParent: TJclSimpleXML); +var + I: Integer; + St: string; +begin + St := Level + '<?mso-application'; + StringStream.WriteString(St, 1, Length(St)); + for I := 0 to Properties.GetCount - 1 do + Properties.Item[I].SaveToStringStream(StringStream); + St := '?>' + sLineBreak; + StringStream.WriteString(St, 1, Length(St)); + if AParent <> nil then + AParent.DoSaveProgress; +end; + //=== { TJclSimpleXMLElemsProlog } =========================================== constructor TJclSimpleXMLElemsProlog.Create; @@ -3551,6 +3636,9 @@ if St = '<!DOCTYPE' then lElem := TJclSimpleXMLElemDocType.Create(nil) else + if St = '<?mso-application' then + lElem := TJclSimpleXMLElemMSOApplication.Create(nil) + else if (Length(St) > 1) and (St[2] <> '!') and (St[2] <> '?') then lEnd := True; @@ -3967,6 +4055,16 @@ FElems.AddObject('xml-stylesheet', Result); end; +function TJclSimpleXMLElemsProlog.AddMSOApplication(AProgId : string): TJclSimpleXMLElemMSOApplication; +begin + // make sure there is an xml header + FindHeader; + Result := TJclSimpleXMLElemMSOApplication.Create(nil); + Result.Name := 'mso-application'; + Result.Properties.Add('progid',AProgId); + FElems.AddObject('mso-application', Result); +end; + function TJclSimpleXMLElemsProlog.AddComment(const AValue: string): TJclSimpleXMLElemComment; begin // make sure there is an xml header This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 15:04:30
|
Revision: 2785 http://jcl.svn.sourceforge.net/jcl/?rev=2785&view=rev Author: outchy Date: 2009-05-30 15:04:29 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4786: Overloaded constructor to TJclScopedStream. Modified Paths: -------------- trunk/jcl/source/common/JclStreams.pas Modified: trunk/jcl/source/common/JclStreams.pas =================================================================== --- trunk/jcl/source/common/JclStreams.pas 2009-05-30 15:00:45 UTC (rev 2784) +++ trunk/jcl/source/common/JclStreams.pas 2009-05-30 15:04:29 UTC (rev 2785) @@ -358,7 +358,8 @@ // scopedstream starting at the current position of the ParentStream // if MaxSize is positive or null, read and write operations cannot overrun this size or the ParentStream limitation // if MaxSize is negative, read and write operations are unlimited (up to the ParentStream limitation) - constructor Create(AParentStream: TStream; AMaxSize: Int64 = -1); + constructor Create(AParentStream: TStream; const AMaxSize: Int64 = -1); overload; + constructor Create(AParentStream: TStream; const AStartPos, AMaxSize: Int64); overload; {$IFDEF CLR} function Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; override; function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override; @@ -2122,7 +2123,7 @@ //=== { TJclScopedStream } =================================================== -constructor TJclScopedStream.Create(AParentStream: TStream; AMaxSize: Int64); +constructor TJclScopedStream.Create(AParentStream: TStream; const AMaxSize: Int64); begin inherited Create; @@ -2132,6 +2133,16 @@ FMaxSize := AMaxSize; end; +constructor TJclScopedStream.Create(AParentStream: TStream; const AStartPos, AMaxSize: Int64); +begin + inherited Create; + + FParentStream := AParentStream; + FStartPos := AStartPos; + FCurrentPos := 0; + FMaxSize := AMaxSize; +end; + {$IFDEF CLR} function TJclScopedStream.Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; {$ELSE ~CLR} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 15:00:54
|
Revision: 2784 http://jcl.svn.sourceforge.net/jcl/?rev=2784&view=rev Author: outchy Date: 2009-05-30 15:00:45 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4775: TJclSysUtils.TJclSimplelog.TimeWrite is not "unicoded". Modified Paths: -------------- trunk/jcl/source/common/JclSysUtils.pas Modified: trunk/jcl/source/common/JclSysUtils.pas =================================================================== --- trunk/jcl/source/common/JclSysUtils.pas 2009-05-30 14:48:01 UTC (rev 2783) +++ trunk/jcl/source/common/JclSysUtils.pas 2009-05-30 15:00:45 UTC (rev 2784) @@ -3211,6 +3211,7 @@ procedure TJclSimpleLog.TimeWrite(const Text: string; Indent: Integer = 0); var S: string; + UTF8S: TUTF8String; SL: TStringList; I: Integer; begin @@ -3222,7 +3223,8 @@ for I := 0 to SL.Count - 1 do begin S := DateTimeToStr(Now)+' : '+StringOfChar(' ', Indent) + StrEnsureSuffix(NativeLineBreak, TrimRight(SL[I])); - FileWrite(FLogFileHandle, Pointer(S)^, Length(S)); + UTF8S := StringToUTF8(S); + FileWrite(FLogFileHandle, UTF8S[1], Length(UTF8S)); end; finally SL.Free; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 14:48:09
|
Revision: 2783 http://jcl.svn.sourceforge.net/jcl/?rev=2783&view=rev Author: outchy Date: 2009-05-30 14:48:01 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4788: Error in EnumServices makes it not work properly when the buffer isn't big enough Modified Paths: -------------- trunk/jcl/source/windows/JclSvcCtrl.pas Modified: trunk/jcl/source/windows/JclSvcCtrl.pas =================================================================== --- trunk/jcl/source/windows/JclSvcCtrl.pas 2009-05-30 14:37:48 UTC (rev 2782) +++ trunk/jcl/source/windows/JclSvcCtrl.pas 2009-05-30 14:48:01 UTC (rev 2783) @@ -1007,32 +1007,47 @@ PEss: PEnumServiceStatus; NtSvc: TJclNtService; BytesNeeded, ServicesReturned, ResumeHandle: DWORD; + LastError: Cardinal; begin Assert((DesiredAccess and SC_MANAGER_ENUMERATE_SERVICE) <> 0); // Enum the services ResumeHandle := 0; // Must set this value to zero !!! try PBuf := nil; - BytesNeeded := 40960; + BytesNeeded := 0; + //from MSDN: + //The maximum size of this array is 256K bytes. To determine the required + //size, specify NULL for this parameter and 0 for the cbBufSize parameter. + //The function will fail and GetLastError will return + //ERROR_INSUFFICIENT_BUFFER. The pcbBytesNeeded parameter will receive the + //required size. + + //(it doesn't actually return ERROR_INSUFFICIENT_BUFFER apparently) + repeat ReallocMem(PBuf, BytesNeeded); Ret := EnumServicesStatus(FHandle, SERVICE_TYPE_ALL, SERVICE_STATE_ALL, PEnumServiceStatus(PBuf){$IFNDEF FPC}^{$ENDIF}, BytesNeeded, BytesNeeded, ServicesReturned, ResumeHandle); - until Ret or (GetLastError <> ERROR_MORE_DATA); + LastError := GetLastError; + + if (ServicesReturned > 0) and (Ret or (LastError = ERROR_MORE_DATA)) then + begin + PEss := PBuf; + for I := 0 to ServicesReturned - 1 do + begin + NtSvc := TJclNtService.Create(Self, PEss^); + try + NtSvc.Refresh; + except + // trap invalid services + end; + Inc(PEss); + end; + end; + until Ret or (LastError <> ERROR_MORE_DATA); Win32Check(Ret); - PEss := PBuf; - for I := 0 to ServicesReturned - 1 do - begin - NtSvc := TJclNtService.Create(Self, PEss^); - try - NtSvc.Refresh; - except - // trap invalid services - end; - Inc(PEss); - end; finally FreeMem(PBuf); end; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 14:37:52
|
Revision: 2782 http://jcl.svn.sourceforge.net/jcl/?rev=2782&view=rev Author: outchy Date: 2009-05-30 14:37:48 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4750: missing string type in InternalGetAnsiString Modified Paths: -------------- trunk/jcl/source/windows/JclRegistry.pas Modified: trunk/jcl/source/windows/JclRegistry.pas =================================================================== --- trunk/jcl/source/windows/JclRegistry.pas 2009-05-30 13:06:46 UTC (rev 2781) +++ trunk/jcl/source/windows/JclRegistry.pas 2009-05-30 14:37:48 UTC (rev 2782) @@ -557,6 +557,7 @@ DataType, DataSize: DWORD; TmpRet: WideString; DataLength: Integer; + RegKinds: TRegKinds; begin Result := True; DataType := REG_NONE; @@ -566,31 +567,30 @@ try if InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, @DataType, nil, @DataSize) = ERROR_SUCCESS then begin - if not (DataType in [REG_BINARY, REG_SZ, REG_EXPAND_SZ]) then + if MultiFlag then + RegKinds := [REG_BINARY, REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ] + else + RegKinds := [REG_BINARY, REG_SZ, REG_EXPAND_SZ]; + if not (DataType in RegKinds) then DataError(RootKey, Key, Name); if Win32Platform = VER_PLATFORM_WIN32_NT then - DataLength := DataSize div SizeOf(WideChar) - else - DataLength := DataSize div SizeOf(AnsiChar); - if Win32Platform = VER_PLATFORM_WIN32_NT then begin + DataLength := DataSize div SizeOf(WideChar); SetLength(TmpRet, DataLength); - Result := InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, nil, PWideChar(TmpRet), @DataSize) = ERROR_SUCCESS + Result := InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, nil, PWideChar(TmpRet), @DataSize) = ERROR_SUCCESS; + if Result then + RetValue := AnsiString(Copy(TmpRet, 1, DataLength - 1)); end else begin + DataLength := DataSize div SizeOf(AnsiChar); SetLength(RetValue, DataLength); Result := InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, nil, PAnsiChar(RetValue), @DataSize) = ERROR_SUCCESS; + if Result then + SetLength(RetValue, DataLength - 1); end; - if Result then + if not Result then begin - if Win32Platform = VER_PLATFORM_WIN32_NT then - RetValue := AnsiString(Copy(TmpRet, 1, DataLength - 1)) - else - SetLength(RetValue, DataLength - 1); - end - else - begin RetValue := ''; if RaiseException then ValueError(RootKey, Key, Name) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 13:06:55
|
Revision: 2781 http://jcl.svn.sourceforge.net/jcl/?rev=2781&view=rev Author: outchy Date: 2009-05-30 13:06:46 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4759: force time and attribute properties when a compression item is created based on a stream. Modified Paths: -------------- trunk/jcl/source/common/JclCompression.pas Modified: trunk/jcl/source/common/JclCompression.pas =================================================================== --- trunk/jcl/source/common/JclCompression.pas 2009-05-30 12:30:53 UTC (rev 2780) +++ trunk/jcl/source/common/JclCompression.pas 2009-05-30 13:06:46 UTC (rev 2781) @@ -4366,6 +4366,7 @@ AStream: TStream; AOwnsStream: Boolean): Integer; var AItem: TJclCompressionItem; + NowFileTime: TFileTime; begin CheckNotCompressing; @@ -4375,6 +4376,17 @@ AItem.Stream := AStream; AItem.OwnsStream := AOwnsStream; AItem.FileSize := AStream.Size - AStream.Position; + NowFileTime := LocalDateTimeToFileTime(Now); + AItem.Attributes := faReadOnly and faArchive; + AItem.CreationTime := NowFileTime; + AItem.LastAccessTime := NowFileTime; + AItem.LastWriteTime := NowFileTime; + {$IFDEF MSWINDOWS} + AItem.HostOS := RsCompression7zWindows; + {$ENDIF MSWINDOWS} + {$IFDEF UNIX} + AItem.HostOS := RsCompression7zUnix; + {$ENDIF UNIX} except AItem.Destroy; raise; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <usc...@us...> - 2009-05-30 13:01:14
|
Revision: 2780 http://jcl.svn.sourceforge.net/jcl/?rev=2780&view=rev Author: uschuster Date: 2009-05-30 12:30:53 +0000 (Sat, 30 May 2009) Log Message: ----------- added memory visualization for longstrings Modified Paths: -------------- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.dfm branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMM.dpk Added Paths: ----------- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryVisualizerFrame.dfm branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryVisualizerFrame.pas Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.dfm =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.dfm 2009-05-30 11:45:53 UTC (rev 2779) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.dfm 2009-05-30 12:30:53 UTC (rev 2780) @@ -97,10 +97,10 @@ end object tsMemory: TTabSheet Caption = 'Memory dump' - ExplicitLeft = 0 - ExplicitTop = 0 - ExplicitWidth = 0 - ExplicitHeight = 0 end + object tsMemoryVisualized: TTabSheet + Caption = 'Memory visualized' + ImageIndex = 2 + end end end Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.pas 2009-05-30 11:45:53 UTC (rev 2779) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.pas 2009-05-30 12:30:53 UTC (rev 2780) @@ -5,7 +5,7 @@ uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Grids, ComCtrls, JclStackTraceViewerAPI, FastMMParser, - FastMMMemoryFrame; + FastMMMemoryFrame, FastMMMemoryVisualizerFrame; type TfrmLeak = class(TFrame, IJclStackTraceViewerPreparableStackFrame, IJclStackTraceViewerStackSelection) @@ -23,11 +23,13 @@ pg: TPageControl; tsMemory: TTabSheet; tsStack: TTabSheet; + tsMemoryVisualized: TTabSheet; private { Private-Deklarationen } FLeakData: TFastMMLeak; FStackFrame: TCustomFrame; FMemoryFrame: TfrmMemory; + FMemoryVisualizerFrame: TfrmMemoryVisualizer; function GetSelected: IJclLocationInfo; function GetPreparableLocationInfoListCount: Integer; function GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; @@ -65,10 +67,14 @@ FMemoryFrame := TfrmMemory.Create(Self); FMemoryFrame.Parent := tsMemory; FMemoryFrame.Align := alClient; + FMemoryVisualizerFrame := TfrmMemoryVisualizer.Create(Self); + FMemoryVisualizerFrame.Parent := tsMemoryVisualized; + FMemoryVisualizerFrame.Align := alClient; end; destructor TfrmLeak.Destroy; begin + FMemoryVisualizerFrame.Free; FMemoryFrame.Free; FStackFrame.Free; inherited Destroy; @@ -121,7 +127,9 @@ StackTraceViewerStackFrame.SetStackList(FLeakData.Stack); tsMemory.TabVisible := Assigned(FLeakData) and FLeakData.FoundMemory; - pg.Visible := tsStack.TabVisible or tsMemory.TabVisible; + tsMemoryVisualized.TabVisible := tsMemory.TabVisible and Assigned(FLeakData.Parent) and + IsVisualizable(FLeakData.BlockClass, FLeakData.Parent.ReportCompilerVersion, @FLeakData.Memory, Length(FLeakData.Memory)); + pg.Visible := tsStack.TabVisible or tsMemory.TabVisible or tsMemoryVisualized.TabVisible; if pg.Visible then pg.TabIndex := 0; if Assigned(FLeakData) and FLeakData.FoundMemory then @@ -129,6 +137,14 @@ FMemoryFrame.Address := FLeakData.Address; FMemoryFrame.MemoryArray := FLeakData.Memory; end; + if tsMemoryVisualized.TabVisible then + begin + FMemoryVisualizerFrame.Memory := @FLeakData.Memory; + FMemoryVisualizerFrame.MemorySize := Length(FLeakData.Memory); + FMemoryVisualizerFrame.ReportCompilerVersion := FLeakData.Parent.ReportCompilerVersion; + FMemoryVisualizerFrame.TypeStr := FLeakData.BlockClass; + FMemoryVisualizerFrame.Decode; + end; end; procedure TfrmLeak.UpdateViews; Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryVisualizerFrame.dfm =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryVisualizerFrame.dfm (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryVisualizerFrame.dfm 2009-05-30 12:30:53 UTC (rev 2780) @@ -0,0 +1,80 @@ +object frmMemoryVisualizer: TfrmMemoryVisualizer + Left = 0 + Top = 0 + Width = 320 + Height = 240 + TabOrder = 0 + object memString: TMemo + Left = 0 + Top = 33 + Width = 320 + Height = 207 + Align = alClient + TabOrder = 0 + end + object pnlTop: TPanel + Left = 0 + Top = 0 + Width = 320 + Height = 33 + Align = alTop + BevelOuter = bvNone + TabOrder = 1 + object Label4: TLabel + Left = 131 + Top = 19 + Width = 37 + Height = 13 + Caption = 'Length:' + end + object Label1: TLabel + Left = 4 + Top = 3 + Width = 53 + Height = 13 + Caption = 'CodePage:' + end + object Label2: TLabel + Left = 4 + Top = 19 + Width = 45 + Height = 13 + Caption = 'ElemSize:' + end + object lbCodePage: TLabel + Left = 65 + Top = 3 + Width = 57 + Height = 13 + Caption = 'lbCodePage' + end + object Label3: TLabel + Left = 131 + Top = 3 + Width = 50 + Height = 13 + Caption = 'RefCount:' + end + object lbRefCount: TLabel + Left = 186 + Top = 3 + Width = 54 + Height = 13 + Caption = 'lbRefCount' + end + object lbLength: TLabel + Left = 186 + Top = 19 + Width = 41 + Height = 13 + Caption = 'lbLength' + end + object lbElemSize: TLabel + Left = 65 + Top = 19 + Width = 49 + Height = 13 + Caption = 'lbElemSize' + end + end +end Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryVisualizerFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryVisualizerFrame.pas (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryVisualizerFrame.pas 2009-05-30 12:30:53 UTC (rev 2780) @@ -0,0 +1,124 @@ +unit FastMMMemoryVisualizerFrame; + +interface + +uses + Windows, Messages, SysUtils, Classes, Math, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls; + +type + TfrmMemoryVisualizer = class(TFrame) + memString: TMemo; + pnlTop: TPanel; + Label4: TLabel; + Label1: TLabel; + Label2: TLabel; + lbCodePage: TLabel; + Label3: TLabel; + lbRefCount: TLabel; + lbLength: TLabel; + lbElemSize: TLabel; + private + { Private-Deklarationen } + FMemory: Pointer; + FMemorySize: Integer; + FReportCompilerVersion: Double; + FTypeStr: string; + public + { Public-Deklarationen } + function Decode: Boolean; + property Memory: Pointer read FMemory write FMemory; + property MemorySize: Integer read FMemorySize write FMemorySize; + property ReportCompilerVersion: Double read FReportCompilerVersion write FReportCompilerVersion; + property TypeStr: string read FTypeStr write FTypeStr; + end; + +function IsVisualizable(const ATypeStr: string; AReportCompilerVersion: Double; AMemory: Pointer; AMemorySize: Integer): Boolean; + +implementation + +{$R *.dfm} + +const + cAnsiString = 'AnsiString'; + cUnicodeString = 'UnicodeString'; + +function GetStringHeaderLength(const ATypeStr: string; AReportCompilerVersion: Double): Integer; +begin + if (ATypeStr = cAnsiString) or (ATypeStr = cUnicodeString) then + begin + if AReportCompilerVersion >= 20 then + Result := 12 + else + Result := 8; + end + else + Result := -1; +end; + +function IsVisualizable(const ATypeStr: string; AReportCompilerVersion: Double; AMemory: Pointer; AMemorySize: Integer): Boolean; +begin + if (ATypeStr = cAnsiString) or (ATypeStr = cUnicodeString) then + Result := AMemorySize >= GetStringHeaderLength(ATypeStr, AReportCompilerVersion) + else + Result := False; +end; + +{ TfrmMemoryVisualizer } + +type + PAnsiStrRec = ^AnsiStrRec; + AnsiStrRec = packed record + refCnt: Longint; + length: Longint; + end; + + PUnicodeStrRec = ^UnicodeStrRec; + UnicodeStrRec = packed record + codePage: Word; + elemSize: Word; + refCnt: Longint; + length: Longint; + end; + +function TfrmMemoryVisualizer.Decode: Boolean; +var + StringHeaderLength, StartIntPtr, DecodableLength: Integer; +begin + Result := IsVisualizable(FTypeStr, FReportCompilerVersion, FMemory, FMemorySize); + if Result then + begin + StringHeaderLength := GetStringHeaderLength(FTypeStr, FReportCompilerVersion); + StartIntPtr := Integer(FMemory) + StringHeaderLength; + if (StringHeaderLength = 12) and (FMemorySize >= StringHeaderLength) then + begin + DecodableLength := Min(FMemorySize - StringHeaderLength, PUnicodeStrRec(FMemory)^.length); + if FTypeStr = cUnicodeString then + memString.Text := Copy(PWideChar(StartIntPtr), 1, DecodableLength) + else + memString.Text := string(Copy(PAnsiChar(StartIntPtr), 1, DecodableLength)); + with PUnicodeStrRec(FMemory)^ do + begin + lbCodePage.Caption := IntToStr(codePage); + lbElemSize.Caption := IntToStr(elemSize); + lbRefCount.Caption := IntToStr(refCnt); + lbLength.Caption := IntToStr(length); + end; + end + else + if FMemorySize >= 8 then + begin + DecodableLength := Min(FMemorySize - StringHeaderLength, PAnsiStrRec(FMemory)^.length); + memString.Text := string(Copy(PAnsiChar(StartIntPtr), 1, DecodableLength)); + lbCodePage.Caption := 'N/A'; + lbElemSize.Caption := 'N/A'; + with PAnsiStrRec(FMemory)^ do + begin + lbRefCount.Caption := IntToStr(refCnt); + lbLength.Caption := IntToStr(length); + end; + end; + end; +end; + +end. Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas 2009-05-30 11:45:53 UTC (rev 2779) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas 2009-05-30 12:30:53 UTC (rev 2780) @@ -27,6 +27,8 @@ TFastMMMemoryArray = array [0..255] of Byte; + TFastMMReport = class; + TFastMMLeak = class(TObject) private FAddress: Integer; @@ -36,10 +38,11 @@ FMemory: TFastMMMemoryArray; FFoundMemory: Boolean; FLeakSize: Integer; + FParent: TFastMMReport; FThreadID: Integer; FStack: TFastMMLocationInfoList; public - constructor Create; + constructor Create(AParent: TFastMMReport); destructor Destroy; override; property Address: Integer read FAddress write FAddress; property AllocationNumber: Integer read FAllocationNumber write FAllocationNumber; @@ -48,6 +51,7 @@ property Memory: TFastMMMemoryArray read FMemory write FMemory; property FoundMemory: Boolean read FFoundMemory write FFoundMemory; property LeakSize: Integer read FLeakSize write FLeakSize; + property Parent: TFastMMReport read FParent; property Stack: TFastMMLocationInfoList read FStack; property ThreadID: Integer read FThreadID write FThreadID; end; @@ -107,6 +111,7 @@ FLeakGroups: TObjectList; FLeaks: TObjectList; FLeakSummary: TStringList; + FReportCompilerVersion: Double; FVMOnFreedObjects: TObjectList; function GetLeakCount: Integer; function GetLeaks(AIndex: Integer): TFastMMLeak; @@ -127,6 +132,7 @@ property LeakGroupItems[AIndex: Integer]: TFastMMLeakGroup read GetLeakGroupItems; property LeakItems[AIndex: Integer]: TFastMMLeak read GetLeaks; property LeakSummary: TStringList read FLeakSummary; + property ReportCompilerVersion: Double read FReportCompilerVersion write FReportCompilerVersion; property VMOnFreedObjectCount: Integer read GetVMOnFreedObjectCount; property VMOnFreedObjectItems[AIndex: Integer]: TFastMMVMOnFreedObject read GetVMOnFreedObjectItems; end; @@ -160,7 +166,7 @@ { TFastMMLeak } -constructor TFastMMLeak.Create; +constructor TFastMMLeak.Create(AParent: TFastMMReport); begin inherited Create; FAddress := -1; @@ -168,6 +174,7 @@ FBlockClass := ''; FFoundMemory := False; FLeakSize := -1; + FParent := AParent; FThreadID := -1; FStack := TFastMMLocationInfoList.Create; end; @@ -254,6 +261,11 @@ FLeakGroups := TObjectList.Create; FLeaks := TObjectList.Create; FLeakSummary := TStringList.Create; + {$IFDEF CONDITIONALEXPRESSIONS} + FReportCompilerVersion := CompilerVersion; + {$ELSE ~CONDITIONALEXPRESSIONS} + FReportCompilerVersion := 5.01; + {$ENDIF ~CONDITIONALEXPRESSIONS} FVMOnFreedObjects := TObjectList.Create; end; @@ -268,7 +280,7 @@ function TFastMMReport.AddLeak: TFastMMLeak; begin - FLeaks.Add(TFastMMLeak.Create); + FLeaks.Add(TFastMMLeak.Create(Self)); Result := TFastMMLeak(FLeaks.Last); end; @@ -524,8 +536,9 @@ end; end; +{ TODO : Parse compiler version when they exist in the report } function TFastMMFileParser.ParseFile(const AFileName: string; AReportList: TObjectList): Integer; -type +type { TODO : There is at least one other report type (FastMM4Messages.InterfaceErrorHeader) } TReportType = (rtUnknown, rtMemoryLeak, rtVMOnFreedObject); const //Leak constants Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMM.dpk =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMM.dpk 2009-05-30 11:45:53 UTC (rev 2779) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMM.dpk 2009-05-30 12:30:53 UTC (rev 2780) @@ -44,6 +44,7 @@ FastMMLeakGroupFrame in 'FastMMLeakGroupFrame.pas' {frmLeakGroup: TFrame}, FastMMFreedObjectFrame in 'FastMMFreedObjectFrame.pas' {frmFreedObject: TFrame}, FastMMMemoryFrame in 'FastMMMemoryFrame.pas' {frmMemory: TFrame}, - FastMMLeakSummaryFrame in 'FastMMLeakSummaryFrame.pas' {frmLeakSummary: TFrame}; + FastMMLeakSummaryFrame in 'FastMMLeakSummaryFrame.pas' {frmLeakSummary: TFrame}, + FastMMMemoryVisualizerFrame in 'FastMMMemoryVisualizerFrame.pas' {frmMemoryVisualizer: TFrame}; end. This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 11:46:25
|
Revision: 2779 http://jcl.svn.sourceforge.net/jcl/?rev=2779&view=rev Author: outchy Date: 2009-05-30 11:45:53 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4743: Logic error in TJclArrayList<T>.MoveArray method TJclQueue<T>.MoveArray and TJclVector<T>.MoveArray are affected too. Modified Paths: -------------- trunk/jcl/source/common/JclArrayLists.pas trunk/jcl/source/common/JclQueues.pas trunk/jcl/source/common/JclVectors.pas trunk/jcl/source/prototypes/JclArrayLists.pas trunk/jcl/source/prototypes/JclQueues.pas trunk/jcl/source/prototypes/JclVectors.pas Modified: trunk/jcl/source/common/JclArrayLists.pas =================================================================== --- trunk/jcl/source/common/JclArrayLists.pas 2009-05-30 11:29:42 UTC (rev 2778) +++ trunk/jcl/source/common/JclArrayLists.pas 2009-05-30 11:45:53 UTC (rev 2779) @@ -12329,11 +12329,33 @@ I: Integer; begin if FromIndex < ToIndex then - for I := 0 to Count - 1 do - List[ToIndex + I] := List[FromIndex + I] - else + begin for I := Count - 1 downto 0 do List[ToIndex + I] := List[FromIndex + I]; + + if (ToIndex - FromIndex) < Count then + // overlapped source and target + for I := 0 to ToIndex - FromIndex - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end + else + begin + for I := 0 to Count - 1 do + List[ToIndex + I] := List[FromIndex + I]; + + if (FromIndex - ToIndex) < Count then + // overlapped source and target + for I := Count - FromIndex + ToIndex to Count - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end; end; //=== { TJclArrayListE<T> } ================================================== Modified: trunk/jcl/source/common/JclQueues.pas =================================================================== --- trunk/jcl/source/common/JclQueues.pas 2009-05-30 11:29:42 UTC (rev 2778) +++ trunk/jcl/source/common/JclQueues.pas 2009-05-30 11:45:53 UTC (rev 2779) @@ -4166,11 +4166,33 @@ I: Integer; begin if FromIndex < ToIndex then - for I := 0 to Count - 1 do - List[ToIndex + I] := List[FromIndex + I] - else + begin for I := Count - 1 downto 0 do List[ToIndex + I] := List[FromIndex + I]; + + if (ToIndex - FromIndex) < Count then + // overlapped source and target + for I := 0 to ToIndex - FromIndex - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end + else + begin + for I := 0 to Count - 1 do + List[ToIndex + I] := List[FromIndex + I]; + + if (FromIndex - ToIndex) < Count then + // overlapped source and target + for I := Count - FromIndex + ToIndex to Count - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end; end; //=== { TJclQueueE<T> } ====================================================== Modified: trunk/jcl/source/common/JclVectors.pas =================================================================== --- trunk/jcl/source/common/JclVectors.pas 2009-05-30 11:29:42 UTC (rev 2778) +++ trunk/jcl/source/common/JclVectors.pas 2009-05-30 11:45:53 UTC (rev 2779) @@ -11597,11 +11597,33 @@ I: Integer; begin if FromIndex < ToIndex then - for I := 0 to Count - 1 do - List[ToIndex + I] := List[FromIndex + I] - else + begin for I := Count - 1 downto 0 do List[ToIndex + I] := List[FromIndex + I]; + + if (ToIndex - FromIndex) < Count then + // overlapped source and target + for I := 0 to ToIndex - FromIndex - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end + else + begin + for I := 0 to Count - 1 do + List[ToIndex + I] := List[FromIndex + I]; + + if (FromIndex - ToIndex) < Count then + // overlapped source and target + for I := Count - FromIndex + ToIndex to Count - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end; end; //=== { TJclVectorE<T> } ===================================================== Modified: trunk/jcl/source/prototypes/JclArrayLists.pas =================================================================== --- trunk/jcl/source/prototypes/JclArrayLists.pas 2009-05-30 11:29:42 UTC (rev 2778) +++ trunk/jcl/source/prototypes/JclArrayLists.pas 2009-05-30 11:45:53 UTC (rev 2779) @@ -354,11 +354,33 @@ I: Integer; begin if FromIndex < ToIndex then - for I := 0 to Count - 1 do - List[ToIndex + I] := List[FromIndex + I] - else + begin for I := Count - 1 downto 0 do List[ToIndex + I] := List[FromIndex + I]; + + if (ToIndex - FromIndex) < Count then + // overlapped source and target + for I := 0 to ToIndex - FromIndex - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end + else + begin + for I := 0 to Count - 1 do + List[ToIndex + I] := List[FromIndex + I]; + + if (FromIndex - ToIndex) < Count then + // overlapped source and target + for I := Count - FromIndex + ToIndex to Count - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end; end; //=== { TJclArrayListE<T> } ================================================== Modified: trunk/jcl/source/prototypes/JclQueues.pas =================================================================== --- trunk/jcl/source/prototypes/JclQueues.pas 2009-05-30 11:29:42 UTC (rev 2778) +++ trunk/jcl/source/prototypes/JclQueues.pas 2009-05-30 11:45:53 UTC (rev 2779) @@ -289,11 +289,33 @@ I: Integer; begin if FromIndex < ToIndex then - for I := 0 to Count - 1 do - List[ToIndex + I] := List[FromIndex + I] - else + begin for I := Count - 1 downto 0 do List[ToIndex + I] := List[FromIndex + I]; + + if (ToIndex - FromIndex) < Count then + // overlapped source and target + for I := 0 to ToIndex - FromIndex - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end + else + begin + for I := 0 to Count - 1 do + List[ToIndex + I] := List[FromIndex + I]; + + if (FromIndex - ToIndex) < Count then + // overlapped source and target + for I := Count - FromIndex + ToIndex to Count - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end; end; //=== { TJclQueueE<T> } ====================================================== Modified: trunk/jcl/source/prototypes/JclVectors.pas =================================================================== --- trunk/jcl/source/prototypes/JclVectors.pas 2009-05-30 11:29:42 UTC (rev 2778) +++ trunk/jcl/source/prototypes/JclVectors.pas 2009-05-30 11:45:53 UTC (rev 2779) @@ -350,11 +350,33 @@ I: Integer; begin if FromIndex < ToIndex then - for I := 0 to Count - 1 do - List[ToIndex + I] := List[FromIndex + I] - else + begin for I := Count - 1 downto 0 do List[ToIndex + I] := List[FromIndex + I]; + + if (ToIndex - FromIndex) < Count then + // overlapped source and target + for I := 0 to ToIndex - FromIndex - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end + else + begin + for I := 0 to Count - 1 do + List[ToIndex + I] := List[FromIndex + I]; + + if (FromIndex - ToIndex) < Count then + // overlapped source and target + for I := Count - FromIndex + ToIndex to Count - 1 do + List[FromIndex + I] := Default(T) + else + // independant + for I := 0 to Count - 1 do + List[FromIndex + I] := Default(T); + end; end; //=== { TJclVectorE<T> } ===================================================== This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 11:29:51
|
Revision: 2778 http://jcl.svn.sourceforge.net/jcl/?rev=2778&view=rev Author: outchy Date: 2009-05-30 11:29:42 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4741: TExpressionCompiler.Clear not clearing internal FExprHash. Modified Paths: -------------- trunk/jcl/source/common/JclExprEval.pas Modified: trunk/jcl/source/common/JclExprEval.pas =================================================================== --- trunk/jcl/source/common/JclExprEval.pas 2009-05-30 11:22:58 UTC (rev 2777) +++ trunk/jcl/source/common/JclExprEval.pas 2009-05-30 11:29:42 UTC (rev 2778) @@ -844,7 +844,7 @@ procedure AddFunc(const AName: string; AFunc: TTernary80Func); overload; procedure Remove(const AName: string); - procedure Clear; + procedure Clear; virtual; property ExtContextSet: TExprSetContext read FExtContextSet; end; @@ -889,7 +889,7 @@ function Compile(const AExpr: string): TCompiledExpression; procedure Remove(const AExpr: string); procedure Delete(ACompiledExpression: TCompiledExpression); - procedure Clear; + procedure Clear; override; end; {$IFDEF UNITVERSIONING} @@ -4401,6 +4401,8 @@ procedure TExpressionCompiler.Clear; begin FExprHash.Iterate(nil, Iterate_FreeObjects); + FExprHash.Clear; + inherited Clear; end; {$IFDEF UNITVERSIONING} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 11:23:19
|
Revision: 2777 http://jcl.svn.sourceforge.net/jcl/?rev=2777&view=rev Author: outchy Date: 2009-05-30 11:22:58 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4795: AdvBuildFileList to include hidden directories. Modified Paths: -------------- trunk/jcl/source/common/JclFileUtils.pas Modified: trunk/jcl/source/common/JclFileUtils.pas =================================================================== --- trunk/jcl/source/common/JclFileUtils.pas 2009-05-30 11:15:10 UTC (rev 2776) +++ trunk/jcl/source/common/JclFileUtils.pas 2009-05-30 11:22:58 UTC (rev 2777) @@ -5841,8 +5841,8 @@ while CurrentItem <= Counter do begin - // searching for subfolders - Rslt := FindFirst(Folders[CurrentItem] + '*.*', faDirectory, FindInfo); + // searching for subfolders (including hidden ones) + Rslt := FindFirst(Folders[CurrentItem] + '*.*', faAnyFile, FindInfo); try while Rslt = 0 do begin This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 11:15:18
|
Revision: 2776 http://jcl.svn.sourceforge.net/jcl/?rev=2776&view=rev Author: outchy Date: 2009-05-30 11:15:10 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4731: TJclBorRADToolInstallation.SubstitutePath doesn't substitute System Variables. Modified Paths: -------------- trunk/jcl/source/common/JclBorlandTools.pas Modified: trunk/jcl/source/common/JclBorlandTools.pas =================================================================== --- trunk/jcl/source/common/JclBorlandTools.pas 2009-05-30 11:05:11 UTC (rev 2775) +++ trunk/jcl/source/common/JclBorlandTools.pas 2009-05-30 11:15:10 UTC (rev 2776) @@ -47,7 +47,7 @@ { } {**************************************************************************************************} { } -{ Last modified: $Date:: $ } +{ Last modified: $Date:: $ } { Revision: $Rev:: $ } { Author: $Author:: $ } { } @@ -3700,6 +3700,14 @@ if FEnvironmentVariables = nil then begin FEnvironmentVariables := TStringList.Create; + + // at first get system environment variables + JclSysInfo.GetEnvironmentVars(FEnvironmentVariables, True); + for I := FEnvironmentVariables.count-1 downto 0 do + if FEnvironmentVariables.Names[I] = EmptyStr then + FEnvironmentVariables.Delete(I); + + // read environment variable overrides if ((VersionNumber >= 6) or (RadToolKind = brBorlandDevStudio)) and ConfigData.SectionExists(EnvVariablesKeyName) then begin This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 11:05:13
|
Revision: 2775 http://jcl.svn.sourceforge.net/jcl/?rev=2775&view=rev Author: outchy Date: 2009-05-30 11:05:11 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4609 JclBorlandTools enhancements part 4: Configuration File deletion is replaced with Configuration File backup. Modified Paths: -------------- trunk/jcl/source/common/JclBorlandTools.pas Modified: trunk/jcl/source/common/JclBorlandTools.pas =================================================================== --- trunk/jcl/source/common/JclBorlandTools.pas 2009-05-30 10:55:36 UTC (rev 2774) +++ trunk/jcl/source/common/JclBorlandTools.pas 2009-05-30 11:05:11 UTC (rev 2775) @@ -2744,13 +2744,8 @@ procedure TJclDCC32.AddProjectOptions(const ProjectFileName, DCPPath: string); var - ConfigurationFileName: string; ProjectOptions: TProjectOptions; begin - ConfigurationFileName := ChangeFileExt(ProjectFileName, ConfigurationExtension); - if FileExists(ConfigurationFileName) then - FileDelete(ConfigurationFileName); - ProjectOptions.UsePackages := False; ProjectOptions.UnitOutputDir := ''; ProjectOptions.SearchPath := ''; @@ -2890,17 +2885,30 @@ function TJclDCC32.MakePackage(const PackageName, BPLPath, DCPPath: string; ExtraOptions: string): Boolean; var SaveDir: string; + ConfigurationFileName, BackupFileName: string; begin SaveDir := GetCurrentDir; SetCurrentDir(ExtractFilePath(PackageName) + '.'); try + // backup existing configuration file, if any + ConfigurationFileName := ChangeFileExt(PackageName, ConfigurationExtension); + if FileExists(ConfigurationFileName) then + FileBackup(ConfigurationFileName, True); + Options.Clear; SetDefaultOptions; AddProjectOptions(PackageName, DCPPath); - AddPathOption('LN', DCPPath); - AddPathOption('LE', BPLPath); - Options.Add(ExtraOptions); - Result := Compile(PackageName); + try + AddPathOption('LN', DCPPath); + AddPathOption('LE', BPLPath); + Options.Add(ExtraOptions); + Result := Compile(PackageName); + finally + // restore existing configuration file, if any + BackupFileName := GetBackupFileName(ConfigurationFileName); + if FileExists(BackupFileName) then + FileMove(BackupFileName, ConfigurationFileName, True); + end; finally SetCurrentDir(SaveDir); end; @@ -2910,16 +2918,29 @@ ExtraOptions: string): Boolean; var SaveDir: string; + ConfigurationFileName, BackupFileName: string; begin SaveDir := GetCurrentDir; SetCurrentDir(ExtractFilePath(ProjectName) + '.'); try + // backup existing configuration file, if any + ConfigurationFileName := ChangeFileExt(ProjectName, ConfigurationExtension); + if FileExists(ConfigurationFileName) then + FileBackup(ConfigurationFileName, True); + Options.Clear; SetDefaultOptions; AddProjectOptions(ProjectName, DcpSearchPath); - AddPathOption('E', OutputDir); - Options.Add(ExtraOptions); - Result := Compile(ProjectName); + try + AddPathOption('E', OutputDir); + Options.Add(ExtraOptions); + Result := Compile(ProjectName); + finally + // restore existing configuration file, if any + BackupFileName := GetBackupFileName(ConfigurationFileName); + if FileExists(BackupFileName) then + FileMove(BackupFileName, ConfigurationFileName, True); + end; finally SetCurrentDir(SaveDir); end; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 10:55:38
|
Revision: 2774 http://jcl.svn.sourceforge.net/jcl/?rev=2774&view=rev Author: outchy Date: 2009-05-30 10:55:36 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4609 JclBorlandTools enhancements part 3: new public function LibDebugFolderName to return the debug dcu folder. Modified Paths: -------------- trunk/jcl/source/common/JclBorlandTools.pas Modified: trunk/jcl/source/common/JclBorlandTools.pas =================================================================== --- trunk/jcl/source/common/JclBorlandTools.pas 2009-05-30 10:52:29 UTC (rev 2773) +++ trunk/jcl/source/common/JclBorlandTools.pas 2009-05-30 10:55:36 UTC (rev 2774) @@ -692,6 +692,7 @@ function SupportsVCL: Boolean; function LibFolderName: string; function ObjFolderName: string; + function LibDebugFolderName: string; // Command line tools property CommandLineTools: TCommandLineTools read FCommandLineTools; property BCC32: TJclBCC32 read GetBCC32; @@ -3980,6 +3981,11 @@ end; {$ENDIF KEEP_DEPRECATED} +function TJclBorRADToolInstallation.LibDebugFolderName: string; +begin + Result := LibFolderName + PathAddSeparator('debug'); +end; + function TJclBorRADToolInstallation.LibFolderName: string; begin Result := PathAddSeparator(RootDir) + PathAddSeparator('lib'); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 10:52:35
|
Revision: 2773 http://jcl.svn.sourceforge.net/jcl/?rev=2773&view=rev Author: outchy Date: 2009-05-30 10:52:29 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4609 JclBorlandTools enhancements part 2: refactored TJclDCC32.AddProjectOptions to make AddBDSProjOptions, AddDOFOptions and AddDProjOptions public functions. Modified Paths: -------------- trunk/jcl/source/common/JclBorlandTools.pas Modified: trunk/jcl/source/common/JclBorlandTools.pas =================================================================== --- trunk/jcl/source/common/JclBorlandTools.pas 2009-05-30 10:42:57 UTC (rev 2772) +++ trunk/jcl/source/common/JclBorlandTools.pas 2009-05-30 10:52:29 UTC (rev 2773) @@ -439,6 +439,15 @@ {$ENDIF KEEP_DEPRECATED} end; + TProjectOptions = record + UsePackages: Boolean; + UnitOutputDir: string; + SearchPath: string; + DynamicPackages: string; + SearchDcpPath: string; + Conditionals: string; + end; + TJclDCC32 = class(TJclBorlandCommandLineTool) protected constructor Create(AInstallation: TJclBorRADToolInstallation); override; @@ -453,6 +462,9 @@ {$IFDEF KEEP_DEPRECATED} function SupportsLibSuffix: Boolean; {$ENDIF KEEP_DEPRECATED} + function AddBDSProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean; + function AddDOFOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean; + function AddDProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean; end; {$IFDEF KEEP_DEPRECATED} TJclDCC = TJclDCC32; @@ -2534,212 +2546,202 @@ //=== { TJclDCC32 } ============================================================ -procedure TJclDCC32.AddProjectOptions(const ProjectFileName, DCPPath: string); - -type - TProjectOptions = record - UsePackages: Boolean; - UnitOutputDir: string; - SearchPath: string; - DynamicPackages: string; - SearchDcpPath: string; - Conditionals: string; - end; - - function AddDProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean; - var - DProjFileName, ProjectConfiguration, ProjectPlatform, PersonalityName: string; - OptionsXmlFile: TJclSimpleXML; - ProjectExtensionsNode, PropertyGroupNode, PersonalityNode, ChildNode: TJclSimpleXMLElem; - NodeIndex: Integer; - ConditionProperty: TJclSimpleXMLProp; - Version: string; +function TJclDCC32.AddDProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean; +var + DProjFileName, ProjectConfiguration, ProjectPlatform, PersonalityName: string; + OptionsXmlFile: TJclSimpleXML; + ProjectExtensionsNode, PropertyGroupNode, PersonalityNode, ChildNode: TJclSimpleXMLElem; + NodeIndex: Integer; + ConditionProperty: TJclSimpleXMLProp; + Version: string; +begin + Version := ''; + DProjFileName := ChangeFileExt(ProjectFileName, SourceExtensionDProject); + Result := FileExists(DProjFileName) and (Installation.IDEVersionNumber >= 5) + and (Installation.RadToolKind = brBorlandDevStudio); + if Result then begin - Version := ''; - DProjFileName := ChangeFileExt(ProjectFileName, SourceExtensionDProject); - Result := FileExists(DProjFileName) and (Installation.IDEVersionNumber >= 5) - and (Installation.RadToolKind = brBorlandDevStudio); - if Result then - begin - OptionsXmlFile := TJclSimpleXML.Create; - try - OptionsXmlFile.LoadFromFile(DProjFileName); - OptionsXmlFile.Options := OptionsXmlFile.Options - [sxoAutoCreate]; - PersonalityName := ''; - ProjectExtensionsNode := OptionsXmlFile.Root.Items.ItemNamed[DProjProjectExtensionsNodeName]; - if Assigned(ProjectExtensionsNode) then + OptionsXmlFile := TJclSimpleXML.Create; + try + OptionsXmlFile.LoadFromFile(DProjFileName); + OptionsXmlFile.Options := OptionsXmlFile.Options - [sxoAutoCreate]; + PersonalityName := ''; + ProjectExtensionsNode := OptionsXmlFile.Root.Items.ItemNamed[DProjProjectExtensionsNodeName]; + if Assigned(ProjectExtensionsNode) then + begin + PersonalityNode := ProjectExtensionsNode.Items.ItemNamed[DProjPersonalityNodeName]; + if Assigned(PersonalityNode) then + PersonalityName := PersonalityNode.Value; + end; + if StrHasPrefix(PersonalityName, [DProjDelphiPersonalityValue]) or + AnsiSameText(PersonalityName, DProjDelphiDotNetPersonalityValue) then + begin + ProjectConfiguration := ''; + ProjectPlatform := ''; + for NodeIndex := 0 to OptionsXmlFile.Root.Items.Count - 1 do begin - PersonalityNode := ProjectExtensionsNode.Items.ItemNamed[DProjPersonalityNodeName]; - if Assigned(PersonalityNode) then - PersonalityName := PersonalityNode.Value; - end; - if StrHasPrefix(PersonalityName, [DProjDelphiPersonalityValue]) or - AnsiSameText(PersonalityName, DProjDelphiDotNetPersonalityValue) then - begin - ProjectConfiguration := ''; - ProjectPlatform := ''; - for NodeIndex := 0 to OptionsXmlFile.Root.Items.Count - 1 do + PropertyGroupNode := OptionsXmlFile.Root.Items.Item[NodeIndex]; + if AnsiSameText(PropertyGroupNode.Name, DProjPropertyGroupNodeName) then begin - PropertyGroupNode := OptionsXmlFile.Root.Items.Item[NodeIndex]; - if AnsiSameText(PropertyGroupNode.Name, DProjPropertyGroupNodeName) then + ConditionProperty := PropertyGroupNode.Properties.ItemNamed[DProjConditionValueName]; + if Assigned(ConditionProperty) then begin - ConditionProperty := PropertyGroupNode.Properties.ItemNamed[DProjConditionValueName]; - if Assigned(ConditionProperty) then + if ((Version = '') and (ProjectConfiguration <> '') and (ProjectPlatform <> '') and + (AnsiPos(Format('%s|%s', [ProjectConfiguration, ProjectPlatform]), ConditionProperty.Value) > 0)) + or + ((Version <> '') and (ProjectConfiguration <> '') and + (AnsiPos(ProjectConfiguration, ConditionProperty.Value) > 0)) + or + ((Version <> '') and (ProjectConfiguration <> '') and + (AnsiPos('$(Base)', ConditionProperty.Value) > 0)) then begin - if ((Version = '') and (ProjectConfiguration <> '') and (ProjectPlatform <> '') and - (AnsiPos(Format('%s|%s', [ProjectConfiguration, ProjectPlatform]), ConditionProperty.Value) > 0)) - or - ((Version <> '') and (ProjectConfiguration <> '') and - (AnsiPos(ProjectConfiguration, ConditionProperty.Value) > 0)) - or - ((Version <> '') and (ProjectConfiguration <> '') and - (AnsiPos('$(Base)', ConditionProperty.Value) > 0)) then - begin - // this is the active configuration, check for overrides - ChildNode := PropertyGroupNode.Items.ItemNamed[DProjUsePackageNodeName]; - if Assigned(ChildNode) then - ProjectOptions.DynamicPackages := ChildNode.Value; - ProjectOptions.UsePackages := ProjectOptions.DynamicPackages <> ''; - ChildNode := PropertyGroupNode.Items.ItemNamed[DProjDcuOutputDirNodeName]; - if Assigned(ChildNode) then - ProjectOptions.UnitOutputDir := ChildNode.Value; - ChildNode := PropertyGroupNode.Items.ItemNamed[DProjUnitSearchPathNodeName]; - if Assigned(ChildNode) then - ProjectOptions.SearchPath := ChildNode.Value; - ChildNode := PropertyGroupNode.Items.ItemNamed[DProjDefineNodeName]; - if Assigned(ChildNode) then - ProjectOptions.Conditionals := ChildNode.Value; - end; + // this is the active configuration, check for overrides + ChildNode := PropertyGroupNode.Items.ItemNamed[DProjUsePackageNodeName]; + if Assigned(ChildNode) then + ProjectOptions.DynamicPackages := ChildNode.Value; + ProjectOptions.UsePackages := ProjectOptions.DynamicPackages <> ''; + ChildNode := PropertyGroupNode.Items.ItemNamed[DProjDcuOutputDirNodeName]; + if Assigned(ChildNode) then + ProjectOptions.UnitOutputDir := ChildNode.Value; + ChildNode := PropertyGroupNode.Items.ItemNamed[DProjUnitSearchPathNodeName]; + if Assigned(ChildNode) then + ProjectOptions.SearchPath := ChildNode.Value; + ChildNode := PropertyGroupNode.Items.ItemNamed[DProjDefineNodeName]; + if Assigned(ChildNode) then + ProjectOptions.Conditionals := ChildNode.Value; + end; + end + else + begin + // check for version and default configurations + ChildNode := PropertyGroupNode.Items.ItemNamed[DProjProjectVersionNodeName]; + if Assigned(ChildNode) then + Version := ChildNode.Value; + + if Version = '' then + begin + ChildNode := PropertyGroupNode.Items.ItemNamed[DProjConfigurationNodeName]; + if Assigned(ChildNode) then + ProjectConfiguration := ChildNode.Value; + ChildNode := PropertyGroupNode.Items.ItemNamed[DProjPlatformNodeName]; + if Assigned(ChildNode) then + ProjectPlatform := ChildNode.Value; end else begin - // check for version and default configurations - ChildNode := PropertyGroupNode.Items.ItemNamed[DProjProjectVersionNodeName]; + ChildNode := PropertyGroupNode.Items.ItemNamed[DProjConfigNodeName]; if Assigned(ChildNode) then - Version := ChildNode.Value; - - if Version = '' then - begin - ChildNode := PropertyGroupNode.Items.ItemNamed[DProjConfigurationNodeName]; - if Assigned(ChildNode) then - ProjectConfiguration := ChildNode.Value; - ChildNode := PropertyGroupNode.Items.ItemNamed[DProjPlatformNodeName]; - if Assigned(ChildNode) then - ProjectPlatform := ChildNode.Value; - end - else - begin - ChildNode := PropertyGroupNode.Items.ItemNamed[DProjConfigNodeName]; - if Assigned(ChildNode) then - ProjectConfiguration := ChildNode.Value; - end; + ProjectConfiguration := ChildNode.Value; end; end; end; end; - finally - OptionsXmlFile.Free; end; + finally + OptionsXmlFile.Free; end; end; +end; - function AddBDSProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean; - var - BDSProjFileName, PersonalityName: string; - OptionsXmlFile: TJclSimpleXML; - PersonalityInfoNode, OptionNode, ChildNode, PersonalityNode, DirectoriesNode: TJclSimpleXMLElem; - NodeIndex: Integer; - NameProperty: TJclSimpleXMLProp; +function TJclDCC32.AddBDSProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean; +var + BDSProjFileName, PersonalityName: string; + OptionsXmlFile: TJclSimpleXML; + PersonalityInfoNode, OptionNode, ChildNode, PersonalityNode, DirectoriesNode: TJclSimpleXMLElem; + NodeIndex: Integer; + NameProperty: TJclSimpleXMLProp; +begin + BDSProjFileName := ChangeFileExt(ProjectFileName, SourceExtensionBDSProject); + Result := FileExists(BDSProjFileName); + if Result then begin - BDSProjFileName := ChangeFileExt(ProjectFileName, SourceExtensionBDSProject); - Result := FileExists(BDSProjFileName); - if Result then - begin - OptionsXmlFile := TJclSimpleXML.Create; - try - OptionsXmlFile.LoadFromFile(BDSProjFileName); - OptionsXmlFile.Options := OptionsXmlFile.Options - [sxoAutoCreate]; - PersonalityInfoNode := OptionsXmlFile.Root.Items.ItemNamed[BDSProjPersonalityInfoNodeName]; - PersonalityName := ''; - if Assigned(PersonalityInfoNode) then - begin - OptionNode := PersonalityInfoNode.Items.ItemNamed[BDSProjOptionNodeName]; - if Assigned(OptionNode) then - for NodeIndex := 0 to OptionNode.Items.Count - 1 do + OptionsXmlFile := TJclSimpleXML.Create; + try + OptionsXmlFile.LoadFromFile(BDSProjFileName); + OptionsXmlFile.Options := OptionsXmlFile.Options - [sxoAutoCreate]; + PersonalityInfoNode := OptionsXmlFile.Root.Items.ItemNamed[BDSProjPersonalityInfoNodeName]; + PersonalityName := ''; + if Assigned(PersonalityInfoNode) then + begin + OptionNode := PersonalityInfoNode.Items.ItemNamed[BDSProjOptionNodeName]; + if Assigned(OptionNode) then + for NodeIndex := 0 to OptionNode.Items.Count - 1 do + begin + ChildNode := OptionNode.Items.Item[NodeIndex]; + if SameText(ChildNode.Name, BDSProjOptionNodeName) then begin - ChildNode := OptionNode.Items.Item[NodeIndex]; - if SameText(ChildNode.Name, BDSProjOptionNodeName) then + NameProperty := ChildNode.Properties.ItemNamed[BDSProjNameProperty]; + if Assigned(NameProperty) and SameText(NameProperty.Value, BDSProjPersonalityValue) then begin - NameProperty := ChildNode.Properties.ItemNamed[BDSProjNameProperty]; - if Assigned(NameProperty) and SameText(NameProperty.Value, BDSProjPersonalityValue) then - begin - PersonalityName := ChildNode.Value; - Break; - end; + PersonalityName := ChildNode.Value; + Break; end; end; - end; - if PersonalityName <> '' then + end; + end; + if PersonalityName <> '' then + begin + PersonalityNode := OptionsXmlFile.Root.Items.ItemNamed[PersonalityName]; + if Assigned(PersonalityNode) then begin - PersonalityNode := OptionsXmlFile.Root.Items.ItemNamed[PersonalityName]; - if Assigned(PersonalityNode) then - begin - DirectoriesNode := PersonalityNode.Items.ItemNamed[BDSProjDirectoriesNodeName]; - if Assigned(DirectoriesNode) then - for NodeIndex := 0 to DirectoriesNode.Items.Count - 1 do + DirectoriesNode := PersonalityNode.Items.ItemNamed[BDSProjDirectoriesNodeName]; + if Assigned(DirectoriesNode) then + for NodeIndex := 0 to DirectoriesNode.Items.Count - 1 do + begin + ChildNode := DirectoriesNode.Items.Item[NodeIndex]; + if SameText(ChildNode.Name, BDSProjDirectoriesNodeName) then begin - ChildNode := DirectoriesNode.Items.Item[NodeIndex]; - if SameText(ChildNode.Name, BDSProjDirectoriesNodeName) then + NameProperty := ChildNode.Properties.ItemNamed[BDSProjNameProperty]; + if Assigned(NameProperty) then begin - NameProperty := ChildNode.Properties.ItemNamed[BDSProjNameProperty]; - if Assigned(NameProperty) then - begin - if SameText(NameProperty.Value, BDSProjUnitOutputDirValue) then - ProjectOptions.UnitOutputDir := ChildNode.Value - else - if SameText(NameProperty.Value, BDSProjSearchPathValue) then - ProjectOptions.SearchPath := ChildNode.Value - else - if SameText(NameProperty.Value, BDSProjPackagesValue) then - ProjectOptions.DynamicPackages := ChildNode.Value - else - if SameText(NameProperty.Value, BDSProjConditionalsValue) then - ProjectOptions.Conditionals := ChildNode.Value - else - if SameText(NameProperty.Value, BDSProjUsePackagesValue) then - ProjectOptions.UsePackages := StrToBoolean(ChildNode.Value); - end; + if SameText(NameProperty.Value, BDSProjUnitOutputDirValue) then + ProjectOptions.UnitOutputDir := ChildNode.Value + else + if SameText(NameProperty.Value, BDSProjSearchPathValue) then + ProjectOptions.SearchPath := ChildNode.Value + else + if SameText(NameProperty.Value, BDSProjPackagesValue) then + ProjectOptions.DynamicPackages := ChildNode.Value + else + if SameText(NameProperty.Value, BDSProjConditionalsValue) then + ProjectOptions.Conditionals := ChildNode.Value + else + if SameText(NameProperty.Value, BDSProjUsePackagesValue) then + ProjectOptions.UsePackages := StrToBoolean(ChildNode.Value); end; end; - end; + end; end; - finally - OptionsXmlFile.Free; end; + finally + OptionsXmlFile.Free; end; end; +end; - function AddDOFOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean; - var - DOFFileName: string; - OptionsFile: TIniFile; +function TJclDCC32.AddDOFOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean; +var + DOFFileName: string; + OptionsFile: TIniFile; +begin + DOFFileName := ChangeFileExt(ProjectFileName, DelphiOptionsFileExtension); + Result := FileExists(DOFFileName); + if Result then begin - DOFFileName := ChangeFileExt(ProjectFileName, DelphiOptionsFileExtension); - Result := FileExists(DOFFileName); - if Result then - begin - OptionsFile := TIniFile.Create(DOFFileName); - try - ProjectOptions.SearchPath := OptionsFile.ReadString(DOFDirectoriesSection, DOFSearchPathName, ''); - ProjectOptions.UnitOutputDir := OptionsFile.ReadString(DOFDirectoriesSection, DOFUnitOutputDirKey, ''); - ProjectOptions.Conditionals := OptionsFile.ReadString(DOFDirectoriesSection, DOFConditionals, ''); - ProjectOptions.UsePackages := OptionsFile.ReadString(DOFCompilerSection, DOFPackageNoLinkKey, '') = '1'; - ProjectOptions.DynamicPackages := OptionsFile.ReadString(DOFLinkerSection, DOFPackagesKey, ''); - finally - OptionsFile.Free; - end; + OptionsFile := TIniFile.Create(DOFFileName); + try + ProjectOptions.SearchPath := OptionsFile.ReadString(DOFDirectoriesSection, DOFSearchPathName, ''); + ProjectOptions.UnitOutputDir := OptionsFile.ReadString(DOFDirectoriesSection, DOFUnitOutputDirKey, ''); + ProjectOptions.Conditionals := OptionsFile.ReadString(DOFDirectoriesSection, DOFConditionals, ''); + ProjectOptions.UsePackages := OptionsFile.ReadString(DOFCompilerSection, DOFPackageNoLinkKey, '') = '1'; + ProjectOptions.DynamicPackages := OptionsFile.ReadString(DOFLinkerSection, DOFPackagesKey, ''); + finally + OptionsFile.Free; end; end; +end; + +procedure TJclDCC32.AddProjectOptions(const ProjectFileName, DCPPath: string); var ConfigurationFileName: string; ProjectOptions: TProjectOptions; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ou...@us...> - 2009-05-30 10:43:21
|
Revision: 2772 http://jcl.svn.sourceforge.net/jcl/?rev=2772&view=rev Author: outchy Date: 2009-05-30 10:42:57 +0000 (Sat, 30 May 2009) Log Message: ----------- Mantis 4609 JclBorlandTools enhancements part 1: command line tools execution events Modified Paths: -------------- trunk/jcl/source/common/JclBorlandTools.pas Modified: trunk/jcl/source/common/JclBorlandTools.pas =================================================================== --- trunk/jcl/source/common/JclBorlandTools.pas 2009-05-24 23:30:36 UTC (rev 2771) +++ trunk/jcl/source/common/JclBorlandTools.pas 2009-05-30 10:42:57 UTC (rev 2772) @@ -396,11 +396,16 @@ destructor Destroy; override; end; + TJclBorlandCommandLineTool = class; + TJclBorlandCommandLineToolEvent = procedure(Sender:TJclBorlandCommandLineTool) of object; + TJclBorlandCommandLineTool = class(TJclBorRADToolInstallationObject, IJclCommandLineTool) private FOptions: TStringList; FOutputCallback: TTextHandler; FOutput: string; + FOnAfterExecute: TJclBorlandCommandLineToolEvent; + FOnBeforeExecute: TJclBorlandCommandLineToolEvent; protected constructor Create(AInstallation: TJclBorRADToolInstallation); virtual; procedure CheckOutputValid; @@ -408,6 +413,7 @@ function GetFileName: string; function GetOptions: TStrings; function GetOutputCallback: TTextHandler; + function InternalExecute(const CommandLine: string): Boolean; procedure SetOutputCallback(const CallbackMethod: TTextHandler); function GetOutput: string; public @@ -418,6 +424,9 @@ property Output: string read GetOutput; property OutputCallback: TTextHandler read FOutputCallback write SetOutputCallback; property Options: TStrings read GetOptions; + + property OnAfterExecute: TJclBorlandCommandLineToolEvent read FOnAfterExecute write FOnAfterExecute; + property OnBeforeExecute: TJclBorlandCommandLineToolEvent read FOnBeforeExecute write FOnBeforeExecute; end; TJclBCC32 = class(TJclBorlandCommandLineTool) @@ -2443,17 +2452,14 @@ end; function TJclBorlandCommandLineTool.Execute(const CommandLine: string): Boolean; -var - LaunchCommand: string; begin - LaunchCommand := Format('%s %s', [FileName, CommandLine]); - if Assigned(FOutputCallback) then - begin - FOutputCallback(LaunchCommand); - Result := JclSysUtils.Execute(LaunchCommand, FOutputCallback) = 0; - end - else - Result := JclSysUtils.Execute(LaunchCommand, FOutput) = 0; + if Assigned(FOnBeforeExecute) then + FOnBeforeExecute(Self); + + Result := InternalExecute(CommandLine); + + if Assigned(FOnAfterExecute) then + FOnAfterExecute(Self); end; function TJclBorlandCommandLineTool.GetExeName: string; @@ -2487,6 +2493,21 @@ Result := FOutputCallback; end; +function TJclBorlandCommandLineTool.InternalExecute( + const CommandLine: string): Boolean; +var + LaunchCommand: string; +begin + LaunchCommand := Format('%s %s', [FileName, CommandLine]); + if Assigned(FOutputCallback) then + begin + FOutputCallback(LaunchCommand); + Result := JclSysUtils.Execute(LaunchCommand, FOutputCallback) = 0; + end + else + Result := JclSysUtils.Execute(LaunchCommand, FOutput) = 0; +end; + procedure TJclBorlandCommandLineTool.SetOutputCallback(const CallbackMethod: TTextHandler); begin FOutputCallback := CallbackMethod; @@ -2815,6 +2836,9 @@ PathList: TStrings; Option, Arguments, CurrentFolder: string; begin + if Assigned(FOnBeforeExecute) then + FOnBeforeExecute(Self); + FOutput := ''; Arguments := ''; CurrentFolder := GetCurrentFolder; @@ -2849,7 +2873,10 @@ PathList.Free; end; - Result := inherited Execute(CommandLine + Arguments); + Result := InternalExecute(CommandLine + Arguments); + + if Assigned(FOnAfterExecute) then + FOnAfterExecute(Self); end; function TJclDCC32.GetExeName: string; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <usc...@us...> - 2009-05-24 23:30:44
|
Revision: 2771 http://jcl.svn.sourceforge.net/jcl/?rev=2771&view=rev Author: uschuster Date: 2009-05-24 23:30:36 +0000 (Sun, 24 May 2009) Log Message: ----------- changes to remove the SourceUnitName prefix from the ProcedureName Modified Paths: -------------- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.pas Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas 2009-05-23 20:11:00 UTC (rev 2770) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas 2009-05-24 23:30:36 UTC (rev 2771) @@ -1,5 +1,7 @@ unit FastMMParser; +{$I jcl.inc} + interface uses @@ -130,6 +132,8 @@ end; TFastMMFileParser = class(TObject) + private + procedure FixStack(ALocationInfoList: TFastMMLocationInfoList); public function ParseFile(const AFileName: string; AReportList: TObjectList): Integer; end; @@ -412,7 +416,11 @@ begin LastIsNumber := True; for I := 1 to Length(S) do + {$IFDEF COMPILER12_UP} + if not CharInSet(S[I], ['0'..'9']) then + {$ELSE !COMPILER12_UP} if not (S[I] in ['0'..'9']) then + {$ENDIF !COMPILER12_UP} begin LastIsNumber := False; Break; @@ -456,7 +464,11 @@ for I := 1 to Length(AStr) do begin C := AStr[I]; + {$IFDEF COMPILER12_UP} + if CharInSet(C, ['0'..'9', 'A'..'F']) then + {$ELSE !COMPILER12_UP} if C in ['0'..'9', 'A'..'F'] then + {$ENDIF !COMPILER12_UP} S := S + C else if C = ' ' then @@ -478,6 +490,40 @@ { TFastMMFileParser } +procedure TFastMMFileParser.FixStack(ALocationInfoList: TFastMMLocationInfoList); +var + I: Integer; + FixProcedureName: Boolean; + S: string; + LocationInfoEx: TJclLocationInfoEx; +begin + if ALocationInfoList.Count > 0 then + begin + FixProcedureName := True; + for I := 0 to ALocationInfoList.Count - 1 do + begin + LocationInfoEx := ALocationInfoList[I]; + if (LocationInfoEx.SourceUnitName <> '') and + (Pos(LocationInfoEx.SourceUnitName + '.', LocationInfoEx.ProcedureName) <> 1) then + begin + FixProcedureName := False; + Break; + end; + end; + if FixProcedureName then + for I := 0 to ALocationInfoList.Count - 1 do + begin + LocationInfoEx := ALocationInfoList[I]; + if LocationInfoEx.SourceUnitName <> '' then + begin + S := LocationInfoEx.ProcedureName; + Delete(S, 1, Length(LocationInfoEx.SourceUnitName) + 1); + LocationInfoEx.ProcedureName := S; + end; + end; + end; +end; + function TFastMMFileParser.ParseFile(const AFileName: string; AReportList: TObjectList): Integer; type TReportType = (rtUnknown, rtMemoryLeak, rtVMOnFreedObject); @@ -817,7 +863,18 @@ TSL.Free; end; for I := 0 to AReportList.Count - 1 do - TFastMMReport(AReportList[I]).BuildGroups; + begin + Report := TFastMMReport(AReportList[I]); + Report.BuildGroups; + for J := 0 to Report.LeakCount - 1 do + FixStack(Report.LeakItems[J].Stack); + for J := 0 to Report.VMOnFreedObjectCount - 1 do + begin + FixStack(Report.VMOnFreedObjectItems[J].Stack1); + FixStack(Report.VMOnFreedObjectItems[J].Stack2); + FixStack(Report.VMOnFreedObjectItems[J].Stack3); + end; + end; Result := AReportList.Count; end; Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.pas 2009-05-23 20:11:00 UTC (rev 2770) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.pas 2009-05-24 23:30:36 UTC (rev 2771) @@ -20,9 +20,9 @@ { } {**************************************************************************************************} { } -{ Last modified: $Date:: $ } -{ Revision: $Rev:: $ } -{ Author: $Author:: $ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } { } {**************************************************************************************************} @@ -58,6 +58,7 @@ function GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; procedure UpdateViews; function GetSelected: IJclLocationInfo; + procedure UpdateListView; public { Public declarations } procedure LoadState(AIni: TCustomIniFile; const ASection, APrefix: string); @@ -149,24 +150,45 @@ end; procedure TfrmStack.SetStackList(const Value: IJclLocationInfoList); +begin + FStackList := Value; + UpdateListView; +end; + +procedure TfrmStack.UpdateListView; var I: Integer; ListItem: TListItem; S: string; PreparedLocationInfo: IJclPreparedLocationInfo; + LocationInfo: IJclLocationInfo; + FixProcedureName: Boolean; begin - FStackList := Value; - lv.Items.BeginUpdate; try lv.Items.Clear; if Assigned(FStackList) then + begin + FixProcedureName := True; for I := 0 to FStackList.Count - 1 do begin + LocationInfo := FStackList[I]; + if (LocationInfo.SourceUnitName <> '') and + (Pos(LocationInfo.SourceUnitName + '.', LocationInfo.ProcedureName) <> 1) then + begin + FixProcedureName := False; + Break; + end; + end; + for I := 0 to FStackList.Count - 1 do + begin ListItem := lv.Items.Add; ListItem.Caption := FStackList[I].ModuleName; ListItem.SubItems.Add(FStackList[I].SourceUnitName); - ListItem.SubItems.Add(FStackList[I].ProcedureName); + S := FStackList[I].ProcedureName; + if FixProcedureName and (FStackList[I].SourceUnitName <> '') then + Delete(S, 1, Length(FStackList[I].SourceUnitName) + 1); + ListItem.SubItems.Add(S); ListItem.SubItems.Add(FStackList[I].SourceName); if FStackList[I].LineNumber > 0 then S := IntToStr(FStackList[I].LineNumber) @@ -200,6 +222,7 @@ end; ListItem.Data := Pointer(FStackList[I]); end; + end; finally lv.Items.EndUpdate; end; @@ -207,7 +230,7 @@ procedure TfrmStack.UpdateView; begin - SetStackList(FStackList); + UpdateListView; end; procedure TfrmStack.UpdateViews; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <usc...@us...> - 2009-05-23 20:11:08
|
Revision: 2770 http://jcl.svn.sourceforge.net/jcl/?rev=2770&view=rev Author: uschuster Date: 2009-05-23 20:11:00 +0000 (Sat, 23 May 2009) Log Message: ----------- fixed crash on IDE shutdown or re-compile if extension for FastMM is installed (now StackTraceViewerStackServices is set to nil) Modified Paths: -------------- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerMainFrame.pas Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerMainFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerMainFrame.pas 2009-05-22 20:30:36 UTC (rev 2769) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerMainFrame.pas 2009-05-23 20:11:00 UTC (rev 2770) @@ -527,6 +527,7 @@ destructor TfrmMain.Destroy; begin + StackTraceViewerStackServices := nil; StackTraceViewerStackProcessorServices := nil; FStackFrame.StackList := nil; FLocationInfoProcessor.Free; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <usc...@us...> - 2009-05-22 20:30:47
|
Revision: 2769 http://jcl.svn.sourceforge.net/jcl/?rev=2769&view=rev Author: uschuster Date: 2009-05-22 20:30:36 +0000 (Fri, 22 May 2009) Log Message: ----------- extension for FastMM Modified Paths: -------------- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerClasses.pas branches/jcl-stack-trace/jcl/source/windows/JclDebug.pas Added Paths: ----------- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMFreedObjectFrame.dfm branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMFreedObjectFrame.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.dfm branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakGroupFrame.dfm branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakGroupFrame.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakSummaryFrame.dfm branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakSummaryFrame.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryFrame.dfm branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryFrame.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMM.dpk branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMMReg.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMMUnit.pas Property changes on: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM ___________________________________________________________________ Added: tsvn:projectlanguage + 1033 Added: bugtraq:url + http://homepages.codegear.com/jedi/issuetracker/view.php?id=%BUGID% Added: bugtraq:message + (Mantis #%BUGID%) Added: bugtraq:logregex + [Mm]antis #?(\d+)(,? ?#?(\d+))+ (\d+) Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMFreedObjectFrame.dfm =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMFreedObjectFrame.dfm (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMFreedObjectFrame.dfm 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,108 @@ +object frmFreedObject: TfrmFreedObject + Left = 0 + Top = 0 + Width = 415 + Height = 240 + TabOrder = 0 + object pnlTop: TPanel + Left = 0 + Top = 0 + Width = 415 + Height = 41 + Align = alTop + BevelOuter = bvNone + TabOrder = 0 + object Label1: TLabel + Left = 3 + Top = 3 + Width = 95 + Height = 13 + Caption = 'Freed Object Class:' + end + object Label2: TLabel + Left = 3 + Top = 19 + Width = 89 + Height = 13 + Caption = 'Allocation number:' + end + object Label3: TLabel + Left = 227 + Top = 3 + Width = 73 + Height = 13 + Caption = 'Virtual Method:' + end + object Label4: TLabel + Left = 227 + Top = 19 + Width = 115 + Height = 13 + Caption = 'Virtual Method Address:' + end + object lbVM: TLabel + Left = 348 + Top = 3 + Width = 22 + Height = 13 + Caption = 'lbVM' + end + object lbVMAddr: TLabel + Left = 348 + Top = 19 + Width = 45 + Height = 13 + Caption = 'lbVMAddr' + end + object lbFreedObjectClass: TLabel + Left = 104 + Top = 3 + Width = 27 + Height = 13 + Caption = 'lbSize' + end + object lbAllocationNumber: TLabel + Left = 104 + Top = 19 + Width = 91 + Height = 13 + Caption = 'lbAllocationNumber' + end + end + object pg: TPageControl + Left = 0 + Top = 41 + Width = 415 + Height = 199 + ActivePage = tsStack1 + Align = alClient + TabOrder = 1 + object tsStack1: TTabSheet + Caption = 'Stack (allocated by)' + end + object tsStack2: TTabSheet + Caption = 'Stack (freed by)' + ImageIndex = 1 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 + end + object tsStack3: TTabSheet + Caption = 'Stack (current)' + ImageIndex = 2 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 + end + object tsMemory: TTabSheet + Caption = 'Memory Dump' + ImageIndex = 3 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 + end + end +end Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMFreedObjectFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMFreedObjectFrame.pas (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMFreedObjectFrame.pas 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,190 @@ +unit FastMMFreedObjectFrame; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ComCtrls, ExtCtrls, JclStackTraceViewerAPI, FastMMParser, + FastMMMemoryFrame; + +type + TfrmFreedObject = class(TFrame, IJclStackTraceViewerPreparableStackFrame, IJclStackTraceViewerStackSelection) + pnlTop: TPanel; + pg: TPageControl; + tsStack1: TTabSheet; + tsStack2: TTabSheet; + tsStack3: TTabSheet; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + lbVM: TLabel; + lbVMAddr: TLabel; + lbFreedObjectClass: TLabel; + lbAllocationNumber: TLabel; + tsMemory: TTabSheet; + private + FFreedObjectData: TFastMMVMOnFreedObject; + FStackFrame1: TCustomFrame; + FStackFrame2: TCustomFrame; + FStackFrame3: TCustomFrame; + FStackInterfaceList: TInterfaceList; + FMemoryFrame: TfrmMemory; + function GetSelected: IJclLocationInfo; + function GetPreparableLocationInfoListCount: Integer; + function GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; + procedure UpdateViews; + procedure SetFreedObjectData(const Value: TFastMMVMOnFreedObject); + { Private-Deklarationen } + public + { Public-Deklarationen } + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property FreedObjectData: TFastMMVMOnFreedObject write SetFreedObjectData; + end; + +implementation + +{$R *.dfm} + +{ TfrmFreedObject } + +constructor TfrmFreedObject.Create(AOwner: TComponent); +var + StackFrameClass: TCustomFrameClass; +begin + inherited Create(AOwner); + FFreedObjectData := nil; + if Assigned(StackTraceViewerStackServices) then + begin + StackFrameClass := StackTraceViewerStackServices.GetDefaultFrameClass(dfStack); + if Assigned(StackFrameClass) then + begin + FStackFrame1 := StackFrameClass.Create(Self); + FStackFrame1.Parent := tsStack1; + FStackFrame1.Align := alClient; + FStackFrame1.Name := 'StackFrame1'; + FStackFrame2 := StackFrameClass.Create(Self); + FStackFrame2.Parent := tsStack2; + FStackFrame2.Align := alClient; + FStackFrame2.Name := 'StackFrame2'; + FStackFrame3 := StackFrameClass.Create(Self); + FStackFrame3.Parent := tsStack3; + FStackFrame3.Align := alClient; + FStackFrame3.Name := 'StackFrame3'; + end; + end; + FMemoryFrame := TfrmMemory.Create(Self); + FMemoryFrame.Parent := tsMemory; + FMemoryFrame.Align := alClient; + FStackInterfaceList := TInterfaceList.Create; +end; + +destructor TfrmFreedObject.Destroy; +begin + FStackInterfaceList := TInterfaceList.Create; + FStackFrame1.Free; + FStackFrame2.Free; + FStackFrame3.Free; + FMemoryFrame.Free; + inherited Destroy; +end; + +function TfrmFreedObject.GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; +begin + if FStackInterfaceList[AIndex].QueryInterface(IJclPreparedLocationInfoList, Result) <> S_OK then + Result := nil; +end; + +function TfrmFreedObject.GetPreparableLocationInfoListCount: Integer; +begin + Result := FStackInterfaceList.Count; +end; + +function TfrmFreedObject.GetSelected: IJclLocationInfo; +var + StackTraceViewerStackSelection: IJclStackTraceViewerStackSelection; +begin + if Assigned(FFreedObjectData) then + begin + if pg.Visible and (pg.ActivePage = tsStack1) and FStackFrame1.Visible and + (FStackFrame1.GetInterface(IJclStackTraceViewerStackSelection, StackTraceViewerStackSelection)) and + Assigned(StackTraceViewerStackSelection.Selected) then + Result := StackTraceViewerStackSelection.Selected + else + if pg.Visible and (pg.ActivePage = tsStack2) and FStackFrame2.Visible and + (FStackFrame2.GetInterface(IJclStackTraceViewerStackSelection, StackTraceViewerStackSelection)) and + Assigned(StackTraceViewerStackSelection.Selected) then + Result := StackTraceViewerStackSelection.Selected + else + if pg.Visible and (pg.ActivePage = tsStack3) and FStackFrame3.Visible and + (FStackFrame3.GetInterface(IJclStackTraceViewerStackSelection, StackTraceViewerStackSelection)) and + Assigned(StackTraceViewerStackSelection.Selected) then + Result := StackTraceViewerStackSelection.Selected + else + Result := nil; + end + else + Result := nil; +end; + +procedure TfrmFreedObject.SetFreedObjectData(const Value: TFastMMVMOnFreedObject); +var + StackTraceViewerStackFrame: IJclStackTraceViewerStackFrame; + PreparedLocationInfoList: IJclPreparedLocationInfoList; +begin + FStackInterfaceList.Clear; + FFreedObjectData := Value; + pnlTop.Visible := Assigned(FFreedObjectData); + if Assigned(FFreedObjectData) then + begin + lbFreedObjectClass.Caption := FFreedObjectData.ObjectClass; + lbAllocationNumber.Caption := IntToStr(FFreedObjectData.AllocationNumber); + lbVM.Caption := FFreedObjectData.VirtualMethod; + lbVMAddr.Caption := Format('%.8x', [FFreedObjectData.VirtualMethodAddress]); + end; + tsStack1.TabVisible := Assigned(FStackFrame1) and Assigned(FFreedObjectData) and (FFreedObjectData.Stack1.Count > 0); + tsStack1.Caption := Format('Stack (allocated by thread %x)', [FFreedObjectData.Stack1Thread]); + if tsStack1.TabVisible and FFreedObjectData.Stack1.GetInterface(IJclPreparedLocationInfoList, PreparedLocationInfoList) then + FStackInterfaceList.Add(PreparedLocationInfoList); + if tsStack1.TabVisible and (FStackFrame1.GetInterface(IJclStackTraceViewerStackFrame, StackTraceViewerStackFrame)) then + StackTraceViewerStackFrame.SetStackList(FFreedObjectData.Stack1); + tsStack2.TabVisible := Assigned(FStackFrame2) and Assigned(FFreedObjectData) and (FFreedObjectData.Stack2.Count > 0); + tsStack2.Caption := Format('Stack (freed by thread %x)', [FFreedObjectData.Stack2Thread]); + if tsStack2.TabVisible and FFreedObjectData.Stack2.GetInterface(IJclPreparedLocationInfoList, PreparedLocationInfoList) then + FStackInterfaceList.Add(PreparedLocationInfoList); + if tsStack2.TabVisible and (FStackFrame2.GetInterface(IJclStackTraceViewerStackFrame, StackTraceViewerStackFrame)) then + StackTraceViewerStackFrame.SetStackList(FFreedObjectData.Stack2); + tsStack3.TabVisible := Assigned(FStackFrame3) and Assigned(FFreedObjectData) and (FFreedObjectData.Stack3.Count > 0); + tsStack3.Caption := Format('Stack (current thread %x)', [FFreedObjectData.Stack3Thread]); + if tsStack3.TabVisible and FFreedObjectData.Stack3.GetInterface(IJclPreparedLocationInfoList, PreparedLocationInfoList) then + FStackInterfaceList.Add(PreparedLocationInfoList); + if tsStack3.TabVisible and (FStackFrame3.GetInterface(IJclStackTraceViewerStackFrame, StackTraceViewerStackFrame)) then + StackTraceViewerStackFrame.SetStackList(FFreedObjectData.Stack3); + tsMemory.TabVisible := Assigned(FFreedObjectData) and FFreedObjectData.FoundMemory; + if Assigned(FFreedObjectData) and FFreedObjectData.FoundMemory then + begin + FMemoryFrame.Address := FFreedObjectData.Address; + FMemoryFrame.MemoryArray := FFreedObjectData.Memory; + end; + pg.Visible := tsStack1.TabVisible or tsStack2.TabVisible or tsStack3.TabVisible or tsMemory.TabVisible; + if pg.Visible then + pg.TabIndex := 0; +end; + +procedure TfrmFreedObject.UpdateViews; +var + StackTraceViewerPreparableStackFrame: IJclStackTraceViewerPreparableStackFrame; +begin + if tsStack1.TabVisible and + (FStackFrame1.GetInterface(IJclStackTraceViewerPreparableStackFrame, StackTraceViewerPreparableStackFrame)) then + StackTraceViewerPreparableStackFrame.UpdateViews; + if tsStack2.TabVisible and + (FStackFrame2.GetInterface(IJclStackTraceViewerPreparableStackFrame, StackTraceViewerPreparableStackFrame)) then + StackTraceViewerPreparableStackFrame.UpdateViews; + if tsStack3.TabVisible and + (FStackFrame3.GetInterface(IJclStackTraceViewerPreparableStackFrame, StackTraceViewerPreparableStackFrame)) then + StackTraceViewerPreparableStackFrame.UpdateViews; +end; + +end. Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.dfm =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.dfm (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.dfm 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,106 @@ +object frmLeak: TfrmLeak + Left = 0 + Top = 0 + Width = 495 + Height = 240 + TabOrder = 0 + object pnlTop: TPanel + Left = 0 + Top = 0 + Width = 495 + Height = 33 + Align = alTop + BevelOuter = bvNone + TabOrder = 0 + object Label1: TLabel + Left = 3 + Top = 3 + Width = 55 + Height = 13 + Caption = 'Timestamp:' + end + object Label2: TLabel + Left = 163 + Top = 3 + Width = 23 + Height = 13 + Caption = 'Size:' + end + object Label3: TLabel + Left = 163 + Top = 19 + Width = 38 + Height = 13 + Caption = 'Thread:' + end + object lbTimestamp: TLabel + Left = 64 + Top = 3 + Width = 59 + Height = 13 + Caption = 'lbTimestamp' + end + object lbSize: TLabel + Left = 224 + Top = 3 + Width = 27 + Height = 13 + Caption = 'lbSize' + end + object lbThread: TLabel + Left = 224 + Top = 19 + Width = 42 + Height = 13 + Caption = 'lbThread' + end + object Label4: TLabel + Left = 320 + Top = 3 + Width = 29 + Height = 13 + Caption = 'Class:' + end + object Label5: TLabel + Left = 320 + Top = 19 + Width = 89 + Height = 13 + Caption = 'Allocation number:' + end + object lbClass: TLabel + Left = 415 + Top = 3 + Width = 33 + Height = 13 + Caption = 'lbClass' + end + object lbAllocationNumber: TLabel + Left = 415 + Top = 19 + Width = 91 + Height = 13 + Caption = 'lbAllocationNumber' + end + end + object pg: TPageControl + Left = 0 + Top = 33 + Width = 495 + Height = 207 + ActivePage = tsStack + Align = alClient + TabOrder = 1 + object tsStack: TTabSheet + Caption = 'Stack' + ImageIndex = 1 + end + object tsMemory: TTabSheet + Caption = 'Memory dump' + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 + end + end +end Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.pas (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakFrame.pas 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,143 @@ +unit FastMMLeakFrame; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls, Grids, ComCtrls, JclStackTraceViewerAPI, FastMMParser, + FastMMMemoryFrame; + +type + TfrmLeak = class(TFrame, IJclStackTraceViewerPreparableStackFrame, IJclStackTraceViewerStackSelection) + pnlTop: TPanel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + lbTimestamp: TLabel; + lbSize: TLabel; + lbThread: TLabel; + Label4: TLabel; + Label5: TLabel; + lbClass: TLabel; + lbAllocationNumber: TLabel; + pg: TPageControl; + tsMemory: TTabSheet; + tsStack: TTabSheet; + private + { Private-Deklarationen } + FLeakData: TFastMMLeak; + FStackFrame: TCustomFrame; + FMemoryFrame: TfrmMemory; + function GetSelected: IJclLocationInfo; + function GetPreparableLocationInfoListCount: Integer; + function GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; + procedure UpdateViews; + procedure SetLeakData(const Value: TFastMMLeak); + public + { Public-Deklarationen } + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property LeakData: TFastMMLeak write SetLeakData; + end; + +implementation + +{$R *.dfm} + +{ TfrmLeak } + +constructor TfrmLeak.Create(AOwner: TComponent); +var + StackFrameClass: TCustomFrameClass; +begin + inherited Create(AOwner); + FLeakData := nil; + if Assigned(StackTraceViewerStackServices) then + begin + StackFrameClass := StackTraceViewerStackServices.GetDefaultFrameClass(dfStack); + if Assigned(StackFrameClass) then + begin + FStackFrame := StackFrameClass.Create(Self); + FStackFrame.Parent := tsStack; + FStackFrame.Align := alClient; + end; + end; + FMemoryFrame := TfrmMemory.Create(Self); + FMemoryFrame.Parent := tsMemory; + FMemoryFrame.Align := alClient; +end; + +destructor TfrmLeak.Destroy; +begin + FMemoryFrame.Free; + FStackFrame.Free; + inherited Destroy; +end; + +function TfrmLeak.GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; +begin + Result := FLeakData.Stack; +end; + +function TfrmLeak.GetPreparableLocationInfoListCount: Integer; +var + Dummy: IJclPreparedLocationInfoList; +begin + if Assigned(FLeakData) and Assigned(FLeakData.Stack) and + (FLeakData.Stack.QueryInterface(IJclPreparedLocationInfoList, Dummy) = S_OK) then + Result := 1 + else + Result := 0; +end; + +function TfrmLeak.GetSelected: IJclLocationInfo; +var + StackTraceViewerStackSelection: IJclStackTraceViewerStackSelection; +begin + if pg.Visible and (pg.ActivePage = tsStack) and FStackFrame.Visible and + (FStackFrame.GetInterface(IJclStackTraceViewerStackSelection, StackTraceViewerStackSelection)) and + Assigned(StackTraceViewerStackSelection.Selected) then + Result := StackTraceViewerStackSelection.Selected + else + Result := nil; +end; + +procedure TfrmLeak.SetLeakData(const Value: TFastMMLeak); +var + StackTraceViewerStackFrame: IJclStackTraceViewerStackFrame; +begin + FLeakData := Value; + pnlTop.Visible := Assigned(FLeakData); + if Assigned(FLeakData) then + begin + lbTimestamp.Caption := FLeakData.DateStr; + lbSize.Caption := IntToStr(FLeakData.LeakSize); + lbThread.Caption := Format('%x', [FLeakData.ThreadID]); + lbClass.Caption := FLeakData.BlockClass; + lbAllocationNumber.Caption := IntToStr(FLeakData.AllocationNumber); + end; + tsStack.TabVisible := Assigned(FStackFrame) and Assigned(FLeakData) and (FLeakData.Stack.Count > 0); + if tsStack.TabVisible and (FStackFrame.GetInterface(IJclStackTraceViewerStackFrame, StackTraceViewerStackFrame)) then + StackTraceViewerStackFrame.SetStackList(FLeakData.Stack); + + tsMemory.TabVisible := Assigned(FLeakData) and FLeakData.FoundMemory; + pg.Visible := tsStack.TabVisible or tsMemory.TabVisible; + if pg.Visible then + pg.TabIndex := 0; + if Assigned(FLeakData) and FLeakData.FoundMemory then + begin + FMemoryFrame.Address := FLeakData.Address; + FMemoryFrame.MemoryArray := FLeakData.Memory; + end; +end; + +procedure TfrmLeak.UpdateViews; +var + StackTraceViewerPreparableStackFrame: IJclStackTraceViewerPreparableStackFrame; +begin + if FStackFrame.Visible and + (FStackFrame.GetInterface(IJclStackTraceViewerPreparableStackFrame, StackTraceViewerPreparableStackFrame)) then + StackTraceViewerPreparableStackFrame.UpdateViews; +end; + +end. Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakGroupFrame.dfm =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakGroupFrame.dfm (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakGroupFrame.dfm 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,44 @@ +object frmLeakGroup: TfrmLeakGroup + Left = 0 + Top = 0 + Width = 320 + Height = 240 + TabOrder = 0 + object pnlTop: TPanel + Left = 0 + Top = 0 + Width = 320 + Height = 33 + Align = alTop + BevelOuter = bvNone + TabOrder = 0 + object Label1: TLabel + Left = 3 + Top = 3 + Width = 58 + Height = 13 + Caption = 'Leak Count:' + end + object Label2: TLabel + Left = 3 + Top = 19 + Width = 48 + Height = 13 + Caption = 'Leak Size:' + end + object lbLeakCount: TLabel + Left = 67 + Top = 3 + Width = 59 + Height = 13 + Caption = 'lbLeakCount' + end + object lbLeakSize: TLabel + Left = 67 + Top = 19 + Width = 49 + Height = 13 + Caption = 'lbLeakSize' + end + end +end Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakGroupFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakGroupFrame.pas (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakGroupFrame.pas 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,118 @@ +unit FastMMLeakGroupFrame; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls, JclStackTraceViewerAPI, FastMMParser; + +type + TfrmLeakGroup = class(TFrame, IJclStackTraceViewerPreparableStackFrame, IJclStackTraceViewerStackSelection) + pnlTop: TPanel; + Label1: TLabel; + Label2: TLabel; + lbLeakCount: TLabel; + lbLeakSize: TLabel; + private + FLeakGroupData: TFastMMLeakGroup; + FStackFrame: TCustomFrame; + function GetSelected: IJclLocationInfo; + function GetPreparableLocationInfoListCount: Integer; + function GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; + procedure UpdateViews; + procedure SetLeakGroupData(const Value: TFastMMLeakGroup); + { Private-Deklarationen } + public + { Public-Deklarationen } + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property LeakGroupData: TFastMMLeakGroup write SetLeakGroupData; + end; + +implementation + +{$R *.dfm} + +{ TfrmLeakGroup } + +constructor TfrmLeakGroup.Create(AOwner: TComponent); +var + StackFrameClass: TCustomFrameClass; +begin + inherited Create(AOwner); + FLeakGroupData := nil; + if Assigned(StackTraceViewerStackServices) then + begin + StackFrameClass := StackTraceViewerStackServices.GetDefaultFrameClass(dfStack); + if Assigned(StackFrameClass) then + begin + FStackFrame := StackFrameClass.Create(Self); + FStackFrame.Parent := Self; + FStackFrame.Align := alClient; + end; + end; +end; + +destructor TfrmLeakGroup.Destroy; +begin + FStackFrame.Free; + inherited Destroy; +end; + +function TfrmLeakGroup.GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; +begin + Result := FLeakGroupData[0].Stack; +end; + +function TfrmLeakGroup.GetPreparableLocationInfoListCount: Integer; +var + Dummy: IJclPreparedLocationInfoList; +begin + if Assigned(FLeakGroupData) and (FLeakGroupData.Count > 0) and + (FLeakGroupData[0].Stack.QueryInterface(IJclPreparedLocationInfoList, Dummy) = S_OK) then + Result := 1 + else + Result := 0; +end; + +function TfrmLeakGroup.GetSelected: IJclLocationInfo; +var + StackTraceViewerStackSelection: IJclStackTraceViewerStackSelection; +begin + if FStackFrame.Visible and + (FStackFrame.GetInterface(IJclStackTraceViewerStackSelection, StackTraceViewerStackSelection)) and + Assigned(StackTraceViewerStackSelection.Selected) then + Result := StackTraceViewerStackSelection.Selected + else + Result := nil; +end; + +procedure TfrmLeakGroup.SetLeakGroupData(const Value: TFastMMLeakGroup); +var + StackTraceViewerStackFrame: IJclStackTraceViewerStackFrame; +begin + FLeakGroupData := Value; + pnlTop.Visible := Assigned(FLeakGroupData); + if Assigned(FLeakGroupData) then + begin + lbLeakCount.Caption := IntToStr(FLeakGroupData.Count); + lbLeakSize.Caption := IntToStr(FLeakGroupData.LeakSize); + end; + if Assigned(FStackFrame) then + begin + FStackFrame.Visible := Assigned(FLeakGroupData) and (FLeakGroupData.Count > 0) and (FLeakGroupData[0].Stack.Count > 0); + if FStackFrame.Visible and (FStackFrame.GetInterface(IJclStackTraceViewerStackFrame, StackTraceViewerStackFrame)) then + StackTraceViewerStackFrame.SetStackList(FLeakGroupData[0].Stack); + end; +end; + +procedure TfrmLeakGroup.UpdateViews; +var + StackTraceViewerPreparableStackFrame: IJclStackTraceViewerPreparableStackFrame; +begin + if FStackFrame.Visible and + (FStackFrame.GetInterface(IJclStackTraceViewerPreparableStackFrame, StackTraceViewerPreparableStackFrame)) then + StackTraceViewerPreparableStackFrame.UpdateViews; +end; + +end. Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakSummaryFrame.dfm =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakSummaryFrame.dfm (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakSummaryFrame.dfm 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,19 @@ +object frmLeakSummary: TfrmLeakSummary + Left = 0 + Top = 0 + Width = 320 + Height = 240 + TabOrder = 0 + object memSummary: TMemo + Left = 0 + Top = 0 + Width = 320 + Height = 240 + Align = alClient + TabOrder = 0 + ExplicitLeft = 72 + ExplicitTop = 80 + ExplicitWidth = 185 + ExplicitHeight = 89 + end +end Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakSummaryFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakSummaryFrame.pas (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMLeakSummaryFrame.pas 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,36 @@ +unit FastMMLeakSummaryFrame; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, FastMMParser; + +type + TfrmLeakSummary = class(TFrame) + memSummary: TMemo; + private + { Private-Deklarationen } + FReport: TFastMMReport; + procedure SetReport(const Value: TFastMMReport); + public + { Public-Deklarationen } + property Report: TFastMMReport write SetReport; + end; + +implementation + +{$R *.dfm} + +{ TfrmLeakSummary } + +procedure TfrmLeakSummary.SetReport(const Value: TFastMMReport); +begin + FReport := Value; + if Assigned(FReport) then + memSummary.Lines.Assign(FReport.LeakSummary) + else + memSummary.Lines.Clear; +end; + +end. Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryFrame.dfm =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryFrame.dfm (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryFrame.dfm 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,44 @@ +object frmMemory: TfrmMemory + Left = 0 + Top = 0 + Width = 320 + Height = 240 + TabOrder = 0 + object Panel2: TPanel + Left = 0 + Top = 0 + Width = 320 + Height = 17 + Align = alTop + BevelOuter = bvNone + TabOrder = 0 + object lbMemoryAddr: TLabel + Left = 52 + Top = 3 + Width = 69 + Height = 13 + Caption = 'lbMemoryAddr' + end + object Label6: TLabel + Left = 3 + Top = 3 + Width = 43 + Height = 13 + Caption = 'Address:' + end + end + object sgMemory: TStringGrid + Left = 0 + Top = 17 + Width = 320 + Height = 223 + Align = alClient + ColCount = 32 + DefaultColWidth = 18 + DefaultRowHeight = 18 + FixedCols = 0 + RowCount = 16 + FixedRows = 0 + TabOrder = 1 + end +end Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryFrame.pas (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMMemoryFrame.pas 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,50 @@ +unit FastMMMemoryFrame; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, FastMMParser, Grids, StdCtrls, ExtCtrls; + +type + TfrmMemory = class(TFrame) + Panel2: TPanel; + lbMemoryAddr: TLabel; + Label6: TLabel; + sgMemory: TStringGrid; + private + { Private-Deklarationen } + FMemoryArray: TFastMMMemoryArray; + procedure SetMemoryArray(const Value: TFastMMMemoryArray); + procedure SetAddress(const Value: Integer); + public + { Public-Deklarationen } + property Address: Integer write SetAddress; + property MemoryArray: TFastMMMemoryArray write SetMemoryArray; + end; + +implementation + +{$R *.dfm} + +{ TfrmMemory } + +procedure TfrmMemory.SetAddress(const Value: Integer); +begin + lbMemoryAddr.Caption := Format('%.8x', [Value]); +end; + +procedure TfrmMemory.SetMemoryArray(const Value: TFastMMMemoryArray); +var + I, J: Integer; +begin + FMemoryArray := Value; + for I := 0 to 7 do + for J := 0 to 31 do + sgMemory.Cells[J, I] := Format('%.2x', [FMemoryArray[I * 32 + J]]); + for I := 0 to 7 do + for J := 0 to 31 do + sgMemory.Cells[J, I + 8] := string(AnsiChar(Chr(FMemoryArray[I * 32 + J]))); +end; + +end. Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/FastMMParser.pas 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,826 @@ +unit FastMMParser; + +interface + +uses + SysUtils, Classes, Contnrs, + {$IFNDEF NOVIEW} + JclStackTraceViewerClasses, + {$ENDIF ~NOVIEW} + JclDebug; + +type + {$IFDEF NOVIEW} + TFastMMLocationInfoList = class(TJclCustomLocationInfoList) + private + function GetItems(AIndex: Integer): TJclLocationInfoEx; + public + constructor Create; override; + function Add(Addr: Pointer): TJclLocationInfoEx; + property Items[AIndex: Integer]: TJclLocationInfoEx read GetItems; default; + end; + {$ELSE ~NOVIEW} + TFastMMLocationInfoList = TJclStackTraceViewerLocationInfoList; + {$ENDIF ~NOVIEW} + + TFastMMMemoryArray = array [0..255] of Byte; + + TFastMMLeak = class(TObject) + private + FAddress: Integer; + FAllocationNumber: Integer; + FBlockClass: string; + FDateStr: string; + FMemory: TFastMMMemoryArray; + FFoundMemory: Boolean; + FLeakSize: Integer; + FThreadID: Integer; + FStack: TFastMMLocationInfoList; + public + constructor Create; + destructor Destroy; override; + property Address: Integer read FAddress write FAddress; + property AllocationNumber: Integer read FAllocationNumber write FAllocationNumber; + property BlockClass: string read FBlockClass write FBlockClass; + property DateStr: string read FDateStr write FDateStr; + property Memory: TFastMMMemoryArray read FMemory write FMemory; + property FoundMemory: Boolean read FFoundMemory write FFoundMemory; + property LeakSize: Integer read FLeakSize write FLeakSize; + property Stack: TFastMMLocationInfoList read FStack; + property ThreadID: Integer read FThreadID write FThreadID; + end; + + TFastMMLeakGroup = class(TObject) + private + FItems: TList; + FLeakSize: Integer; + FLeakSizeUpdate: Boolean; + function GetCount: Integer; + function GetItems(AIndex: Integer): TFastMMLeak; + function GetLeakSize: Integer; + public + constructor Create; + destructor Destroy; override; + procedure Add(ALeak: TFastMMLeak); + property Count: Integer read GetCount; + property Items[AIndex: Integer]: TFastMMLeak read GetItems; default; + property LeakSize: Integer read GetLeakSize; + end; + + TFastMMVMOnFreedObject = class(TObject) + private + FAddress: Integer; + FAllocationNumber: Integer; + FObjectClass: string; + FMemory: TFastMMMemoryArray; + FFoundMemory: Boolean; + FStack1: TFastMMLocationInfoList; + FStack1Thread: Integer; + FStack2: TFastMMLocationInfoList; + FStack2Thread: Integer; + FStack3: TFastMMLocationInfoList; + FStack3Thread: Integer; + FVirtualMethod: string; + FVirtualMethodAddress: Integer; + public + constructor Create; + destructor Destroy; override; + property Address: Integer read FAddress write FAddress; + property AllocationNumber: Integer read FAllocationNumber write FAllocationNumber; + property ObjectClass: string read FObjectClass write FObjectClass; + property Memory: TFastMMMemoryArray read FMemory write FMemory; + property FoundMemory: Boolean read FFoundMemory write FFoundMemory; + property Stack1Thread: Integer read FStack1Thread write FStack1Thread; + property Stack1: TFastMMLocationInfoList read FStack1; + property Stack2Thread: Integer read FStack2Thread write FStack2Thread; + property Stack2: TFastMMLocationInfoList read FStack2; + property Stack3Thread: Integer read FStack3Thread write FStack3Thread; + property Stack3: TFastMMLocationInfoList read FStack3; + property VirtualMethod: string read FVirtualMethod write FVirtualMethod; + property VirtualMethodAddress: Integer read FVirtualMethodAddress write FVirtualMethodAddress; + end; + + TFastMMReport = class(TObject) + private + FLeakGroups: TObjectList; + FLeaks: TObjectList; + FLeakSummary: TStringList; + FVMOnFreedObjects: TObjectList; + function GetLeakCount: Integer; + function GetLeaks(AIndex: Integer): TFastMMLeak; + function GetLeakGroupCount: Integer; + function GetLeakGroupItems(AIndex: Integer): TFastMMLeakGroup; + function SameStack(AStack1, AStack2: TFastMMLocationInfoList): Boolean; + function GetVMOnFreedObjectCount: Integer; + function GetVMOnFreedObjectItems(AIndex: Integer): TFastMMVMOnFreedObject; + public + constructor Create; + destructor Destroy; override; + function AddLeak: TFastMMLeak; + function AddLeakGroup: TFastMMLeakGroup; + function AddVMOnFreedObject: TFastMMVMOnFreedObject; + procedure BuildGroups; + property LeakCount: Integer read GetLeakCount; + property LeakGroupCount: Integer read GetLeakGroupCount; + property LeakGroupItems[AIndex: Integer]: TFastMMLeakGroup read GetLeakGroupItems; + property LeakItems[AIndex: Integer]: TFastMMLeak read GetLeaks; + property LeakSummary: TStringList read FLeakSummary; + property VMOnFreedObjectCount: Integer read GetVMOnFreedObjectCount; + property VMOnFreedObjectItems[AIndex: Integer]: TFastMMVMOnFreedObject read GetVMOnFreedObjectItems; + end; + + TFastMMFileParser = class(TObject) + public + function ParseFile(const AFileName: string; AReportList: TObjectList): Integer; + end; + +implementation + +{$IFDEF NOVIEW} +function TFastMMLocationInfoList.Add(Addr: Pointer): TJclLocationInfoEx; +begin + Result := InternalAdd(Addr); +end; + +constructor TFastMMLocationInfoList.Create; +begin + inherited Create; + FOptions := []; +end; + +function TFastMMLocationInfoList.GetItems(AIndex: Integer): TJclLocationInfoEx; +begin + Result := TJclLocationInfoEx(FItems[AIndex]); +end; +{$ENDIF NOVIEW} + +{ TFastMMLeak } + +constructor TFastMMLeak.Create; +begin + inherited Create; + FAddress := -1; + FAllocationNumber := -1; + FBlockClass := ''; + FFoundMemory := False; + FLeakSize := -1; + FThreadID := -1; + FStack := TFastMMLocationInfoList.Create; +end; + +destructor TFastMMLeak.Destroy; +begin + FStack.Free; + inherited Destroy; +end; + +{ TFastMMLeakGroup } + +constructor TFastMMLeakGroup.Create; +begin + inherited Create; + FItems := TList.Create; + FLeakSizeUpdate := True; +end; + +destructor TFastMMLeakGroup.Destroy; +begin + FItems.Free; + inherited Destroy; +end; + +procedure TFastMMLeakGroup.Add(ALeak: TFastMMLeak); +begin + FItems.Add(ALeak); +end; + +function TFastMMLeakGroup.GetCount: Integer; +begin + Result := FItems.Count +end; + +function TFastMMLeakGroup.GetItems(AIndex: Integer): TFastMMLeak; +begin + Result := TFastMMLeak(FItems[AIndex]); +end; + +function TFastMMLeakGroup.GetLeakSize: Integer; +var + I: Integer; +begin + if FLeakSizeUpdate then + begin + FLeakSizeUpdate := False; + FLeakSize := 0; + for I := 0 to Count - 1 do + Inc(FLeakSize, Items[I].LeakSize); + end; + Result := FLeakSize; +end; + +{ TFastMMVMOnFreedObject } + +constructor TFastMMVMOnFreedObject.Create; +begin + inherited Create; + FAddress := -1; + FAllocationNumber := -1; + FFoundMemory := False; + FStack1 := TFastMMLocationInfoList.Create; + FStack1Thread := -1; + FStack2 := TFastMMLocationInfoList.Create; + FStack2Thread := -1; + FStack3 := TFastMMLocationInfoList.Create; + FStack3Thread := -1; +end; + +destructor TFastMMVMOnFreedObject.Destroy; +begin + FStack3.Free; + FStack2.Free; + FStack1.Free; + inherited Destroy; +end; + +{ TFastMMReport } + +constructor TFastMMReport.Create; +begin + inherited Create; + FLeakGroups := TObjectList.Create; + FLeaks := TObjectList.Create; + FLeakSummary := TStringList.Create; + FVMOnFreedObjects := TObjectList.Create; +end; + +destructor TFastMMReport.Destroy; +begin + FVMOnFreedObjects.Free; + FLeakSummary.Free; + FLeaks.Free; + FLeakGroups.Free; + inherited Destroy; +end; + +function TFastMMReport.AddLeak: TFastMMLeak; +begin + FLeaks.Add(TFastMMLeak.Create); + Result := TFastMMLeak(FLeaks.Last); +end; + +function TFastMMReport.AddLeakGroup: TFastMMLeakGroup; +begin + FLeakGroups.Add(TFastMMLeakGroup.Create); + Result := TFastMMLeakGroup(FLeakGroups.Last); +end; + +function TFastMMReport.AddVMOnFreedObject: TFastMMVMOnFreedObject; +begin + FVMOnFreedObjects.Add(TFastMMVMOnFreedObject.Create); + Result := TFastMMVMOnFreedObject(FVMOnFreedObjects.Last); +end; + +procedure TFastMMReport.BuildGroups; +var + I: Integer; + LeftLeaks: TList; + LeakGroup: TFastMMLeakGroup; + FirstLeak: TFastMMLeak; +begin + FLeakGroups.Clear; + if LeakCount > 0 then + begin + LeftLeaks := TList.Create; + try + for I := 0 to LeakCount - 1 do + LeftLeaks.Add(LeakItems[I]); + while LeftLeaks.Count > 0 do + begin + LeakGroup := AddLeakGroup; + FirstLeak := TFastMMLeak(LeftLeaks[0]); + LeakGroup.Add(FirstLeak); + LeftLeaks.Delete(0); + for I := LeftLeaks.Count - 1 downto 0 do + if SameStack(FirstLeak.Stack, TFastMMLeak(LeftLeaks[I]).Stack) then + begin + LeakGroup.Add(TFastMMLeak(LeftLeaks[I])); + LeftLeaks.Delete(I); + end; + end; + finally + LeftLeaks.Free; + end; + end; +end; + +function TFastMMReport.GetLeakCount: Integer; +begin + Result := FLeaks.Count; +end; + +function TFastMMReport.GetLeakGroupCount: Integer; +begin + Result := FLeakGroups.Count +end; + +function TFastMMReport.GetLeakGroupItems(AIndex: Integer): TFastMMLeakGroup; +begin + Result := TFastMMLeakGroup(FLeakGroups[AIndex]); +end; + +function TFastMMReport.GetLeaks(AIndex: Integer): TFastMMLeak; +begin + Result := TFastMMLeak(FLeaks[AIndex]); +end; + +function TFastMMReport.GetVMOnFreedObjectCount: Integer; +begin + Result := FVMOnFreedObjects.Count; +end; + +function TFastMMReport.GetVMOnFreedObjectItems(AIndex: Integer): TFastMMVMOnFreedObject; +begin + Result := TFastMMVMOnFreedObject(FVMOnFreedObjects[AIndex]); +end; + +function TFastMMReport.SameStack(AStack1, AStack2: TFastMMLocationInfoList): Boolean; +var + I: Integer; +begin + Result := Assigned(AStack1) and Assigned(AStack2) and (AStack1.Count = AStack2.Count); + if Result then + for I := 0 to AStack1.Count - 1 do + if AStack1[I].Address <> AStack2[I].Address then + begin + Result := False; + Break; + end; +end; + +function GetLocationInfoFromFastMMLine(AStr: string; var ALocationInfo: TJclLocationInfoEx): Boolean; +var + I: Integer; + BlockOpen, LastIsNumber: Boolean; + C: Char; + S: string; + Blocks: TStringList; +begin + Result := False; + BlockOpen := False; + Blocks := TStringList.Create; + try + S := ''; + for I := 1 to Length(AStr) do + begin + C := AStr[I]; + if C = '[' then + begin + if BlockOpen then + begin + Blocks.Clear; + Break; + end + else + begin + BlockOpen := True; + S := ''; + end; + end + else + if C = ']' then + begin + if BlockOpen then + begin + BlockOpen := False; + Blocks.Add(S); + end + else + begin + Blocks.Clear; + Break; + end; + end + else + S := S + C; + end; + + if Blocks.Count > 0 then + begin + LastIsNumber := False; + S := Blocks[Blocks.Count - 1]; + if S <> '' then + begin + LastIsNumber := True; + for I := 1 to Length(S) do + if not (S[I] in ['0'..'9']) then + begin + LastIsNumber := False; + Break; + end; + end; + if LastIsNumber then + begin + if Blocks.Count = 4 then + begin + ALocationInfo.SourceName := Blocks[0]; + ALocationInfo.SourceUnitName := Blocks[1]; + ALocationInfo.ProcedureName := Blocks[2]; + ALocationInfo.LineNumber := StrToInt(Blocks[3]); + Result := True; + end + else + if Blocks.Count = 3 then + begin + ALocationInfo.SourceUnitName := Blocks[0]; + ALocationInfo.ProcedureName := Blocks[1]; + ALocationInfo.LineNumber := StrToInt(Blocks[2]); + Result := True; + end; + end + else + if Blocks.Count = 1 then + begin + ALocationInfo.ProcedureName := Blocks[0]; + Result := True; + end + else + if Blocks.Count = 2 then + begin + ALocationInfo.SourceUnitName := Blocks[0]; + ALocationInfo.ProcedureName := Blocks[1]; + Result := True; + end; + if Result then + begin + S := ''; + for I := 1 to Length(AStr) do + begin + C := AStr[I]; + if C in ['0'..'9', 'A'..'F'] then + S := S + C + else + if C = ' ' then + begin + if S <> '' then + ALocationInfo.Address := Pointer(StrToInt('$' + S)); + Break; + end + else + Break; + end; + + end; + end; + finally + Blocks.Free; + end; +end; + +{ TFastMMFileParser } + +function TFastMMFileParser.ParseFile(const AFileName: string; AReportList: TObjectList): Integer; +type + TReportType = (rtUnknown, rtMemoryLeak, rtVMOnFreedObject); +const + //Leak constants + cDateTime = '--------------------------------2'; + cLeakSize = 'A memory block has been leaked. The size is: '; + cThread = 'This block was allocated by thread 0x'; + cStack = 'the stack trace (return addresses) at the time was:'; + cBlockClass = 'The block is currently used for an object of class: '; + cAllocNo = 'The allocation number is: '; + cMemory = 'Current memory dump of 256 bytes starting at pointer address '; + cReportEnd = 'This application has leaked memory.'; + cReportSummaryPart = ' bytes: '; + //Virtual method call on freed object + cVMFOStart = 'FastMM has detected an attempt to call a virtual method on a freed object. An access violation will now be raised in order to abort the current operation.'; + cVMFOClass = 'Freed object class: '; + cVMFOVirtualMethod = 'Virtual method: '; + cVMFOVirtualMethodAddress = 'Virtual method address: '; + cVMFOAllocNo = 'The allocation number was: '; + cVMFOStack1Thread = 'The object was allocated by thread 0x'; + cVMFOStack1Stack = 'and the stack trace (return addresses) at the time was:'; + cVMFOStack2Thread = 'The object was subsequently freed by thread 0x'; + cVMFOStack2Stack = 'and the stack trace (return addresses) at the time was:'; + cVMFOStack3Thread = 'The current thread ID is 0x'; + cVMFOStack3Stack = 'and the stack trace (return addresses) leading to this error is:'; + cVMFOMemory = 'Current memory dump of 256 bytes starting at pointer address '; +var + TSL: TStringList; + I, J, K, P: Integer; + Report: TFastMMReport; + Leak: TFastMMLeak; + VMOnFreedObject: TFastMMVMOnFreedObject; + S, S2: string; + LI: TJclLocationInfoEx; + LocationInfoEx: TJclLocationInfoEx; + MemoryArray: TFastMMMemoryArray; + CreateNewReport: Boolean; + ReportType, LastReportType: TReportType; +begin + Result := -1; + if FileExists(AFileName) and Assigned(AReportList) then + begin + TSL := TStringList.Create; + try + TSL.LoadFromFile(AFileName); + TSL.Text := AdjustLineBreaks(TSL.Text); + I := 0; + Leak := nil; + VMOnFreedObject := nil; + Report := nil; + CreateNewReport := True; + ReportType := rtUnknown; + LastReportType := rtUnknown; + while I < TSL.Count do + begin + S := TSL[I]; + if Pos(cLeakSize, S) = 1 then + begin + ReportType := rtMemoryLeak; + if CreateNewReport or (LastReportType <> ReportType) then + begin + AReportList.Add(TFastMMReport.Create); + Report := TFastMMReport(AReportList.Last); + CreateNewReport := False; + end; + LastReportType := ReportType; + Leak := Report.AddLeak; + Delete(S, 1, Length(cLeakSize)); + Leak.LeakSize := StrToIntDef(S, -1); + if (I > 1) then + begin + S := TSL[I - 1]; + if Pos(cDateTime, S) = 1 then + begin + Delete(S, 1, Length(cDateTime) - 1); + P := Pos('-', S); + if P > 1 then + Leak.DateStr := Copy(S, 1, P - 1); + end; + end; + end + else + if Pos(cVMFOStart, S) = 1 then + begin + ReportType := rtVMOnFreedObject; + if CreateNewReport or (LastReportType <> ReportType) then + begin + AReportList.Add(TFastMMReport.Create); + Report := TFastMMReport(AReportList.Last); + CreateNewReport := False; + end; + LastReportType := ReportType; + VMOnFreedObject := Report.AddVMOnFreedObject; + end + else + if (ReportType = rtMemoryLeak) and Assigned(Leak) then + begin + if Pos(cThread, S) = 1 then + begin + Delete(S, 1, Length(cThread)); + P := Pos(',', S); + if P > 1 then + Leak.ThreadID := StrToIntDef('$' + Copy(S, 1, P - 1), -1); + end; + if Pos(cStack, S) > 0 then + begin + Inc(I); + + LI := TJclLocationInfoEx.Create(nil, nil); + try + while (Trim(TSL[I]) = '') or GetLocationInfoFromFastMMLine(TSL[I], LI) do + begin + if Trim(TSL[I]) <> '' then + begin + LocationInfoEx := Leak.Stack.Add(nil); + LocationInfoEx.Assign(LI); + LI.Clear; + end; + Inc(I); + end; + finally + LI.Free; + end; + + Dec(I); + end; + if Pos(cBlockClass, S) = 1 then + begin + Delete(S, 1, Length(cBlockClass)); + Leak.BlockClass := S; + end; + if Pos(cAllocNo, S) = 1 then + begin + Delete(S, 1, Length(cAllocNo)); + Leak.AllocationNumber := StrToIntDef(S, -1); + end; + if Pos(cMemory, S) = 1 then + begin + Delete(S, 1, Length(cMemory)); + P := Pos(':', S); + if P > 1 then + begin + Leak.Address := StrToIntDef('$' + Copy(S, 1, P - 1), -1); + Inc(I); + for J := 0 to 7 do + begin + S := Trim(TSL[I]); + if Length(S) = 95 then + begin + for K := 0 to 31 do + begin + S2 := Copy(S, K * 3 + 1, 2); + MemoryArray[J * 32 + K] := StrToIntDef('$' + S2, -1); + end; + end + else + Break; + Inc(I); + if J = 7 then + begin + Leak.FoundMemory := True; + Leak.Memory := MemoryArray; + end; + end; + Dec(I); + end; + end; + if Pos(cReportEnd, S) > 0 then + begin + Inc(I); + while (I < TSL.Count) and ((TSL[I]) = '') do + Inc(I); + while (I < TSL.Count) and (Pos(cReportSummaryPart, TSL[I]) > 0) do + begin + Report.LeakSummary.Add(TSL[I]); + Inc(I); + end; + CreateNewReport := True; + end; + end + else + if (ReportType = rtVMOnFreedObject) and Assigned(VMOnFreedObject) then + begin + if Pos(cVMFOClass, S) = 1 then + begin + Delete(S, 1, Length(cVMFOClass)); + VMOnFreedObject.ObjectClass := S; + end + else + if Pos(cVMFOVirtualMethod, S) = 1 then + begin + Delete(S, 1, Length(cVMFOVirtualMethod)); + VMOnFreedObject.VirtualMethod := S; + end + else + if Pos(cVMFOVirtualMethodAddress, S) = 1 then + begin + Delete(S, 1, Length(cVMFOVirtualMethodAddress)); + VMOnFreedObject.VirtualMethodAddress := StrToIntDef('$' + S, -1); + end + else + if Pos(cVMFOAllocNo, S) = 1 then + begin + Delete(S, 1, Length(cVMFOAllocNo)); + VMOnFreedObject.AllocationNumber := StrToIntDef(S, -1); + end + else + if Pos(cVMFOStack1Thread, S) = 1 then + begin + Delete(S, 1, Length(cVMFOStack1Thread)); + P := Pos(',', S); + if P > 1 then + VMOnFreedObject.Stack1Thread := StrToIntDef('$' + Copy(S, 1, P - 1), -1); + if Pos(cVMFOStack1Stack, S) > 0 then + begin + Inc(I); + + LI := TJclLocationInfoEx.Create(nil, nil); + try + while (Trim(TSL[I]) = '') or GetLocationInfoFromFastMMLine(TSL[I], LI) do + begin + if Trim(TSL[I]) <> '' then + begin + LocationInfoEx := VMOnFreedObject.Stack1.Add(nil); + LocationInfoEx.Assign(LI); + LI.Clear; + end; + Inc(I); + end; + finally + LI.Free; + end; + + Dec(I); + end; + end + else + if Pos(cVMFOStack2Thread, S) = 1 then + begin + Delete(S, 1, Length(cVMFOStack2Thread)); + P := Pos(',', S); + if P > 1 then + VMOnFreedObject.Stack2Thread := StrToIntDef('$' + Copy(S, 1, P - 1), -1); + if Pos(cVMFOStack2Stack, S) > 0 then + begin + Inc(I); + + LI := TJclLocationInfoEx.Create(nil, nil); + try + while (Trim(TSL[I]) = '') or GetLocationInfoFromFastMMLine(TSL[I], LI) do + begin + if Trim(TSL[I]) <> '' then + begin + LocationInfoEx := VMOnFreedObject.Stack2.Add(nil); + LocationInfoEx.Assign(LI); + LI.Clear; + end; + Inc(I); + end; + finally + LI.Free; + end; + + Dec(I); + end; + end + else + if Pos(cVMFOStack3Thread, S) = 1 then + begin + Delete(S, 1, Length(cVMFOStack3Thread)); + P := Pos(',', S); + if P > 1 then + VMOnFreedObject.Stack3Thread := StrToIntDef('$' + Copy(S, 1, P - 1), -1); + if Pos(cVMFOStack3Stack, S) > 0 then + begin + Inc(I); + + LI := TJclLocationInfoEx.Create(nil, nil); + try + while (Trim(TSL[I]) = '') or GetLocationInfoFromFastMMLine(TSL[I], LI) do + begin + if Trim(TSL[I]) <> '' then + begin + LocationInfoEx := VMOnFreedObject.Stack3.Add(nil); + LocationInfoEx.Assign(LI); + LI.Clear; + end; + Inc(I); + end; + finally + LI.Free; + end; + + Dec(I); + end; + end + else + if Pos(cVMFOMemory, S) = 1 then + begin + Delete(S, 1, Length(cVMFOMemory)); + P := Pos(':', S); + if P > 1 then + begin + VMOnFreedObject.Address := StrToIntDef('$' + Copy(S, 1, P - 1), -1); + Inc(I); + for J := 0 to 7 do + begin + while Trim(TSL[I]) = '' do + Inc(I); + S := Trim(TSL[I]); + if Length(S) = 95 then + begin + for K := 0 to 31 do + begin + S2 := Copy(S, K * 3 + 1, 2); + MemoryArray[J * 32 + K] := StrToIntDef('$' + S2, -1); + end; + end + else + Break; + Inc(I); + if J = 7 then + begin + VMOnFreedObject.FoundMemory := True; + VMOnFreedObject.Memory := MemoryArray; + end; + end; + Dec(I); + end; + end; + + end; + Inc(I); + end; + finally + TSL.Free; + end; + for I := 0 to AReportList.Count - 1 do + TFastMMReport(AReportList[I]).BuildGroups; + + Result := AReportList.Count; + end; +end; + +end. Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMM.dpk =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMM.dpk (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMM.dpk 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,49 @@ +package StackTraceViewerFastMM; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + designide, + Jcl, + vcl, + JclBaseExpert, + xmlrtl, + vclactnband, + vclx, + JclStackTraceViewerExpert; + +contains + StackTraceViewerFastMMReg in 'StackTraceViewerFastMMReg.pas', + StackTraceViewerFastMMUnit in 'StackTraceViewerFastMMUnit.pas', + FastMMParser in 'FastMMParser.pas', + FastMMLeakFrame in 'FastMMLeakFrame.pas' {frmLeak: TFrame}, + FastMMLeakGroupFrame in 'FastMMLeakGroupFrame.pas' {frmLeakGroup: TFrame}, + FastMMFreedObjectFrame in 'FastMMFreedObjectFrame.pas' {frmFreedObject: TFrame}, + FastMMMemoryFrame in 'FastMMMemoryFrame.pas' {frmMemory: TFrame}, + FastMMLeakSummaryFrame in 'FastMMLeakSummaryFrame.pas' {frmLeakSummary: TFrame}; + +end. Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMMReg.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMMReg.pas (rev 0) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMMReg.pas 2009-05-22 20:30:36 UTC (rev 2769) @@ -0,0 +1,82 @@ +unit StackTraceViewerFastMMReg; + +interface + +procedure Register; + +implementation + +uses + SysUtils, Forms, Dialogs, ToolsAPI, JclStackTraceViewerAPI, StackTraceViewerFastMMUnit; + +type + TIOTAProjectTestWizard = class(TNotifierObject, IOTAMenuWizard, IOTAWizard) + private + FFastMMReportData: TFastMMReportData; + public + constructor Create; + destructor Destroy; override; + procedure Execute; + function GetIDString: string; + function GetMenuText: string; + function GetName: string; + function GetState: TWizardState; + end; + +procedure Register; +begin + RegisterPackageWizard(TIOTAProjectTestWizard.Create); +end; + +constructor TIOTAProjectTestWizard.Create; +begin + inherited Create; + FFastMMReportData := TFastMMReportData.Create; +end; + +destructor TIOTAProjectTestWizard.Destroy; +begin + FFastMMReportData.Free; + inherited Destroy; +end; + +procedure TIOTAProjectTestWizard.Execute; +var + OpenDialog: TOpenDialog; + FastMMFile: string; +begin + OpenDialog := TOpenDialog.Create(nil); + try + if OpenDialog.Execute then + FastMMFile := OpenDialog.FileName; + finally + OpenDialog.Free; + end; + if FastMMFile <> '' then + FFastMMReportData.LoadFastMMFile(FastMMFile); +end; + +function TIOTAProjectTestWizard.GetIDString: string; +begin + Result := 'PROJECT JEDI.JclStackTraceViewerFastMM'; +end; + +function TIOTAProjectTestWizard.GetMenuText: string; +begin + Result := '&Load FastMM Logfile'; +end; + +function TIOTAProjectTestWizard.GetName: string; +begin + Result := 'JCL Stack Trace Viewer Extension for FastMM'; +end; + +function TIOTAProjectTestWizard.GetState: TWizardState; +begin + if Assigned(StackTraceViewerStackProcessorServices) then + Result := [wsEnabled] + else + Result := []; +end; + +end. Added: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExamples/FastMM/StackTraceViewerFastMMUnit.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/APIExam... [truncated message content] |
From: <usc...@us...> - 2009-05-22 20:23:12
|
Revision: 2768 http://jcl.svn.sourceforge.net/jcl/?rev=2768&view=rev Author: uschuster Date: 2009-05-22 20:23:03 +0000 (Fri, 22 May 2009) Log Message: ----------- - implemented stack refresh after update - JclStackTraceViewerStackFrame.dfm: number columns are now right aligned Modified Paths: -------------- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerAPI.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerMainFrame.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.dfm branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.pas branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerThreadFrame.pas Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerAPI.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerAPI.pas 2009-05-18 22:49:11 UTC (rev 2767) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerAPI.pas 2009-05-22 20:23:03 UTC (rev 2768) @@ -187,12 +187,14 @@ ['{5868BC94-D24A-42EB-8A4A-9AB411702407}'] function GetStackList: IJclLocationInfoList; procedure SetStackList(const AValue: IJclLocationInfoList); + procedure UpdateView; end; IJclStackTraceViewerPreparableStackFrame = interface ['{E1E3D9FF-AE1C-43AD-8273-1A440B5C46C1}'] function GetPreparableLocationInfoListCount: Integer; function GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; + procedure UpdateViews; property PreparableLocationInfoListCount: Integer read GetPreparableLocationInfoListCount; property PreparableLocationInfoList[AIndex: Integer]: IJclPreparedLocationInfoList read GetPreparableLocationInfoList; Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerMainFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerMainFrame.pas 2009-05-18 22:49:11 UTC (rev 2767) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerMainFrame.pas 2009-05-22 20:23:03 UTC (rev 2768) @@ -661,11 +661,13 @@ I: Integer; PreparableStackFrame: IJclStackTraceViewerPreparableStackFrame; PreparedLocationInfoList: IJclPreparedLocationInfoList; + UpdateView: Boolean; begin inherited; if Assigned(StackTraceViewerStackProcessorServices) and Assigned(FLastControl) and (FLastControl.GetInterface(IJclStackTraceViewerPreparableStackFrame, PreparableStackFrame)) then begin + UpdateView := False; for I := 0 to PreparableStackFrame.PreparableLocationInfoListCount - 1 do begin PreparedLocationInfoList := PreparableStackFrame.PreparableLocationInfoList[I]; @@ -673,8 +675,11 @@ begin StackTraceViewerStackProcessorServices.ModuleList := PreparedLocationInfoList.ModuleInfoList; StackTraceViewerStackProcessorServices.PrepareLocationInfoList(PreparedLocationInfoList, True); + UpdateView := True; end; end; + if UpdateView then + PreparableStackFrame.UpdateViews; end; end; Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.dfm =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.dfm 2009-05-18 22:49:11 UTC (rev 2767) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.dfm 2009-05-22 20:23:03 UTC (rev 2768) @@ -24,9 +24,11 @@ Caption = 'SourceName' end item + Alignment = taRightJustify Caption = 'LineNumber' end item + Alignment = taRightJustify Caption = 'LineNumberOffsetFromProcedureStart' end item @@ -36,6 +38,7 @@ Caption = 'Project/File' end item + Alignment = taRightJustify Caption = 'TranslatedLineNumber' end> GridLines = True Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.pas 2009-05-18 22:49:11 UTC (rev 2767) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerStackFrame.pas 2009-05-22 20:23:03 UTC (rev 2768) @@ -53,8 +53,10 @@ procedure DoSelectStackLine; function GetStackList: IJclLocationInfoList; procedure SetStackList(const Value: IJclLocationInfoList); + procedure UpdateView; function GetPreparableLocationInfoListCount: Integer; function GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; + procedure UpdateViews; function GetSelected: IJclLocationInfo; public { Public declarations } @@ -203,6 +205,16 @@ end; end; +procedure TfrmStack.UpdateView; +begin + SetStackList(FStackList); +end; + +procedure TfrmStack.UpdateViews; +begin + UpdateView; +end; + {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); Modified: branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerThreadFrame.pas =================================================================== --- branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerThreadFrame.pas 2009-05-18 22:49:11 UTC (rev 2767) +++ branches/jcl-stack-trace/jcl/experts/stacktraceviewer/JclStackTraceViewerThreadFrame.pas 2009-05-22 20:23:03 UTC (rev 2768) @@ -65,6 +65,7 @@ procedure UpdateSplitterState; function GetPreparableLocationInfoListCount: Integer; function GetPreparableLocationInfoList(AIndex: Integer): IJclPreparedLocationInfoList; + procedure UpdateViews; procedure UpdatePreparableLocationInfoLists; { Private declarations } public @@ -226,6 +227,18 @@ end; end; +procedure TfrmThread.UpdateViews; +var + StackTraceViewerPreparableStackFrame: IJclStackTraceViewerPreparableStackFrame; +begin + if FStackFrame.Visible and + (FStackFrame.GetInterface(IJclStackTraceViewerPreparableStackFrame, StackTraceViewerPreparableStackFrame)) then + StackTraceViewerPreparableStackFrame.UpdateViews; + if FCreationStackFrame.Visible and + (FCreationStackFrame.GetInterface(IJclStackTraceViewerPreparableStackFrame, StackTraceViewerPreparableStackFrame)) then + StackTraceViewerPreparableStackFrame.UpdateViews; +end; + {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |