Menu
▾
▴
jcl-checkins-diff
|
From: <ou...@us...> - 2006-04-21 13:11:25
|
Revision: 1611 Author: outchy Date: 2006-04-21 06:11:16 -0700 (Fri, 21 Apr 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1611&view=rev Log Message: ----------- JclStream introduced for C5 and D5 compatibility New random and multiplexed streams Bug fix: position was not incremented Modified Paths: -------------- trunk/jcl/source/common/JclResources.pas trunk/jcl/source/common/JclStreams.pas Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2006-04-21 10:36:32 UTC (rev 1610) +++ trunk/jcl/source/common/JclResources.pas 2006-04-21 13:11:16 UTC (rev 1611) @@ -1720,6 +1720,10 @@ RsCompressionZLibZVersionError = 'zlib returned: Version error'; RsCompressionZLibError = 'ZLib error'; +//=== JclStreams ============================================================= +resourcestring + RsStreamsRangeError = '32 bit overflow in stream operations, use the 64 bit version'; + implementation // History: Modified: trunk/jcl/source/common/JclStreams.pas =================================================================== --- trunk/jcl/source/common/JclStreams.pas 2006-04-21 10:36:32 UTC (rev 1610) +++ trunk/jcl/source/common/JclStreams.pas 2006-04-21 13:11:16 UTC (rev 1611) @@ -17,6 +17,7 @@ { All rights reserved. } { } { Contributors: } +{ Florent Ouchet (outchy) } { } {**************************************************************************************************} @@ -30,44 +31,139 @@ interface uses - Classes; + SysUtils, Classes; type - TJclEmptyStream = class(TStream) +{$IFDEF COMPILER5} + TSeekOrigin = (soBeginning, soCurrent, soEnd); +{$ENDIF COMPILER5} + + EJclStreamException = class(Exception); + + // abstraction layer to support Delphi 5 and C++Builder 5 streams + // 64 bit version of overloaded functions are introduced + TJclStream = class(TStream) protected - procedure SetSize(NewSize: Longint); override; + procedure SetSize(NewSize: Longint); overload; override; + procedure SetSize(const NewSize: Int64); overload; {$IFDEF COMPILER5} virtual; {$ELSE COMPILER5} override; {$ENDIF COMPILER5} + public + function Seek(Offset: Longint; Origin: Word): Longint; overload; override; + function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload; {$IFDEF COMPILER5} virtual; {$ELSE COMPILER5} override; {$ENDIF COMPILER5} + end; + + // classes that inherit from TJclStream should override these methods: + //TMyJclStream = class(TJclStream) + //protected + // procedure SetSize(const NewSize: Int64); override; + //public + // function Read(var Buffer; Count: Longint): Longint; override; + // function Write(const Buffer; Count: Longint): Longint; override; + // function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; + //end; + + TJclEmptyStream = class(TJclStream) + protected procedure SetSize(const NewSize: Int64); override; public function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; end; - TJclNullStream = class(TStream) + TJclNullStream = class(TJclStream) private FPosition: Int64; FSize: Int64; protected - procedure SetSize(NewSize: Longint); override; procedure SetSize(const NewSize: Int64); override; public function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; end; + TJclRandomStream = class(TJclNullStream) + public + function Read(var Buffer; Count: Longint): Longint; override; + end; + + TJclMultiplexStream = class(TJclStream) + private + FStreams: TList; + FReadStreamIndex: Integer; + function GetStream(Index: Integer): TStream; + function GetStreamCount: Integer; + procedure SetStream(Index: Integer; const Value: TStream); + function GetReadStream: TStream; + procedure SetReadStream(const Value: TStream); + procedure SetReadStreamIndex(const Value: Integer); + protected + procedure SetSize(const NewSize: Int64); override; + public + constructor Create; reintroduce; + destructor Destroy; override; + function Read(var Buffer; Count: Longint): Longint; override; + function Write(const Buffer; Count: Longint): Longint; override; + function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; + + function AddStream(NewStream: TStream): Integer; + procedure ClearStream; + function RemoveStream(AStream: TStream): Integer; + procedure DeleteStream(const Index: Integer); + + property Streams[Index: Integer]: TStream read GetStream write SetStream; + property ReadStreamIndex: Integer read FReadStreamIndex write SetReadStreamIndex; + property ReadStream: TStream read GetReadStream write SetReadStream; + property StreamCount: Integer read GetStreamCount; + end; + implementation -//=== { TJclEmptyStream } ==================================================== +uses + JclResources, JclBase; -procedure TJclEmptyStream.SetSize(NewSize: Longint); +//=== { TJclStream } ========================================================= + +function TJclStream.Seek(Offset: Integer; Origin: Word): Longint; +var + Result64: Int64; begin + case Origin of + soFromBeginning : + Result64 := Seek(Int64(Offset), soBeginning); + soFromCurrent : + Result64 := Seek(Int64(Offset), soCurrent); + soFromEnd : + Result64 := Seek(Int64(Offset), soEnd); + else + Result64 := 0; + end; + if (Result64 < Low(LongInt)) or (Result64 > High(LongInt)) then + raise EJclStreamException.CreateRes(@RsStreamsRangeError); + Result := Result64; end; +function TJclStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; +begin + // override to customize + Result := -1; +end; + +procedure TJclStream.SetSize(NewSize: Integer); +begin + SetSize(Int64(NewSize)); +end; + +procedure TJclStream.SetSize(const NewSize: Int64); +begin + // override to customize +end; + +//=== { TJclEmptyStream } ==================================================== + procedure TJclEmptyStream.SetSize(const NewSize: Int64); begin + // nothing end; function TJclEmptyStream.Read(var Buffer; Count: Longint): Longint; @@ -80,11 +176,6 @@ Result := 0; end; -function TJclEmptyStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - Result := 0; -end; - function TJclEmptyStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; begin Result := 0; @@ -92,11 +183,6 @@ //=== { TJclNullStream } ===================================================== -procedure TJclNullStream.SetSize(NewSize: Longint); -begin - SetSize(Int64(NewSize)); -end; - procedure TJclNullStream.SetSize(const NewSize: Int64); begin if NewSize > 0 then @@ -114,7 +200,10 @@ if FSize - FPosition < Count then Count := FSize - FPosition; if Count > 0 then + begin FillChar(Buffer, Count, 0); + FPosition := FPosition + Count; + end; Result := Count; end; @@ -128,27 +217,15 @@ Result := Count; end; -function TJclNullStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - case Origin of - soFromBeginning: - Result := Seek(Int64(Offset), soBeginning); - soFromCurrent: - Result := Seek(Int64(Offset), soCurrent); - soFromEnd: - Result := Seek(Int64(Offset), soEnd); - else - Result := -1; - end; -end; - function TJclNullStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; begin case Origin of soBeginning: begin if Offset >= 0 then - FPosition := Offset; + FPosition := Offset + else + FPosition := 0; if FPosition > FSize then FPosition := FSize; Result := FPosition; @@ -165,7 +242,9 @@ soEnd: begin if Offset <= 0 then - FPosition := FSize - Offset; + FPosition := FSize + Offset // offset is negative + else + FPosition := FSize; if FPosition < 0 then FPosition := 0; Result := FPosition; @@ -175,6 +254,150 @@ end; end; +//=== { TJclRandomStream } =================================================== + +function TJclRandomStream.Read(var Buffer; Count: Integer): Longint; +{$IFDEF COMPILER5} +type + PWord = ^Word; +{$ENDIF COMPILER5} +var + BufferPtr: PByte; +begin + if Count < 0 then + Count := 0; + if FSize - FPosition < Count then + Count := FSize - FPosition; + if Count > 0 then + begin + BufferPtr := @Buffer; + while Count > 1 do + begin + PWord(BufferPtr)^ := Random($10000); + Inc(BufferPtr, 2); + end; + if Count <> 0 then + BufferPtr^ := Random($100); + FPosition := FPosition + Count; + end; + Result := Count; +end; + +//=== { TJclMultiplexStream } ================================================ + +function TJclMultiplexStream.AddStream(NewStream: TStream): Integer; +begin + Result := FStreams.Add(Pointer(NewStream)); +end; + +procedure TJclMultiplexStream.ClearStream; +begin + FStreams.Clear; + FReadStreamIndex := -1; +end; + +constructor TJclMultiplexStream.Create; +begin + inherited Create; + FStreams := TList.Create; + FReadStreamIndex := -1; +end; + +procedure TJclMultiplexStream.DeleteStream(const Index: Integer); +begin + FStreams.Delete(Index); + if ReadStreamIndex = Index then + FReadStreamIndex := -1 + else if ReadStreamIndex > Index then + Dec(FReadStreamIndex); +end; + +destructor TJclMultiplexStream.Destroy; +begin + FStreams.Free; + inherited Destroy; +end; + +function TJclMultiplexStream.GetReadStream: TStream; +begin + if FReadStreamIndex >= 0 then + Result := TStream(FStreams.Items[FReadStreamIndex]) + else + Result := nil; +end; + +function TJclMultiplexStream.GetStream(Index: Integer): TStream; +begin + Result := TStream(FStreams.Items[Index]); +end; + +function TJclMultiplexStream.GetStreamCount: Integer; +begin + Result := FStreams.Count; +end; + +function TJclMultiplexStream.Read(var Buffer; Count: Integer): Longint; +var + AReadStream: TStream; +begin + AReadStream := ReadStream; + if Assigned(AReadStream) then + Result := AReadStream.Read(Buffer, Count) + else + Result := 0; +end; + +function TJclMultiplexStream.RemoveStream(AStream: TStream): Integer; +begin + Result := FStreams.Remove(Pointer(AStream)); + if FReadStreamIndex = Result then + FReadStreamIndex := -1 + else if FReadStreamIndex > Result then + Dec(FReadStreamIndex); +end; + +function TJclMultiplexStream.Seek(const Offset: Int64; + Origin: TSeekOrigin): Int64; +begin + // what should this function do? + Result := -1; +end; + +procedure TJclMultiplexStream.SetReadStream(const Value: TStream); +begin + FReadStreamIndex := FStreams.IndexOf(Pointer(Value)); +end; + +procedure TJclMultiplexStream.SetReadStreamIndex(const Value: Integer); +begin + FReadStreamIndex := Value; +end; + +procedure TJclMultiplexStream.SetSize(const NewSize: Int64); +begin + // what should this function do? +end; + +procedure TJclMultiplexStream.SetStream(Index: Integer; const Value: TStream); +begin + FStreams.Items[Index] := Pointer(Value); +end; + +function TJclMultiplexStream.Write(const Buffer; Count: Integer): Longint; +var + Index: Integer; + ByteWritten, MinByteWritten: Longint; +begin + MinByteWritten := Count; + for Index := 0 to StreamCount - 1 do + begin + ByteWritten := TStream(FStreams.Items[Index]).Write(Buffer, Count); + if ByteWritten < MinByteWritten then + MinByteWritten := ByteWritten; + end; + Result := MinByteWritten; +end; + // History: // $Log$ This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <mar...@us...> - 2006-04-24 08:20:45
|
Revision: 1617 Author: marquardt Date: 2006-04-24 01:20:33 -0700 (Mon, 24 Apr 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1617&view=rev Log Message: ----------- tightened and fixed Seek logic Modified Paths: -------------- trunk/jcl/source/common/JclResources.pas trunk/jcl/source/common/JclStreams.pas Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2006-04-24 05:56:49 UTC (rev 1616) +++ trunk/jcl/source/common/JclResources.pas 2006-04-24 08:20:33 UTC (rev 1617) @@ -750,6 +750,21 @@ resourcestring RsComplexInvalidString = 'Failed to create a complex number from the string provided'; +//=== JclCompression ========================================================= +resourcestring + RsCompressionOperationNotSupported = 'Operation is not supported.'; + RsCompressionReadNotSupported = 'read is not an supported operation.'; + RsCompressionWriteNotSupported = 'write is not an supported operation.'; + RsCompressionResetNotSupported = 'reset is not an supported operation.'; + RsCompressionSeekNotSupported = 'seek is not an supported operation.'; + RsCompressionZLibZErrNo = 'zlib returned: ERRNO'; + RsCompressionZLibZStreamError = 'zlib returned: Stream error'; + RsCompressionZLibZDataError = 'zlib returned: data error'; + RsCompressionZLibZMemError = 'zlib returned: memory error'; + RsCompressionZLibZBufError = 'zlib returned: buffer error'; + RsCompressionZLibZVersionError = 'zlib returned: Version error'; + RsCompressionZLibError = 'ZLib error'; + //=== JclConsole ============================================================= resourcestring RsCannotRaiseSignal = 'Cannot raise %s signal.'; @@ -1447,7 +1462,6 @@ RsHKCCShort = 'HKCC'; RsHKDDShort = 'HKDD'; - //=== JclRTTI ================================================================ resourcestring RsRTTIValueOutOfRange = 'Value out of range (%s).'; @@ -1705,25 +1719,6 @@ RsMidiInUnknownError = 'Unknown MIDI-In error No. %d'; RsMidiOutUnknownError = 'Unknown MIDI-Out error No. %d'; -//=== JclCompression ========================================================= -resourcestring - RsCompressionOperationNotSupported = 'Operation is not supported.'; - RsCompressionReadNotSupported = 'read is not an supported operation.'; - RsCompressionWriteNotSupported = 'write is not an supported operation.'; - RsCompressionResetNotSupported = 'reset is not an supported operation.'; - RsCompressionSeekNotSupported = 'seek is not an supported operation.'; - RsCompressionZLibZErrNo = 'zlib returned: ERRNO'; - RsCompressionZLibZStreamError = 'zlib returned: Stream error'; - RsCompressionZLibZDataError = 'zlib returned: data error'; - RsCompressionZLibZMemError = 'zlib returned: memory error'; - RsCompressionZLibZBufError = 'zlib returned: buffer error'; - RsCompressionZLibZVersionError = 'zlib returned: Version error'; - RsCompressionZLibError = 'ZLib error'; - -//=== JclStreams ============================================================= -resourcestring - RsStreamsRangeError = '32 bit overflow in stream operations, use the 64 bit version'; - implementation // History: Modified: trunk/jcl/source/common/JclStreams.pas =================================================================== --- trunk/jcl/source/common/JclStreams.pas 2006-04-24 05:56:49 UTC (rev 1616) +++ trunk/jcl/source/common/JclStreams.pas 2006-04-24 08:20:33 UTC (rev 1617) @@ -66,7 +66,8 @@ TJclEmptyStream = class(TJclStream) protected - procedure SetSize(const NewSize: Int64); override; + procedure SetSize(NewSize: Longint); overload; override; + procedure SetSize(const NewSize: Int64); overload; override; public function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Longint): Longint; override; @@ -145,10 +146,10 @@ soFromEnd: Result64 := Seek(Int64(Offset), soEnd); else - Result64 := 0; + Result64 := -1; end; - if (Result64 < Low(Longint)) or (Result64 > High(Longint)) then - raise EJclStreamException.CreateRes(@RsStreamsRangeError); + if (Result64 < 0) or (Result64 > High(Longint)) then + Result64 := -1; Result := Result64; end; @@ -190,6 +191,15 @@ Result := 0; end; +function TJclEmptyStream.Seek(Offset: Longint; Origin: Word): Longint; +begin + if (Offset <> 0) or not (Origin in [soFromBeginning, soFromCurrent, soFromEnd]) then + // seeking to anywhere except the position 0 is an error + Result := -1 + else + Result := 0; +end; + function TJclEmptyStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; begin if Offset <> 0 then @@ -248,17 +258,29 @@ else FPosition := 0; if FPosition > FSize then + begin FPosition := FSize; - Result := FPosition; + Result := -1; + end + else + Result := FPosition; end; soCurrent: begin FPosition := FPosition + Offset; if FPosition > FSize then + begin FPosition := FSize; + Result := -1; + end + else if FPosition < 0 then + begin FPosition := 0; - Result := FPosition; + Result := -1; + end + else + Result := FPosition; end; soEnd: begin @@ -267,8 +289,12 @@ else FPosition := FSize; if FPosition < 0 then + begin FPosition := 0; - Result := FPosition; + Result := -1; + end + else + Result := FPosition; end; else Result := -1; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <ou...@us...> - 2006-04-29 06:23:27
|
Revision: 1624 Author: outchy Date: 2006-04-28 23:23:15 -0700 (Fri, 28 Apr 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1624&view=rev Log Message: ----------- UnitVersioning: $URL$ keyword enabled. Modified Paths: -------------- trunk/jcl/source/common/JclBorlandTools.pas trunk/jcl/source/common/JclSysInfo.pas trunk/jcl/source/common/JclUnitVersioningProviders.pas Property Changed: ---------------- trunk/jcl/source/common/JclUnitVersioningProviders.pas Modified: trunk/jcl/source/common/JclBorlandTools.pas =================================================================== --- trunk/jcl/source/common/JclBorlandTools.pas 2006-04-29 03:27:24 UTC (rev 1623) +++ trunk/jcl/source/common/JclBorlandTools.pas 2006-04-29 06:23:15 UTC (rev 1624) @@ -124,11 +124,17 @@ ProjectTypePackage = 'package'; ProjectTypeLibrary = 'library'; - ProjectTypeProgram = 'program'; + ProjectTypeProgram = 'program'; + Personality32Bit = '32 bit'; + Personality64Bit = '64 bit'; PersonalityDelphi = 'Delphi'; + PersonalityDelphiDotNet = 'Delphi.net'; PersonalityBCB = 'C++Builder'; PersonalityCSB = 'C#Builder'; + PersonalityVB = 'Visual Basic'; + PersonalityDesign = 'Design'; + PersonalityUnknown = 'Unknown personality'; PersonalityBDS = 'Borland Developer Studio'; DOFDirectoriesSection = 'Directories'; @@ -149,12 +155,29 @@ // Installed versions information classes type - TJclBorPersonality = (bpDelphi32, bpBCBuilder32, bpDelphiNet32, bpDelphiNet64, - bpCSBuilder32, bpCSBuilder64); + TJclBorPersonality = (bpDelphi32, bpDelphi64, bpBCBuilder32, bpBCBuilder64, + bpDelphiNet32, bpDelphiNet64, bpCSBuilder32, bpCSBuilder64, + bpVisualBasic32, bpVisualBasic64, bpDesign, bpUnknown); // bpDelphi64, bpBCBuilder64); TJclBorPersonalities = set of TJclBorPersonality; +const + JclBorPersonalityDescription: array [TJclBorPersonality] of string = + ( Personality32Bit + ' ' + PersonalityDelphi, + Personality64Bit + ' ' + PersonalityDelphi, + Personality32Bit + ' ' + PersonalityBCB, + Personality64Bit + ' ' + PersonalityBCB, + Personality32Bit + ' ' + PersonalityDelphiDotNet, + Personality64Bit + ' ' + PersonalityDelphiDotNet, + Personality32Bit + ' ' + PersonalityCSB, + Personality64Bit + ' ' + PersonalityCSB, + Personality32Bit + ' ' + PersonalityVB, + Personality64Bit + ' ' + PersonalityVB, + PersonalityDesign, + PersonalityUnknown ); + +type TJclBorRADToolInstallation = class; TJclBorRADToolInstallationObject = class(TInterfacedObject) Modified: trunk/jcl/source/common/JclSysInfo.pas =================================================================== --- trunk/jcl/source/common/JclSysInfo.pas 2006-04-29 03:27:24 UTC (rev 1623) +++ trunk/jcl/source/common/JclSysInfo.pas 2006-04-29 06:23:15 UTC (rev 1624) @@ -426,6 +426,7 @@ SSE: Byte; // SSE version 0 = no SSE, 1 = SSE, 2 = SSE2, 3 = SSE3 IsFDIVOK: Boolean; Is64Bits: Boolean; + DEPEnabled: Boolean; // incomplete HasCacheInfo: Boolean; HasExtendedInfo: Boolean; PType: Byte; @@ -1100,6 +1101,7 @@ function GetFreeSystemResources(const ResourceType: TFreeSysResKind): Integer; overload; function GetFreeSystemResources: TFreeSystemResources; overload; +function GetBPP: Cardinal; {$ENDIF MSWINDOWS} // Public global variables @@ -5190,6 +5192,20 @@ end; end; +function GetBPP: Cardinal; +var + DC: HDC; +begin + DC := GetDC(HWND_DESKTOP); + if DC <> 0 then + begin + Result := GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES); + ReleaseDC(HWND_DESKTOP, DC); + end + else + Result := 0; +end; + //=== Initialization/Finalization ============================================ procedure InitSysInfo; Modified: trunk/jcl/source/common/JclUnitVersioningProviders.pas =================================================================== --- trunk/jcl/source/common/JclUnitVersioningProviders.pas 2006-04-29 03:27:24 UTC (rev 1623) +++ trunk/jcl/source/common/JclUnitVersioningProviders.pas 2006-04-29 06:23:15 UTC (rev 1624) @@ -1,4 +1,4 @@ -{**************************************************************************************************} +{**************************************************************************************************} { } { Project JEDI Code Library (JCL) } { } @@ -388,7 +388,7 @@ const UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$RCSfile$'; + RCSfile: '$URL$'; Revision: '$Revision$'; Date: '$Date$'; LogPath: 'JCL\common'; Property changes on: trunk/jcl/source/common/JclUnitVersioningProviders.pas ___________________________________________________________________ Name: svn:keywords - Author Date Id Revision + Author Date Id Revision Url This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <mar...@us...> - 2006-05-04 11:36:15
|
Revision: 1634 Author: marquardt Date: 2006-05-04 04:36:04 -0700 (Thu, 04 May 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1634&view=rev Log Message: ----------- bugfixes and new stream classes Modified Paths: -------------- trunk/jcl/source/common/JclResources.pas trunk/jcl/source/common/JclStreams.pas Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2006-05-03 09:05:05 UTC (rev 1633) +++ trunk/jcl/source/common/JclResources.pas 2006-05-04 11:36:04 UTC (rev 1634) @@ -1532,6 +1532,12 @@ resourcestring RsInvalidSampleSize = 'Invalid sample size (%d)'; +//=== JclStreams ============================================================= +resourcestring + RsStreamsCreateError = 'Cannot create file %s'; + RsStreamsOpenError = 'Cannot open file %s'; + RsStreamsSetSizeError = 'Error setting stream size'; + //=== JclStrHashMap ========================================================== resourcestring RsStringHashMapMustBeEmpty = 'HashList: must be empty to set size to zero'; Modified: trunk/jcl/source/common/JclStreams.pas =================================================================== --- trunk/jcl/source/common/JclStreams.pas 2006-05-03 09:05:05 UTC (rev 1633) +++ trunk/jcl/source/common/JclStreams.pas 2006-05-04 11:36:04 UTC (rev 1634) @@ -32,6 +32,12 @@ interface uses + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + Libc, + {$ENDIF LINUX} SysUtils, Classes; type @@ -39,7 +45,7 @@ TSeekOrigin = (soBeginning, soCurrent, soEnd); {$ENDIF COMPILER5} - EJclStreamException = class(Exception); + EJclStreamError = class(Exception); // abstraction layer to support Delphi 5 and C++Builder 5 streams // 64 bit version of overloaded functions are introduced @@ -54,17 +60,44 @@ {$IFDEF COMPILER5} reintroduce; overload; virtual; {$ELSE} overload; override; {$ENDIF} end; - { classes that inherit from TJclStream should override these methods: - TMyJclStream = class(TJclStream) + //=== VCL stream replacements === + + TJclHandleStream = class(TJclStream) + private + FHandle: THandle; protected + procedure SetSize(NewSize: Longint); override; procedure SetSize(const NewSize: Int64); override; public + constructor Create(AHandle: THandle); virtual; function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Longint): Longint; override; function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; + property Handle: THandle read FHandle; end; + + TJclFileStream = class(TJclHandleStream) + public + constructor Create(const FileName: string; Mode: Word; Rights: Cardinal = 0); reintroduce; virtual; + destructor Destroy; override; + end; + + { + TJclCustomMemoryStream = class(TJclStream) + end; + + TJclMemoryStream = class(TJclCustomMemoryStream) + end; + + TJclStringStream = class(TJclStream) + end; + + TJclResourceStream = class(TJclCustomMemoryStream) + end; } + //=== new stream ideas === + TJclEmptyStream = class(TJclStream) protected procedure SetSize(NewSize: Longint); overload; override; @@ -276,6 +309,128 @@ // override to customize end; +//=== { TJclHandleStream } =================================================== + +constructor TJclHandleStream.Create(AHandle: THandle); +begin + inherited Create; + FHandle := AHandle; +end; + +function TJclHandleStream.Read(var Buffer; Count: Longint): Longint; +begin + {$IFDEF MSWINDOWS} + if (Count <= 0) or not ReadFile(Handle, Buffer, DWORD(Count), DWORD(Result), nil) then + Result := 0; + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + Result := __read(Handle, Buffer, Count); + {$ENDIF LINUX} +end; + +function TJclHandleStream.Write(const Buffer; Count: Longint): Longint; +begin + {$IFDEF MSWINDOWS} + if (Count <= 0) or not WriteFile(Handle, Buffer, DWORD(Count), DWORD(Result), nil) then + Result := 0; + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + Result := __write(Handle, Buffer, Count); + {$ENDIF LINUX} +end; + +{$IFDEF MSWINDOWS} +function TJclHandleStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; +const + INVALID_SET_FILE_POINTER = -1; +type + TLarge = record + case Boolean of + False: + (OffsetLo: Longint; + OffsetHi: Longint); + True: + (Offset64: Int64); + end; +var + Offs: TLarge; +begin + Offs.Offset64 := Offset; + Offs.OffsetLo := SetFilePointer(Handle, Offs.OffsetLo, @Offs.OffsetHi, Ord(Origin)); + if (Offs.OffsetLo = INVALID_SET_FILE_POINTER) and (GetLastError <> NO_ERROR) then + Result := -1 + else + Result := Offs.Offset64; +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +function TJclHandleStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; +begin + Result := __lseek(Handle, Offset, Origin); +end; +{$ENDIF LINUX} + +procedure TJclHandleStream.SetSize(NewSize: Longint); +begin + SetSize(Int64(NewSize)); +end; + +procedure TJclHandleStream.SetSize(const NewSize: Int64); +begin + Seek(NewSize, soBeginning); + {$IFDEF MSWINDOWS} + if not SetEndOfFile(Handle) then + RaiseLastOSError; + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + if ftruncate(Handle, Position) = -1 then + raise EJclStreamError.CreateRes(@RsStreamsSetSizeError); + {$ENDIF LINUX} +end; + +//=== { TJclFileStream } ===================================================== + +constructor TJclFileStream.Create(const FileName: string; Mode: Word; Rights: Cardinal); +var + H: THandle; +begin + if Mode = fmCreate then + begin + H := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, + 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); + inherited Create(H); + if Handle = INVALID_HANDLE_VALUE then + {$IFDEF CLR} + raise EJclStreamError.CreateFmt(RsStreamsCreateError, [FileName]); + {$ELSE} + raise EJclStreamError.CreateResFmt(@RsStreamsCreateError, [FileName]); + {$ENDIF CLR} + end + else + begin + H := THandle(FileOpen(FileName, Mode)); + inherited Create(H); + if Handle = INVALID_HANDLE_VALUE then + {$IFDEF CLR} + raise EJclStreamError.CreateFmt(RsStreamsOpenError, [FileName]); + {$ELSE} + raise EJclStreamError.CreateResFmt(@RsStreamsOpenError, [FileName]); + {$ENDIF CLR} + end; +end; + +destructor TJclFileStream.Destroy; +begin + {$IFDEF MSWINDOWS} + if Handle <> INVALID_HANDLE_VALUE then + CloseHandle(Handle); + {$ENDIF MSWINDOWS} + {$IFDEF LINUX} + __close(Handle); + {$ENDIF LINUX} + inherited Destroy; +end; + //=== { TJclEmptyStream } ==================================================== // a stream which stays empty no matter what you do @@ -331,8 +486,10 @@ begin if Count < 0 then Count := 0; + // FPosition > FSize is possible! if FSize - FPosition < Count then Count := FSize - FPosition; + // does not read if beyond EOF if Count > 0 then begin FillChar(Buffer, Count, 0); @@ -346,62 +503,35 @@ if Count < 0 then Count := 0; FPosition := FPosition + Count; + // writing when FPosition > FSize is possible! if FPosition > FSize then FSize := FPosition; Result := Count; end; function TJclNullStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; +var + Rel: Int64; begin case Origin of soBeginning: - begin - if Offset >= 0 then - FPosition := Offset - else - FPosition := 0; - if FPosition > FSize then - begin - FPosition := FSize; - Result := -1; - end - else - Result := FPosition; - end; + Rel := 0; soCurrent: - begin - FPosition := FPosition + Offset; - if FPosition > FSize then - begin - FPosition := FSize; - Result := -1; - end - else - if FPosition < 0 then - begin - FPosition := 0; - Result := -1; - end - else - Result := FPosition; - end; + Rel := FPosition; soEnd: - begin - if Offset <= 0 then - FPosition := FSize + Offset // offset is negative - else - FPosition := FSize; - if FPosition < 0 then - begin - FPosition := 0; - Result := -1; - end - else - Result := FPosition; - end; + Rel := FSize; else + // force Rel + Offset = -1 (code is never reached) + Rel := Offset - 1; + end; + if Rel + Offset >= 0 then + begin + // all non-negative destination positions including beyond EOF are valid + FPosition := Rel + Offset; + Result := FPosition; + end + else Result := -1; - end; end; //=== { TJclRandomStream } =================================================== @@ -434,17 +564,14 @@ I: Longint; BufferPtr: PByte; begin - if Count < 0 then - Count := 0; - if Size - Position < Count then - Count := Size - Position; + // this handles all necessary checks + Count := inherited Read(Buffer, Count); BufferPtr := @Buffer; for I := 0 to Count - 1 do begin BufferPtr^ := RandomData; Inc(BufferPtr); end; - Position := Position + Count; Result := Count; end; @@ -873,38 +1000,40 @@ //=== { TJclEasyStream } ===================================================== function TJclEasyStream.IsEqual(Stream: TStream): Boolean; -type - TTestBuffer = array [0..4095] of Byte; +const + BUFSIZE = 65536; var - MyPos: Integer; - MyRead: Integer; - MyBuffer: TTestBuffer; - StreamPos: Integer; - StreamRead: Integer; - StreamBuffer: TTestBuffer; + SavePos, StreamSavePos: Integer; + ReadCount, StreamReadCount: Integer; + Buffer, StreamBuffer: PChar; TestSize: Integer; begin Result := False; - MyPos := Position; - StreamPos := Stream.Position; + SavePos := Position; + StreamSavePos := Stream.Position; if Size <> Stream.Size then Exit; + Buffer := nil; try + GetMem(Buffer, 2*BUFSIZE); + StreamBuffer := Buffer + BUFSIZE; Position := 0; Stream.Position := 0; TestSize := Size; while Position < TestSize do begin - MyRead := Read(MyBuffer, SizeOf(MyBuffer)); - StreamRead := Stream.Read(StreamBuffer, SizeOf(StreamBuffer)); - if MyRead <> StreamRead then + ReadCount := Read(Buffer^, BUFSIZE); + StreamReadCount := Stream.Read(StreamBuffer^, BUFSIZE); + if ReadCount <> StreamReadCount then Exit; - if not CompareMem(Addr(MyBuffer), Addr(StreamBuffer), MyRead) then + if not CompareMem(Buffer, StreamBuffer, ReadCount) then Exit; end; finally - Position := MyPos; - Stream.Position := StreamPos; + Position := SavePos; + Stream.Position := StreamSavePos; + if Buffer <> nil then + FreeMem(Buffer); end; Result := True; end; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <ou...@us...> - 2006-05-23 01:16:48
|
Revision: 1662 Author: outchy Date: 2006-05-22 18:16:24 -0700 (Mon, 22 May 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1662&view=rev Log Message: ----------- BooleanToStr moved to JclSysUtils Modified Paths: -------------- trunk/jcl/examples/windows/clr/ClrDemoTableForm.pas trunk/jcl/examples/windows/fileversion/VerInfoDemoMain.pas trunk/jcl/source/common/JclAnsiStrings.pas trunk/jcl/source/common/JclStrings.pas trunk/jcl/source/common/JclSysUtils.pas trunk/jcl/source/windows/JclWideFormat.pas Modified: trunk/jcl/examples/windows/clr/ClrDemoTableForm.pas =================================================================== --- trunk/jcl/examples/windows/clr/ClrDemoTableForm.pas 2006-05-20 19:38:28 UTC (rev 1661) +++ trunk/jcl/examples/windows/clr/ClrDemoTableForm.pas 2006-05-23 01:16:24 UTC (rev 1662) @@ -59,7 +59,7 @@ {$IFDEF USE_JWA} JwaWinCrypt, JwaWinNT, {$ENDIF} - JclStrings, ClrDemoMain; + JclStrings, JclSysUtils, ClrDemoMain; { TfrmTable } Modified: trunk/jcl/examples/windows/fileversion/VerInfoDemoMain.pas =================================================================== --- trunk/jcl/examples/windows/fileversion/VerInfoDemoMain.pas 2006-05-20 19:38:28 UTC (rev 1661) +++ trunk/jcl/examples/windows/fileversion/VerInfoDemoMain.pas 2006-05-23 01:16:24 UTC (rev 1662) @@ -33,7 +33,7 @@ {$R *.DFM} uses - JclFileUtils, JclStrings; + JclFileUtils, JclStrings, JclSysUtils; { TForm1 } Modified: trunk/jcl/source/common/JclAnsiStrings.pas =================================================================== --- trunk/jcl/source/common/JclAnsiStrings.pas 2006-05-20 19:38:28 UTC (rev 1661) +++ trunk/jcl/source/common/JclAnsiStrings.pas 2006-05-23 01:16:24 UTC (rev 1662) @@ -333,7 +333,9 @@ function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; // Miscellaneous +{$IFDEF KEEP_DEPRECATED} function BooleanToStr(B: Boolean): AnsiString; +{$ENDIF KEEP_DEPRECATED} function FileToString(const FileName: AnsiString): AnsiString; procedure StringToFile(const FileName, Contents: AnsiString); function StrToken(var S: AnsiString; Separator: AnsiChar): AnsiString; @@ -3691,13 +3693,14 @@ end; //=== Miscellaneous ========================================================== - +{$IFDEF KEEP_DEPRECATED} function BooleanToStr(B: Boolean): AnsiString; const Bools: array [Boolean] of AnsiString = ('False', 'True'); begin Result := Bools[B]; end; +{$ENDIF KEEP_DEPRECATED} function FileToString(const FileName: AnsiString): AnsiString; var Modified: trunk/jcl/source/common/JclStrings.pas =================================================================== --- trunk/jcl/source/common/JclStrings.pas 2006-05-20 19:38:28 UTC (rev 1661) +++ trunk/jcl/source/common/JclStrings.pas 2006-05-23 01:16:24 UTC (rev 1662) @@ -334,7 +334,9 @@ function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; // Miscellaneous +{$IFDEF KEEP_DEPRECATED} function BooleanToStr(B: Boolean): string; +{$ENDIF KEEP_DEPRECATED} function FileToString(const FileName: string): AnsiString; procedure StringToFile(const FileName: string; const Contents: AnsiString); function StrToken(var S: string; Separator: Char): string; @@ -3797,12 +3799,14 @@ //=== Miscellaneous ========================================================== +{$IFDEF KEEP_DEPRECATED} function BooleanToStr(B: Boolean): string; const Bools: array [Boolean] of string = ('False', 'True'); begin Result := Bools[B]; end; +{$ENDIF KEEP_DEPRECATED} function FileToString(const FileName: string): AnsiString; var Modified: trunk/jcl/source/common/JclSysUtils.pas =================================================================== --- trunk/jcl/source/common/JclSysUtils.pas 2006-05-20 19:38:28 UTC (rev 1661) +++ trunk/jcl/source/common/JclSysUtils.pas 2006-05-23 01:16:24 UTC (rev 1662) @@ -437,6 +437,7 @@ EJclConversionError = class(EJclError); function StrToBoolean(const S: string): Boolean; +function BooleanToStr(B: Boolean): string; function IntToBool(I: Integer): Boolean; function BoolToInt(B: Boolean): Integer; @@ -2692,6 +2693,14 @@ end; end; +function BooleanToStr(B: Boolean): string; +begin + if B then + Result := DefaultTrueBoolStr + else + Result := DefaultFalseBoolStr; +end; + function IntToBool(I: Integer): Boolean; begin Result := I <> 0; Modified: trunk/jcl/source/windows/JclWideFormat.pas =================================================================== --- trunk/jcl/source/windows/JclWideFormat.pas 2006-05-20 19:38:28 UTC (rev 1661) +++ trunk/jcl/source/windows/JclWideFormat.pas 2006-05-23 01:16:24 UTC (rev 1662) @@ -86,7 +86,8 @@ JclBase, // for PByte and PCardinal JclMath, // for TDelphiSet JclResources, // for resourcestrings - JclStrings, // for BooleanToStr, StrLen + JclStrings, // for StrLen + JclSysUtils, // for BooleanToStr JclWideStrings; // for StrLenW, MoveWideChar type This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <ah...@us...> - 2006-05-30 18:28:21
|
Revision: 1672 Author: ahuser Date: 2006-05-30 11:28:12 -0700 (Tue, 30 May 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1672&view=rev Log Message: ----------- TStringBuilder class + DotNetFormat() Modified Paths: -------------- trunk/jcl/source/common/JclResources.pas trunk/jcl/source/common/JclStrings.pas Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2006-05-29 22:02:45 UTC (rev 1671) +++ trunk/jcl/source/common/JclResources.pas 2006-05-30 18:28:12 UTC (rev 1672) @@ -1549,6 +1549,11 @@ RsBlankSearchString = 'Search string cannot be blank'; RsInvalidEmptyStringItem = 'String list passed to StringsToMultiSz cannot contain empty strings.'; RsNumericConstantTooLarge = 'Numeric constant too large.'; + RsFormatException = 'Format exception'; + RsDotNetFormatNullFormat = 'Format string is null'; + RsArgumentIsNull = 'Argument %d is null'; + RsDotNetFormatArgumentNotSupported = 'Argument type of %d is not supported'; + RsArgumentOutOfRange = 'Argument out of range'; //=== JclStructStorage ======================================================= resourcestring Modified: trunk/jcl/source/common/JclStrings.pas =================================================================== --- trunk/jcl/source/common/JclStrings.pas 2006-05-29 22:02:45 UTC (rev 1671) +++ trunk/jcl/source/common/JclStrings.pas 2006-05-30 18:28:12 UTC (rev 1672) @@ -236,7 +236,7 @@ function StrStrCount(const S, SubS: string): Integer; function StrCompare(const S1, S2: string): Integer; function StrCompareRange(const S1, S2: string; const Index, Count: Integer): Integer; -function StrFillChar(const C: Char; Count: Integer): string; +function StrFillChar(const C: Char; Count: Integer): string; function StrFind(const Substr, S: string; const Index: Integer = 1): Integer; function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; function StrIndex(const S: string; const List: array of string): Integer; @@ -363,6 +363,106 @@ function TryStrToCurr(const S: string; out Value: Currency): Boolean; {$ENDIF COMPILER5} + +{$IFDEF CLR} +type + TStringBuilder = System.Text.StringBuilder; + +function DotNetFormat(const Fmt: string; const Args: array of System.Object): string; overload; +function DotNetFormat(const Fmt: string; const Arg0: System.Object): string; overload; +function DotNetFormat(const Fmt: string; const Arg0, Arg1: System.Object): string; overload; +function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: System.Object): string; overload; + +{$ELSE} + +type + FormatException = class(Exception); + ArgumentException = class(Exception); + ArgumentNullException = class(Exception); + ArgumentOutOfRangeException = class(Exception); + + IToString = interface + ['{C4ABABB4-1029-46E7-B5FA-99800F130C05}'] + function ToString: string; + end; + + TCharDynArray = array of Char; + + // The TStringBuilder class is a Delphi implementation of the .NET + // System.Text.StringBuilder. + // It is zero based and the method that allow an TObject (Append, Insert, + // AppendFormat) are limited to IToString implementors. + TStringBuilder = class(TInterfacedObject, IToString) + private + FChars: TCharDynArray; + FLength: Integer; + FMaxCapacity: Integer; + FLock: TRTLCriticalSection; + + function GetCapacity: Integer; + procedure SetCapacity(const Value: Integer); + function GetChars(Index: Integer): Char; + procedure SetChars(Index: Integer; const Value: Char); + procedure Set_Length(const Value: Integer); + + function AppendPChar(Value: PChar; Count: Integer; RepeatCount: Integer = 1): TStringBuilder; + function InsertPChar(Index: Integer; Value: PChar; Count: Integer; RepeatCount: Integer = 1): TStringBuilder; + public + constructor Create(const Value: string; Capacity: Integer = 16); overload; + constructor Create(Capacity: Integer = 16; MaxCapacity: Integer = MaxInt); overload; + constructor Create(const Value: string; StartIndex, Length, Capacity: Integer); overload; + destructor Destroy; override; + + function Append(const Value: string): TStringBuilder; overload; + function Append(const Value: string; StartIndex, Length: Integer): TStringBuilder; overload; + function Append(Value: Boolean): TStringBuilder; overload; + function Append(Value: Char; RepeatCount: Integer = 1): TStringBuilder; overload; + function Append(const Value: array of Char): TStringBuilder; overload; + function Append(const Value: array of Char; StartIndex, Length: Integer): TStringBuilder; overload; + function Append(Value: Cardinal): TStringBuilder; overload; + function Append(Value: Integer): TStringBuilder; overload; + function Append(Value: Double): TStringBuilder; overload; + function Append(Value: Int64): TStringBuilder; overload; + function Append(Obj: TObject): TStringBuilder; overload; + function AppendFormat(const Fmt: string; const Args: array of const): TStringBuilder; overload; + function AppendFormat(const Fmt: string; Arg0: Variant): TStringBuilder; overload; + function AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TStringBuilder; overload; + function AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TStringBuilder; overload; + + function Insert(Index: Integer; const Value: string; Count: Integer = 1): TStringBuilder; overload; + function Insert(Index: Integer; Value: Boolean): TStringBuilder; overload; + function Insert(Index: Integer; const Value: array of Char): TStringBuilder; overload; + function Insert(Index: Integer; const Value: array of Char; StartIndex, Length: Integer): TStringBuilder; overload; + function Insert(Index: Integer; Value: Cardinal): TStringBuilder; overload; + function Insert(Index: Integer; Value: Integer): TStringBuilder; overload; + function Insert(Index: Integer; Value: Double): TStringBuilder; overload; + function Insert(Index: Integer; Value: Int64): TStringBuilder; overload; + function Insert(Index: Integer; Obj: TObject): TStringBuilder; overload; + + function Replace(OldChar, NewChar: Char; StartIndex: Integer = 0; Count: Integer = -1): TStringBuilder; overload; + function Replace(OldValue, NewValue: string; StartIndex: Integer = 0; Count: Integer = -1): TStringBuilder; overload; + + function Remove(StartIndex, Length: Integer): TStringBuilder; + function EnsureCapacity(Capacity: Integer): Integer; + + function ToString: string; + + property __Chars__[Index: Integer]: Char read GetChars write SetChars; default; + property Chars: TCharDynArray read FChars; + property Length: Integer read FLength write Set_Length; + property Capacity: Integer read GetCapacity write SetCapacity; + property MaxCapacity: Integer read FMaxCapacity; + end; + + +// DotNetFormat() uses the .NET format style: "{argX}" +function DotNetFormat(const Fmt: string; const Args: array of const): string; overload; +function DotNetFormat(const Fmt: string; const Arg0: Variant): string; overload; +function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; overload; +function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; overload; + +{$ENDIF CLR} + // Exceptions type EJclStringError = EJclError; @@ -4188,7 +4288,675 @@ end; {$ENDIF COMPILER5} +{$IFDEF CLR} +function DotNetFormat(const Fmt: string; const Args: array of System.Object): string; +begin + Result := System.String.Format(Fmt, Args); +end; + +function DotNetFormat(const Fmt: string; const Arg0: System.Object): string; +begin + Result := System.String.Format(Fmt, Arg0); +end; + +function DotNetFormat(const Fmt: string; const Arg0, Arg1: System.Object): string; +begin + Result := System.String.Format(Fmt, Arg0, Arg1); +end; + +function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: System.Object): string; +begin + Result := System.String.Format(Fmt, Arg0, Arg1, Arg2); +end; + +{$ELSE} + +const + BoolToStr: array[Boolean] of string[5] = ('false', 'true'); + +type + TInterfacedObjectAccess = class(TInterfacedObject); + +procedure MoveChar(const Source; var Dest; Count: Integer); +begin + if Count > 0 then + Move(Source, Dest, Count * SizeOf(Char)); +end; + +function DotNetFormat(const Fmt: string; const Arg0: Variant): string; +begin + Result := DotNetFormat(Fmt, [Arg0]); +end; + +function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; +begin + Result := DotNetFormat(Fmt, [Arg0, Arg1]); +end; + +function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; +begin + Result := DotNetFormat(Fmt, [Arg0, Arg1, Arg2]); +end; + +function DotNetFormat(const Fmt: string; const Args: array of const): string; +var + F, P: PChar; + Len, Capacity, Count: Integer; + Index, ErrorCode: Integer; + S: string; + + procedure Grow(Count: Integer); + begin + if Len + Count > Capacity then + begin + Capacity := Capacity * 5 div 3 + Count; + SetLength(Result, Capacity); + end; + end; + + function InheritsFrom(AClass: TClass; const ClassName: string): Boolean; + begin + Result := True; + while AClass <> nil do + begin + if CompareText(AClass.ClassName, ClassName) = 0 then + Exit; + AClass := AClass.ClassParent; + end; + Result := False; + end; + + function GetStringOf(const V: TVarData; Index: Integer): string; overload; + begin + case V.VType of + varEmpty, varNull: + raise ArgumentNullException.CreateRes(@RsArgumentIsNull); + varSmallInt: + Result := IntToStr(V.VSmallInt); + varInteger: + Result := IntToStr(V.VInteger); + varSingle: + Result := FloatToStr(V.VSingle); + varDouble: + Result := FloatToStr(V.VDouble); + varCurrency: + Result := CurrToStr(V.VCurrency); + varDate: + Result := DateTimeToStr(V.VDate); + varOleStr: + Result := V.VOleStr; + varBoolean: + Result := BoolToStr[V.VBoolean <> False]; + varShortInt: + Result := IntToStr(V.VShortInt); + varByte: + Result := IntToStr(V.VByte); + varWord: + Result := IntToStr(V.VWord); + varLongWord: + Result := IntToStr(V.VLongWord); + varInt64: + Result := IntToStr(V.VInt64); + varString: + Result := string(V.VString); + + {varArray, + varDispatch, + varError, + varUnknown, + varAny, + varByRef:} + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + end; + end; + + function GetStringOf(Index: Integer): string; overload; + var + V: TVarRec; + Intf: IToString; + begin + V := Args[Index]; + if (V.VInteger = 0) and + (V.VType in [vtExtended, vtString, vtObject, vtClass, vtCurrency, + vtInterface, vtInt64]) then + raise ArgumentNullException.CreateResFmt(@RsArgumentIsNull, [Index]); + + case V.VType of + vtInteger: + Result := IntToStr(V.VInteger); + vtBoolean: + Result := BoolToStr[V.VBoolean]; + vtChar: + Result := V.VChar; + vtExtended: + Result := FloatToStr(V.VExtended^); + vtString: + Result := V.VString^; + vtPointer: + Result := IntToHex(Cardinal(V.VPointer), 8); + vtPChar: + Result := V.VPChar; + vtObject: + if (V.VObject is TInterfacedObject) and V.VObject.GetInterface(IToString, Intf) then + begin + Result := Intf.ToString; + Pointer(Intf) := nil; // do not release the object + // undo the RefCount change + Dec(TInterfacedObjectAccess(V.VObject).FRefCount); + end + else if InheritsFrom(V.VObject.ClassType, 'TComponent') and V.VObject.GetInterface(IToString, Intf) then + Result := Intf.ToString + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + vtClass: + Result := V.VClass.ClassName; + vtWideChar: + Result := V.VWideChar; + vtPWideChar: + Result := V.VPWideChar; + vtAnsiString: + Result := string(V.VAnsiString); + vtCurrency: + Result := CurrToStr(V.VCurrency^); + vtVariant: + Result := GetStringOf(TVarData(V.VVariant^), Index); + vtInterface: + if IInterface(V.VInterface).QueryInterface(IToString, Intf) = 0 then + Result := IToString(Intf).ToString + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + vtWideString: + Result := WideString(V.VWideString); + vtInt64: + Result := IntToStr(V.VInt64^); + else + raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); + end; + end; + +begin + if Length(Args) = 0 then + begin + Result := Fmt; + Exit; + end; + Len := 0; + Capacity := Length(Fmt); + SetLength(Result, Capacity); + if Capacity = 0 then + raise ArgumentNullException.CreateRes(@RsDotNetFormatNullFormat); + + P := Pointer(Fmt); + F := P; + while True do + begin + if (P[0] = #0) or (P[0] = '{') then + begin + Count := P - F; + Inc(P); + if (P[-1] <> #0) and (P[0] = '{') then + Inc(Count); // include '{' + + if Count > 0 then + begin + Grow(Count); + MoveChar(F[0], Result[Len + 1], Count); + Inc(Len, Count); + end; + + if P[-1] = #0 then + Break; + + if P[0] <> '{' then + begin + F := P; + Inc(P); + while (P[0] <> #0) and (P[0] <> '}') do + Inc(P); + SetString(S, F, P - F); + Val(S, Index, ErrorCode); + if ErrorCode <> 0 then + raise FormatException.CreateRes(@RsFormatException); + if (Index < 0) or (Index > High(Args)) then + raise FormatException.CreateRes(@RsFormatException); + S := GetStringOf(Index); + if S <> '' then + begin + Grow(Length(S)); + MoveChar(S[1], Result[Len + 1], Length(S)); + Inc(Len, Length(S)); + end; + + if P[0] = #0 then + Break; + end; + F := P + 1; + end + else + if (P[0] = '}') and (P[1] = '}') then + begin + Count := P - F + 1; + Inc(P); // skip next '}' + + Grow(Count); + MoveChar(F[0], Result[Len + 1], Count); + Inc(Len, Count); + F := P + 1; + end; + + Inc(P); + end; + + SetLength(Result, Len); +end; + +{ TStringBuilder } + +constructor TStringBuilder.Create(Capacity: Integer; MaxCapacity: Integer); +begin + inherited Create; + InitializeCriticalSection(FLock); + SetLength(FChars, Capacity); + FMaxCapacity := MaxCapacity; +end; + +destructor TStringBuilder.Destroy; +begin + DeleteCriticalSection(FLock); + inherited Destroy; +end; + +constructor TStringBuilder.Create(const Value: string; Capacity: Integer); +begin + Create(Capacity); + Append(Value); +end; + +constructor TStringBuilder.Create(const Value: string; StartIndex, + Length, Capacity: Integer); +begin + Create(Capacity); + Append(Value, StartIndex + 1, Length); +end; + +function TStringBuilder.ToString: string; +begin + if FLength > 0 then + SetString(Result, PChar(@FChars[0]), FLength) + else + Result := ''; +end; + +function TStringBuilder.EnsureCapacity(Capacity: Integer): Integer; +begin + if System.Length(FChars) < Capacity then + SetCapacity(Capacity); + Result := System.Length(FChars); +end; + +procedure TStringBuilder.SetCapacity(const Value: Integer); +begin + if Value <> System.Length(FChars) then + begin + SetLength(FChars, Value); + if Value < FLength then + FLength := Value; + end; +end; + +function TStringBuilder.GetChars(Index: Integer): Char; +begin + Result := FChars[Index]; +end; + +procedure TStringBuilder.SetChars(Index: Integer; const Value: Char); +begin + FChars[Index] := Value; +end; + +procedure TStringBuilder.Set_Length(const Value: Integer); +begin + FLength := Value; +end; + +function TStringBuilder.GetCapacity: Integer; +begin + Result := System.Length(FChars); +end; + +function TStringBuilder.AppendPChar(Value: PChar; Count: Integer; RepeatCount: Integer): TStringBuilder; +var + Capacity: Integer; + IsMultiThreaded: Boolean; +begin + if (Count > 0) and (RepeatCount > 0) then + begin + IsMultiThreaded := IsMultiThread; + if IsMultiThreaded then + EnterCriticalSection(FLock); + try + repeat + Capacity := System.Length(FChars); + if Capacity + Count > MaxCapacity then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Capacity < FLength + Count then + SetLength(FChars, Capacity * 5 div 3 + Count); + if Count = 1 then + FChars[FLength] := Value[0] + else + MoveChar(Value[0], FChars[FLength], Count); + Inc(FLength, Count); + + Dec(RepeatCount); + until RepeatCount <= 0; + finally + if IsMultiThreaded then + LeaveCriticalSection(FLock); + end; + end; + Result := Self; +end; + +function TStringBuilder.InsertPChar(Index: Integer; Value: PChar; Count, + RepeatCount: Integer): TStringBuilder; +var + Capacity: Integer; + IsMultiThreaded: Boolean; +begin + if (Index < 0) or (Index > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + + if Index = FLength then + begin + AppendPChar(Value, Count, RepeatCount); + end + else + if (Count > 0) and (RepeatCount > 0) then + begin + IsMultiThreaded := IsMultiThread; + if IsMultiThreaded then + EnterCriticalSection(FLock); + try + repeat + Capacity := System.Length(FChars); + if Capacity + Count > MaxCapacity then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Capacity < FLength + Count then + SetLength(FChars, Capacity * 5 div 3 + Count); + MoveChar(FChars[Index], FChars[Index + Count], FLength - Index); + if Count = 1 then + FChars[Index] := Value[0] + else + MoveChar(Value[0], FChars[Index], Count); + Inc(FLength, Count); + + Dec(RepeatCount); + + Inc(Index, Count); // little optimization + until RepeatCount <= 0; + finally + if IsMultiThreaded then + LeaveCriticalSection(FLock); + end; + end; + Result := Self; +end; + +function TStringBuilder.Append(const Value: array of Char): TStringBuilder; +var + Len: Integer; +begin + Len := System.Length(Value); + if Len > 0 then + AppendPChar(@Value[0], Len); + Result := Self; +end; + +function TStringBuilder.Append(const Value: array of Char; StartIndex, Length: Integer): TStringBuilder; +var + Len: Integer; +begin + Len := System.Length(Value); + if (Length > 0) and (StartIndex < Len) then + begin + if StartIndex + Length > Len then + Length := Len - StartIndex; + AppendPChar(PChar(@Value[0]) + StartIndex, Length); + end; + Result := Self; +end; + +function TStringBuilder.Append(Value: Char; RepeatCount: Integer = 1): TStringBuilder; +begin + Result := AppendPChar(@Value, 1, RepeatCount); +end; + +function TStringBuilder.Append(const Value: string): TStringBuilder; +var + Len: Integer; +begin + Len := System.Length(Value); + if Len > 0 then + AppendPChar(Pointer(Value), Len); + Result := Self; +end; + +function TStringBuilder.Append(const Value: string; StartIndex, Length: Integer): TStringBuilder; +var + Len: Integer; +begin + Len := System.Length(Value); + if (Length > 0) and (StartIndex < Len) then + begin + if StartIndex + Length > Len then + Length := Len - StartIndex; + AppendPChar(PChar(Pointer(Value)) + StartIndex, Length); + end; + Result := Self; +end; + +function TStringBuilder.Append(Value: Boolean): TStringBuilder; +begin + Result := Append(BoolToStr[Value]); +end; + +function TStringBuilder.Append(Value: Cardinal): TStringBuilder; +begin + Result := Append(IntToStr(Value)); +end; + +function TStringBuilder.Append(Value: Integer): TStringBuilder; +begin + Result := Append(IntToStr(Value)); +end; + +function TStringBuilder.Append(Value: Double): TStringBuilder; +begin + Result := Append(FloatToStr(Value)); +end; + +function TStringBuilder.Append(Value: Int64): TStringBuilder; +begin + Result := Append(IntToStr(Value)); +end; + +function TStringBuilder.Append(Obj: TObject): TStringBuilder; +begin + Result := Append(DotNetFormat('{0}', [Obj])); +end; + +function TStringBuilder.AppendFormat(const Fmt: string; Arg0: Variant): TStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, [Arg0])); +end; + +function TStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, [Arg0, Arg1])); +end; + +function TStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, [Arg0, Arg1, Arg2])); +end; + +function TStringBuilder.AppendFormat(const Fmt: string; const Args: array of const): TStringBuilder; +begin + Result := Append(DotNetFormat(Fmt, Args)); +end; + +function TStringBuilder.Insert(Index: Integer; const Value: array of Char): TStringBuilder; +var + Len: Integer; +begin + Len := System.Length(Value); + if Len > 0 then + InsertPChar(Index, @Value[0], Len); + Result := Self; +end; + +function TStringBuilder.Insert(Index: Integer; const Value: string; Count: Integer): TStringBuilder; +var + Len: Integer; +begin + Len := System.Length(Value); + if Len > 0 then + InsertPChar(Index, Pointer(Value), Len, Count); + Result := Self; +end; + +function TStringBuilder.Insert(Index: Integer; Value: Boolean): TStringBuilder; +begin + Result := Insert(Index, BoolToStr[Value]); +end; + +function TStringBuilder.Insert(Index: Integer; const Value: array of Char; + StartIndex, Length: Integer): TStringBuilder; +var + Len: Integer; +begin + Len := System.Length(Value); + if (Length > 0) and (StartIndex < Len) then + begin + if StartIndex + Length > Len then + Length := Len - StartIndex; + InsertPChar(Index, PChar(@Value[0]) + StartIndex, Length); + end; + Result := Self; +end; + +function TStringBuilder.Insert(Index: Integer; Value: Double): TStringBuilder; +begin + Result := Insert(Index, FloatToStr(Value)); +end; + +function TStringBuilder.Insert(Index: Integer; Value: Int64): TStringBuilder; +begin + Result := Insert(Index, IntToStr(Value)); +end; + +function TStringBuilder.Insert(Index: Integer; Value: Cardinal): TStringBuilder; +begin + Result := Insert(Index, IntToStr(Value)); +end; + +function TStringBuilder.Insert(Index, Value: Integer): TStringBuilder; +begin + Result := Insert(Index, IntToStr(Value)); +end; + +function TStringBuilder.Insert(Index: Integer; Obj: TObject): TStringBuilder; +begin + Result := Insert(Index, Format('{0}', [Obj])); +end; + +function TStringBuilder.Remove(StartIndex, Length: Integer): TStringBuilder; +begin + if (StartIndex < 0) or (Length < 0) or (StartIndex + Length > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Length > 0 then + begin + MoveChar(FChars[StartIndex + Length], FChars[StartIndex], Length); + Dec(FLength, Length); + end; + Result := Self; +end; + +function TStringBuilder.Replace(OldChar, NewChar: Char; StartIndex, + Count: Integer): TStringBuilder; +var + i: Integer; +begin + if Count = -1 then + Count := FLength; + if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if (Count > 0) and (OldChar <> NewChar) then + begin + for i := StartIndex to StartIndex + Length - 1 do + if FChars[i] = OldChar then + FChars[i] := NewChar; + end; + Result := Self; +end; + +function TStringBuilder.Replace(OldValue, NewValue: string; StartIndex, + Count: Integer): TStringBuilder; +var + i: Integer; + Offset: Integer; + NewLen, OldLen, Capacity: Integer; +begin + if Count = -1 then + Count := FLength; + if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if OldValue = '' then + raise ArgumentException.CreateResFmt(@RsArgumentIsNull, [0]); + + if (Count > 0) and (OldValue <> NewValue) then + begin + OldLen := System.Length(OldValue); + NewLen := System.Length(NewValue); + Offset := NewLen - OldLen; + Capacity := System.Length(FChars); + for i := StartIndex to StartIndex + Length - 1 do + if FChars[i] = OldValue[1] then + begin + if OldLen > 1 then + if StrLComp(@FChars[i + 1], PChar(OldValue) + 1, OldLen - 1) <> 0 then + Continue; + if Offset <> 0 then + begin + if FLength - OldLen + NewLen > MaxCurrency then + raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); + if Capacity < FLength + Offset then + begin + Capacity := Capacity * 5 div 3 + Offset; + SetLength(FChars, Capacity); + end; + if Offset < 0 then + MoveChar(FChars[i - Offset], FChars[i], FLength - i) + else + MoveChar(FChars[i + OldLen], FChars[i + OldLen + Offset], FLength - OldLen - i); + Inc(FLength, Offset); + end; + if NewLen > 0 then + begin + if (OldLen = 1) and (NewLen = 1) then + FChars[i] := NewValue[1] + else + MoveChar(NewValue[1], FChars[i], NewLen); + end; + end; + end; + Result := Self; +end; +{$ENDIF CLR} + + {$IFNDEF CLR} initialization LoadCharTypes; // this table first This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <mar...@us...> - 2006-07-23 05:36:05
|
Revision: 1690 Author: marquardt Date: 2006-07-22 22:35:54 -0700 (Sat, 22 Jul 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1690&view=rev Log Message: ----------- minor style cleanups Modified Paths: -------------- trunk/jcl/source/common/JclAnsiStrings.pas trunk/jcl/source/common/JclArrayLists.pas Modified: trunk/jcl/source/common/JclAnsiStrings.pas =================================================================== --- trunk/jcl/source/common/JclAnsiStrings.pas 2006-07-16 15:14:39 UTC (rev 1689) +++ trunk/jcl/source/common/JclAnsiStrings.pas 2006-07-23 05:35:54 UTC (rev 1690) @@ -178,8 +178,8 @@ {$ENDIF ~CLR} procedure StrMove(var Dest: AnsiString; const Source: AnsiString; const ToIndex, FromIndex, Count: Integer); -function StrPadLeft(const S: AnsiString; Len: Integer; C: AnsiChar = AnsiSpace ): AnsiString; -function StrPadRight(const S: AnsiString; Len: Integer; C: AnsiChar = AnsiSpace ): AnsiString; +function StrPadLeft(const S: AnsiString; Len: Integer; C: AnsiChar = AnsiSpace): AnsiString; +function StrPadRight(const S: AnsiString; Len: Integer; C: AnsiChar = AnsiSpace): AnsiString; function StrProper(const S: AnsiString): AnsiString; {$IFNDEF CLR} procedure StrProperBuff(S: PAnsiChar); @@ -289,7 +289,7 @@ // Character Search and Replace function CharPos(const S: AnsiString; const C: AnsiChar; const Index: Integer = 1): Integer; function CharLastPos(const S: AnsiString; const C: AnsiChar; const Index: Integer = 1): Integer; -function CharIPos(const S: AnsiString; C: AnsiChar; const Index: Integer = 1 ): Integer; +function CharIPos(const S: AnsiString; C: AnsiChar; const Index: Integer = 1): Integer; function CharReplace(var S: AnsiString; const Search, Replace: AnsiChar): Integer; {$IFNDEF CLR} @@ -326,9 +326,9 @@ procedure StrIToStrings(S, Sep: AnsiString; const List: TStrings; const AllowEmptyString: Boolean = True); procedure StrToStrings(S, Sep: AnsiString; const List: TStrings; const AllowEmptyString: Boolean = True); function StringsToStr(const List: TStrings; const Sep: AnsiString; const AllowEmptyString: Boolean = True): AnsiString; -procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True ); +procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True); procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean = True); -procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean = True ); +procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean = True); function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean; // Miscellaneous @@ -345,7 +345,7 @@ {$ENDIF ~CLR} function StrToFloatSafe(const S: AnsiString): Float; function StrToIntSafe(const S: AnsiString): Integer; -procedure StrNormIndex(const StrLen: integer; var Index: integer; var Count: integer); overload; +procedure StrNormIndex(const StrLen: Integer; var Index: Integer; var Count: Integer); overload; {$IFDEF CLR} function ArrayOf(List: TStrings): TDynStringArray; overload; @@ -884,7 +884,7 @@ function StrEnsureNoPrefix(const Prefix, Text: AnsiString): AnsiString; var - PrefixLen : Integer; + PrefixLen: Integer; begin PrefixLen := Length(Prefix); if Copy(Text, 1, PrefixLen) = Prefix then @@ -895,8 +895,8 @@ function StrEnsureNoSuffix(const Suffix, Text: AnsiString): AnsiString; var - SuffixLen : Integer; - StrLength : Integer; + SuffixLen: Integer; + StrLength: Integer; begin SuffixLen := Length(Suffix); StrLength := Length(Text); @@ -959,7 +959,7 @@ end; end; - if val > 255 then + if Val > 255 then {$IFDEF CLR} raise EJclStringError.Create(RsNumericConstantTooLarge); {$ELSE} @@ -1364,10 +1364,10 @@ SourceMatchPtr: PAnsiChar; { pointers into S and Search when first character has } SearchMatchPtr: PAnsiChar; { been matched and we're probing for a complete match } ResultPtr: PAnsiChar; { pointer into Result of character being written } - ResultIndex, - SearchLength, { length of search string } - ReplaceLength, { length of replace string } - BufferLength, { length of temporary result buffer } + ResultIndex: Integer; + SearchLength: Integer; { length of search string } + ReplaceLength: Integer; { length of replace string } + BufferLength: Integer; { length of temporary result buffer } ResultLength: Integer; { length of result string } C: AnsiChar; { first character of search string } IgnoreCase: Boolean; @@ -1565,13 +1565,13 @@ function StrSmartCase(const S: AnsiString; Delimiters: TSysCharSet): AnsiString; var -{$IFDEF CLR} + {$IFDEF CLR} Index: Integer; LenS: Integer; -{$ELSE} + {$ELSE} Source, Dest: PAnsiChar; Index, Len: Integer; -{$ENDIF CLR} + {$ENDIF CLR} begin Result := ''; if Delimiters = [] then @@ -1593,7 +1593,7 @@ UniqueString(Result); Len := Length(S); - Source := PAnsiChar(S); + Source := PAnsiChar(S); Dest := PAnsiChar(Result); Inc(Dest); @@ -1640,7 +1640,7 @@ else // Characters < ' ' are escaped with hex sequence if S[I] < #32 then - Result := Result + Format('\x%.2x',[Integer(S[I])]) + Result := Result + Format('\x%.2x', [Integer(S[I])]) else Result := Result + S[I]; end; @@ -1706,7 +1706,8 @@ begin I := 1; L := Length(S); - while (I <= L) and (S[I] = C) do Inc(I); + while (I <= L) and (S[I] = C) do + Inc(I); Result := Copy(S, I, L - I + 1); end; @@ -1716,7 +1717,8 @@ begin I := 1; L := Length(S); - while (I <= L) and (S[I] in Chars) do Inc(I); + while (I <= L) and (S[I] in Chars) do + Inc(I); Result := Copy(S, I, L - I + 1); end; @@ -1725,7 +1727,8 @@ I: Integer; begin I := Length(S); - while (I >= 1) and (S[I] in Chars) do Dec(I); + while (I >= 1) and (S[I] in Chars) do + Dec(I); Result := Copy(S, 1, I); end; @@ -1734,7 +1737,8 @@ I: Integer; begin I := Length(S); - while (I >= 1) and (S[I] = C) do Dec(I); + while (I >= 1) and (S[I] = C) do + Dec(I); Result := Copy(S, 1, I); end; @@ -1845,7 +1849,8 @@ Foo: AnsiString; begin case StrRefCount(S) of - -1, 0: { nothing } ; + -1, 0: + { nothing } ; 1: begin Finalize(S); @@ -2250,22 +2255,22 @@ {$IFDEF CLR} function StrFillChar(const C: Char; Count: Integer): string; var - sb: System.Text.StringBuilder; + SB: System.Text.StringBuilder; begin - sb := System.Text.StringBuilder.Create(Count); + SB := System.Text.StringBuilder.Create(Count); while Count > 0 do begin - sb.Append(C); + SB.Append(C); Dec(Count); end; - Result := sb.ToString(); + Result := SB.ToString; end; {$ENDIF CLR} {$IFDEF CLR} function StrFind(const Substr, S: AnsiString; const Index: Integer): Integer; begin - Result := System.String(S).ToLower().IndexOf(System.String(SubStr).ToLower(), Index - 1) + 1; + Result := System.String(S).ToLower().IndexOf(System.String(SubStr).ToLower, Index - 1) + 1; end; {$ELSE} function StrFind(const Substr, S: AnsiString; const Index: Integer): Integer; assembler; @@ -3057,7 +3062,7 @@ L: Integer; begin PosStart := Pos(Start, S); - PosEnd := StrSearch(Stop, S, PosStart+1); // PosEnd has to be after PosStart. + PosEnd := StrSearch(Stop, S, PosStart + 1); // PosEnd has to be after PosStart. if (PosStart > 0) and (PosEnd > PosStart) then begin @@ -3083,7 +3088,7 @@ Result := Copy(S, Start, Count); end; -function StrRestOf(const S: AnsiString; N: Integer ): AnsiString; +function StrRestOf(const S: AnsiString; N: Integer): AnsiString; begin Result := Copy(S, N, (Length(S) - N + 1)); end; @@ -3097,7 +3102,7 @@ function CharEqualNoCase(const C1, C2: AnsiChar): Boolean; begin - //if they are not equal chars, may be same letter different case + // if they are not equal chars, may be same letter different case Result := (C1 = C2) or (CharIsAlpha(C1) and CharIsAlpha(C2) and (CharLower(C1) = CharLower(C2))); end; @@ -3293,22 +3298,18 @@ function CharLastPos(const S: AnsiString; const C: AnsiChar; const Index: Integer): Integer; begin if (Index > 0) and (Index <= Length(S)) then - begin for Result := Length(S) downto Index do if S[Result] = C then Exit; - end; Result := 0; end; function CharPos(const S: AnsiString; const C: AnsiChar; const Index: Integer): Integer; begin if (Index > 0) and (Index <= Length(S)) then - begin for Result := Index to Length(S) do if S[Result] = C then Exit; - end; Result := 0; end; @@ -3475,7 +3476,7 @@ P := StrECopyW(P, PWideChar(Source[I])); Inc(P); end; - P^:= #0; + P^ := #0; Result := Dest; end; @@ -3607,7 +3608,8 @@ end; end; -function StringsToStr(const List: TStrings; const Sep: AnsiString; const AllowEmptyString: Boolean): AnsiString; +function StringsToStr(const List: TStrings; const Sep: AnsiString; + const AllowEmptyString: Boolean): AnsiString; var I, L: Integer; begin @@ -3692,6 +3694,7 @@ end; //=== Miscellaneous ========================================================== + {$IFDEF KEEP_DEPRECATED} function BooleanToStr(B: Boolean): AnsiString; const @@ -3703,47 +3706,47 @@ function FileToString(const FileName: AnsiString): AnsiString; var - fs: TFileStream; + FS: TFileStream; Len: Integer; {$IFDEF CLR} Buf: array of Byte; {$ENDIF CLR} begin - fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try - Len := fs.Size; + Len := FS.Size; SetLength(Result, Len); if Len > 0 then {$IFDEF CLR} begin SetLength(Buf, Len); - fs.ReadBuffer(Buf, Len); + FS.ReadBuffer(Buf, Len); Result := Buf; end; {$ELSE} - fs.ReadBuffer(Result[1], Len); + FS.ReadBuffer(Result[1], Len); {$ENDIF CLR} finally - fs.Free; + FS.Free; end; end; procedure StringToFile(const FileName: AnsiString; const Contents: AnsiString); var - fs: TFileStream; + FS: TFileStream; Len: Integer; begin - fs := TFileStream.Create(FileName, fmCreate); + FS := TFileStream.Create(FileName, fmCreate); try Len := Length(Contents); if Len > 0 then {$IFDEF CLR} - fs.WriteBuffer(BytesOf(Contents), Len); + FS.WriteBuffer(BytesOf(Contents), Len); {$ELSE} - fs.WriteBuffer(Contents[1], Len); + FS.WriteBuffer(Contents[1], Len); {$ENDIF CLR} finally - fs.Free; + FS.Free; end; end; @@ -3765,6 +3768,7 @@ end; {$IFNDEF CLR} + procedure StrTokens(const S: AnsiString; const List: TStrings); var Start: PAnsiChar; @@ -3841,7 +3845,7 @@ Exit; end else - while (S^ in [AnsiSpace, AnsiLineFeed, AnsiCarriageReturn]) do + while S^ in [AnsiSpace, AnsiLineFeed, AnsiCarriageReturn] do Inc(S); end; else @@ -3851,6 +3855,7 @@ end; end; end; + {$ENDIF ~CLR} function StrToFloatSafe(const S: AnsiString): Float; @@ -3908,8 +3913,8 @@ if Temp[I] = DecSep then Temp[I] := ThouSep else - if Temp[I] = ThouSep then - Temp[I] := DecSep; + if Temp[I] = ThouSep then + Temp[I] := DecSep; end; Temp := StrKeepChars(Temp, AnsiDecDigits + [DecSep]); @@ -3918,7 +3923,7 @@ begin if Temp[1] = DecSep then Temp := '0' + Temp; - if Temp[length(Temp)] = DecSep then + if Temp[Length(Temp)] = DecSep then Temp := Temp + '0'; Result := StrToFloat(Temp); if IsNegative then @@ -3933,10 +3938,10 @@ Result := Trunc(StrToFloatSafe(S)); end; -procedure StrNormIndex(const StrLen: integer; var Index: integer; var Count: integer); overload; +procedure StrNormIndex(const StrLen: Integer; var Index: Integer; var Count: Integer); overload; begin - Index := Max(1, Min(Index, StrLen+1)); - Count := Max(0, Min(Count, StrLen+1 - Index)); + Index := Max(1, Min(Index, StrLen + 1)); + Count := Max(0, Min(Count, StrLen + 1 - Index)); end; {$IFDEF CLR} Modified: trunk/jcl/source/common/JclArrayLists.pas =================================================================== --- trunk/jcl/source/common/JclArrayLists.pas 2006-07-16 15:14:39 UTC (rev 1689) +++ trunk/jcl/source/common/JclArrayLists.pas 2006-07-23 05:35:54 UTC (rev 1690) @@ -221,9 +221,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} // inlined FOwnList.Add if FOwnList.FSize = FOwnList.Capacity then FOwnList.Grow; @@ -243,9 +243,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := FOwnList.FElementData[FCursor]; end; @@ -265,9 +265,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := FOwnList.FElementData[FCursor]; //FLastRet := FCursor; Inc(FCursor); @@ -284,9 +284,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Dec(FCursor); //FLastRet := FCursor; Result := FOwnList.FElementData[FCursor]; @@ -303,9 +303,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} with FOwnList do begin FElementData[FCursor] := nil; // Force Release @@ -326,9 +326,9 @@ if FLastRet = -1 then raise EJclIllegalState.Create(SIllegalState); } -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} FOwnList.FElementData[FCursor] := AInterface; end; @@ -386,9 +386,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} // inlined FOwnList.Add if FOwnList.FSize = FOwnList.Capacity then FOwnList.Grow; @@ -408,9 +408,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := FOwnList.FElementData[FCursor]; end; @@ -430,9 +430,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := FOwnList.FElementData[FCursor]; //FLastRet := FCursor; Inc(FCursor); @@ -449,9 +449,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Dec(FCursor); //FLastRet := FCursor; Result := FOwnList.FElementData[FCursor]; @@ -468,9 +468,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} with FOwnList do begin FElementData[FCursor] := ''; // Force Release @@ -491,9 +491,9 @@ if FLastRet = -1 then raise EJclIllegalState.Create(SIllegalState); } -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} FOwnList.FElementData[FCursor] := AString; end; @@ -551,9 +551,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} // inlined FOwnList.Add if FOwnList.FSize = FOwnList.Capacity then FOwnList.Grow; @@ -573,9 +573,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := FOwnList.FElementData[FCursor]; end; @@ -595,9 +595,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := FOwnList.FElementData[FCursor]; //FLastRet := FCursor; Inc(FCursor); @@ -614,9 +614,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Dec(FCursor); //FLastRet := FCursor; Result := FOwnList.FElementData[FCursor]; @@ -633,9 +633,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} with FOwnList do begin FreeObject(FElementData[FCursor]); @@ -652,9 +652,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} FOwnList.FElementData[FCursor] := AObject; end; @@ -697,9 +697,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if (Index < 0) or (Index > FSize) then {$IFDEF CLR} raise EJclOutOfBoundsError.Create(RsEOutOfBounds); @@ -718,13 +718,13 @@ var It: IJclIntfIterator; Size: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if (Index < 0) or (Index >= FSize) then {$IFDEF CLR} @@ -754,9 +754,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if FSize = Capacity then Grow; {$IFNDEF CLR} @@ -770,13 +770,13 @@ function TJclIntfArrayList.AddAll(ACollection: IJclIntfCollection): Boolean; var It: IJclIntfIterator; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if ACollection = nil then Exit; @@ -798,13 +798,13 @@ procedure TJclIntfArrayList.Clear; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} for I := 0 to FSize - 1 do FElementData[I] := nil; FSize := 0; @@ -822,13 +822,13 @@ function TJclIntfArrayList.Contains(AInterface: IInterface): Boolean; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if AInterface = nil then Exit; @@ -843,13 +843,13 @@ function TJclIntfArrayList.ContainsAll(ACollection: IJclIntfCollection): Boolean; var It: IJclIntfIterator; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := True; if ACollection = nil then Exit; @@ -862,13 +862,13 @@ var I: Integer; It: IJclIntfIterator; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if ACollection = nil then Exit; @@ -887,9 +887,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if (Index < 0) or (Index >= FSize) then Result := nil else @@ -915,7 +915,8 @@ begin if Capacity > 64 then Capacity := Capacity + Capacity div 4 - else if FCapacity = 0 then + else + if FCapacity = 0 then FCapacity := 64 else Capacity := Capacity * 4; @@ -924,13 +925,13 @@ function TJclIntfArrayList.IndexOf(AInterface: IInterface): Integer; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := -1; if AInterface = nil then Exit; @@ -965,13 +966,13 @@ function TJclIntfArrayList.LastIndexOf(AInterface: IInterface): Integer; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := -1; if AInterface = nil then Exit; @@ -986,13 +987,13 @@ function TJclIntfArrayList.Remove(AInterface: IInterface): Boolean; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if AInterface = nil then Exit; @@ -1013,9 +1014,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if (Index < 0) or (Index >= FSize) then {$IFDEF CLR} raise EJclOutOfBoundsError.Create(RsEOutOfBounds); @@ -1032,13 +1033,13 @@ function TJclIntfArrayList.RemoveAll(ACollection: IJclIntfCollection): Boolean; var It: IJclIntfIterator; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := True; if ACollection = nil then Exit; @@ -1050,13 +1051,13 @@ function TJclIntfArrayList.RetainAll(ACollection: IJclIntfCollection): Boolean; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if ACollection = nil then Exit; @@ -1071,9 +1072,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if (Index < 0) or (Index >= FSize) then {$IFDEF CLR} raise EJclOutOfBoundsError.Create(RsEOutOfBounds); @@ -1092,13 +1093,13 @@ var I: Integer; Last: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Last := First + Count - 1; if Last >= FSize then Last := FSize - 1; @@ -1146,9 +1147,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if (Index < 0) or (Index > FSize) then {$IFDEF CLR} raise EJclOutOfBoundsError.Create(RsEOutOfBounds); @@ -1167,13 +1168,13 @@ var It: IJclStrIterator; Size: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if (Index < 0) or (Index >= FSize) then @@ -1208,9 +1209,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if FSize = Capacity then Grow; {$IFNDEF CLR} @@ -1224,13 +1225,13 @@ function TJclStrArrayList.AddAll(ACollection: IJclStrCollection): Boolean; var It: IJclStrIterator; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if ACollection = nil then Exit; @@ -1253,13 +1254,13 @@ procedure TJclStrArrayList.Clear; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} for I := 0 to FSize - 1 do FElementData[I] := ''; FSize := 0; @@ -1277,13 +1278,13 @@ function TJclStrArrayList.Contains(const AString: string): Boolean; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if AString = '' then Exit; @@ -1298,32 +1299,32 @@ function TJclStrArrayList.ContainsAll(ACollection: IJclStrCollection): Boolean; var It: IJclStrIterator; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := True; if ACollection = nil then Exit; It := ACollection.First; while Result and It.HasNext do - Result := contains(It.Next); + Result := Contains(It.Next); end; function TJclStrArrayList.Equals(ACollection: IJclStrCollection): Boolean; var I: Integer; It: IJclStrIterator; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if ACollection = nil then Exit; @@ -1347,9 +1348,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if (Index < 0) or (Index >= FSize) then Result := '' else @@ -1375,7 +1376,8 @@ begin if Capacity > 64 then Capacity := Capacity + Capacity div 4 - else if FCapacity = 0 then + else + if FCapacity = 0 then FCapacity := 64 else Capacity := Capacity * 4; @@ -1384,13 +1386,13 @@ function TJclStrArrayList.IndexOf(const AString: string): Integer; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := -1; if AString = '' then Exit; @@ -1420,13 +1422,13 @@ function TJclStrArrayList.LastIndexOf(const AString: string): Integer; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := -1; if AString = '' then Exit; @@ -1441,13 +1443,13 @@ function TJclStrArrayList.Remove(const AString: string): Boolean; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if AString = '' then Exit; @@ -1468,9 +1470,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if (Index < 0) or (Index >= FSize) then {$IFDEF CLR} raise EJclOutOfBoundsError.Create(RsEOutOfBounds); @@ -1487,13 +1489,13 @@ function TJclStrArrayList.RemoveAll(ACollection: IJclStrCollection): Boolean; var It: IJclStrIterator; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := True; if ACollection = nil then Exit; @@ -1505,13 +1507,13 @@ function TJclStrArrayList.RetainAll(ACollection: IJclStrCollection): Boolean; var I: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Result := False; if ACollection = nil then Exit; @@ -1526,9 +1528,9 @@ CS: IInterface; {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} if (Index < 0) or (Index >= FSize) then {$IFDEF CLR} raise EJclOutOfBoundsError.Create(RsEOutOfBounds); @@ -1547,13 +1549,13 @@ var I: Integer; Last: Integer; -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS: IInterface; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} begin -{$IFDEF THREADSAFE} + {$IFDEF THREADSAFE} CS := EnterCriticalSection; -{$ENDIF THREADSAFE} + {$ENDIF THREADSAFE} Last := First + Count - 1; if Last >= FSize then Last := FSize - 1; @@ -1603,9 +1605,9 @@ C... [truncated message content] |
|
From: <mar...@us...> - 2006-07-24 05:35:30
|
Revision: 1694 Author: marquardt Date: 2006-07-23 22:34:39 -0700 (Sun, 23 Jul 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1694&view=rev Log Message: ----------- style cleaned unitversioning entries Modified Paths: -------------- trunk/jcl/source/common/Jcl8087.pas trunk/jcl/source/common/JclAbstractContainers.pas trunk/jcl/source/common/JclAlgorithms.pas trunk/jcl/source/common/JclAnsiStrings.pas trunk/jcl/source/common/JclArrayLists.pas trunk/jcl/source/common/JclArraySets.pas trunk/jcl/source/common/JclBase.pas trunk/jcl/source/common/JclBinaryTrees.pas trunk/jcl/source/common/JclBorlandTools.pas trunk/jcl/source/common/JclComplex.pas trunk/jcl/source/common/JclCompression.pas trunk/jcl/source/common/JclContainerIntf.pas trunk/jcl/source/common/JclCounter.pas trunk/jcl/source/common/JclDateTime.pas trunk/jcl/source/common/JclExprEval.pas trunk/jcl/source/common/JclFileUtils.pas trunk/jcl/source/common/JclHashMaps.pas trunk/jcl/source/common/JclHashSets.pas trunk/jcl/source/common/JclIniFiles.pas trunk/jcl/source/common/JclLinkedLists.pas trunk/jcl/source/common/JclLogic.pas trunk/jcl/source/common/JclMIDI.pas trunk/jcl/source/common/JclMath.pas trunk/jcl/source/common/JclMime.pas trunk/jcl/source/common/JclPCRE.pas trunk/jcl/source/common/JclQueues.pas trunk/jcl/source/common/JclRTTI.pas trunk/jcl/source/common/JclResources.pas trunk/jcl/source/common/JclSchedule.pas trunk/jcl/source/common/JclStacks.pas trunk/jcl/source/common/JclStatistics.pas trunk/jcl/source/common/JclStrHashMap.pas trunk/jcl/source/common/JclStreams.pas trunk/jcl/source/common/JclStrings.pas trunk/jcl/source/common/JclSysInfo.pas trunk/jcl/source/common/JclSysUtils.pas trunk/jcl/source/common/JclUnitConv.pas trunk/jcl/source/common/JclValidation.pas trunk/jcl/source/common/JclVectors.pas trunk/jcl/source/common/JclWideStrings.pas Modified: trunk/jcl/source/common/Jcl8087.pas =================================================================== --- trunk/jcl/source/common/Jcl8087.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/Jcl8087.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -40,7 +40,7 @@ interface {$IFDEF UNITVERSIONING} -Uses +uses JclUnitVersioning; {$ENDIF UNITVERSIONING} @@ -73,7 +73,6 @@ function Mask8087Exceptions(Exceptions: T8087Exceptions): T8087Exceptions; function Unmask8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean = True): T8087Exceptions; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -86,7 +85,6 @@ implementation - const X87ExceptBits = $3F; Modified: trunk/jcl/source/common/JclAbstractContainers.pas =================================================================== --- trunk/jcl/source/common/JclAbstractContainers.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclAbstractContainers.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -93,7 +93,6 @@ procedure LoadDelimited(const AString: string; const Separator: string = AnsiLineBreak); end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -106,7 +105,6 @@ implementation - //=== { TJclAbstractContainer } ============================================== {$IFDEF THREADSAFE} Modified: trunk/jcl/source/common/JclAlgorithms.pas =================================================================== --- trunk/jcl/source/common/JclAlgorithms.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclAlgorithms.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -31,9 +31,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} JclBase, JclContainerIntf; // function pointer types @@ -115,7 +115,6 @@ procedure Sort(AList: IJclStrList; First, Last: Integer; AComparator: TStrCompare); overload; procedure Sort(AList: IJclList; First, Last: Integer; AComparator: TCompare); overload; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -128,7 +127,6 @@ implementation - uses SysUtils; Modified: trunk/jcl/source/common/JclAnsiStrings.pas =================================================================== --- trunk/jcl/source/common/JclAnsiStrings.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclAnsiStrings.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -54,9 +54,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} {$IFDEF MSWINDOWS} Windows, {$ENDIF MSWINDOWS} @@ -358,7 +358,6 @@ type EJclStringError = EJclError; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -371,7 +370,6 @@ implementation - uses {$IFDEF CLR} System.Globalization, @@ -3985,5 +3983,4 @@ UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} - end. Modified: trunk/jcl/source/common/JclArrayLists.pas =================================================================== --- trunk/jcl/source/common/JclArrayLists.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclArrayLists.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -31,9 +31,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} Classes, JclBase, JclAbstractContainers, JclContainerIntf; @@ -164,7 +164,6 @@ property OwnsObjects: Boolean read FOwnsObjects; end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -177,7 +176,6 @@ implementation - uses SysUtils, JclResources; Modified: trunk/jcl/source/common/JclArraySets.pas =================================================================== --- trunk/jcl/source/common/JclArraySets.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclArraySets.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -31,9 +31,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} JclBase, JclAbstractContainers, JclContainerIntf, JclArrayLists; type @@ -86,7 +86,6 @@ procedure Union(ACollection: IJclCollection); end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -99,7 +98,6 @@ implementation - uses SysUtils, JclResources; Modified: trunk/jcl/source/common/JclBase.pas =================================================================== --- trunk/jcl/source/common/JclBase.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclBase.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -38,9 +38,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} {$IFDEF CLR} System.Reflection, {$ELSE} @@ -156,7 +156,7 @@ {$IFNDEF CLR} // Redefinition of PByteArray to avoid range check exceptions. type - TJclByteArray = array[0..MaxInt div SizeOf(Byte) - 1] of Byte; + TJclByteArray = array [0..MaxInt div SizeOf(Byte) - 1] of Byte; PJclByteArray = ^TJclByteArray; TBytes = Pointer; // under .NET System.pas: TBytes = array of Byte; @@ -236,7 +236,6 @@ function ByteArrayToString(const Data: TBytes; Count: Integer): string; {$ENDIF CLR} - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -249,7 +248,6 @@ implementation - uses JclResources; @@ -270,7 +268,8 @@ { Keep reference counting working } if FromIndex < ToIndex then FillChar(List[FromIndex], (ToIndex - FromIndex) * SizeOf(List[0]), 0) - else if FromIndex > ToIndex then + else + if FromIndex > ToIndex then FillChar(List[FromIndex + Count - 1], (FromIndex - ToIndex) * SizeOf(List[0]), 0); {$ENDIF CLR} end; @@ -292,7 +291,8 @@ { Keep reference counting working } if FromIndex < ToIndex then FillChar(List[FromIndex], (ToIndex - FromIndex) * SizeOf(List[0]), 0) - else if FromIndex > ToIndex then + else + if FromIndex > ToIndex then FillChar(List[FromIndex + Count - 1], (FromIndex - ToIndex) * SizeOf(List[0]), 0); {$ENDIF CLR} end; @@ -335,16 +335,16 @@ var Dest: string; ToIndex, Count: Integer); {$IFDEF CLR} var - i: Integer; + I: Integer; Buf: array of Char; begin Buf := Dest.ToCharArray; if FromIndex <= ToIndex then - for i := 0 to Count - 1 do - Buf[ToIndex + i] := Source[FromIndex + i] + for I := 0 to Count - 1 do + Buf[ToIndex + I] := Source[FromIndex + I] else - for i := Count - 1 downto 0 do - Buf[ToIndex + i] := Source[FromIndex + i]; + for I := Count - 1 downto 0 do + Buf[ToIndex + I] := Source[FromIndex + I]; Dest := System.String.Create(Buf); {$ELSE} begin @@ -505,8 +505,6 @@ end; {$ENDIF ~XPLATFORM_RTL} - - {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); Modified: trunk/jcl/source/common/JclBinaryTrees.pas =================================================================== --- trunk/jcl/source/common/JclBinaryTrees.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclBinaryTrees.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -33,9 +33,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} Classes, JclBase, JclAbstractContainers, JclAlgorithms, JclContainerIntf; Modified: trunk/jcl/source/common/JclBorlandTools.pas =================================================================== --- trunk/jcl/source/common/JclBorlandTools.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclBorlandTools.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -61,9 +61,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} {$IFDEF MSWINDOWS} Windows, MSHelpServices_TLB, @@ -824,7 +824,6 @@ procedure GetBPKFileInfo(const BPKFileName: string; out RunOnly: Boolean; const BinaryFileName: PString = nil; const Description: PString = nil); - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -837,7 +836,6 @@ implementation - uses SysConst, {$IFDEF MSWINDOWS} Modified: trunk/jcl/source/common/JclComplex.pas =================================================================== --- trunk/jcl/source/common/JclComplex.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclComplex.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -38,9 +38,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} SysUtils, JclBase, JclMath, JclResources, JclStrings; @@ -231,7 +231,6 @@ MaxTerm: Byte = 35; EpsilonSqr: Float = 1E-20; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -244,7 +243,6 @@ implementation - const MaxFracLen = 18; RectOne: TRectCoord = (X: 1.0; Y: 0.0); Modified: trunk/jcl/source/common/JclCompression.pas =================================================================== --- trunk/jcl/source/common/JclCompression.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclCompression.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -44,9 +44,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} {$IFDEF MSWINDOWS} Windows, {$ENDIF MSWINDOWS} @@ -213,7 +213,6 @@ EJclCompressionError = class(EJclError); - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -226,7 +225,6 @@ implementation - uses JclResources; Modified: trunk/jcl/source/common/JclContainerIntf.pas =================================================================== --- trunk/jcl/source/common/JclContainerIntf.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclContainerIntf.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -35,9 +35,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} Classes, JclBase; @@ -456,7 +456,6 @@ EJclIllegalArgumentError = class(EJclError); EJclOperationNotSupportedError = class(EJclError); - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -469,7 +468,6 @@ implementation - {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); Modified: trunk/jcl/source/common/JclCounter.pas =================================================================== --- trunk/jcl/source/common/JclCounter.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclCounter.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -38,9 +38,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} {$IFDEF MSWINDOWS} Windows, {$ENDIF MSWINDOWS} @@ -82,7 +82,6 @@ type EJclCounterError = class(EJclError); - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -95,7 +94,6 @@ implementation - uses SysUtils, JclResources; Modified: trunk/jcl/source/common/JclDateTime.pas =================================================================== --- trunk/jcl/source/common/JclDateTime.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclDateTime.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -53,9 +53,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} {$IFDEF CLR} System.Globalization, System.Runtime.InteropServices, {$ELSE} @@ -203,7 +203,6 @@ type EJclDateTimeError = class(EJclError); - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -216,7 +215,6 @@ implementation - const DaysInMonths: array [1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); Modified: trunk/jcl/source/common/JclExprEval.pas =================================================================== --- trunk/jcl/source/common/JclExprEval.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclExprEval.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -39,9 +39,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} SysUtils, Classes, JclBase, JclSysUtils, JclStrHashMap, JclResources; @@ -842,7 +842,6 @@ procedure Clear; end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -855,7 +854,6 @@ implementation - //=== { TExprHashContext } =================================================== constructor TExprHashContext.Create(ACaseSensitive: Boolean; AHashSize: Integer); Modified: trunk/jcl/source/common/JclFileUtils.pas =================================================================== --- trunk/jcl/source/common/JclFileUtils.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclFileUtils.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -961,7 +961,6 @@ // return the index of an item function PathListItemIndex(const List, Item: string): Integer; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -969,12 +968,11 @@ Revision: '$Revision$'; Date: '$Date$'; LogPath: 'JCL\source\common' - ); + ); {$ENDIF UNITVERSIONING} implementation - uses {$IFDEF Win32API} ShellApi, Modified: trunk/jcl/source/common/JclHashMaps.pas =================================================================== --- trunk/jcl/source/common/JclHashMaps.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclHashMaps.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -31,9 +31,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} JclBase, JclAbstractContainers, JclContainerIntf; type @@ -305,7 +305,6 @@ property OwnsObjects: Boolean read FOwnsObjects; end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -318,7 +317,6 @@ implementation - uses SysUtils, JclArrayLists, JclArraySets, JclResources; Modified: trunk/jcl/source/common/JclHashSets.pas =================================================================== --- trunk/jcl/source/common/JclHashSets.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclHashSets.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -31,9 +31,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} Classes, JclBase, JclAbstractContainers, JclContainerIntf, JclHashMaps; @@ -128,7 +128,6 @@ destructor Destroy; override; end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -141,7 +140,6 @@ implementation - {$IFDEF CLR} var GlobalRefUnique: TObject = nil; @@ -624,7 +622,6 @@ {$ENDIF UNITVERSIONING} {$ENDIF FPC} - {$IFDEF UNITVERSIONING} finalization UnregisterUnitVersion(HInstance); Modified: trunk/jcl/source/common/JclIniFiles.pas =================================================================== --- trunk/jcl/source/common/JclIniFiles.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclIniFiles.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -33,9 +33,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} SysUtils, Classes, IniFiles; // Initialization (ini) Files @@ -50,7 +50,6 @@ procedure IniReadStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings); procedure IniWriteStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings); - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -63,7 +62,6 @@ implementation - {$IFDEF CLR} type TIniFile = TMemIniFile; @@ -186,7 +184,6 @@ end; end; - {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); Modified: trunk/jcl/source/common/JclLinkedLists.pas =================================================================== --- trunk/jcl/source/common/JclLinkedLists.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclLinkedLists.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -31,9 +31,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} Classes, JclBase, JclAbstractContainers, JclContainerIntf; @@ -191,7 +191,6 @@ property OwnsObjects: Boolean read FOwnsObjects; end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -204,7 +203,6 @@ implementation - uses SysUtils, JclResources; Modified: trunk/jcl/source/common/JclLogic.pas =================================================================== --- trunk/jcl/source/common/JclLogic.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclLogic.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -47,7 +47,7 @@ interface {$IFDEF UNITVERSIONING} -Uses +uses JclUnitVersioning; {$ENDIF UNITVERSIONING} @@ -285,7 +285,6 @@ CardinalMask = Cardinal($FFFFFFFF); Int64Mask = Int64($FFFFFFFFFFFFFFFF); - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -298,7 +297,6 @@ implementation - uses JclBase; Modified: trunk/jcl/source/common/JclMIDI.pas =================================================================== --- trunk/jcl/source/common/JclMIDI.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclMIDI.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -35,9 +35,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} Classes, JclBase; @@ -360,7 +360,6 @@ function MIDISingleNoteTuningData(Key: TMIDINote; Frequency: Single): TSingleNoteTuningData; function MIDINoteToStr(Note: TMIDINote): string; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -373,7 +372,6 @@ implementation - uses SysUtils, {$IFDEF MSWINDOWS} @@ -389,7 +387,7 @@ begin raise EJclInternalError.CreateRes(@RsMidiNotImplemented); end; - {$ENDIF UNIX} +{$ENDIF UNIX} function MIDIOut(DeviceID: Cardinal = 0): IJclMIDIOut; begin Modified: trunk/jcl/source/common/JclMath.pas =================================================================== --- trunk/jcl/source/common/JclMath.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclMath.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -625,7 +625,6 @@ function SecH(const Z: TRectComplex): TRectComplex; overload; function CscH(const Z: TRectComplex): TRectComplex; overload; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -638,7 +637,6 @@ implementation - uses {$IFDEF Win32API} Windows, @@ -4459,5 +4457,4 @@ UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} - end. Modified: trunk/jcl/source/common/JclMime.pas =================================================================== --- trunk/jcl/source/common/JclMime.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclMime.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -54,9 +54,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} {$IFDEF CLR} System.Text, {$ENDIF CLR} @@ -121,7 +121,6 @@ MIME_DECODED_LINE_BREAK = MIME_ENCODED_LINE_BREAK div 4 * 3; MIME_BUFFER_SIZE = MIME_DECODED_LINE_BREAK * 3 * 4 * 4; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -134,7 +133,6 @@ implementation - // Caution: For MimeEncodeStream and all other kinds of multi-buffered // Mime encodings (i.e. Files etc.), BufferSize must be set to a multiple of 3. // Even though the implementation of the Mime decoding routines below Modified: trunk/jcl/source/common/JclPCRE.pas =================================================================== --- trunk/jcl/source/common/JclPCRE.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclPCRE.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -32,9 +32,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} {$IFDEF MSWINDOWS} Windows, {$ENDIF MSWINDOWS} @@ -92,7 +92,6 @@ property ErrorOffset: Integer read FErrorOffset; end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -105,7 +104,6 @@ implementation - uses pcre, JclResources; @@ -258,19 +256,14 @@ initialization pcre.LibNotLoadedHandler := LibNotLoadedHandler; LoadPCRE; - - {$IFDEF UNITVERSIONING} RegisterUnitVersion(HInstance, UnitVersioning); {$ENDIF UNITVERSIONING} - - finalization {$IFDEF UNITVERSIONING} UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} - UnloadPCRE; end. Modified: trunk/jcl/source/common/JclQueues.pas =================================================================== --- trunk/jcl/source/common/JclQueues.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclQueues.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -31,9 +31,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} JclBase, JclAbstractContainers, JclContainerIntf; type @@ -88,7 +88,6 @@ constructor Create(ACapacity: Integer = DefaultContainerCapacity); end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -101,7 +100,6 @@ implementation - uses JclResources; Modified: trunk/jcl/source/common/JclRTTI.pas =================================================================== --- trunk/jcl/source/common/JclRTTI.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclRTTI.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -378,7 +378,6 @@ function JclIsClass(const AnObj: TObject; const AClass: TClass): Boolean; function JclIsClassByName(const AnObj: TObject; const AClass: TClass): Boolean; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -391,7 +390,6 @@ implementation - uses {$IFDEF HAS_UNIT_RTLCONSTS} RtlConsts, @@ -3023,19 +3021,14 @@ {$IFNDEF CLR} initialization TypeList := TThreadList.Create; - {$IFDEF UNITVERSIONING} RegisterUnitVersion(HInstance, UnitVersioning); {$ENDIF UNITVERSIONING} - - finalization - {$IFDEF UNITVERSIONING} UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} - ClearInfoList; FreeAndNil(TypeList); Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclResources.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -45,7 +45,7 @@ interface {$IFDEF UNITVERSIONING} -Uses +uses JclUnitVersioning; {$ENDIF UNITVERSIONING} @@ -1734,7 +1734,6 @@ RsMidiInUnknownError = 'Unknown MIDI-In error No. %d'; RsMidiOutUnknownError = 'Unknown MIDI-Out error No. %d'; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -1747,7 +1746,6 @@ implementation - {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); Modified: trunk/jcl/source/common/JclSchedule.pas =================================================================== --- trunk/jcl/source/common/JclSchedule.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclSchedule.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -37,9 +37,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} SysUtils, JclBase; @@ -179,7 +179,6 @@ function EqualTimeStamps(const Stamp1, Stamp2: TTimeStamp): Boolean; function IsNullTimeStamp(const Stamp: TTimeStamp): Boolean; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -192,7 +191,6 @@ implementation - uses JclDateTime, JclResources; Modified: trunk/jcl/source/common/JclStacks.pas =================================================================== --- trunk/jcl/source/common/JclStacks.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclStacks.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -31,9 +31,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} JclBase, JclAbstractContainers, JclContainerIntf; type @@ -88,7 +88,6 @@ constructor Create(ACapacity: Integer = DefaultContainerCapacity); end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -101,7 +100,6 @@ implementation - //=== { TJclIntfStack } ====================================================== constructor TJclIntfStack.Create(ACapacity: Integer = DefaultContainerCapacity); Modified: trunk/jcl/source/common/JclStatistics.pas =================================================================== --- trunk/jcl/source/common/JclStatistics.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclStatistics.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -42,9 +42,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} JclBase, JclMath; type @@ -83,7 +83,6 @@ function SumSquareFloatArray(const B: TDynFloatArray): Float; function SumPairProductFloatArray(const X, Y: TDynFloatArray): Float; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -96,7 +95,6 @@ implementation - uses JclLogic, {$IFNDEF CLR} Modified: trunk/jcl/source/common/JclStrHashMap.pas =================================================================== --- trunk/jcl/source/common/JclStrHashMap.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclStrHashMap.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -34,9 +34,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} SysUtils, JclBase, JclResources; @@ -164,7 +164,6 @@ function Compare(const L, R: string): Integer; override; end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -177,7 +176,6 @@ implementation - // Case Sensitive & Insensitive Traits function TCaseSensitiveTraits.Compare(const L, R: string): Integer; begin @@ -867,18 +865,14 @@ end; initialization - {$IFDEF UNITVERSIONING} RegisterUnitVersion(HInstance, UnitVersioning); {$ENDIF UNITVERSIONING} - finalization - {$IFDEF UNITVERSIONING} UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} - FreeAndNil(GlobalCaseInsensitiveTraits); FreeAndNil(GlobalCaseSensitiveTraits); Modified: trunk/jcl/source/common/JclStreams.pas =================================================================== --- trunk/jcl/source/common/JclStreams.pas 2006-07-23 17:31:36 UTC (rev 1693) +++ trunk/jcl/source/common/JclStreams.pas 2006-07-24 05:34:39 UTC (rev 1694) @@ -31,9 +31,9 @@ interface uses -{$IFDEF UNITVERSIONING} + {$IFDEF UNITVERSIONING} JclUnitVersioning, -{$ENDIF UNITVERSIONING} + {$ENDIF UNITVERSIONING} {$IFDEF MSWINDOWS} Windows, {$ENDIF MSWINDOWS} @@ -273,7 +273,6 @@ procedure WriteSizedString(const Value: string); end; - {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -286,7 +285,6 @@ implementation - uses JclBase, JclResources; Modified: trunk/jcl/source/common/JclStrings.pas ===========... [truncated message content] |
|
From: <mar...@us...> - 2006-07-28 22:18:38
|
Revision: 1696 Author: marquardt Date: 2006-07-25 22:42:36 -0700 (Tue, 25 Jul 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1696&view=rev Log Message: ----------- IFNDEF ELSE changed to IFDEF ELSE Modified Paths: -------------- trunk/jcl/source/common/JclEDISEF.pas trunk/jcl/source/common/JclEDI_ANSIX12.pas trunk/jcl/source/common/JclFileUtils.pas Modified: trunk/jcl/source/common/JclEDISEF.pas =================================================================== --- trunk/jcl/source/common/JclEDISEF.pas 2006-07-25 05:56:46 UTC (rev 1695) +++ trunk/jcl/source/common/JclEDISEF.pas 2006-07-26 05:42:36 UTC (rev 1696) @@ -1408,12 +1408,7 @@ procedure ParseSEGSDataOfSETSDefinition(Data: string; Segment: TEDISEFSegment; SEFFile: TEDISEFFile); - {$IFNDEF CLR} - function ToPChar(const S: string): PChar; - begin - Result := PChar(S); - end; - {$ELSE} + {$IFDEF CLR} function ToPChar(const S: string): string; var I: Integer; @@ -1426,7 +1421,12 @@ end; Result := S; end; - {$ENDIF ~CLR} + {$ELSE} + function ToPChar(const S: string): PChar; + begin + Result := PChar(S); + end; + {$ENDIF CLR} var Temp: TStringList; Modified: trunk/jcl/source/common/JclEDI_ANSIX12.pas =================================================================== --- trunk/jcl/source/common/JclEDI_ANSIX12.pas 2006-07-25 05:56:46 UTC (rev 1695) +++ trunk/jcl/source/common/JclEDI_ANSIX12.pas 2006-07-26 05:42:36 UTC (rev 1696) @@ -282,8 +282,8 @@ FSESegment: TEDISegment; function GetSegment(Index: Integer): TEDISegment; procedure SetSegment(Index: Integer; Segment: TEDISegment); - procedure SetSTSegment({$IFNDEF BCB6}const {$ENDIF !BCB6}STSegment: TEDISegment); - procedure SetSESegment({$IFNDEF BCB6}const {$ENDIF !BCB6}SESegment: TEDISegment); + procedure SetSTSegment({$IFNDEF BCB6} const {$ENDIF} STSegment: TEDISegment); + procedure SetSESegment({$IFNDEF BCB6} const {$ENDIF} SESegment: TEDISegment); protected procedure InternalCreateHeaderTrailerSegments; virtual; function InternalCreateSegment: TEDISegment; virtual; @@ -703,13 +703,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := AppendEDIDataObjects(TEDIDataObjectArray(ElementArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(ElementArray)); for I := 0 to High(ElementArray) do HelpArray[I] := TEDIDataObject(ElementArray[I]); Result := AppendEDIDataObjects(HelpArray); + {$ELSE} + Result := AppendEDIDataObjects(TEDIDataObjectArray(ElementArray)); {$ENDIF CLR} end; @@ -725,11 +725,11 @@ begin FDelimiters := InternalAssignDelimiters; if not Assigned(FDelimiters) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError036); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError036); - {$ELSE} - raise EJclEDIError.Create(RsEDIError036); - {$ENDIF ~CLR} + {$ENDIF CLR} end; FData := FSegmentId; @@ -782,11 +782,11 @@ begin FDelimiters := InternalAssignDelimiters; if not Assigned(FDelimiters) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError035); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError035); - {$ELSE} - raise EJclEDIError.Create(RsEDIError035); - {$ENDIF ~CLR} + {$ENDIF CLR} end; // Continue StartPos := 1; @@ -844,13 +844,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(ElementArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(ElementArray)); for I := 0 to High(ElementArray) do HelpArray[I] := TEDIDataObject(ElementArray[I]); Result := InsertEDIDataObjects(InsertIndex, HelpArray); + {$ELSE} + Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(ElementArray)); {$ENDIF CLR} end; @@ -1003,13 +1003,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := AppendEDIDataObjects(TEDIDataObjectArray(SegmentArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(SegmentArray)); for I := 0 to High(SegmentArray) do HelpArray[I] := TEDIDataObject(SegmentArray[I]); Result := AppendEDIDataObjects(HelpArray); + {$ELSE} + Result := AppendEDIDataObjects(TEDIDataObjectArray(SegmentArray)); {$ENDIF CLR} end; @@ -1024,11 +1024,11 @@ begin FDelimiters := InternalAssignDelimiters; if not Assigned(FDelimiters) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError026); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError026); - {$ELSE} - raise EJclEDIError.Create(RsEDIError026); - {$ENDIF ~CLR} + {$ENDIF CLR} end; FData := FSTSegment.Assemble; @@ -1085,11 +1085,11 @@ begin FDelimiters := InternalAssignDelimiters; if not Assigned(FDelimiters) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError025); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError025); - {$ELSE} - raise EJclEDIError.Create(RsEDIError025); - {$ENDIF ~CLR} + {$ENDIF CLR} end; // Find the first segment StartPos := 1; @@ -1163,13 +1163,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(SegmentArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(SegmentArray)); for I := 0 to High(SegmentArray) do HelpArray[I] := TEDIDataObject(SegmentArray[I]); Result := InsertEDIDataObjects(InsertIndex, HelpArray); + {$ELSE} + Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(SegmentArray)); {$ENDIF CLR} end; @@ -1205,7 +1205,7 @@ SetEDIDataObject(Index, Segment); end; -procedure TEDITransactionSet.SetSESegment({$IFNDEF BCB6}const {$ENDIF !BCB6}SESegment: TEDISegment); +procedure TEDITransactionSet.SetSESegment({$IFNDEF BCB6} const {$ENDIF} SESegment: TEDISegment); begin FreeAndNil(FSESegment); FSESegment := SESegment; @@ -1213,7 +1213,7 @@ FSESegment.Parent := Self; end; -procedure TEDITransactionSet.SetSTSegment({$IFNDEF BCB6}const {$ENDIF !BCB6}STSegment: TEDISegment); +procedure TEDITransactionSet.SetSTSegment({$IFNDEF BCB6} const {$ENDIF} STSegment: TEDISegment); begin FreeAndNil(FSTSegment); FSTSegment := STSegment; @@ -1268,13 +1268,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := AppendEDIDataObjects(TEDIDataObjectArray(TransactionSetArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(TransactionSetArray)); for I := 0 to High(TransactionSetArray) do HelpArray[I] := TEDIDataObject(TransactionSetArray[I]); Result := AppendEDIDataObjects(HelpArray); + {$ELSE} + Result := AppendEDIDataObjects(TEDIDataObjectArray(TransactionSetArray)); {$ENDIF CLR} end; @@ -1289,11 +1289,11 @@ begin FDelimiters := InternalAssignDelimiters; if not Assigned(FDelimiters) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError020); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError020); - {$ELSE} - raise EJclEDIError.Create(RsEDIError020); - {$ENDIF ~CLR} + {$ENDIF CLR} end; FData := FGSSegment.Assemble; FGSSegment.Data := ''; @@ -1348,11 +1348,11 @@ begin FDelimiters := InternalAssignDelimiters; if not Assigned(FDelimiters) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError019); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError019); - {$ELSE} - raise EJclEDIError.Create(RsEDIError019); - {$ENDIF ~CLR} + {$ENDIF CLR} end; // Find Functional Group Header Segment StartPos := 1; @@ -1367,26 +1367,26 @@ FGSSegment.Disassemble; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError021); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError021); - {$ELSE} - raise EJclEDIError.Create(RsEDIError021); - {$ENDIF ~CLR} + {$ENDIF CLR} end -else - {$IFNDEF CLR} + else + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError022); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError022); - {$ELSE} - raise EJclEDIError.Create(RsEDIError022); - {$ENDIF ~CLR} + {$ENDIF CLR} // Search for Transaction Set Header SearchResult := StrSearch(FDelimiters.SD + TSHSegmentId + FDelimiters.ED, FData, StartPos); if SearchResult <= 0 then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError027); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError027); - {$ELSE} - raise EJclEDIError.Create(RsEDIError027); - {$ENDIF ~CLR} + {$ENDIF CLR} // Set next start position StartPos := SearchResult + FDelimiters.SDLen; // Move past the delimiter // Continue @@ -1408,18 +1408,18 @@ FEDIDataObjects[I].Disassemble; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError028); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError028); - {$ELSE} - raise EJclEDIError.Create(RsEDIError028); - {$ENDIF ~CLR} + {$ENDIF CLR} end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError029); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError029); - {$ELSE} - raise EJclEDIError.Create(RsEDIError029); - {$ENDIF ~CLR} + {$ENDIF CLR} // Set the next start position StartPos := SearchResult + FDelimiters.SDLen; // Move past the delimiter // @@ -1442,18 +1442,18 @@ FGESegment.Disassemble; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError023); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError023); - {$ELSE} - raise EJclEDIError.Create(RsEDIError023); - {$ENDIF ~CLR} + {$ENDIF CLR} end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError024); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError024); - {$ELSE} - raise EJclEDIError.Create(RsEDIError024); - {$ENDIF ~CLR} + {$ENDIF CLR} FData := ''; FState := ediDisassembled; end; @@ -1482,13 +1482,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(TransactionSetArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(TransactionSetArray)); for I := 0 to High(TransactionSetArray) do HelpArray[I] := TEDIDataObject(TransactionSetArray[I]); Result := InsertEDIDataObjects(InsertIndex, HelpArray); + {$ELSE} + Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(TransactionSetArray)); {$ENDIF CLR} end; @@ -1590,13 +1590,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := AppendEDIDataObjects(TEDIDataObjectArray(FunctionalGroupArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(FunctionalGroupArray)); for I := 0 to High(FunctionalGroupArray) do HelpArray[I] := TEDIDataObject(FunctionalGroupArray[I]); Result := AppendEDIDataObjects(HelpArray); + {$ELSE} + Result := AppendEDIDataObjects(TEDIDataObjectArray(FunctionalGroupArray)); {$ENDIF CLR} end; @@ -1609,11 +1609,11 @@ Result := ''; if not Assigned(FDelimiters) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError013); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError013); - {$ELSE} - raise EJclEDIError.Create(RsEDIError013); - {$ENDIF ~CLR} + {$ENDIF CLR} FData := FISASegment.Assemble; FISASegment.Data := ''; @@ -1664,11 +1664,11 @@ DeleteFunctionalGroups; if not Assigned(FDelimiters) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError012); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError012); - {$ELSE} - raise EJclEDIError.Create(RsEDIError012); - {$ENDIF ~CLR} + {$ENDIF CLR} StartPos := 1; // Search for Interchange Control Header @@ -1681,18 +1681,18 @@ FISASegment.Disassemble; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError014); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError014); - {$ELSE} - raise EJclEDIError.Create(RsEDIError014); - {$ENDIF ~CLR} + {$ENDIF CLR} end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError015); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError015); - {$ELSE} - raise EJclEDIError.Create(RsEDIError015); - {$ENDIF ~CLR} + {$ENDIF CLR} // Search for Functional Group Header SearchResult := StrSearch(FDelimiters.SD + FGHSegmentId + FDelimiters.ED, FData, StartPos); // Check for TA1 Segment @@ -1703,11 +1703,11 @@ SearchResult := I; end; if (SearchResult <= 0) and (not ProcessTA1) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError022); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError022); - {$ELSE} - raise EJclEDIError.Create(RsEDIError022); - {$ENDIF ~CLR} + {$ENDIF CLR} // Set next start positon StartPos := SearchResult + FDelimiters.SDLen; // Move past the delimiter // Continue @@ -1731,18 +1731,18 @@ FEDIDataObjects[I].Disassemble; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError023); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError023); - {$ELSE} - raise EJclEDIError.Create(RsEDIError023); - {$ENDIF ~CLR} + {$ENDIF CLR} end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError024); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError024); - {$ELSE} - raise EJclEDIError.Create(RsEDIError024); - {$ENDIF ~CLR} + {$ENDIF CLR} // Set next start positon StartPos := SearchResult + FDelimiters.SDLen; // Move past the delimiter // Verify the next record is a Functional Group Header @@ -1789,18 +1789,18 @@ FIEASegment.Disassemble; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError016); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError016); - {$ELSE} - raise EJclEDIError.Create(RsEDIError016); - {$ENDIF ~CLR} + {$ENDIF CLR} end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError017); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError017); - {$ELSE} - raise EJclEDIError.Create(RsEDIError017); - {$ENDIF ~CLR} + {$ENDIF CLR} FData := ''; FState := ediDisassembled; end; @@ -1834,13 +1834,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(FunctionalGroupArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(FunctionalGroupArray)); for I := 0 to High(FunctionalGroupArray) do HelpArray[I] := TEDIDataObject(FunctionalGroupArray[I]); Result := InsertEDIDataObjects(InsertIndex, HelpArray); + {$ELSE} + Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(FunctionalGroupArray)); {$ENDIF CLR} end; @@ -1928,13 +1928,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := AppendEDIDataObjects(TEDIDataObjectArray(InterchangeControlArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(InterchangeControlArray)); for I := 0 to High(InterchangeControlArray) do HelpArray[I] := TEDIDataObject(InterchangeControlArray[I]); Result := AppendEDIDataObjects(HelpArray); + {$ELSE} + Result := AppendEDIDataObjects(TEDIDataObjectArray(InterchangeControlArray)); {$ENDIF CLR} end; @@ -2019,11 +2019,11 @@ InternalDelimitersDetection(StartPos); end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError015); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError015); - {$ELSE} - raise EJclEDIError.Create(RsEDIError015); - {$ENDIF ~CLR} + {$ENDIF CLR} // Continue while (StartPos + Length(ICHSegmentId)) < Length(FData) do begin @@ -2044,18 +2044,18 @@ FEDIDataObjects[I].Disassemble; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError016); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError016); - {$ELSE} - raise EJclEDIError.Create(RsEDIError016); - {$ENDIF ~CLR} + {$ENDIF CLR} end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError017); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError017); - {$ELSE} - raise EJclEDIError.Create(RsEDIError017); - {$ENDIF ~CLR} + {$ENDIF CLR} // Set next start position, Move past the delimiter StartPos := SearchResult + FDelimiters.SDLen; // Verify the next record is an Interchange Control Header @@ -2073,11 +2073,11 @@ if foIgnoreGarbageAtEndOfFile in FEDIFileOptions then Break else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError018); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError018); - {$ELSE} - raise EJclEDIError.Create(RsEDIError018); - {$ENDIF ~CLR} + {$ENDIF CLR} end; end; FData := ''; @@ -2113,13 +2113,13 @@ I: Integer; {$ENDIF CLR} begin - {$IFNDEF CLR} - Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(InterchangeControlArray)); - {$ELSE} + {$IFDEF CLR} SetLength(HelpArray, Length(InterchangeControlArray)); for I := 0 to High(InterchangeControlArray) do HelpArray[I] := TEDIDataObject(InterchangeControlArray[I]); Result := InsertEDIDataObjects(InsertIndex, HelpArray); + {$ELSE} + Result := InsertEDIDataObjects(InsertIndex, TEDIDataObjectArray(InterchangeControlArray)); {$ENDIF CLR} end; @@ -2135,24 +2135,24 @@ begin EDIFileStream := TFileStream.Create(FFileName, fmOpenRead or fmShareDenyNone); try - {$IFNDEF CLR} - SetLength(FData, EDIFileStream.Size); - EDIFileStream.Read(Pointer(FData)^, EDIFileStream.Size); - {$ELSE} + {$IFDEF CLR} SetLength(Buf, EDIFileStream.Size); EDIFileStream.Read(Buf, EDIFileStream.Size); FData := StringOf(Buf); - {$ENDIF ~CLR} + {$ELSE} + SetLength(FData, EDIFileStream.Size); + EDIFileStream.Read(Pointer(FData)^, EDIFileStream.Size); + {$ENDIF CLR} finally EDIFileStream.Free; end; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError001); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError001); - {$ELSE} - raise EJclEDIError.Create(RsEDIError001); - {$ENDIF ~CLR} + {$ENDIF CLR} end; procedure TEDIFile.LoadFromFile(const FileName: string); @@ -2176,21 +2176,21 @@ begin EDIFileStream := TFileStream.Create(FFileName, fmCreate or fmShareDenyNone); try - {$IFNDEF CLR} + {$IFDEF CLR} + EDIFileStream.Write(BytesOf(FData), Length(FData)); + {$ELSE} EDIFileStream.Write(Pointer(FData)^, Length(FData)); - {$ELSE} - EDIFileStream.Write(BytesOf(FData), Length(FData)); - {$ENDIF ~CLR} + {$ENDIF CLR} finally EDIFileStream.Free; end; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError002); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError002); - {$ELSE} - raise EJclEDIError.Create(RsEDIError002); - {$ENDIF ~CLR} + {$ENDIF CLR} end; procedure TEDIFile.SaveToFile; @@ -2201,21 +2201,21 @@ begin EDIFileStream := TFileStream.Create(FFileName, fmCreate or fmShareDenyNone); try - {$IFNDEF CLR} + {$IFDEF CLR} + EDIFileStream.Write(BytesOf(FData), Length(FData)); + {$ELSE} EDIFileStream.Write(Pointer(FData)^, Length(FData)); - {$ELSE} - EDIFileStream.Write(BytesOf(FData), Length(FData)); - {$ENDIF ~CLR} + {$ENDIF CLR} finally EDIFileStream.Free; end; end else - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError002); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError002); - {$ELSE} - raise EJclEDIError.Create(RsEDIError002); - {$ENDIF ~CLR} + {$ENDIF CLR} end; procedure TEDIFile.SetInterchangeControl(Index: Integer; Interchange: TEDIInterchangeControl); @@ -2700,11 +2700,11 @@ begin FDelimiters := InternalAssignDelimiters; if not Assigned(FDelimiters) then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.Create(RsEDIError035); + {$ELSE} raise EJclEDIError.CreateRes(@RsEDIError035); - {$ELSE} - raise EJclEDIError.Create(RsEDIError035); - {$ENDIF ~CLR} + {$ENDIF CLR} end; SearchResult := StrSearch(FDelimiters.ED + FDelimiters.SS, FData, 1); if SearchResult <> 0 then @@ -3214,11 +3214,11 @@ for I := 0 to DataSegment.ElementCount - 1 do begin if I > J then - {$IFNDEF CLR} + {$IFDEF CLR} + raise EJclEDIError.CreateFmt(RsEDIError002, + {$ELSE} raise EJclEDIError.CreateResFmt(@RsEDIError058, - {$ELSE} - raise EJclEDIError.CreateFmt(RsEDIError002, - {$ENDIF ~CLR} + {$ENDIF CLR} [IntToStr(I), DataSegment.SegmentID, IntToStr(DataSegment.GetIndexPositionFromParent)]); DataSegment.Element[I].SpecPointer := SpecSegment.Element[I]; Modified: trunk/jcl/source/common/JclFileUtils.pas =================================================================== --- trunk/jcl/source/common/JclFileUtils.pas 2006-07-25 05:56:46 UTC (rev 1695) +++ trunk/jcl/source/common/JclFileUtils.pas 2006-07-26 05:42:36 UTC (rev 1696) @@ -233,7 +233,7 @@ {$ENDIF ~CLR} function FileBackup(const FileName: string; Move: Boolean = False): Boolean; function FileCopy(const ExistingFileName, NewFileName: string; ReplaceExisting: Boolean = False): Boolean; -function FileDelete(const FileName: string {$IFNDEF CLR}; MoveToRecycleBin: Boolean = False{$ENDIF}): Boolean; +function FileDelete(const FileName: string {$IFNDEF CLR}; MoveToRecycleBin: Boolean = False {$ENDIF}): Boolean; function FileExists(const FileName: string): Boolean; function FileMove(const ExistingFileName, NewFileName: string; ReplaceExisting: Boolean = False): Boolean; function FileRestore(const FileName: string): Boolean; @@ -2905,7 +2905,7 @@ {$ENDIF ~CLR} end; -function FileDelete(const FileName: string {$IFNDEF CLR}; MoveToRecycleBin: Boolean = False{$ENDIF}): Boolean; +function FileDelete(const FileName: string {$IFNDEF CLR}; MoveToRecycleBin: Boolean = False {$ENDIF}): Boolean; {$IFDEF CLR} begin Result := True; @@ -5582,6 +5582,7 @@ end; {$IFNDEF CLR} + procedure TJclFileEnumerator.AfterConstruction; begin inherited AfterConstruction; @@ -5616,6 +5617,7 @@ Destroy; end; end; + {$ENDIF ~CLR} procedure TJclFileEnumerator.Assign(Source: TPersistent); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <mar...@us...> - 2006-08-03 15:46:22
|
Revision: 1710 Author: marquardt Date: 2006-08-03 08:46:14 -0700 (Thu, 03 Aug 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1710&view=rev Log Message: ----------- resource strings placed in JclResources.pas and some prefixing of resourcestrings Modified Paths: -------------- trunk/jcl/source/common/JclBase.pas trunk/jcl/source/common/JclBorlandTools.pas trunk/jcl/source/common/JclResources.pas Modified: trunk/jcl/source/common/JclBase.pas =================================================================== --- trunk/jcl/source/common/JclBase.pas 2006-08-03 15:07:15 UTC (rev 1709) +++ trunk/jcl/source/common/JclBase.pas 2006-08-03 15:46:14 UTC (rev 1710) @@ -353,6 +353,7 @@ end; {$IFDEF CLR} + function GetBytesEx(const Value): TBytes; begin if TObject(Value) is TBytes then @@ -365,7 +366,7 @@ BitConverter.GetBytes(UInt32(Value)) { TODO : Add further types } else - raise EJclError.CreateFmt('GetBytesEx(): Unsupported value type: %s', [TObject(Value).GetType.FullName]); + raise EJclError.CreateFmt(RsEGetBytesExFmt, [TObject(Value).GetType.FullName]); end; procedure SetBytesEx(var Value; Bytes: TBytes); @@ -380,7 +381,7 @@ Value := BitConverter.ToUInt32(Bytes, 0) { TODO : Add further types } else - raise EJclError.CreateFmt('SetBytesEx(): Unsupported value type: %s', [TObject(Value).GetType.FullName]); + raise EJclError.CreateFmt(RsESetBytesExFmt, [TObject(Value).GetType.FullName]); end; procedure SetIntegerSet(var DestSet: TIntegerSet; Value: UInt32); Modified: trunk/jcl/source/common/JclBorlandTools.pas =================================================================== --- trunk/jcl/source/common/JclBorlandTools.pas 2006-08-03 15:07:15 UTC (rev 1709) +++ trunk/jcl/source/common/JclBorlandTools.pas 2006-08-03 15:46:14 UTC (rev 1710) @@ -1237,7 +1237,7 @@ if SameText(PackageExtension, SourceExtensionBCBPackage) then GetBPKFileInfo(PackageFileName, RunOnly, @Result) else - raise EJclBorRadException.CreateResFmt(@RsUnknownPackageExtension, [PackageExtension]); + raise EJclBorRadException.CreateResFmt(@RsEUnknownPackageExtension, [PackageExtension]); Result := PathAddSeparator(BPLPath) + Result; end; @@ -1266,7 +1266,7 @@ if SameText(ProjectExtension, SourceExtensionBCBProject) then GetBPRFileInfo(ProjectFileName, Result) else - raise EJclBorRadException.CreateResFmt(@RsUnknownProjectExtension, [ProjectExtension]); + raise EJclBorRadException.CreateResFmt(@RsEUnknownProjectExtension, [ProjectExtension]); Result := PathAddSeparator(OutputPath) + Result; end; @@ -1436,7 +1436,7 @@ S := 'bcb'; else //brBorlandDevStudio : - raise EJclBorRadException.Create('open help not present in Borland Developer Studio'); + raise EJclBorRadException.CreateRes(@RsENoOpenHelp); end; Result := Format(FormatName, [RootDir, S, VersionNumber]); end; @@ -1716,7 +1716,7 @@ procedure TJclBorRADToolIdeTool.CheckIndex(Index: Integer); begin if (Index < 0) or (Index >= Count) then - raise EJclError.CreateRes(@RsIndexOufOfRange); + raise EJclError.CreateRes(@RsEIndexOufOfRange); end; function TJclBorRADToolIdeTool.GetCount: Integer; @@ -2085,7 +2085,7 @@ procedure TJclBorlandCommandLineTool.CheckOutputValid; begin if Assigned(FOutputCallback) then - raise EJclCommandLineToolError.CreateResFmt(@RsCmdLineToolOutputInvalid, [GetExeName]); + raise EJclCommandLineToolError.CreateResFmt(@RsECmdLineToolOutputInvalid, [GetExeName]); end; function TJclBorlandCommandLineTool.Execute(const CommandLine: string): Boolean; @@ -2744,7 +2744,7 @@ OutputString(Format(RsCompilingPackage, [PackageName])); if not IsBCBPackage(PackageName) then - raise EJclBorRADException.CreateResFmt(@RsNotABCBPackage, [PackageName]); + raise EJclBorRADException.CreateResFmt(@RsENotABCBPackage, [PackageName]); PackagePath := PathRemoveSeparator(ExtractFilePath(PackageName)); SaveDir := GetCurrentDir; @@ -2785,7 +2785,7 @@ OutputString(Format(RsCompilingProject, [ProjectName])); if not IsBCBProject(ProjectName) then - raise EJclBorRADException.CreateResFmt(@RsNotADelphiProject, [ProjectName]); + raise EJclBorRADException.CreateResFmt(@RsENotADelphiProject, [ProjectName]); PackagePath := PathRemoveSeparator(ExtractFilePath(ProjectName)); SaveDir := GetCurrentDir; @@ -2832,7 +2832,7 @@ OutputString(Format(RsCompilingPackage, [PackageName])); if not IsDelphiPackage(PackageName) then - raise EJclBorRADException.CreateResFmt(@RsNotADelphiPackage, [PackageName]); + raise EJclBorRADException.CreateResFmt(@RsENotADelphiPackage, [PackageName]); if MapCreate then NewOptions := ExtraOptions + ' -GD' @@ -2860,7 +2860,7 @@ OutputString(Format(RsCompilingProject, [ProjectName])); if not IsDelphiProject(ProjectName) then - raise EJclBorRADException.CreateResFmt(@RsNotADelphiProject, [ProjectName]); + raise EJclBorRADException.CreateResFmt(@RsENotADelphiProject, [ProjectName]); if MapCreate then ExtraOptions := '-GD' @@ -2892,7 +2892,7 @@ if SameText(PackageExtension, SourceExtensionDelphiPackage) then Result := CompileDelphiPackage(PackageName, BPLPath, DCPPath) else - raise EJclBorRadException.CreateResFmt(@RsUnknownPackageExtension, [PackageExtension]); + raise EJclBorRadException.CreateResFmt(@RsEUnknownPackageExtension, [PackageExtension]); end; function TJclBorRADToolInstallation.CompileProject(const ProjectName, @@ -2907,7 +2907,7 @@ if SameText(ProjectExtension, SourceExtensionDelphiProject) then Result := CompileDelphiProject(ProjectName, OutputDir, DcpSearchPath) else - raise EJclBorRadException.CreateResFmt(@RsUnknownProjectExtension, [ProjectExtension]); + raise EJclBorRadException.CreateResFmt(@RsEUnknownProjectExtension, [ProjectExtension]); end; function TJclBorRADToolInstallation.FindFolderInPath(Folder: string; List: TStrings): Integer; @@ -2934,7 +2934,7 @@ if not Assigned(FBpr2Mak) then begin if not (clProj2Mak in CommandLineTools) then - raise EJclBorRadException.CreateResFmt(@RsNotFound, [Bpr2MakExeName]); + raise EJclBorRadException.CreateResFmt(@RsENotFound, [Bpr2MakExeName]); FBpr2Mak := TJclBpr2Mak.Create(Self); end; Result := FBpr2Mak; @@ -2945,7 +2945,7 @@ if not Assigned(FBCC32) then begin if not (clBcc32 in CommandLineTools) then - raise EJclBorRadException.CreateResFmt(@RsNotFound, [Bcc32ExeName]); + raise EJclBorRadException.CreateResFmt(@RsENotFound, [Bcc32ExeName]); FBCC32 := TJclBCC32.Create(Self); end; Result := FBCC32; @@ -2956,7 +2956,7 @@ if not Assigned(FDCC32) then begin if not (clDcc32 in CommandLineTools) then - raise EJclBorRadException.CreateResFmt(@RsNotFound, [Dcc32ExeName]); + raise EJclBorRadException.CreateResFmt(@RsENotFound, [Dcc32ExeName]); FDCC32 := TJclDCC32.Create(Self); end; Result := FDCC32; @@ -3116,7 +3116,7 @@ if not Assigned(FMake) then begin if not (clMake in CommandLineTools) then - raise EJclBorRadException.CreateResFmt(@RsNotFound, [MakeExeName]); + raise EJclBorRadException.CreateResFmt(@RsENotFound, [MakeExeName]); {$IFDEF KYLIX} FMake := TJclCommandLineTool.Create(MakeExeName); {$ELSE ~KYLIX} @@ -3208,7 +3208,7 @@ GetBPKFileInfo(PackageName, RunOnly, @BinaryFileName, @Description); BinaryFileName := PathAddSeparator(BPLPath) + BinaryFileName; if RunOnly then - raise EJclBorRadException.CreateResFmt(@RsCannotInstallRunOnly, [PackageName]); + raise EJclBorRadException.CreateResFmt(@RsECannotInstallRunOnly, [PackageName]); Result := CompileBCBPackage(PackageName, BPLPath, DCPPath) and RegisterIdePackage(BinaryFileName, Description); @@ -3226,7 +3226,7 @@ GetBPKFileInfo(PackageName, RunOnly, @BinaryFileName, @Description); BinaryFileName := PathAddSeparator(BPLPath) + BinaryFileName; if RunOnly then - raise EJclBorRadException.CreateResFmt(@RsCannotInstallRunOnly, [PackageName]); + raise EJclBorRadException.CreateResFmt(@RsECannotInstallRunOnly, [PackageName]); Result := CompileBCBPackage(PackageName, BPLPath, DCPPath) and RegisterPackage(BinaryFileName, Description); @@ -3263,7 +3263,7 @@ GetDPKFileInfo(PackageName, RunOnly, @LibSuffix, @Description); if RunOnly then - raise EJclBorRadException.CreateResFmt(@RsCannotInstallRunOnly, [PackageName]); + raise EJclBorRadException.CreateResFmt(@RsECannotInstallRunOnly, [PackageName]); BPLFileName := PathAddSeparator(BPLPath) + PathExtractFileNameNoExt(PackageName) + LibSuffix + BinaryExtensionPackage; @@ -3282,7 +3282,7 @@ GetDPKFileInfo(PackageName, RunOnly, @LibSuffix, @Description); if RunOnly then - raise EJclBorRadException.CreateResFmt(@RsCannotInstallRunOnly, [PackageName]); + raise EJclBorRadException.CreateResFmt(@RsECannotInstallRunOnly, [PackageName]); BPLFileName := PathAddSeparator(BPLPath) + PathExtractFileNameNoExt(PackageName) + LibSuffix + BinaryExtensionPackage; @@ -3303,7 +3303,7 @@ if SameText(ProjectExtension, SourceExtensionDelphiProject) then Result := InstallDelphiExpert(ProjectName, OutputDir, DcpSearchPath) else - raise EJclBorRADException.CreateResFmt(@RsUnknownProjectExtension, [ProjectExtension]); + raise EJclBorRADException.CreateResFmt(@RsEUnknownProjectExtension, [ProjectExtension]); end; function TJclBorRADToolInstallation.InstallIDEPackage(const PackageName, BPLPath, DCPPath: string): Boolean; @@ -3317,7 +3317,7 @@ if SameText(PackageExtension, SourceExtensionDelphiPackage) then Result := InstallDelphiIdePackage(PackageName, BPLPath, DCPPath) else - raise EJclBorRADException.CreateResFmt(@RsUnknownIdePackageExtension, [PackageExtension]); + raise EJclBorRADException.CreateResFmt(@RsEUnknownIdePackageExtension, [PackageExtension]); end; function TJclBorRADToolInstallation.InstallPackage(const PackageName, BPLPath, DCPPath: string): Boolean; @@ -3331,7 +3331,7 @@ if SameText(PackageExtension, SourceExtensionDelphiPackage) then Result := InstallDelphiPackage(PackageName, BPLPath, DCPPath) else - raise EJclBorRADException.CreateResFmt(@RsUnknownPackageExtension, [PackageExtension]); + raise EJclBorRADException.CreateResFmt(@RsEUnknownPackageExtension, [PackageExtension]); end; {$IFDEF KEEP_DEPRECATED} @@ -3688,7 +3688,7 @@ OutputString(Format(RsExpertUninstallationStarted, [ProjectName])); if not IsBCBProject(ProjectName) then - raise EJclBorRADException.CreateResFmt(@RsNotABCBProject, [ProjectName]); + raise EJclBorRADException.CreateResFmt(@RsENotABCBProject, [ProjectName]); GetBPRFileInfo(ProjectName, BinaryFileName); BinaryFileName := PathAddSeparator(OutputDir) + BinaryFileName; @@ -3713,7 +3713,7 @@ OutputString(Format(RsIdePackageUninstallationStarted, [PackageName])); if not IsBCBPackage(PackageName) then - raise EJclBorRADException.CreateResFmt(@RsNotABCBPackage, [PackageName]); + raise EJclBorRADException.CreateResFmt(@RsENotABCBPackage, [PackageName]); GetBPKFileInfo(PackageName, RunOnly, @BinaryFileName); @@ -3754,7 +3754,7 @@ OutputString(Format(RsPackageUninstallationStarted, [PackageName])); if not IsBCBPackage(PackageName) then - raise EJclBorRADException.CreateResFmt(@RsNotABCBPackage, [PackageName]); + raise EJclBorRADException.CreateResFmt(@RsENotABCBPackage, [PackageName]); GetBPKFileInfo(PackageName, RunOnly, @BinaryFileName); @@ -3793,7 +3793,7 @@ OutputString(Format(RsExpertUninstallationStarted, [ProjectName])); if not IsDelphiProject(ProjectName) then - raise EJclBorRADException.CreateResFmt(@RsNotADelphiProject, [ProjectName]); + raise EJclBorRADException.CreateResFmt(@RsENotADelphiProject, [ProjectName]); BaseName := PathExtractFileNameNoExt(ProjectName); GetDPRFileInfo(ProjectName, BinaryExtension, @LibSuffix); @@ -3821,7 +3821,7 @@ OutputString(Format(RsIdePackageUninstallationStarted, [PackageName])); if not IsDelphiPackage(PackageName) then - raise EJclBorRADException.CreateResFmt(@RsNotADelphiPackage, [PackageName]); + raise EJclBorRADException.CreateResFmt(@RsENotADelphiPackage, [PackageName]); GetDPKFileInfo(PackageName, RunOnly, @LibSuffix); BaseName := PathExtractFileNameNoExt(PackageName); @@ -3857,7 +3857,7 @@ OutputString(Format(RsPackageUninstallationStarted, [PackageName])); if not IsDelphiPackage(PackageName) then - raise EJclBorRADException.CreateResFmt(@RsNotADelphiPackage, [PackageName]); + raise EJclBorRADException.CreateResFmt(@RsENotADelphiPackage, [PackageName]); GetDPKFileInfo(PackageName, RunOnly, @LibSuffix); BaseName := PathExtractFileNameNoExt(PackageName); @@ -3894,7 +3894,7 @@ if SameText(ProjectExtension, SourceExtensionDelphiProject) then Result := UninstallDelphiExpert(ProjectName, OutputDir) else - raise EJclBorRadException.CreateResFmt(@RsUnknownProjectExtension, [ProjectExtension]); + raise EJclBorRadException.CreateResFmt(@RsEUnknownProjectExtension, [ProjectExtension]); end; function TJclBorRADToolInstallation.UninstallIDEPackage(const PackageName, BPLPath, DCPPath: string): Boolean; @@ -3908,7 +3908,7 @@ if SameText(PackageExtension, SourceExtensionDelphiPackage) then Result := UninstallDelphiIdePackage(PackageName, BPLPath, DCPPath) else - raise EJclBorRadException.CreateResFmt(@RsUnknownIdePackageExtension, [PackageExtension]); + raise EJclBorRadException.CreateResFmt(@RsEUnknownIdePackageExtension, [PackageExtension]); end; function TJclBorRADToolInstallation.UninstallPackage(const PackageName, BPLPath, DCPPath: string): Boolean; @@ -3922,7 +3922,7 @@ if SameText(PackageExtension, SourceExtensionDelphiPackage) then Result := UninstallDelphiPackage(PackageName, BPLPath, DCPPath) else - raise EJclBorRadException.CreateResFmt(@RsUnknownPackageExtension, [PackageExtension]); + raise EJclBorRadException.CreateResFmt(@RsEUnknownPackageExtension, [PackageExtension]); end; function TJclBorRADToolInstallation.UnregisterExpert(const BinaryFileName: string): Boolean; @@ -4113,7 +4113,7 @@ Include(FPersonalities, bpDelphi32); if FPersonalities = [] then - raise EJclBorRadException.CreateRes(@RsNoSupportedPersonality); + raise EJclBorRadException.CreateRes(@RsENoSupportedPersonality); end; destructor TJclBDSInstallation.Destroy; @@ -4185,7 +4185,7 @@ if DualPackageInstallation then begin if not (bpBCBuilder32 in Personalities) then - raise EJclBorRadException.CreateResFmt(@RsDualPackageNotSupported, [Name]); + raise EJclBorRadException.CreateResFmt(@RsEDualPackageNotSupported, [Name]); NewOptions := Format('%s -JL -NB"%s" -NO"%s" -N1"%s"', [ExtraOptions, DcpPath, DcpPath, VclIncludeDir]); @@ -4205,7 +4205,7 @@ OutputString(Format(RsCompilingProject, [ProjectName])); if not IsDelphiProject(ProjectName) then - raise EJclBorRADException.CreateResFmt(@RsNotADelphiProject, [ProjectName]); + raise EJclBorRADException.CreateResFmt(@RsENotADelphiProject, [ProjectName]); if MapCreate then ExtraOptions := '-GD' @@ -4340,7 +4340,7 @@ function TJclBDSInstallation.GetVclIncludeDir: string; begin if not (bpBCBuilder32 in Personalities) then - raise EJclBorRadException.CreateResFmt(@RsDualPackageNotSupported, [Name]); + raise EJclBorRadException.CreateResFmt(@RsEDualPackageNotSupported, [Name]); Result := inherited GetVclIncludeDir; end; @@ -4416,7 +4416,7 @@ procedure TJclBDSInstallation.SetDualPackageInstallation(const Value: Boolean); begin if Value and not (bpBCBuilder32 in Personalities) then - raise EJclBorRadException.CreateResFmt(@RsDualPackageNotSupported, [Name]); + raise EJclBorRadException.CreateResFmt(@RsEDualPackageNotSupported, [Name]); FDualPackageInstallation := Value; end; Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2006-08-03 15:07:15 UTC (rev 1709) +++ trunk/jcl/source/common/JclResources.pas 2006-08-03 15:46:14 UTC (rev 1710) @@ -59,15 +59,13 @@ RsWin32Prefix = 'Win32: %s (%u)'; RsDynArrayError = 'DynArrayInitialize: ElementSize out of bounds'; RsSysErrorMessageFmt = 'Win32 Error %d (%x)'; + {$IFDEF CLR} + RsEGetBytesExFmt = 'GetBytesEx(): Unsupported value type: %s'; + RsESetBytesExFmt = 'SetBytesEx(): Unsupported value type: %s'; + {$ENDIF CLR} //=== JclBorlandTools ======================================================== resourcestring - RsNotFound = '%s not found'; - RsNotABcbPackage = '%s not a C++Builder package source file'; - RsNotABcbProject = '%s not a C++Builder project source file'; - RsNotADelphiPackage = '%s not a Delphi package source file'; - RsNotADelphiProject = '%s not a Delphi project source file'; - RsIndexOufOfRange = 'Index out of range'; RsNeedUpdate = 'You should install latest Update Pack #%d for %s'; RsUpdatePackName = 'Update Pack #%d'; RsDelphiName = 'Delphi'; @@ -92,19 +90,11 @@ RsPersonal = 'Personal'; RsProfessional = 'Professional'; - RsNoSupportedPersonality = 'No personalities supported'; - RsDualPackageNotSupported = 'This installation of %s doesn''t support dual packages'; RsCommandLineToolMissing = 'No compiler available for %s'; - RsUnknownProjectExtension = '%s not a known project extension'; - RsUnknownPackageExtension = '%s not a known package extension'; - RsUnknownIdePackageExtension = '%s not a known ide package extension'; - - RsCannotInstallRunOnly = 'A run-only package cannot be installed'; RsUnknownProjectType = '%s not a known project type'; RsBorlandStudioProjects = 'Borland Studio Projects'; - RsCmdLineToolOutputInvalid = '%s: Output invalid, when OutputCallback assigned.'; RsPackageInstallationStarted = 'Installing package %s'; RsPackageInstallationFinished = 'Installation of package finished'; @@ -145,6 +135,23 @@ RsCleaningOk = 'Cleaning ok'; RsCleaningFailed = 'Cleaning failed'; + RsEUnknownPackageExtension = '%s not a known package extension'; + RsEUnknownProjectExtension = '%s not a known project extension'; + RsEUnknownIdePackageExtension = '%s not a known IDE package extension'; + RsEIndexOufOfRange = 'Index out of range'; + RsECmdLineToolOutputInvalid = '%s: Output invalid, when OutputCallback assigned.'; + RsENotABcbPackage = '%s not a C++Builder package source file'; + RsENotADelphiProject = '%s not a Delphi project source file'; + RsENotADelphiPackage = '%s not a Delphi package source file'; + RsENotFound = '%s not found'; + RsECannotInstallRunOnly = 'A run-only package cannot be installed'; + RsENotABcbProject = '%s not a C++Builder project source file'; + RsENoSupportedPersonality = 'No personalities supported'; + RsEDualPackageNotSupported = 'This installation of %s doesn''t support dual packages'; + {$IFDEF MSWINDOWS} + RsENoOpenHelp = 'open help not present in Borland Developer Studio'; + {$ENDIF MSWINDOWS} + //=== JclCIL ================================================================= resourcestring RsInstructionStreamInvalid = 'Invalid IL instruction stream'; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <ou...@us...> - 2006-08-10 10:28:46
|
Revision: 1716 Author: outchy Date: 2006-08-10 03:28:29 -0700 (Thu, 10 Aug 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1716&view=rev Log Message: ----------- removed invalid mime-type Property Changed: ---------------- trunk/jcl/examples/windows/debug/reportconverter/ExceptionReportConverter.dpr trunk/jcl/examples/windows/debug/reportconverter/formConverter.dfm trunk/jcl/examples/windows/debug/reportconverter/formConverter.pas trunk/jcl/source/common/JclStreams.pas Property changes on: trunk/jcl/examples/windows/debug/reportconverter/ExceptionReportConverter.dpr ___________________________________________________________________ Name: svn:mime-type - text/plain Property changes on: trunk/jcl/examples/windows/debug/reportconverter/formConverter.dfm ___________________________________________________________________ Name: svn:mime-type - text/plain Property changes on: trunk/jcl/examples/windows/debug/reportconverter/formConverter.pas ___________________________________________________________________ Name: svn:mime-type - text/plain Property changes on: trunk/jcl/source/common/JclStreams.pas ___________________________________________________________________ Name: svn:mime-type - text/plain This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <ou...@us...> - 2006-08-14 20:36:06
|
Revision: 1731 Author: outchy Date: 2006-08-14 13:35:43 -0700 (Mon, 14 Aug 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1731&view=rev Log Message: ----------- bug fixes submitted by Mario R. Carro Update to PCRE 6.7 Modified Paths: -------------- trunk/jcl/source/common/JclPCRE.pas trunk/jcl/source/common/JclResources.pas trunk/jcl/source/common/pcre.pas Modified: trunk/jcl/source/common/JclPCRE.pas =================================================================== --- trunk/jcl/source/common/JclPCRE.pas 2006-08-11 19:34:03 UTC (rev 1730) +++ trunk/jcl/source/common/JclPCRE.pas 2006-08-14 20:35:43 UTC (rev 1731) @@ -17,13 +17,15 @@ { } { Contributor(s): } { Robert Rossmair (rrossmair) } +{ Mario R. Carro } +{ Florent Ouchet (outchy) } { } {**************************************************************************************************} { } { Class wrapper for PCRE (PERL Compatible Regular Expression) } { } { Unit owner: Peter Th\xF6rnqvist } -{ Last modified: $Date$ } +{ Last modified: $Date$ } { } {**************************************************************************************************} @@ -56,7 +58,10 @@ PPCREIntArray = ^TPCREIntArray; TJclAnsiRegExOption = (roIgnoreCase, roMultiLine, roDotAll, roExtended, - roAnchored, roDollarEndOnly, roExtra, roNotBOL, roNotEOL, roUnGreedy, roNotEmpty, roUTF8); + roAnchored, roDollarEndOnly, roExtra, roNotBOL, roNotEOL, roUnGreedy, + roNotEmpty, roUTF8, roNoAutoCapture, roNoUTF8Check, roAutoCallout, + roPartial, roDfaShortest, roDfaRestart, roDfaFirstLine, roDupNames, + roNewLineCR, roNewLineLF); TJclAnsiRegExOptions = set of TJclAnsiRegExOption; TJclAnsiCaptureOffset = record FirstPos: Integer; @@ -75,6 +80,7 @@ FStringCount: Integer; FVectorSize: Integer; FTables: PChar; + FMaxCaptureLength: Integer; function GetCaptureCount: Integer; function GetCaptures(Index: Integer): AnsiString; function GetAPIOptions(RunTime: Boolean): Integer; @@ -90,6 +96,7 @@ property CaptureOffset[Index: Integer]: TJclAnsiCaptureOffset read GetCapturesOffset; property ErrorMessage: AnsiString read FErrorMessage; property ErrorOffset: Integer read FErrorOffset; + property MaxCaptureLength: Integer read FMaxCaptureLength write FMaxCaptureLength; end; {$IFDEF UNITVERSIONING} @@ -108,6 +115,16 @@ pcre, JclResources; +function JclPCREGetMem(Size: Integer): Pointer; cdecl; +begin + GetMem(Result, Size); +end; + +procedure JclPCREFreeMem(P: Pointer); cdecl; +begin + FreeMem(P); +end; + function PCRECheck(Value: Integer): Boolean; var PErr: PResStringRec; @@ -129,6 +146,34 @@ PErr := @RsErrNoMemory; PCRE_ERROR_NOSUBSTRING: PErr := @RsErrNoSubString; + PCRE_ERROR_MATCHLIMIT: + PErr := @RsErrMatchLimit; + PCRE_ERROR_CALLOUT: + PErr := @RsErrCallout; + PCRE_ERROR_BADUTF8: + PErr := @RsErrBadUTF8; + PCRE_ERROR_BADUTF8_OFFSET: + PErr := @RsErrBadUTF8Offset; + PCRE_ERROR_PARTIAL: + PErr := @RsErrPartial; + PCRE_ERROR_BADPARTIAL: + PErr := @RsErrBadPartial; + PCRE_ERROR_INTERNAL: + PErr := @RsErrInternal; + PCRE_ERROR_BADCOUNT: + PErr := @RsErrBadCount; + PCRE_ERROR_DFA_UITEM: + PErr := @RsErrDfaUItem; + PCRE_ERROR_DFA_UCOND: + PErr := @RsErrDfaUCond; + PCRE_ERROR_DFA_UMLIMIT: + PErr := @RsErrDfaUMLimit; + PCRE_ERROR_DFA_WSSIZE: + PErr := @RsErrDfaWSSize; + PCRE_ERROR_DFA_RECURSE: + PErr := @RsErrDfaRecurse; + PCRE_ERROR_RECURSIONLIMIT: + PErr := @RsErrRecursionLimit; else Result := True; end; @@ -141,17 +186,17 @@ constructor TJclAnsiRegEx.Create; begin inherited Create; + FMaxCaptureLength := 1024; FVectorSize := SizeOf(FVector) div SizeOf(Integer); end; destructor TJclAnsiRegEx.Destroy; begin - (* - if FCode <> nil then - pcre_free(FCode); - if FExtra <> nil then - pcre_free(FExtra); - *) + if FCode <> nil then + pcre_free^(FCode); + if FExtra <> nil then + pcre_free^(FExtra); + inherited Destroy; end; @@ -166,22 +211,34 @@ FTables := nil; if Pattern = '' then raise EPCREError.CreateRes(@RsErrNull, PCRE_ERROR_NULL); + if FCode <> nil then pcre_free^(FCode); FCode := pcre_compile(PChar(Pattern), GetAPIOptions(False), @ErrPtr, @ErrOffset, FTables); FErrorMessage := ErrPtr; FErrorOffset := ErrOffset; Result := (FCode <> nil); if Result and Study then + begin + if FExtra <> nil then pcre_free^(FExtra); FExtra := pcre_study(FCode, 0, @ErrPtr); + end; end; function TJclAnsiRegEx.GetAPIOptions(RunTime: Boolean): Integer; const + { roIgnoreCase, roMultiLine, roDotAll, roExtended, + roAnchored, roDollarEndOnly, roExtra, roNotBOL, roNotEOL, roUnGreedy, + roNotEmpty, roUTF8, roNoAutoCapture, roNoUTF8Check, roAutoCallout, + roPartial, roDfaShortest, roDfaRestart, roDfaFirstLine, roDupNames, + roNewLineCR, roNewLineLF } cDesignOptions: array [TJclAnsiRegExOption] of Integer = - (PCRE_CASELESS, PCRE_MULTILINE, PCRE_DOTALL, PCRE_EXTENDED, PCRE_ANCHORED, PCRE_DOLLAR_ENDONLY, - PCRE_EXTRA, 0, 0, PCRE_UNGREEDY, 0, PCRE_UTF8); + (PCRE_CASELESS, PCRE_MULTILINE, PCRE_DOTALL, PCRE_EXTENDED, PCRE_ANCHORED, + PCRE_DOLLAR_ENDONLY, PCRE_EXTRA, 0, 0, PCRE_UNGREEDY, 0, PCRE_UTF8, + PCRE_NO_AUTO_CAPTURE, PCRE_NO_UTF8_CHECK, PCRE_AUTO_CALLOUT, 0, 0, 0, 0, + PCRE_DUPNAMES, PCRE_NEWLINE_CR, PCRE_NEWLINE_LF); cRunOptions: array [TJclAnsiRegExOption] of Integer = - (0, 0, 0, 0, 0, 0, - 0, PCRE_NOTBOL, PCRE_NOTEOL, 0, PCRE_NOTEMPTY, 0); + (0, 0, 0, 0, 0, 0, 0, PCRE_NOTBOL, PCRE_NOTEOL, 0, PCRE_NOTEMPTY, 0, 0, + PCRE_NO_UTF8_CHECK, 0, PCRE_PARTIAL, 0, 0, 0, 0, PCRE_NEWLINE_CR, + PCRE_NEWLINE_LF); var I: TJclAnsiRegExOption; begin @@ -208,13 +265,12 @@ function TJclAnsiRegEx.GetCaptures(Index: Integer): AnsiString; var - Buffer: array [0..1024] of Char; Len: Integer; begin - Len := pcre_copy_substring(PChar(FSubject), @FVector, FStringCount, Index, Buffer, SizeOf(Buffer)); + SetLength(Result, MaxCaptureLength); + Len := pcre_copy_substring(PChar(FSubject), @FVector, FStringCount, Index, PChar(Result), MaxCaptureLength); PCRECheck(Len); - - SetString(Result, Buffer, Len); + SetLength(Result, Len); end; function TJclAnsiRegEx.GetCapturesOffset(Index: Integer): TJclAnsiCaptureOffset; @@ -259,6 +315,8 @@ initialization pcre.LibNotLoadedHandler := LibNotLoadedHandler; LoadPCRE; + SetPCREMallocCallback(JclPCREGetMem); + SetPCREFreeCallback(JclPCREFreeMem); {$IFDEF UNITVERSIONING} RegisterUnitVersion(HInstance, UnitVersioning); {$ENDIF UNITVERSIONING} Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2006-08-11 19:34:03 UTC (rev 1730) +++ trunk/jcl/source/common/JclResources.pas 2006-08-14 20:35:43 UTC (rev 1731) @@ -1261,14 +1261,29 @@ //=== JclPCRE ================================================================ resourcestring - RsErrNoMatch = 'No match'; - RsErrNull = 'Required value is null'; - RsErrBadOption = 'Bad option'; - RsErrBadMagic = 'Bad magic'; - RsErrUnknownNode = 'Unknown node'; - RsErrNoMemory = 'Out of memory'; - RsErrNoSubString = 'No substring'; - RsErrLibNotLoaded = 'PCRE library not loaded'; + RsErrNoMatch = 'No match'; + RsErrNull = 'Required value is null'; + RsErrBadOption = 'Bad option'; + RsErrBadMagic = 'Bad magic'; + RsErrUnknownNode = 'Unknown node'; + RsErrNoMemory = 'Out of memory'; + RsErrNoSubString = 'No substring'; + RsErrMatchLimit = 'Match limit'; + RsErrCallout = 'Callout'; + RsErrBadUTF8 = 'Bad UTF-8'; + RsErrBadUTF8Offset = 'Bad UTF-8 offset'; + RsErrPartial = 'Partial'; + RsErrBadPartial = 'Bad partial'; + RsErrInternal = 'Internal'; + RsErrBadCount = 'Bad count'; + RsErrDfaUItem = 'DFA UItem'; + RsErrDfaUCond = 'DFA UCond'; + RsErrDfaUMLimit = 'DFA UMLimit'; + RsErrDfaWSSize = 'DFA WSSize'; + RsErrDfaRecurse = 'DFA Recurse'; + RsErrRecursionLimit = 'Recursion limit'; + RsErrLibNotLoaded = 'PCRE library not loaded'; + RsErrMemFuncNotSet = 'PCRE memory management functions not set'; //=== JclPeImage ============================================================= resourcestring @@ -1605,12 +1620,12 @@ RsIntelCacheDescr08 = '16KB instruction cache, 4-way set associative, 32 byte line size'; RsIntelCacheDescr0A = '8KB data cache 2-way set associative, 32 byte line size'; RsIntelCacheDescr0C = '16KB data cache, 4-way set associative, 32 byte line size'; - RsIntelCacheDescr22 = '3\xB0 Level cache, 512 KBytes, 4-way set associative, 2 lines per sector, 128 byte sector size'; - RsIntelCacheDescr23 = '3\xB0 Level cache, 1 MBytes, 8-way set associative, 2 lines per sector, 128 byte sector size'; - RsIntelCacheDescr25 = '3\xB0 Level cache, 2 MBytes, 8-way set associative, 2 lines per sector, 128 byte line size'; - RsIntelCacheDescr29 = '3\xB0 Level cache, 4M Bytes, 8-way set associative, 2 lines per sector, 128 byte line size'; - RsIntelCacheDescr2C = '1\xB0 Level data cache: 32K Bytes, 8-way set associative, 64 byte line size'; - RsIntelCacheDescr30 = '1\xB0 Level instruction cache: 32K Bytes, 8-way set associative, 64 byte line size'; + RsIntelCacheDescr22 = '3 Level cache, 512 KBytes, 4-way set associative, 2 lines per sector, 128 byte sector size'; + RsIntelCacheDescr23 = '3 Level cache, 1 MBytes, 8-way set associative, 2 lines per sector, 128 byte sector size'; + RsIntelCacheDescr25 = '3 Level cache, 2 MBytes, 8-way set associative, 2 lines per sector, 128 byte line size'; + RsIntelCacheDescr29 = '3 Level cache, 4M Bytes, 8-way set associative, 2 lines per sector, 128 byte line size'; + RsIntelCacheDescr2C = '1 Level data cache: 32K Bytes, 8-way set associative, 64 byte line size'; + RsIntelCacheDescr30 = '1 Level instruction cache: 32K Bytes, 8-way set associative, 64 byte line size'; RsIntelCacheDescr40 = 'No L2 cache'; RsIntelCacheDescr41 = 'Unified cache, 32 byte cache line, 4-way set associative, 128Kb'; RsIntelCacheDescr42 = 'Unified cache, 32 byte cache line, 4-way set associative, 256Kb'; @@ -1623,26 +1638,26 @@ RsIntelCacheDescr5B = 'Data TLB, 4 KBytes and 4 MBytes pages, 64 Entries'; RsIntelCacheDescr5C = 'Data TLB, 4 KBytes and 4 MBytes pages, 128 Entries'; RsIntelCacheDescr5D = 'Data TLB, 4 KBytes and 4 MBytes pages, 256 Entries'; - RsIntelCacheDescr60 = '1\xB0 Level data cache: 16 KByte, 8-way set associative, 64 byte line size'; - RsIntelCacheDescr66 = '1\xB0 Level Data cache, 8 KBytes, 4-way set associative, 64 Bytes line size'; - RsIntelCacheDescr67 = '1\xB0 Level Data cache, 16 KBytes, 4-way set associative, 64 Bytes line size'; - RsIntelCacheDescr68 = '1\xB0 Level Data cache, 32 KBytes, 4-way set associative, 64 Bytes line size'; - RsIntelCacheDescr70 = 'Trace cache, 12 K\xB5Ops, 8-way set associative'; - RsIntelCacheDescr71 = 'Trace cache, 16 K\xB5Ops, 8-way set associative'; - RsIntelCacheDescr72 = 'Trace cache, 32 K\xB5Ops, 8-way set associative'; - RsIntelCacheDescr78 = '2\xB0 Level cache, 1 MBytes, 4-way set associative, 64 Bytes line size'; - RsIntelCacheDescr79 = '2\xB0 Level cache, 128 KBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size'; - RsIntelCacheDescr7A = '2\xB0 Level cache, 256 KBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size'; - RsIntelCacheDescr7B = '2\xB0 Level cache, 512 KBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size'; - RsIntelCacheDescr7C = '2\xB0 Level cache, 1 MBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size'; - RsIntelCacheDescr7D = '2\xB0 Level cache, 2 MByte, 8-way set associative, 64byte line size'; - RsIntelCacheDescr7F = '2\xB0 Level cache, 512 KByte, 2-way set associative, 64-byte line size'; - RsIntelCacheDescr82 = '2\xB0 Level cache, 256 KBytes, 8-way associative, 32 Bytes line size'; - RsIntelCacheDescr83 = '2\xB0 Level cache, 512 KBytes, 8-way associative, 32 Bytes line size'; - RsIntelCacheDescr84 = '2\xB0 Level cache, 1 MBytes, 8-way associative, 32 Bytes line size'; - RsIntelCacheDescr85 = '2\xB0 Level cache, 2 MBytes, 8-way associative, 32 Bytes line size'; - RsIntelCacheDescr86 = '2\xB0 Level cache, 512 KByte, 4-way set associative, 64 byte line size'; - RsIntelCacheDescr87 = '2\xB0 Level cache, 1 MByte, 8-way set associative, 64 byte line size'; + RsIntelCacheDescr60 = '1 Level data cache: 16 KByte, 8-way set associative, 64 byte line size'; + RsIntelCacheDescr66 = '1 Level Data cache, 8 KBytes, 4-way set associative, 64 Bytes line size'; + RsIntelCacheDescr67 = '1 Level Data cache, 16 KBytes, 4-way set associative, 64 Bytes line size'; + RsIntelCacheDescr68 = '1 Level Data cache, 32 KBytes, 4-way set associative, 64 Bytes line size'; + RsIntelCacheDescr70 = 'Trace cache, 12 KOps, 8-way set associative'; + RsIntelCacheDescr71 = 'Trace cache, 16 KOps, 8-way set associative'; + RsIntelCacheDescr72 = 'Trace cache, 32 KOps, 8-way set associative'; + RsIntelCacheDescr78 = '2 Level cache, 1 MBytes, 4-way set associative, 64 Bytes line size'; + RsIntelCacheDescr79 = '2 Level cache, 128 KBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size'; + RsIntelCacheDescr7A = '2 Level cache, 256 KBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size'; + RsIntelCacheDescr7B = '2 Level cache, 512 KBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size'; + RsIntelCacheDescr7C = '2 Level cache, 1 MBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size'; + RsIntelCacheDescr7D = '2 Level cache, 2 MByte, 8-way set associative, 64byte line size'; + RsIntelCacheDescr7F = '2 Level cache, 512 KByte, 2-way set associative, 64-byte line size'; + RsIntelCacheDescr82 = '2 Level cache, 256 KBytes, 8-way associative, 32 Bytes line size'; + RsIntelCacheDescr83 = '2 Level cache, 512 KBytes, 8-way associative, 32 Bytes line size'; + RsIntelCacheDescr84 = '2 Level cache, 1 MBytes, 8-way associative, 32 Bytes line size'; + RsIntelCacheDescr85 = '2 Level cache, 2 MBytes, 8-way associative, 32 Bytes line size'; + RsIntelCacheDescr86 = '2 Level cache, 512 KByte, 4-way set associative, 64 byte line size'; + RsIntelCacheDescr87 = '2 Level cache, 1 MByte, 8-way set associative, 64 byte line size'; RsIntelCacheDescrB0 = 'Instruction TLB, 4 KByte Pages, 4-way set associative, 128 entries'; RsIntelCacheDescrB3 = 'Data TLB, 4 KByte Pages, 4-way set associative, 128 entries'; RsIntelCacheDescrF0 = '64-Byte Prefetching'; Modified: trunk/jcl/source/common/pcre.pas =================================================================== --- trunk/jcl/source/common/pcre.pas 2006-08-11 19:34:03 UTC (rev 1730) +++ trunk/jcl/source/common/pcre.pas 2006-08-14 20:35:43 UTC (rev 1731) @@ -19,6 +19,8 @@ { } { Contributor(s): } { Robert Rossmair (rrossmair) } +{ Mario R. Carro } +{ Florent Ouchet (outchy) } { } { The latest release of PCRE is always available from } { ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre/pcre-xxx.tar.gz } @@ -65,30 +67,52 @@ const (* Options *) - PCRE_CASELESS = $0001; + PCRE_CASELESS = $00000001; {$EXTERNALSYM PCRE_CASELESS} - PCRE_MULTILINE = $0002; + PCRE_MULTILINE = $00000002; {$EXTERNALSYM PCRE_MULTILINE} - PCRE_DOTALL = $0004; + PCRE_DOTALL = $00000004; {$EXTERNALSYM PCRE_DOTALL} - PCRE_EXTENDED = $0008; + PCRE_EXTENDED = $00000008; {$EXTERNALSYM PCRE_EXTENDED} - PCRE_ANCHORED = $0010; + PCRE_ANCHORED = $00000010; {$EXTERNALSYM PCRE_ANCHORED} - PCRE_DOLLAR_ENDONLY = $0020; + PCRE_DOLLAR_ENDONLY = $00000020; {$EXTERNALSYM PCRE_DOLLAR_ENDONLY} - PCRE_EXTRA = $0040; + PCRE_EXTRA = $00000040; {$EXTERNALSYM PCRE_EXTRA} - PCRE_NOTBOL = $0080; + PCRE_NOTBOL = $00000080; {$EXTERNALSYM PCRE_NOTBOL} - PCRE_NOTEOL = $0100; + PCRE_NOTEOL = $00000100; {$EXTERNALSYM PCRE_NOTEOL} - PCRE_UNGREEDY = $0200; + PCRE_UNGREEDY = $00000200; {$EXTERNALSYM PCRE_UNGREEDY} - PCRE_NOTEMPTY = $0400; + PCRE_NOTEMPTY = $00000400; {$EXTERNALSYM PCRE_NOTEMPTY} - PCRE_UTF8 = $0800; + PCRE_UTF8 = $00000800; {$EXTERNALSYM PCRE_UTF8} + PCRE_NO_AUTO_CAPTURE = $00001000; + {$EXTERNALSYM PCRE_NO_AUTO_CAPTURE} + PCRE_NO_UTF8_CHECK = $00002000; + {$EXTERNALSYM PCRE_NO_UTF8_CHECK} + PCRE_AUTO_CALLOUT = $00004000; + {$EXTERNALSYM PCRE_AUTO_CALLOUT} + PCRE_PARTIAL = $00008000; + {$EXTERNALSYM PCRE_PARTIAL} + PCRE_DFA_SHORTEST = $00010000; + {$EXTERNALSYM PCRE_DFA_SHORTEST} + PCRE_DFA_RESTART = $00020000; + {$EXTERNALSYM PCRE_DFA_RESTART} + PCRE_FIRSTLINE = $00040000; + {$EXTERNALSYM PCRE_FIRSTLINE} + PCRE_DUPNAMES = $00080000; + {$EXTERNALSYM PCRE_DUPNAMES} + PCRE_NEWLINE_CR = $00100000; + {$EXTERNALSYM PCRE_NEWLINE_CR} + PCRE_NEWLINE_LF = $00200000; + {$EXTERNALSYM PCRE_NEWLINE_LF} + PCRE_NEWLINE_CRLF = $00300000; + {$EXTERNALSYM PCRE_NEWLINE_CRLF} (* Exec-time and get-time error codes *) @@ -106,6 +130,34 @@ {$EXTERNALSYM PCRE_ERROR_NOMEMORY} PCRE_ERROR_NOSUBSTRING = -7; {$EXTERNALSYM PCRE_ERROR_NOSUBSTRING} + PCRE_ERROR_MATCHLIMIT = -8; + {$EXTERNALSYM PCRE_ERROR_MATCHLIMIT} + PCRE_ERROR_CALLOUT = -9; (* Never used by PCRE itself *) + {$EXTERNALSYM PCRE_ERROR_CALLOUT} + PCRE_ERROR_BADUTF8 = -10; + {$EXTERNALSYM PCRE_ERROR_BADUTF8} + PCRE_ERROR_BADUTF8_OFFSET = -11; + {$EXTERNALSYM PCRE_ERROR_BADUTF8_OFFSET} + PCRE_ERROR_PARTIAL = -12; + {$EXTERNALSYM PCRE_ERROR_PARTIAL} + PCRE_ERROR_BADPARTIAL = -13; + {$EXTERNALSYM PCRE_ERROR_BADPARTIAL} + PCRE_ERROR_INTERNAL = -14; + {$EXTERNALSYM PCRE_ERROR_INTERNAL} + PCRE_ERROR_BADCOUNT = -15; + {$EXTERNALSYM PCRE_ERROR_BADCOUNT} + PCRE_ERROR_DFA_UITEM = -16; + {$EXTERNALSYM PCRE_ERROR_DFA_UITEM} + PCRE_ERROR_DFA_UCOND = -17; + {$EXTERNALSYM PCRE_ERROR_DFA_UCOND} + PCRE_ERROR_DFA_UMLIMIT = -18; + {$EXTERNALSYM PCRE_ERROR_DFA_UMLIMIT} + PCRE_ERROR_DFA_WSSIZE = -19; + {$EXTERNALSYM PCRE_ERROR_DFA_WSSIZE} + PCRE_ERROR_DFA_RECURSE = -20; + {$EXTERNALSYM PCRE_ERROR_DFA_RECURSE} + PCRE_ERROR_RECURSIONLIMIT = -21; + {$EXTERNALSYM PCRE_ERROR_RECURSIONLIMIT} (* Request types for pcre_fullinfo() *) @@ -123,16 +175,61 @@ {$EXTERNALSYM PCRE_INFO_FIRSTTABLE} PCRE_INFO_LASTLITERAL = 6; {$EXTERNALSYM PCRE_INFO_LASTLITERAL} + PCRE_INFO_NAMEENTRYSIZE = 7; + {$EXTERNALSYM PCRE_INFO_NAMEENTRYSIZE} + PCRE_INFO_NAMECOUNT = 8; + {$EXTERNALSYM PCRE_INFO_NAMECOUNT} + PCRE_INFO_NAMETABLE = 9; + {$EXTERNALSYM PCRE_INFO_NAMETABLE} + PCRE_INFO_STUDYSIZE = 10; + {$EXTERNALSYM PCRE_INFO_STUDYSIZE} + PCRE_INFO_DEFAULT_TABLES = 11; + {$EXTERNALSYM PCRE_INFO_DEFAULT_TABLES} + (* Request types for pcre_config() *) + PCRE_CONFIG_UTF8 = 0; + {$EXTERNALSYM PCRE_CONFIG_UTF8} + PCRE_CONFIG_NEWLINE = 1; + {$EXTERNALSYM PCRE_CONFIG_NEWLINE} + PCRE_CONFIG_LINK_SIZE = 2; + {$EXTERNALSYM PCRE_CONFIG_LINK_SIZE} + PCRE_CONFIG_POSIX_MALLOC_THRESHOLD = 3; + {$EXTERNALSYM PCRE_CONFIG_POSIX_MALLOC_THRESHOLD} + PCRE_CONFIG_MATCH_LIMIT = 4; + {$EXTERNALSYM PCRE_CONFIG_MATCH_LIMIT} + PCRE_CONFIG_STACKRECURSE = 5; + {$EXTERNALSYM PCRE_CONFIG_STACKRECURSE} + PCRE_CONFIG_UNICODE_PROPERTIES = 6; + {$EXTERNALSYM PCRE_CONFIG_UNICODE_PROPERTIES} + PCRE_CONFIG_MATCH_LIMIT_RECURSION = 7; + {$EXTERNALSYM PCRE_CONFIG_MATCH_LIMIT_RECURSION} + + (* Bit flags for the pcre_extra structure *) + + PCRE_EXTRA_STUDY_DATA = $0001; + {$EXTERNALSYM PCRE_EXTRA_STUDY_DATA} + PCRE_EXTRA_MATCH_LIMIT = $0002; + {$EXTERNALSYM PCRE_EXTRA_MATCH_LIMIT} + PCRE_EXTRA_CALLOUT_DATA = $0004; + {$EXTERNALSYM PCRE_EXTRA_CALLOUT_DATA} + PCRE_EXTRA_TABLES = $0008; + {$EXTERNALSYM PCRE_EXTRA_TABLES} + PCRE_EXTRA_MATCH_LIMIT_RECURSION = $0010; + {$EXTERNALSYM PCRE_EXTRA_MATCH_LIMIT_RECURSION} + type (* Types *) PPChar = ^PChar; + {$EXTERNALSYM PPChar} PPPChar = ^PPChar; + {$EXTERNALSYM PPPChar} PInteger = ^Integer; + {$EXTERNALSYM PInteger} PPointer = ^Pointer; + {$EXTERNALSYM PPointer} real_pcre = record - magic_number: Longword; + {magic_number: Longword; size: Integer; tables: PChar; options: Longword; @@ -140,121 +237,264 @@ top_backref: word; first_char: PChar; req_char: PChar; - code: array [0..0] of Char; + code: array [0..0] of Char;} end; - //{$EXTERNALSYM real_pcre} + {$EXTERNALSYM real_pcre} TPCRE = real_pcre; + {$EXTERNALSYM TPCRE} PPCRE = ^TPCRE; + {$EXTERNALSYM PPCRE} real_pcre_extra = record - options: PChar; - start_bits: array [0..31] of Char; + {options: PChar; + start_bits: array [0..31] of Char;} + flags: Cardinal; (* Bits for which fields are set *) + study_data: Pointer; (* Opaque data from pcre_study() *) + match_limit: Cardinal; (* Maximum number of calls to match() *) + callout_data: Pointer; (* Data passed back in callouts *) + tables: PChar; (* Pointer to character tables *) + match_limit_recursion: Cardinal; (* Max recursive calls to match() *) end; - //{$EXTERNALSYM real_pcre_extra} + {$EXTERNALSYM real_pcre_extra} TPCREExtra = real_pcre_extra; + {$EXTERNALSYM TPCREExtra} PPCREExtra = ^TPCREExtra; + {$EXTERNALSYM PPCREExtra} + pcre_callout_block = record + version: Integer; (* Identifies version of block *) + (* ------------------------ Version 0 ------------------------------- *) + callout_number: Integer; (* Number compiled into pattern *) + offset_vector: PInteger; (* The offset vector *) + subject: PChar; (* The subject being matched *) + subject_length: Integer; (* The length of the subject *) + start_match: Integer; (* Offset to start of this match attempt *) + current_position: Integer; (* Where we currently are in the subject *) + capture_top: Integer; (* Max current capture *) + capture_last: Integer; (* Most recently closed capture *) + callout_data: Pointer; (* Data passed in with the call *) + (* ------------------- Added for Version 1 -------------------------- *) + pattern_position: Integer; (* Offset to next item in the pattern *) + next_item_length: Integer; (* Length of next item in the pattern *) + (* ------------------------------------------------------------------ *) + end; + {$EXTERNALSYM pcre_callout_block} + + pcre_malloc_callback = function(Size: Integer): Pointer; cdecl; + {$EXTERNALSYM pcre_malloc_callback} + pcre_free_callback = procedure(P: Pointer); cdecl; + {$EXTERNALSYM pcre_free_callback} + pcre_stack_malloc_callback = function(Size: Integer): Pointer; cdecl; + {$EXTERNALSYM pcre_stack_malloc_callback} + pcre_stack_free_callback = procedure(P: Pointer); cdecl; + {$EXTERNALSYM pcre_stack_free_callback} + pcre_callout_callback = procedure(var callout_block: pcre_callout_block); cdecl; + {$EXTERNALSYM pcre_callout_callback} + +var + // do not modify the following variables, use the setters/getters below + pcre_malloc: ^pcre_malloc_callback = nil; + {$EXTERNALSYM pcre_malloc} + pcre_free: ^pcre_free_callback = nil; + {$EXTERNALSYM pcre_free} + pcre_stack_malloc: ^pcre_stack_malloc_callback = nil; + {$EXTERNALSYM pcre_stack_malloc} + pcre_stack_free: ^pcre_stack_free_callback = nil; + {$EXTERNALSYM pcre_stack_free} + pcre_callout: ^pcre_callout_callback = nil; + {$EXTERNALSYM pcre_callout} + +procedure SetPCREMallocCallback(const FuncCallback: pcre_malloc_callback); +{$EXTERNALSYM SetPCREMallocCallback} +function GetPCREMallocCallback: pcre_malloc_callback; +{$EXTERNALSYM GetPCREMallocCallback} +procedure SetPCREFreeCallback(const FuncCallback: pcre_free_callback); +{$EXTERNALSYM SetPCREFreeCallback} +function GetPCREFreeCallback: pcre_free_callback; +{$EXTERNALSYM GetPCREFreeCallback} +procedure SetPCREStackMallocCallback(const FuncCallback: pcre_stack_malloc_callback); +{$EXTERNALSYM SetPCREStackMallocCallback} +function GetPCREStackMallocCallback: pcre_stack_malloc_callback; +{$EXTERNALSYM GetPCREStackMallocCallback} +procedure SetPCREStackFreeCallback(const FuncCallback: pcre_stack_free_callback); +{$EXTERNALSYM SetPCREStackFreeCallback} +function GetPCREStackFreeCallback: pcre_stack_free_callback; +{$EXTERNALSYM GetPCREStackFreeCallback} +procedure SetPCRECalloutCallback(const FuncCallback: pcre_callout_callback); +{$EXTERNALSYM SetPCRECalloutCallback} +function GetPCRECalloutCallback: pcre_callout_callback; +{$EXTERNALSYM GetPCRECalloutCallback} + +type + TPCRELibNotLoadedHandler = procedure; cdecl; + +var + // Value to initialize function pointers below with, in case LoadPCRE fails + // or UnloadPCRE is called. Typically the handler will raise an exception. + LibNotLoadedHandler: TPCRELibNotLoadedHandler = nil; + (* Functions *) {$IFNDEF PCRE_LINKONREQUEST} function pcre_compile(const pattern: PChar; options: Integer; const errptr: PPChar; erroffset: PInteger; const tableptr: PChar): PPCRE; cdecl; {$EXTERNALSYM pcre_compile} +function pcre_compile2(const pattern: PChar; options: Integer; + const errorcodeptr: PInteger; const errorptr: PPChar; erroroffset: PInteger; + const tables: PChar): PPCRE; cdecl; +{$EXTERNALSYM pcre_compile2} +function pcre_config(what: Integer; where: Pointer): Integer; cdecl; +{$EXTERNALSYM pcre_config} +function pcre_copy_named_substring(const code: PPCRE; const subject: PChar; + ovector: PInteger; stringcount: Integer; const stringname: PChar; + buffer: PChar; size: Integer): Integer; cdecl; +{$EXTERNALSYM pcre_copy_named_substring} function pcre_copy_substring(const subject: PChar; ovector: PInteger; stringcount, stringnumber: Integer; buffer: PChar; buffersize: Integer): Integer; cdecl; {$EXTERNALSYM pcre_copy_substring} +function pcre_dfa_exec(const argument_re: PPCRE; const extra_data: PPCREExtra; + const subject: PChar; length: Integer; start_offset: Integer; + options: Integer; offsets: PInteger; offsetcount: Integer; workspace: PInteger; + wscount: Integer): Integer; cdecl; +{$EXTERNALSYM pcre_dfa_exec} function pcre_exec(const code: PPCRE; const extra: PPCREExtra; const subject: PChar; + length, startoffset, options: Integer; ovector: PInteger; ovecsize: Integer): Integer; cdecl; {$EXTERNALSYM pcre_exec} - length, startoffset, options: Integer; ovector: PInteger; ovecsize: Integer): Integer; cdecl; -function pcre_study(const code: PPCRE; options: Integer; const errptr: PPChar): PPCREExtra; cdecl; -{$EXTERNALSYM pcre_study} -function pcre_get_substring(const subject: PChar; ovector: PInteger; -{$EXTERNALSYM pcre_get_substring} - stringcount, stringnumber: Integer; const stringptr: PPChar): Integer; cdecl; -function pcre_get_substring_list(const subject: PChar; ovector: PInteger; - stringcount: Integer; listptr: PPPChar): Integer; cdecl; -{$EXTERNALSYM pcre_get_substring_list} procedure pcre_free_substring(var stringptr: PChar); cdecl; {$EXTERNALSYM pcre_free_substring} procedure pcre_free_substring_list(var stringptr: PChar); cdecl; {$EXTERNALSYM pcre_free_substring_list} -function pcre_maketables: PChar; cdecl; -{$EXTERNALSYM pcre_maketables} function pcre_fullinfo(const code: PPCRE; const extra: PPCREExtra; what: Integer; where: Pointer): Integer; cdecl; {$EXTERNALSYM pcre_fullinfo} +function pcre_get_named_substring(const code: PPCRE; const subject: PChar; + ovector: PInteger; stringcount: Integer; const stringname: PChar; + const stringptr: PPChar): Integer; cdecl; +{$EXTERNALSYM pcre_get_named_substring} +function pcre_get_stringnumber(const code: PPCRE; const stringname: PChar): Integer; cdecl; +{$EXTERNALSYM pcre_get_stringnumber} +function pcre_get_stringtable_entries(const code: PPCRE; const stringname: PChar; + firstptr: PPChar; lastptr: PPChar): Integer; cdecl; +{$EXTERNALSYM pcre_get_stringtable_entries} +function pcre_get_substring(const subject: PChar; ovector: PInteger; + stringcount, stringnumber: Integer; const stringptr: PPChar): Integer; cdecl; +{$EXTERNALSYM pcre_get_substring} +function pcre_get_substring_list(const subject: PChar; ovector: PInteger; + stringcount: Integer; listptr: PPPChar): Integer; cdecl; +{$EXTERNALSYM pcre_get_substring_list} function pcre_info(const code: PPCRE; optptr, firstcharptr: PInteger): Integer; cdecl; {$EXTERNALSYM pcre_info} +function pcre_maketables: PChar; cdecl; +{$EXTERNALSYM pcre_maketables} +function pcre_refcount(argument_re: PPCRE; adjust: Integer): Integer; cdecl; +{$EXTERNALSYM pcre_refcount} +function pcre_study(const code: PPCRE; options: Integer; const errptr: PPChar): PPCREExtra; cdecl; +{$EXTERNALSYM pcre_study} function pcre_version: PC... [truncated message content] |
|
From: <mo...@us...> - 2006-08-27 22:14:23
|
Revision: 1745 Author: morrac Date: 2006-08-27 15:14:13 -0700 (Sun, 27 Aug 2006) ViewCVS: http://svn.sourceforge.net/jcl/?rev=1745&view=rev Log Message: ----------- 1- There's a new property called ErrorCode that contains the error code of the last compile. 2- FVector (the array of capture ranges) is now dinamically allocated. This makes the footprint of the instances almost 3 kbytes smaller, and avoids match errors in extreme cases. 3- CaptureCount is now initialized by Compile (it was previously initialized only after calling Match). 4- There's two new global procedures, called InitializeLocaleSupport and TerminateLocaleSupport (that need not be normally called). 5- The UserLocale parameter of Compile is now optional and defaults to False. 6- GetCaptures was reimplemented for better performance (less stack usage, faster execution). It also avoids errors with long captures. 7- GetCapturesOffset was fixed for off-by-one errors. 8- There's a new TJclAnsiRegEx specific error constant named JCL_PCRE_ERROR_STUDYFAILED. 9- Now Compile fails if the Study parameter is set to True and the study fails. ErrorCode is set to JCL_PCRE_ERROR_STUDYFAILED. 10- Minor code cleanups. 11- All pointer checks for nil where replaced with calls Assigned. 12- All AnsiString variables where changed to String. For more details regarding points 1 to 10 see my message to the jcl devel mailing list of day 2006-aug-20. Points 11 and 12 where added based on reviewers' recommendations. Modified Paths: -------------- trunk/jcl/source/common/JclPCRE.pas trunk/jcl/source/common/JclResources.pas Modified: trunk/jcl/source/common/JclPCRE.pas =================================================================== --- trunk/jcl/source/common/JclPCRE.pas 2006-08-23 19:01:13 UTC (rev 1744) +++ trunk/jcl/source/common/JclPCRE.pas 2006-08-27 22:14:13 UTC (rev 1745) @@ -31,6 +31,8 @@ unit JclPCRE; +{$RANGECHECKS OFF} + interface uses @@ -45,6 +47,9 @@ {$ENDIF HAS_UNIT_LIBC} Classes, SysUtils; +const + JCL_PCRE_ERROR_STUDYFAILED = -999; + type EPCREError = class(Exception) private @@ -54,7 +59,7 @@ property ErrorCode: Integer read FErrorCode; end; - TPCREIntArray = array [0..2999] of Integer; // 1000 subpatterns should be enough... + TPCREIntArray = array [0 .. 0] of Integer; PPCREIntArray = ^TPCREIntArray; TJclAnsiRegExOption = (roIgnoreCase, roMultiLine, roDotAll, roExtended, @@ -73,32 +78,40 @@ FCode: Pointer; FExtra: Pointer; FOptions: TJclAnsiRegExOptions; - FSubject: AnsiString; - FErrorMessage: AnsiString; + FSubject: String; + + FErrorCode: Integer; + FErrorMessage: String; FErrorOffset: Integer; - FVector: TPCREIntArray; + + FVector: PPCREIntArray; + FVectorSize: Integer; FStringCount: Integer; - FVectorSize: Integer; - FTables: PChar; - FMaxCaptureLength: Integer; + function GetCaptureCount: Integer; - function GetCaptures(Index: Integer): AnsiString; + function GetCaptures(Index: Integer): String; function GetAPIOptions(RunTime: Boolean): Integer; function GetCapturesOffset(Index: Integer): TJclAnsiCaptureOffset; + public - constructor Create; destructor Destroy; override; - function Compile(const Pattern: AnsiString; Study, UserLocale: Boolean): Boolean; - function Match(const Subject: AnsiString; StartOffset: Cardinal = 1): Boolean; + property Options: TJclAnsiRegExOptions read FOptions write FOptions; + function Compile(const Pattern: String; Study: Boolean; + UserLocale: Boolean = False): Boolean; + function Match(const Subject: String; StartOffset: Cardinal = 1): Boolean; property CaptureCount: Integer read GetCaptureCount; - property Captures[Index: Integer]: AnsiString read GetCaptures; + property Captures[Index: Integer]: String read GetCaptures; property CaptureOffset[Index: Integer]: TJclAnsiCaptureOffset read GetCapturesOffset; - property ErrorMessage: AnsiString read FErrorMessage; + + property ErrorCode: Integer read FErrorCode; + property ErrorMessage: String read FErrorMessage; property ErrorOffset: Integer read FErrorOffset; - property MaxCaptureLength: Integer read FMaxCaptureLength write FMaxCaptureLength; end; +procedure InitializeLocaleSupport; +procedure TerminateLocaleSupport; + {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -115,6 +128,9 @@ pcre, JclResources; +var + GTables: PChar; + function JclPCREGetMem(Size: Integer): Pointer; cdecl; begin GetMem(Result, Size); @@ -174,6 +190,8 @@ PErr := @RsErrDfaRecurse; PCRE_ERROR_RECURSIONLIMIT: PErr := @RsErrRecursionLimit; + JCL_PCRE_ERROR_STUDYFAILED: + PErr := @RsErrStudyFailed; else Result := True; end; @@ -183,43 +201,60 @@ //=== { TJclAnsiRegEx } ====================================================== -constructor TJclAnsiRegEx.Create; -begin - inherited Create; - FMaxCaptureLength := 1024; - FVectorSize := SizeOf(FVector) div SizeOf(Integer); -end; - destructor TJclAnsiRegEx.Destroy; begin - if FCode <> nil then + if Assigned(FCode) then pcre_free^(FCode); - if FExtra <> nil then + if Assigned(FExtra) then pcre_free^(FExtra); + if Assigned(FVector) then + FreeMem(FVector); inherited Destroy; end; -function TJclAnsiRegEx.Compile(const Pattern: AnsiString; Study, UserLocale: Boolean): Boolean; +function TJclAnsiRegEx.Compile(const Pattern: String; Study: Boolean; + UserLocale: Boolean = False): Boolean; var - ErrPtr: PChar; - ErrOffset: Integer; + ErrMsgPtr: PChar; + Tables: PChar; begin if UserLocale then - FTables := pcre_maketables + begin + InitializeLocaleSupport; + Tables := GTables; + end else - FTables := nil; + Tables := nil; + if Pattern = '' then raise EPCREError.CreateRes(@RsErrNull, PCRE_ERROR_NULL); - if FCode <> nil then pcre_free^(FCode); - FCode := pcre_compile(PChar(Pattern), GetAPIOptions(False), @ErrPtr, @ErrOffset, FTables); - FErrorMessage := ErrPtr; - FErrorOffset := ErrOffset; - Result := (FCode <> nil); - if Result and Study then + + if Assigned(FCode) then pcre_free^(FCode); + FCode := pcre_compile2(PChar(Pattern), GetAPIOptions(False), + @FErrorCode, @ErrMsgPtr, @FErrorOffset, Tables); + FErrorMessage := ErrMsgPtr; + Result := Assigned(FCode); + if Result then begin - if FExtra <> nil then pcre_free^(FExtra); - FExtra := pcre_study(FCode, 0, @ErrPtr); + if Study then + begin + if Assigned(FExtra) then pcre_free^(FExtra); + FExtra := pcre_study(FCode, 0, @ErrMsgPtr); + Result := Assigned(FExtra) or (not Assigned(ErrMsgPtr)); + if not Result then + begin + FErrorCode := JCL_PCRE_ERROR_STUDYFAILED; + FErrorMessage := ErrMsgPtr; + end; + end; + + PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_CAPTURECOUNT, @FStringCount)); + if FStringCount > 0 then + FVectorSize := (FStringCount + 1) * 3 + else + FVectorSize := 0; + ReAllocMem(FVector, FVectorSize * SizeOf(Integer)); end; end; @@ -260,17 +295,22 @@ function TJclAnsiRegEx.GetCaptureCount: Integer; begin Result := FStringCount; - // PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_CAPTURECOUNT, @Result)); end; -function TJclAnsiRegEx.GetCaptures(Index: Integer): AnsiString; +function TJclAnsiRegEx.GetCaptures(Index: Integer): String; var - Len: Integer; + From, Len: Integer; begin - SetLength(Result, MaxCaptureLength); - Len := pcre_copy_substring(PChar(FSubject), @FVector, FStringCount, Index, PChar(Result), MaxCaptureLength); - PCRECheck(Len); - SetLength(Result, Len); + if (Index < 0) or (Index >= FStringCount) then + PCRECheck(PCRE_ERROR_NOSUBSTRING) + else + begin + Index := Index * 2; + From := FVector^[Index]; + Len := FVector^[Index + 1] - From; + SetLength(Result, Len); + Move(FSubject[From + 1], PChar(Result)^, Len); + end; end; function TJclAnsiRegEx.GetCapturesOffset(Index: Integer): TJclAnsiCaptureOffset; @@ -280,25 +320,42 @@ Result.FirstPos := -1; Result.LastPos := -1; end; - Result.FirstPos := FVector[Index * 2]; - Result.LastPos := FVector[Index * 2 + 1]; + Index := Index * 2; + Result.FirstPos := FVector^[Index]; + Result.LastPos := FVector^[Index + 1] - 1; end; -function TJclAnsiRegEx.Match(const Subject: AnsiString; StartOffset: Cardinal = 1): Boolean; +function TJclAnsiRegEx.Match(const Subject: String; StartOffset: Cardinal = 1): Boolean; begin - if (FCode = nil) or (Subject = '') then + if (not Assigned(FCode)) or (Subject = '') then begin Result := False; Exit; end; if StartOffset < 1 then StartOffset := 1; + FSubject := Subject; FStringCount := pcre_exec(FCode, FExtra, PChar(FSubject), Length(FSubject), - StartOffset - 1, GetAPIOptions(True), @FVector, FVectorSize); - Result := FStringCount > 0; + StartOffset - 1, GetAPIOptions(True), PInteger(FVector), FVectorSize); + Result := FStringCount >= 0; end; +procedure InitializeLocaleSupport; +begin + if not Assigned(GTables) then + GTables := pcre_maketables; +end; + +procedure TerminateLocaleSupport; +begin + if Assigned(GTables) then + begin + pcre_free^(GTables); + GTables := nil; + end; +end; + //=== { EPCREError } ========================================================= constructor EPCREError.CreateRes(ResStringRec: PResStringRec; ErrorCode: Integer); @@ -322,6 +379,7 @@ {$ENDIF UNITVERSIONING} finalization + TerminateLocaleSupport; {$IFDEF UNITVERSIONING} UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} Modified: trunk/jcl/source/common/JclResources.pas =================================================================== --- trunk/jcl/source/common/JclResources.pas 2006-08-23 19:01:13 UTC (rev 1744) +++ trunk/jcl/source/common/JclResources.pas 2006-08-27 22:14:13 UTC (rev 1745) @@ -1283,7 +1283,8 @@ RsErrDfaRecurse = 'DFA Recurse'; RsErrRecursionLimit = 'Recursion limit'; RsErrLibNotLoaded = 'PCRE library not loaded'; - RsErrMemFuncNotSet = 'PCRE memory management functions not set'; + RsErrMemFuncNotSet = 'PCRE memory management functions not set'; + RsErrStudyFailed = 'Study failed'; //=== JclPeImage ============================================================= resourcestring This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
|
From: <ou...@us...> - 2006-09-14 20:03:12
|
Revision: 1769
http://svn.sourceforge.net/jcl/?rev=1769&view=rev
Author: outchy
Date: 2006-09-14 13:02:40 -0700 (Thu, 14 Sep 2006)
Log Message:
-----------
Possible DEP issue
Fixed error when JclSysUtils is compiled for the .net framework
Modified Paths:
--------------
trunk/jcl/source/common/JclAbstractContainers.pas
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclAbstractContainers.pas
===================================================================
--- trunk/jcl/source/common/JclAbstractContainers.pas 2006-09-14 19:47:52 UTC (rev 1768)
+++ trunk/jcl/source/common/JclAbstractContainers.pas 2006-09-14 20:02:40 UTC (rev 1769)
@@ -111,6 +111,7 @@
constructor TJclAbstractContainer.Create;
begin
+ inherited Create;
FCriticalSection := TJclIntfCriticalSection.Create;
end;
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2006-09-14 19:47:52 UTC (rev 1768)
+++ trunk/jcl/source/common/JclSysUtils.pas 2006-09-14 20:02:40 UTC (rev 1769)
@@ -654,6 +654,7 @@
try
Move(Buffer^, BaseAddress^, Size);
WrittenBytes := Size;
+ FlushInstructionCache(GetCurrentProcess, BaseAddress, Size);
finally
VirtualProtect(BaseAddress, Size, OldProtect, Dummy);
end;
@@ -3107,10 +3108,12 @@
{$ENDIF ~CLR}
initialization
- {$IFDEF THREADSAFE}
- if not Assigned(GlobalMMFHandleListCS) then
- GlobalMMFHandleListCS := TJclIntfCriticalSection.Create;
- {$ENDIF THREADSAFE}
+ {$IFNDEF CLR}
+ {$IFDEF THREADSAFE}
+ if not Assigned(GlobalMMFHandleListCS) then
+ GlobalMMFHandleListCS := TJclIntfCriticalSection.Create;
+ {$ENDIF THREADSAFE}
+ {$ENDIF ~CLR}
{$IFDEF UNITVERSIONING}
RegisterUnitVersion(HInstance, UnitVersioning);
{$ENDIF UNITVERSIONING}
@@ -3121,9 +3124,8 @@
{$ENDIF UNITVERSIONING}
{$IFNDEF CLR}
FinalizeMMFHandleList;
- {$ENDIF ~CLR}
{$IFDEF THREADSAFE}
GlobalMMFHandleListCS.Free;
{$ENDIF THREADSAFE}
-
+ {$ENDIF ~CLR}
end.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ou...@us...> - 2006-11-04 21:10:37
|
Revision: 1815
http://svn.sourceforge.net/jcl/?rev=1815&view=rev
Author: outchy
Date: 2006-11-04 13:10:27 -0800 (Sat, 04 Nov 2006)
Log Message:
-----------
Reworked gzip streams:
- additional properties stored in the file header (fat system, compression level)
- formalization of the file format (header and footer)
- header and data CRC can be checked
- automatic date/time on compress
- extrafield can be read and written
- additional checks before storing file name and comment as C strings (null terminated)
- TODO: read/write of additional headers containing access rights (etc...)
Modified Paths:
--------------
trunk/jcl/source/common/JclCompression.pas
trunk/jcl/source/common/JclResources.pas
Modified: trunk/jcl/source/common/JclCompression.pas
===================================================================
--- trunk/jcl/source/common/JclCompression.pas 2006-11-04 21:04:16 UTC (rev 1814)
+++ trunk/jcl/source/common/JclCompression.pas 2006-11-04 21:10:27 UTC (rev 1815)
@@ -41,6 +41,8 @@
unit JclCompression;
+{$I jcl.inc}
+
interface
uses
@@ -58,7 +60,8 @@
{$ENDIF HAS_UNIT_LIBC}
SysUtils, Classes,
JclBase,
- zlibh;
+ zlibh,
+ JclStreams;
{**************************************************************************************************}
{
@@ -158,21 +161,113 @@
end;
// GZIP Support
+
+//=== { GZIP helpers } =======================================================
+
+type
+ TJclGZIPHeader = packed record
+ ID1: Byte;
+ ID2: Byte;
+ CompressionMethod: Byte;
+ Flags: Byte;
+ ModifiedTime: Cardinal;
+ ExtraFlags: Byte;
+ OS: Byte;
+ end;
+
+ TJclGZIPFooter = packed record
+ DataCRC32: Cardinal;
+ DataSize: Cardinal;
+ end;
+
+const
+ // ID1 and ID2 fields
+ JCL_GZIP_ID1 = $1F; // value for the ID1 field
+ JCL_GZIP_ID2 = $8B; // value for the ID2 field
+
+ // Compression Model field
+ JCL_GZIP_CM_DEFLATE = 8; // Zlib classic
+
+ // Flags field : extra fields for the header
+ JCL_GZIP_FLAG_TEXT = $01; // file is probably ASCII text
+ JCL_GZIP_FLAG_CRC = $02; // a CRC16 for the header is present
+ JCL_GZIP_FLAG_EXTRA = $04; // extra fields present
+ JCL_GZIP_FLAG_NAME = $08; // original file name is present
+ JCL_GZIP_FLAG_COMMENT = $10; // comment is present
+
+ // ExtraFlags field : compression level
+ JCL_GZIP_EFLAG_MAX = 2; // compressor used maximum compression
+ JCL_GZIP_EFLAG_FAST = 4; // compressor used fastest compression
+
+ // OS field : file system
+ JCL_GZIP_OS_FAT = 0; // FAT filesystem (MS-DOS, OS/2, NT/Win32)
+ JCL_GZIP_OS_AMIGA = 1; // Amiga
+ JCL_GZIP_OS_VMS = 2; // VMS (or OpenVMS)
+ JCL_GZIP_OS_UNIX = 3; // Unix
+ JCL_GZIP_OS_VM = 4; // VM/CMS
+ JCL_GZIP_OS_ATARI = 5; // Atari TOS
+ JCL_GZIP_OS_HPFS = 6; // HPFS filesystem (OS/2, NT)
+ JCL_GZIP_OS_MAC = 7; // Macintosh
+ JCL_GZIP_OS_Z = 8; // Z-System
+ JCL_GZIP_OS_CPM = 9; // CP/M
+ JCL_GZIP_OS_TOPS = 10; // TOPS-20
+ JCL_GZIP_OS_NTFS = 11; // NTFS filesystem (NT)
+ JCL_GZIP_OS_QDOS = 12; // QDOS
+ JCL_GZIP_OS_ACORN = 13; // Acorn RISCOS
+ JCL_GZIP_OS_UNKNOWN = 255; // unknown
+
+type
+ TJclGZIPSubFieldHeader = packed record
+ SI1: Byte;
+ SI2: Byte;
+ Len: Word;
+ end;
+// constants to identify sub fields in the extra field
+// source: http://www.gzip.org/format.txt
+const
+ JCL_GZIP_X_AC1 = $41; // AC Acorn RISC OS/BBC MOS file type information
+ JCL_GZIP_X_AC2 = $43;
+ JCL_GZIP_X_Ap1 = $41; // Ap Apollo file type information
+ JCL_GZIP_X_Ap2 = $70;
+ JCL_GZIP_X_cp1 = $63; // cp file compressed by cpio
+ JCL_GZIP_X_cp2 = $70;
+ JCL_GZIP_X_GS1 = $1D; // GS gzsig
+ JCL_GZIP_X_GS2 = $53;
+ JCL_GZIP_X_KN1 = $4B; // KN KeyNote assertion (RFC 2704)
+ JCL_GZIP_X_KN2 = $4E;
+ JCL_GZIP_X_Mc1 = $4D; // Mc Macintosh info (Type and Creator values)
+ JCL_GZIP_X_Mc2 = $63;
+ JCL_GZIP_X_RO1 = $52; // RO Acorn Risc OS file type information
+ JCL_GZIP_X_RO2 = $4F;
+
+type
+ TJclGZIPFlag = (gfDataIsText, gfHeaderCRC16, gfExtraField, gfOriginalFileName,
+ gfComment);
+ TJclGZIPFlags = set of TJclGZIPFlag;
+ TJclGZIPFatSystem = (gfsFat, gfsAmiga, gfsVMS, gfsUnix, gfsVM, gfsAtari, gfsHPFS,
+ gfsMac, gfsZ, gfsCPM, gfsTOPS, gfsNTFS, gfsQDOS, gfsAcorn, gfsOther, gfsUnknown);
+
// Format is described in RFC 1952, http://www.faqs.org/rfcs/rfc1952.html
TJclGZIPCompressionStream = class(TJclCompressStream)
private
+ FFlags: TJclGZIPFlags;
+ FUnixTime: Cardinal;
+ FAutoSetTime: Boolean;
+ FCompressionLevel: TJclCompressionLevel;
+ FFatSystem: TJclGZIPFatSystem;
+ FExtraField: string;
+ FOriginalFileName: string;
FComment: string;
- FOriginalDateTime: TDateTime;
- FOriginalFileName: string;
+ FZLibStream: TJclZlibCompressStream;
+ FOriginalSize: Cardinal;
+ FDataCRC32: Cardinal;
FHeaderWritten: Boolean;
- FZlStream: TJclZlibCompressStream;
-
- FOriginalSize: Cardinal;
- FCRC32: Cardinal;
- FCompressionLevel: TJclCompressionLevel;
-
procedure WriteHeader;
- procedure ZlStreamProgress(Sender: TObject);
+ function GetDosTime: TDateTime;
+ function GetUnixTime: Cardinal;
+ procedure SetDosTime(const Value: TDateTime);
+ procedure SetUnixTime(Value: Cardinal);
+ procedure ZLibStreamProgress(Sender: TObject);
public
constructor Create(Destination: TStream; CompressionLevel: TJclCompressionLevel = -1);
destructor Destroy; override;
@@ -183,42 +278,66 @@
// the last call to Write.
function Flush: Integer; override;
+ property Flags: TJclGZIPFlags read FFlags write FFlags;
+ property DosTime: TDateTime read GetDosTime write SetDosTime;
+ property UnixTime: Cardinal read GetUnixTime write SetUnixTime;
+ property AutoSetTime: Boolean read FAutoSetTime write FAutoSetTime;
+ property FatSystem: TJclGZIPFatSystem read FFatSystem write FFatSystem;
+ property ExtraField: string read FExtraField write FExtraField;
// Note: In order for most decompressors to work, the original file name
// must be given or they would display an empty file name in their list.
// This does not affect the decompression stream below as it simply reads
// the value and does not work with it
property OriginalFileName: string read FOriginalFileName write FOriginalFileName;
- property OriginalDateTime: TDateTime read FOriginalDateTime write FOriginalDateTime;
property Comment: string read FComment write FComment;
end;
TJclGZIPDecompressionStream = class(TJclDecompressStream)
private
- FZlStream: TJclZLibDecompressStream;
- FMemStream: TMemoryStream;
-
- FHeaderRead: Boolean;
+ FHeader: TJclGZIPHeader;
+ FFooter: TJclGZIPFooter;
+ FCompressedDataStream: TJclDelegatedStream;
+ FZLibStream: TJclZLibDecompressStream;
FOriginalFileName: string;
FComment: string;
- FOriginalDateTime: TDateTime;
- FCRC16: Word;
+ FExtraField: string;
+ FComputedHeaderCRC16: Word;
+ FStoredHeaderCRC16: Word;
+ FComputedDataCRC32: Cardinal;
FCompressedDataSize: Int64;
- FCRC32: Cardinal;
- FOriginalSize: Cardinal;
-
- function ReadHeader: Boolean;
- procedure ZlStreamProgress(Sender: TObject);
+ FDataSize: Int64;
+ FDataStarted: Boolean;
+ FDataEnded: Boolean;
+ FAutoCheckDataCRC32: Boolean;
+ function GetCompressedDataSize: Int64;
+ function GetComputedDataCRC32: Cardinal;
+ function GetDosTime: TDateTime;
+ function GetFatSystem: TJclGZIPFatSystem;
+ function GetFlags: TJclGZIPFlags;
+ function GetOriginalDataSize: Cardinal;
+ function GetStoredDataCRC32: Cardinal;
+ function ReadCompressedData(Sender: TObject; var Buffer; Count: Longint): Longint;
+ procedure ZLibStreamProgress(Sender: TObject);
public
+ constructor Create(Source: TStream; CheckHeaderCRC: Boolean = True);
destructor Destroy; override;
-
function Read(var Buffer; Count: Longint): Longint; override;
+ property ComputedHeaderCRC16: Word read FComputedHeaderCRC16;
+ property StoredHeaderCRC16: Word read FStoredHeaderCRC16;
+ property ExtraField: string read FExtraField;
property OriginalFileName: string read FOriginalFileName;
- property OriginalSize: Cardinal read FOriginalSize;
- property OriginalDateTime: TDateTime read FOriginalDateTime;
property Comment: string read FComment;
- property CRC16: Word read FCRC16;
- property CRC32: Cardinal read FCRC32;
+ property Flags: TJclGZIPFlags read GetFlags;
+ property CompressionLevel: Byte read FHeader.ExtraFlags;
+ property FatSystem: TJclGZIPFatSystem read GetFatSystem;
+ property UnixTime: Cardinal read FHeader.ModifiedTime;
+ property DosTime: TDateTime read GetDosTime;
+ property ComputedDataCRC32: Cardinal read GetComputedDataCRC32;
+ property StoredDataCRC32: Cardinal read GetStoredDataCRC32;
+ property AutoCheckDataCRC32: Boolean read FAutoCheckDataCRC32 write FAutoCheckDataCRC32;
+ property CompressedDataSize: Int64 read GetCompressedDataSize;
+ property OriginalDataSize: Cardinal read GetOriginalDataSize;
end;
// RAR Support
@@ -627,41 +746,73 @@
CompressionLevel: TJclCompressionLevel);
begin
inherited Create(Destination);
-
+
+ FAutoSetTime := True;
+ FFatSystem := gfsUnknown;
FCompressionLevel := CompressionLevel;
- FCRC32 := crc32(0, nil, 0);
+ FDataCRC32 := crc32(0, nil, 0);
end;
destructor TJclGZIPCompressionStream.Destroy;
begin
- FZlStream.Free;
+ FZLibStream.Free;
inherited Destroy;
end;
function TJclGZIPCompressionStream.Flush: Integer;
+var
+ AFooter: TJclGZIPFooter;
begin
- if Assigned(FZlStream) then
- Result := FZlStream.Flush
+ if Assigned(FZLibStream) then
+ Result := FZLibStream.Flush
else
Result := 0;
- // Write trailer, CRC32 followed by ISIZE
- FStream.Write(FCRC32, SizeOf(FCRC32));
- FStream.Write(FOriginalSize, SizeOf(FOriginalSize));
+ // Write footer, CRC32 followed by ISIZE
+ AFooter.DataCRC32 := FDataCRC32;
+ AFooter.DataSize := FOriginalSize;
- Inc(Result, SizeOf(FCRC32) + SizeOf(FOriginalSize));
+ Inc(Result, FStream.Write(AFooter, SizeOf(AFooter)));
end;
+function TJclGZIPCompressionStream.GetDosTime: TDateTime;
+begin
+ if AutoSetTime then
+ Result := Now
+ else
+ Result := UnixTimeToDateTime(FUnixTime);
+end;
+
+function TJclGZIPCompressionStream.GetUnixTime: Cardinal;
+begin
+ if AutoSetTime then
+ Result := DateTimeToUnixTime(Now)
+ else
+ Result := FUnixTime;
+end;
+
procedure TJclGZIPCompressionStream.Reset;
begin
- if Assigned(FZlStream) then
- FZlStream.Reset;
+ if Assigned(FZLibStream) then
+ FZLibStream.Reset;
- FCRC32 := crc32(0, nil, 0);
+ FDataCRC32 := crc32(0, nil, 0);
FOriginalSize := 0;
end;
+procedure TJclGZIPCompressionStream.SetDosTime(const Value: TDateTime);
+begin
+ AutoSetTime := False;
+ FUnixTime := DateTimeToUnixTime(Value);
+end;
+
+procedure TJclGZIPCompressionStream.SetUnixTime(Value: Cardinal);
+begin
+ AutoSetTime := False;
+ FUnixTime := Value;
+end;
+
function TJclGZIPCompressionStream.Write(const Buffer; Count: Integer): Longint;
begin
if not FHeaderWritten then
@@ -670,215 +821,356 @@
FHeaderWritten := True;
end;
- if not Assigned(FZlStream) then
+ if not Assigned(FZLibStream) then
begin
- FZlStream := TJclZlibCompressStream.Create(FStream, FCompressionLevel);
- FZlStream.WindowBits := -DEF_WBITS; // negative value for raw mode
- FZlStream.OnProgress := ZlStreamProgress;
+ FZLibStream := TJclZlibCompressStream.Create(FStream, FCompressionLevel);
+ FZLibStream.WindowBits := -DEF_WBITS; // negative value for raw mode
+ FZLibStream.OnProgress := ZLibStreamProgress;
end;
- Result := FZlStream.Write(Buffer, Count);
- FCRC32 := crc32(FCRC32, PBytef(@Buffer), Result);
+ Result := FZLibStream.Write(Buffer, Count);
+ FDataCRC32 := crc32(FDataCRC32, PBytef(@Buffer), Result);
Inc(FOriginalSize, Result);
end;
procedure TJclGZIPCompressionStream.WriteHeader;
var
- Dummy: Byte;
- UnixTimeStamp: Cardinal;
- Flags: Byte;
+ HeaderCRC: Cardinal;
+ procedure StreamWriteBuffer(const Buffer; Count: Longint);
+ begin
+ FStream.WriteBuffer(Buffer, Count);
+ if gfHeaderCRC16 in Flags then
+ HeaderCRC := crc32(HeaderCRC, @Byte(Buffer), Count);
+ end;
+ function CheckCString(const Buffer: string): Boolean;
+ var
+ Index: Integer;
+ begin
+ Result := False;
+ for Index := 0 to Length(Buffer) do
+ if Buffer[Index] = #0 then
+ Exit;
+ Result := True;
+ end;
+const
+ FatSystemToByte: array [TJclGZIPFatSystem] of Byte =
+ ( JCL_GZIP_OS_FAT, JCL_GZIP_OS_AMIGA, JCL_GZIP_OS_VMS, JCL_GZIP_OS_UNIX,
+ JCL_GZIP_OS_VM, JCL_GZIP_OS_ATARI, JCL_GZIP_OS_HPFS, JCL_GZIP_OS_MAC,
+ JCL_GZIP_OS_Z, JCL_GZIP_OS_CPM, JCL_GZIP_OS_TOPS, JCL_GZIP_OS_NTFS,
+ JCL_GZIP_OS_QDOS, JCL_GZIP_OS_ACORN, JCL_GZIP_OS_UNKNOWN, JCL_GZIP_OS_UNKNOWN );
+var
+ AHeader: TJclGZIPHeader;
+ ExtraFieldLength: Word;
begin
- // ID1
- Dummy := $1F;
- FStream.Write(Dummy, 1);
- // ID2
- Dummy := $8B;
- FStream.Write(Dummy, 1);
+ if gfHeaderCRC16 in Flags then
+ HeaderCRC := crc32(0, nil, 0);
- // Compression Method, always deflate
- Dummy := 8;
- FStream.Write(Dummy, 1);
+ AHeader.ID1 := JCL_GZIP_ID1;
+ AHeader.ID2 := JCL_GZIP_ID2;
+ AHeader.CompressionMethod := JCL_GZIP_CM_DEFLATE;
+ AHeader.Flags := 0;
+ if gfDataIsText in Flags then
+ AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_TEXT;
+ if gfHeaderCRC16 in Flags then
+ AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_CRC;
+ if (gfExtraField in Flags) and (ExtraField <> '') then
+ AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_EXTRA;
+ if (gfOriginalFileName in Flags) and (OriginalFileName <> '') then
+ AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_NAME;
+ if (gfComment in Flags) and (Comment <> '') then
+ AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_COMMENT;
- // Flags
- Flags := $00;
- if Length(FOriginalFileName) > 0 then
- Flags := Flags or $08;
- if Length(FComment) > 0 then
- Flags := Flags or $10;
- FStream.Write(Flags, 1);
+ if AutoSetTime then
+ AHeader.ModifiedTime := DateTimeToUnixTime(Now)
+ else
+ AHeader.ModifiedTime := FUnixTime;
- // MTIME
- UnixTimeStamp := DateTimeToUnixTime(OriginalDateTime);
- FStream.Write(UnixTimeStamp, SizeOf(UnixTimeStamp));
+ case FCompressionLevel of
+ Z_BEST_COMPRESSION :
+ AHeader.ExtraFlags := JCL_GZIP_EFLAG_MAX;
+ Z_BEST_SPEED :
+ AHeader.ExtraFlags := JCL_GZIP_EFLAG_FAST;
+ else
+ AHeader.ExtraFlags := 0;
+ end;
- // No extras
- Dummy := $0;
- FStream.Write(Dummy, 1);
+ AHeader.OS := FatSystemToByte[FatSystem];
- // Unknown OS
- Dummy := $FF;
- FStream.Write(Dummy, 1);
+ StreamWriteBuffer(AHeader, SizeOf(AHeader));
- // FileName, if any
- if Length(FOriginalFileName) > 0 then
+ if (gfExtraField in Flags) and (ExtraField <> '') then
begin
- FStream.Write(FOriginalFileName[1], Length(FOriginalFileName));
- Dummy := $0;
- FStream.Write(Dummy, 1);
+ if Length(ExtraField) > High(Word) then
+ raise EJclCompressionError.CreateRes(@RsCompilationGZIPExtraFieldTooLong);
+ ExtraFieldLength := Length(ExtraField);
+ StreamWriteBuffer(ExtraFieldLength, SizeOf(ExtraFieldLength));
+ StreamWriteBuffer(ExtraField[1], Length(ExtraField));
end;
- // Comment, if any
- if Length(FComment) > 0 then
+ if (gfOriginalFileName in Flags) and (OriginalFileName <> '') then
begin
- FStream.Write(FComment[1], Length(FComment));
- Dummy := $0;
- FStream.Write(Dummy, 1);
+ if not CheckCString(OriginalFileName) then
+ raise EJclCompressionError.CreateRes(@RsCompilationGZIPBadString);
+ StreamWriteBuffer(OriginalFileName[1], Length(OriginalFileName) + 1);
end;
+
+ if (gfComment in Flags) and (Comment <> '') then
+ begin
+ if not CheckCString(Comment) then
+ raise EJclCompressionError.CreateRes(@RsCompilationGZIPBadString);
+ StreamWriteBuffer(Comment[1], Length(Comment) + 1);
+ end;
+
+ if (gfHeaderCRC16 in Flags) then
+ FStream.WriteBuffer(HeaderCRC, SizeOf(HeaderCRC));
end;
-procedure TJclGZIPCompressionStream.ZlStreamProgress(Sender: TObject);
+procedure TJclGZIPCompressionStream.ZLibStreamProgress(Sender: TObject);
begin
Progress(Self);
end;
//=== { TJclGZIPDecompressionStream } ========================================
-destructor TJclGZIPDecompressionStream.Destroy;
-begin
- FZlStream.Free;
- FMemStream.Free;
-
- inherited Destroy;
-end;
-
-function TJclGZIPDecompressionStream.Read(var Buffer; Count: Integer): Longint;
-begin
- if not FHeaderRead then
+constructor TJclGZIPDecompressionStream.Create(Source: TStream; CheckHeaderCRC: Boolean);
+var
+ HeaderCRC: Cardinal;
+ ComputeHeaderCRC: Boolean;
+ procedure ReadBuffer(var Buffer; SizeOfBuffer: Longint);
begin
- if not ReadHeader then
- begin
- Result := 0;
- Exit;
- end;
- FHeaderRead := True;
+ Source.ReadBuffer(Buffer, SizeOfBuffer);
+ if ComputeHeaderCRC then
+ HeaderCRC := crc32(HeaderCRC, @Byte(Buffer), SizeOfBuffer);
end;
- if not Assigned(FZlStream) then
+ function ReadCString: string;
+ var
+ Dummy: Char;
begin
- FMemStream := TMemoryStream.Create;
- FMemStream.CopyFrom(FStream, FCompressedDataSize);
- FMemStream.Position := 0;
- FZlStream := TJclZLibDecompressStream.Create(FMemStream, -DEF_WBITS); // negative value for raw mode
- FZlStream.OnProgress := ZlStreamProgress;
-
- // we are now positionned right in front of CRC32 and ISIZE and we can
- // thus read them
- FStream.Read(FCRC32, SizeOf(FCRC32));
- FStream.Read(FOriginalSize, SizeOf(FOriginalSize));
+ repeat
+ Source.ReadBuffer(Dummy, SizeOf(Dummy));
+ FOriginalFileName := FOriginalFileName + Dummy;
+ until Dummy = #0;
+ SetLength(FOriginalFileName, Length(FOriginalFileName) - 1);
end;
-
- Result := FZlStream.Read(Buffer, Count);
-end;
-
-function TJclGZIPDecompressionStream.ReadHeader: Boolean;
var
- ID1: Byte;
- ID2: Byte;
- CM: Byte;
- Flags: Byte;
- HasHeaderCRC16: Boolean;
- HasExtra: Boolean;
- HasName: Boolean;
- HasComment: Boolean;
- Dummy: Byte;
- OriginalTimeStamp: Cardinal;
- ExtraLength: Word;
- I: Integer;
+ ExtraFieldLength: Word;
begin
- Result := False;
+ inherited Create(Source);
- // ID
- FStream.Read(ID1, 1);
- FStream.Read(ID2, 1);
- if (ID1 <> $1F) or (ID2 <> $8B) then
+ FAutoCheckDataCRC32 := True;
+ FComputedDataCRC32 := crc32(0, nil, 0);
+ HeaderCRC := crc32(0, nil, 0);
+
+ ComputeHeaderCRC := CheckHeaderCRC;
+ ReadBuffer(FHeader, SizeOf(FHeader));
+ if (FHeader.ID1 <> JCL_GZIP_ID1) or (FHeader.ID2 <> JCL_GZIP_ID2) then
+ raise EJclCompressionError.CreateResFmt(@RsCompressionGZipInvalidID, [FHeader.ID1, FHeader.ID2]);
+ if (FHeader.CompressionMethod <> JCL_GZIP_CM_DEFLATE) then
+ raise EJclCompressionError.CreateResFmt(@RsCompressionGZipUnsupportedCM, [FHeader.CompressionMethod]);
+
+ if (FHeader.Flags and JCL_GZIP_FLAG_EXTRA) <> 0 then
begin
- // Invalid ID
- Exit;
+ ReadBuffer(ExtraFieldLength, SizeOf(ExtraFieldLength));
+ SetLength(FExtraField, ExtraFieldLength);
+ ReadBuffer(FExtraField[1], ExtraFieldLength);
end;
- // Compression method
- FStream.Read(CM, 1);
- if CM <> 8 then
+ if (FHeader.Flags and JCL_GZIP_FLAG_NAME) <> 0 then
+ FOriginalFileName := ReadCString;
+ if (FHeader.Flags and JCL_GZIP_FLAG_COMMENT) <> 0 then
+ FComment := ReadCString;
+
+ if CheckHeaderCRC then
begin
- // Invalid compression method, only deflate is known
- Exit;
+ ComputeHeaderCRC := False;
+ FComputedHeaderCRC16 := HeaderCRC and $FFFF;
end;
- // Flags
- FStream.Read(Flags, 1);
- if Flags and $E0 <> $00 then
+ if (FHeader.Flags and JCL_GZIP_FLAG_CRC) <> 0 then
begin
- // Extra flags, don't know what to do with them
- Exit;
+ Source.ReadBuffer(FStoredHeaderCRC16, SizeOf(FStoredHeaderCRC16));
+ if CheckHeaderCRC and (FComputedHeaderCRC16 <> FStoredHeaderCRC16) then
+ raise EJclCompressionError.CreateRes(@RsCompressionGZipHeaderCRC);
end;
+end;
- HasHeaderCRC16 := Flags and $02 = $02;
- HasExtra := Flags and $04 = $04;
- HasName := Flags and $08 = $08;
- HasComment := Flags and $10 = $10;
+destructor TJclGZIPDecompressionStream.Destroy;
+begin
+ FZLibStream.Free;
+ FCompressedDataStream.Free;
+ inherited Destroy;
+end;
- // Original modification time
- FStream.Read(OriginalTimeStamp, SizeOf(OriginalTimeStamp));
- FOriginalDateTime := UnixTimeToDateTime(OriginalTimeStamp);
+function TJclGZIPDecompressionStream.GetCompressedDataSize: Int64;
+begin
+ if not FDataStarted then
+ Result := FStream.Size - FStream.Position - SizeOf(FFooter)
+ else
+ if FDataEnded then
+ Result := FCompressedDataSize
+ else
+ raise EJclCompressionError.CreateRes(@RsCompressionGZipDecompressing);
+end;
- // Extra flags and OS are ignored
- FStream.Read(Dummy, 1);
- FStream.Read(Dummy, 1);
+function TJclGZIPDecompressionStream.GetComputedDataCRC32: Cardinal;
+begin
+ if FDataEnded then
+ Result := FComputedDataCRC32
+ else
+ raise EJclCompressionError.CreateRes(@RsCompressionGZipNotDecompressed);
+end;
- // If file has extra, ignore it
- if HasExtra then
- begin
- FStream.Read(ExtraLength, SizeOf(ExtraLength));
+function TJclGZIPDecompressionStream.GetDosTime: TDateTime;
+begin
+ Result := UnixTimeToDateTime(FHeader.ModifiedTime);
+end;
- for I := 0 to ExtraLength - 1 do
- FStream.Read(Dummy, 1);
+function TJclGZIPDecompressionStream.GetFatSystem: TJclGZIPFatSystem;
+const
+ ByteToFatSystem: array [JCL_GZIP_OS_FAT..JCL_GZIP_OS_ACORN] of TJclGZIPFatSystem =
+ ( gfsFat, gfsAmiga, gfsVMS, gfsUnix, gfsVM, gfsAtari, gfsHPFS, gfsMac, gfsZ,
+ gfsCPM, gfsTOPS, gfsNTFS, gfsQDOS, gfsAcorn );
+begin
+ case FHeader.OS of
+ JCL_GZIP_OS_FAT..JCL_GZIP_OS_ACORN :
+ Result := ByteToFatSystem[FHeader.OS];
+ JCL_GZIP_OS_UNKNOWN :
+ Result := gfsUnknown;
+ else
+ Result := gfsOther;
end;
+end;
- // Read name, if present
- FOriginalFileName := '';
- if HasName then
+function TJclGZIPDecompressionStream.GetFlags: TJclGZIPFlags;
+begin
+ Result := [];
+ if (FHeader.Flags and JCL_GZIP_FLAG_TEXT) <> 0 then
+ Result := Result + [gfDataIsText];
+ if (FHeader.Flags and JCL_GZIP_FLAG_CRC) <> 0 then
+ Result := Result + [gfHeaderCRC16];
+ if (FHeader.Flags and JCL_GZIP_FLAG_EXTRA) <> 0 then
+ Result := Result + [gfExtraField];
+ if (FHeader.Flags and JCL_GZIP_FLAG_NAME) <> 0 then
+ Result := Result + [gfOriginalFileName];
+ if (FHeader.Flags and JCL_GZIP_FLAG_COMMENT) <> 0 then
+ Result := Result + [gfComment];
+end;
+
+function TJclGZIPDecompressionStream.GetOriginalDataSize: Cardinal;
+var
+ StartPos: {$IFDEF COMPILER5}Longint;{$ELSE ~COMPILER5}Int64;{$ENDIF ~COMPILER5}
+ AFooter: TJclGZIPFooter;
+begin
+ if not FDataStarted then
begin
- FStream.Read(Dummy, 1);
- while Dummy <> 0 do
- begin
- FOriginalFileName := FOriginalFileName + Chr(Dummy);
- FStream.Read(Dummy, 1);
+ StartPos := FStream.Position;
+ try
+ FStream.Seek(-SizeOf(AFooter), soFromEnd);
+ FStream.ReadBuffer(AFooter, SizeOf(AFooter));
+ Result := AFooter.DataSize;
+ finally
+ FStream.Seek(StartPos, {$IFDEF COMPILER5}soFromBeginning{$ELSE ~COMPILER5}soBeginning{$ENDIF ~COMPILER5});
end;
- end;
+ end
+ else
+ if FDataEnded then
+ Result := FFooter.DataSize
+ else
+ raise EJclCompressionError.CreateRes(@RsCompressionGZipDecompressing);
+end;
- // Read comment, if present
- FComment := '';
- if HasComment then
+function TJclGZIPDecompressionStream.GetStoredDataCRC32: Cardinal;
+var
+ StartPos: {$IFDEF COMPILER5}Longint;{$ELSE ~COMPILER5}Int64;{$ENDIF ~COMPILER5}
+ AFooter: TJclGZIPFooter;
+begin
+ if not FDataStarted then
begin
- FStream.Read(Dummy, 1);
- while Dummy <> 0 do
- begin
- FComment := FComment + Chr(Dummy);
- FStream.Read(Dummy, 1);
+ StartPos := FStream.Position;
+ try
+ FStream.Seek(-SizeOf(AFooter), soFromEnd);
+ FStream.ReadBuffer(AFooter, SizeOf(AFooter));
+ Result := AFooter.DataCRC32;
+ finally
+ FStream.Seek(StartPos, {$IFDEF COMPILER5}soFromBeginning{$ELSE ~COMPILER5}soBeginning{$ENDIF ~COMPILER5});
end;
+ end
+ else
+ if FDataEnded then
+ Result := FFooter.DataCRC32
+ else
+ raise EJclCompressionError.CreateRes(@RsCompressionGZipDecompressing);
+end;
+
+function TJclGZIPDecompressionStream.Read(var Buffer; Count: Longint): Longint;
+begin
+ if not Assigned(FZLibStream) then
+ begin
+ FCompressedDataStream := TJclDelegatedStream.Create;
+ FCompressedDataStream.OnRead := ReadCompressedData;
+ FZLibStream := TJclZLibDecompressStream.Create(FCompressedDataStream, -DEF_WBITS);
+ FZLibStream.OnProgress := ZLibStreamProgress;
end;
+ Result := FZLibStream.Read(Buffer, Count);
+ Inc(FDataSize, Result);
+ FComputedDataCRC32 := crc32(FComputedDataCRC32, @Byte(Buffer), Result);
+ if Result < Count then
+ begin
+ if not FDataEnded then
+ // the decompressed stream is stopping before the compressed stream
+ raise EJclCompressionError(RsCompressionGZipInternalError);
+ if AutoCheckDataCRC32 and (FComputedDataCRC32 <> FFooter.DataCRC32) then
+ raise EJclCompressionError(RsCompressionGZipDataCRCFailed);
+ end;
+end;
- // Read CRC16, if present
- FCRC16 := 0;
- if HasHeaderCRC16 then
- FStream.Read(FCRC16, SizeOf(FCRC16));
+function TJclGZIPDecompressionStream.ReadCompressedData(Sender: TObject; var Buffer;
+ Count: Longint): Longint;
+var
+ BufferAddr: PChar;
+ FooterAddr: PChar;
+begin
+ if (Count = 0) or FDataEnded then
+ begin
+ Result := 0;
+ Exit;
+ end
+ else
+ if not FDataStarted then
+ begin
+ FDataStarted := True;
+ // prolog
+ if FStream.Read(FFooter, SizeOf(FFooter)) < SizeOf(FFooter) then
+ raise EJclCompressionError.CreateRes(@RsCompressionGZipDataTruncated);
+ end;
- FCompressedDataSize := FStream.Size - FStream.Position - 2 * SizeOf(Cardinal);
+ BufferAddr := @Char(Buffer);
+ Move(FFooter, Buffer, SizeOf(FFooter));
+ Result := FStream.Read(BufferAddr[SizeOf(FFooter)], Count - SizeOf(FFooter))
+ + FStream.Read(FFooter, SizeOf(FFooter));
- Result := True;
+ if Result < Count then
+ begin
+ FDataEnded := True;
+ // epilog
+ FooterAddr := @FFooter;
+ if (Count - Result) < SizeOf(FFooter) then
+ begin
+ // the "real" footer is splitted in the data and the footer
+ // shift the valid bytes of the footer to their place
+ Move(FFooter, FooterAddr[Count - Result], SizeOf(FFooter) - Count + Result);
+ // the missing bytes of the footer are located after the data
+ Move(BufferAddr[Result], FFooter, Count - Result);
+ end
+ else
+ // the "real" footer is located in the data
+ Move(BufferAddr[Result], FFooter, SizeOf(FFooter));
+ end;
+ Inc(FCompressedDataSize, Result);
end;
-procedure TJclGZIPDecompressionStream.ZlStreamProgress(Sender: TObject);
+procedure TJclGZIPDecompressionStream.ZLibStreamProgress(Sender: TObject);
begin
Progress(Self);
end;
Modified: trunk/jcl/source/common/JclResources.pas
===================================================================
--- trunk/jcl/source/common/JclResources.pas 2006-11-04 21:04:16 UTC (rev 1814)
+++ trunk/jcl/source/common/JclResources.pas 2006-11-04 21:10:27 UTC (rev 1815)
@@ -777,6 +777,16 @@
RsCompressionZLibZBufError = 'zlib returned: buffer error';
RsCompressionZLibZVersionError = 'zlib returned: Version error';
RsCompressionZLibError = 'ZLib error';
+ RsCompressionGZIPInvalidID = 'GZip: Invalid ID (ID1=%.2x; ID2=%.2x)';
+ RsCompressionGZIPUnsupportedCM = 'GZip: unsupported compression method (%d)';
+ RsCompressionGZIPHeaderCRC = 'GZip: CRC failed, header is damaged';
+ RsCompressionGZIPDecompressing = 'GZip: this property is not readable when the data are being decompressed';
+ RsCompressionGZIPNotDecompressed = 'GZip: this property is not readable until the data are fully decompressed';
+ RsCompressionGZIPDataTruncated = 'GZip: data are truncated';
+ RsCompressionGZIPInternalError = 'GZip: internal error';
+ RsCompressionGZIPDataCRCFailed = 'GZip: CRC failed, data are damaged';
+ RsCompilationGZIPExtraFieldTooLong = 'GZip: extra field is too long';
+ RsCompilationGZIPBadString = 'GZip: the string contains null chars';
//=== JclConsole =============================================================
resourcestring
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ou...@us...> - 2006-11-11 15:01:10
|
Revision: 1819
http://svn.sourceforge.net/jcl/?rev=1819&view=rev
Author: outchy
Date: 2006-11-11 07:00:52 -0800 (Sat, 11 Nov 2006)
Log Message:
-----------
Mantis 1207 Bad index in JclMatches could cause access violations.
Modified Paths:
--------------
trunk/jcl/source/common/JclAnsiStrings.pas
trunk/jcl/source/common/JclStrings.pas
Modified: trunk/jcl/source/common/JclAnsiStrings.pas
===================================================================
--- trunk/jcl/source/common/JclAnsiStrings.pas 2006-11-07 15:10:53 UTC (rev 1818)
+++ trunk/jcl/source/common/JclAnsiStrings.pas 2006-11-11 15:00:52 UTC (rev 1819)
@@ -2717,6 +2717,9 @@
if Result or (S = '') then
Exit;
+ if (Index <= 0) or (Index > Length(S)) then
+ raise EJclStringError.CreateRes(@RsArgumentOutOfRange);
+
StringPtr := PAnsiChar(@S[Index]);
PatternPtr := PAnsiChar(SubStr);
StringRes := nil;
Modified: trunk/jcl/source/common/JclStrings.pas
===================================================================
--- trunk/jcl/source/common/JclStrings.pas 2006-11-07 15:10:53 UTC (rev 1818)
+++ trunk/jcl/source/common/JclStrings.pas 2006-11-11 15:00:52 UTC (rev 1819)
@@ -2849,6 +2849,9 @@
if Result or (S = '') then
Exit;
+ if (Index <= 0) or (Index > Length(S)) then
+ raise EJclStringError.CreateRes(@RsArgumentOutOfRange);
+
StringPtr := PChar(@S[Index]);
PatternPtr := PChar(SubStr);
StringRes := nil;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ou...@us...> - 2006-11-30 19:19:50
|
Revision: 1826
http://svn.sourceforge.net/jcl/?rev=1826&view=rev
Author: outchy
Date: 2006-11-30 11:19:48 -0800 (Thu, 30 Nov 2006)
Log Message:
-----------
Updated to the latest specifications of Intel and AMD
CPUID rewritten in purepascal (easier to maintain)
New features detection: logical cores, physical cores, NX (non execute) bit, SSE3 (Streaming SIMD Extension 3), SSSE3 (Supplement to Streaming SIMD Extensions 3).
Modified Paths:
--------------
trunk/jcl/source/common/JclResources.pas
trunk/jcl/source/common/JclSysInfo.pas
Modified: trunk/jcl/source/common/JclResources.pas
===================================================================
--- trunk/jcl/source/common/JclResources.pas 2006-11-27 21:19:43 UTC (rev 1825)
+++ trunk/jcl/source/common/JclResources.pas 2006-11-30 19:19:48 UTC (rev 1826)
@@ -1650,56 +1650,64 @@
RsIntelUnknownCache = 'Unknown cache ID (%.2x)';
RsIntelCacheDescr00 = 'Null descriptor';
- RsIntelCacheDescr01 = 'Instruction TLB, 4Kb pages, 4-way set associative, 32 entries';
- RsIntelCacheDescr02 = 'Instruction TLB, 4Mb pages, fully associative, 2 entries';
- RsIntelCacheDescr03 = 'Data TLB, 4Kb pages, 4-way set associative, 64 entries';
- RsIntelCacheDescr04 = 'Data TLB, 4Mb pages, 4-way set associative, 8 entries';
- RsIntelCacheDescr06 = '8KB instruction cache, 4-way set associative, 32 byte line size';
- RsIntelCacheDescr08 = '16KB instruction cache, 4-way set associative, 32 byte line size';
- RsIntelCacheDescr0A = '8KB data cache 2-way set associative, 32 byte line size';
- RsIntelCacheDescr0C = '16KB data cache, 4-way set associative, 32 byte line size';
- RsIntelCacheDescr22 = '3 Level cache, 512 KBytes, 4-way set associative, 2 lines per sector, 128 byte sector size';
- RsIntelCacheDescr23 = '3 Level cache, 1 MBytes, 8-way set associative, 2 lines per sector, 128 byte sector size';
- RsIntelCacheDescr25 = '3 Level cache, 2 MBytes, 8-way set associative, 2 lines per sector, 128 byte line size';
- RsIntelCacheDescr29 = '3 Level cache, 4M Bytes, 8-way set associative, 2 lines per sector, 128 byte line size';
- RsIntelCacheDescr2C = '1 Level data cache: 32K Bytes, 8-way set associative, 64 byte line size';
- RsIntelCacheDescr30 = '1 Level instruction cache: 32K Bytes, 8-way set associative, 64 byte line size';
- RsIntelCacheDescr40 = 'No L2 cache';
- RsIntelCacheDescr41 = 'Unified cache, 32 byte cache line, 4-way set associative, 128Kb';
- RsIntelCacheDescr42 = 'Unified cache, 32 byte cache line, 4-way set associative, 256Kb';
- RsIntelCacheDescr43 = 'Unified cache, 32 byte cache line, 4-way set associative, 512Kb';
- RsIntelCacheDescr44 = 'Unified cache, 32 byte cache line, 4-way set associative, 1Mb';
- RsIntelCacheDescr45 = 'Unified cache, 32 byte cache line, 4-way set associative, 2Mb';
- RsIntelCacheDescr50 = 'Instruction TLB, 4 KBytes and 2 MBytes or 4 MBytes pages, 64 Entries';
- RsIntelCacheDescr51 = 'Instruction TLB, 4 KBytes and 2 MBytes or 4 MBytes pages, 128 Entries';
- RsIntelCacheDescr52 = 'Instruction TLB, 4 KBytes and 2 MBytes or 4 MBytes pages, 256 Entries';
- RsIntelCacheDescr5B = 'Data TLB, 4 KBytes and 4 MBytes pages, 64 Entries';
- RsIntelCacheDescr5C = 'Data TLB, 4 KBytes and 4 MBytes pages, 128 Entries';
- RsIntelCacheDescr5D = 'Data TLB, 4 KBytes and 4 MBytes pages, 256 Entries';
- RsIntelCacheDescr60 = '1 Level data cache: 16 KByte, 8-way set associative, 64 byte line size';
- RsIntelCacheDescr66 = '1 Level Data cache, 8 KBytes, 4-way set associative, 64 Bytes line size';
- RsIntelCacheDescr67 = '1 Level Data cache, 16 KBytes, 4-way set associative, 64 Bytes line size';
- RsIntelCacheDescr68 = '1 Level Data cache, 32 KBytes, 4-way set associative, 64 Bytes line size';
- RsIntelCacheDescr70 = 'Trace cache, 12 KOps, 8-way set associative';
- RsIntelCacheDescr71 = 'Trace cache, 16 KOps, 8-way set associative';
- RsIntelCacheDescr72 = 'Trace cache, 32 KOps, 8-way set associative';
- RsIntelCacheDescr78 = '2 Level cache, 1 MBytes, 4-way set associative, 64 Bytes line size';
- RsIntelCacheDescr79 = '2 Level cache, 128 KBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size';
- RsIntelCacheDescr7A = '2 Level cache, 256 KBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size';
- RsIntelCacheDescr7B = '2 Level cache, 512 KBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size';
- RsIntelCacheDescr7C = '2 Level cache, 1 MBytes, 8-way set associative, dual-sectored line, 64 Bytes sector size';
- RsIntelCacheDescr7D = '2 Level cache, 2 MByte, 8-way set associative, 64byte line size';
- RsIntelCacheDescr7F = '2 Level cache, 512 KByte, 2-way set associative, 64-byte line size';
- RsIntelCacheDescr82 = '2 Level cache, 256 KBytes, 8-way associative, 32 Bytes line size';
- RsIntelCacheDescr83 = '2 Level cache, 512 KBytes, 8-way associative, 32 Bytes line size';
- RsIntelCacheDescr84 = '2 Level cache, 1 MBytes, 8-way associative, 32 Bytes line size';
- RsIntelCacheDescr85 = '2 Level cache, 2 MBytes, 8-way associative, 32 Bytes line size';
- RsIntelCacheDescr86 = '2 Level cache, 512 KByte, 4-way set associative, 64 byte line size';
- RsIntelCacheDescr87 = '2 Level cache, 1 MByte, 8-way set associative, 64 byte line size';
- RsIntelCacheDescrB0 = 'Instruction TLB, 4 KByte Pages, 4-way set associative, 128 entries';
- RsIntelCacheDescrB3 = 'Data TLB, 4 KByte Pages, 4-way set associative, 128 entries';
- RsIntelCacheDescrF0 = '64-Byte Prefetching';
- RsIntelCacheDescrF1 = '128-Byte Prefetching';
+ RsIntelCacheDescr01 = 'Instruction TLB: 4 KByte pages, 4-way set associative, 32 entries';
+ RsIntelCacheDescr02 = 'Instruction TLB: 4 MByte pages, 4-way set associative, 2 entries';
+ RsIntelCacheDescr03 = 'Data TLB: 4 KByte pages, 4-way set associative, 64 entries';
+ RsIntelCacheDescr04 = 'Data TLB: 4 MByte pages, 4-way set associative, 8 entries';
+ RsIntelCacheDescr05 = 'Data TLB1: 4 MByte pages, 4-way set associative, 32 entries';
+ RsIntelCacheDescr06 = '1st level instruction cache: 8 KBytes, 4-way set associative, 32 byte line size';
+ RsIntelCacheDescr08 = '1st level instruction cache: 16 KBytes, 4-way set associative, 32 byte line size';
+ RsIntelCacheDescr0A = '1st level data cache: 8 KBytes, 2-way set associative, 32 byte line size';
+ RsIntelCacheDescr0B = 'Instruction TLB: 4 MByte pages, 4-way set associative, 4 entries';
+ RsIntelCacheDescr0C = '1st level data cache: 16 KBytes, 4-way set associative, 32 byte line size';
+ RsIntelCacheDescr22 = '3rd level cache: 512 KBytes, 4-way set associative, 64 byte line size, 2 lines per sector';
+ RsIntelCacheDescr23 = '3rd level cache: 1 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector';
+ RsIntelCacheDescr25 = '3rd level cache: 2 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector';
+ RsIntelCacheDescr29 = '3rd level cache: 4 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector';
+ RsIntelCacheDescr2C = '1st level data cache: 32 KBytes, 8-way set associative, 64 byte line size';
+ RsIntelCacheDescr30 = '1st level instruction cache: 32 KBytes, 8-way set associative, 64 byte line size';
+ RsIntelCacheDescr40 = 'No 2nd-level cache or, if processor contains a valid 2nd-level cache, no 3rd-level cache';
+ RsIntelCacheDescr41 = '2nd-level cache: 128 KBytes, 4-way set associative, 32 byte line size';
+ RsIntelCacheDescr42 = '2nd-level cache: 256 KBytes, 4-way set associative, 32 byte line size';
+ RsIntelCacheDescr43 = '2nd-level cache: 512 KBytes, 4-way set associative, 32 byte line size';
+ RsIntelCacheDescr44 = '2nd-level cache: 1 MBytes, 4-way set associative, 32 byte line size';
+ RsIntelCacheDescr45 = '2nd-level cache: 2 MBytes, 4-way set associative, 32 byte line size';
+ RsIntelCacheDescr46 = '3rd-level cache: 4 MBytes, 4-way set associative, 64 byte line size';
+ RsIntelCacheDescr47 = '3rd-level cache: 8 MBytes, 4-way set associative, 64 byte line size';
+ RsIntelCacheDescr49 = '2nd-level cache: 4 MBytes, 16-way set associative, 64 byte line size';
+ RsIntelCacheDescr50 = 'Instruction TLB: 4 KByte and 2 MByte or 4 MByte pages, 64 Entries';
+ RsIntelCacheDescr51 = 'Instruction TLB: 4 KByte and 2 MByte or 4 MByte pages, 128 Entries';
+ RsIntelCacheDescr52 = 'Instruction TLB: 4 KByte and 2 MByte or 4 MByte pages, 256 Entries';
+ RsIntelCacheDescr56 = 'Data TLB0: 4 MByte pages, 4-way set associative, 16 entries';
+ RsIntelCacheDescr57 = 'Data TLB0: 4 KByte pages, 4-way associative, 16 entries';
+ RsIntelCacheDescr5B = 'Data TLB: 4 KByte and 4 MByte pages, 64 Entries';
+ RsIntelCacheDescr5C = 'Data TLB: 4 KByte and 4 MByte pages, 128 Entries';
+ RsIntelCacheDescr5D = 'Data TLB: 4 KByte and 4 MByte pages, 256 Entries';
+ RsIntelCacheDescr60 = '1st-level data cache: 16 KByte, 8-way set associative, 64 byte line size';
+ RsIntelCacheDescr66 = '1st-level data cache: 8 KBytes, 4-way set associative, 64 byte line size';
+ RsIntelCacheDescr67 = '1st-level data cache: 16 KBytes, 4-way set associative, 64 byte line size';
+ RsIntelCacheDescr68 = '1st-level data cache: 32 KBytes, 4-way set associative, 64 byte line size';
+ RsIntelCacheDescr70 = 'Trace cache: 12 K-\xB5Ops, 8-way set associative';
+ RsIntelCacheDescr71 = 'Trace cache: 16 K-\xB5Ops, 8-way set associative';
+ RsIntelCacheDescr72 = 'Trace cache: 32 K-\xB5Ops, 8-way set associative';
+ RsIntelCacheDescr78 = '2nd-level cache: 1 MBytes, 4-way set associative, 64 bytes line size';
+ RsIntelCacheDescr79 = '2nd-level cache: 128 KBytes, 8-way set associative, 64 bytes line size, 2 lines per sector';
+ RsIntelCacheDescr7A = '2nd-level cache: 256 KBytes, 8-way set associative, 64 bytes line size, 2 lines per sector';
+ RsIntelCacheDescr7B = '2nd-level cache: 512 KBytes, 8-way set associative, 64 bytes line size, 2 lines per sector';
+ RsIntelCacheDescr7C = '2nd-level cache: 1 MBytes, 8-way set associative, 64 bytes line size, 2 lines per sector';
+ RsIntelCacheDescr7D = '2nd-level cache: 2 MBytes, 8-way set associative, 64 byte line size';
+ RsIntelCacheDescr7F = '2nd-level cache: 512 KBytes, 2-way set associative, 64 byte line size';
+ RsIntelCacheDescr82 = '2nd-level cache: 256 KBytes, 8-way associative, 32 byte line size';
+ RsIntelCacheDescr83 = '2nd-level cache: 512 KBytes, 8-way associative, 32 byte line size';
+ RsIntelCacheDescr84 = '2nd-level cache: 1 MBytes, 8-way associative, 32 byte line size';
+ RsIntelCacheDescr85 = '2nd-level cache: 2 MBytes, 8-way associative, 32 byte line size';
+ RsIntelCacheDescr86 = '2nd-level cache: 512 KByte, 4-way set associative, 64 byte line size';
+ RsIntelCacheDescr87 = '2nd-level cache: 1 MByte, 8-way set associative, 64 byte line size';
+ RsIntelCacheDescrB0 = 'Instruction TLB: 4 KByte pages, 4-way set associative, 128 entries';
+ RsIntelCacheDescrB3 = 'Data TLB: 4 KByte pages, 4-way set associative, 128 entries';
+ RsIntelCacheDescrB4 = 'Data TLB1: 4 KByte pages, 4-way set associative, 256 entries';
+ RsIntelCacheDescrF0 = '64-Byte Prefetching';
+ RsIntelCacheDescrF1 = '128-Byte Prefetching';
RsOSVersionWin95 = 'Windows 95';
RsOSVersionWin95OSR2 = 'Windows 95 OSR2';
Modified: trunk/jcl/source/common/JclSysInfo.pas
===================================================================
--- trunk/jcl/source/common/JclSysInfo.pas 2006-11-27 21:19:43 UTC (rev 1825)
+++ trunk/jcl/source/common/JclSysInfo.pas 2006-11-30 19:19:48 UTC (rev 1826)
@@ -333,8 +333,13 @@
L2Cache: Cardinal;
CacheDescriptors: array [0..15] of Byte;
BrandID: Byte;
+ FlushLineSize: Byte;
+ APICID: Byte;
ExFeatures: Cardinal;
Ex64Features: Cardinal;
+ Ex64Features2: Cardinal;
+ PhysicalAddressBits: Byte;
+ VirtualAddressBits: Byte;
end;
TCyrixSpecific = record
@@ -342,16 +347,26 @@
TLBInfo: array [0..3] of Byte;
end;
- TAMDSpecific = record
+ TAMDSpecific = packed record
ExFeatures: Cardinal;
- MByteDataTLB: array [TTLBInformation] of Byte;
- MByteInstructionTLB: array [TTLBInformation] of Byte;
- KByteDataTLB: array [TTLBInformation] of Byte;
- KByteInstructionTLB: array [TTLBInformation] of Byte;
+ ExFeatures2: Cardinal;
+ Features2: Cardinal;
+ BrandID: Byte;
+ FlushLineSize: Byte;
+ APICID: Byte;
+ ExBrandID: Word;
+ // do not split L1 MByte TLB
+ L1MByteInstructionTLB: array [TTLBInformation] of Byte;
+ L1MByteDataTLB: array [TTLBInformation] of Byte;
+ // do not split L1 KByte TLB
+ L1KByteInstructionTLB: array [TTLBInformation] of Byte;
+ L1KByteDataTLB: array [TTLBInformation] of Byte;
L1DataCache: array [TCacheInformation] of Byte;
L1InstructionCache: array [TCacheInformation] of Byte;
- L2MByteDataTLB: array [TTLBInformation] of Byte; // L2 TLB for 2-MByte and 4-MByte pages
+ // do not split L2 MByte TLB
L2MByteInstructionTLB: array [TTLBInformation] of Byte; // L2 TLB for 2-MByte and 4-MByte pages
+ L2MByteDataTLB: array [TTLBInformation] of Byte; // L2 TLB for 2-MByte and 4-MByte pages
+ // do not split L2 KByte TLB
L2KByteDataTLB: array [TTLBInformation] of Byte; // L2 TLB for 4-KByte pages
L2KByteInstructionTLB: array [TTLBInformation] of Byte; // L2 TLB for 4-KByte pages
L2Cache: Cardinal;
@@ -428,7 +443,7 @@
SSE: Byte; // SSE version 0 = no SSE, 1 = SSE, 2 = SSE2, 3 = SSE3
IsFDIVOK: Boolean;
Is64Bits: Boolean;
- DEPEnabled: Boolean; // incomplete
+ DEPCapable: Boolean;
HasCacheInfo: Boolean;
HasExtendedInfo: Boolean;
PType: Byte;
@@ -455,6 +470,8 @@
L3CacheLineSize: Byte; // in Byte
L3CacheAssociativity: Byte;
L3LinesPerSector: Byte;
+ LogicalCore: Byte;
+ PhysicalCore: Byte;
// todo: TLB
case CpuType: Byte of
CPU_TYPE_INTEL: (IntelSpecific: TIntelSpecific;);
@@ -587,15 +604,15 @@
EINTEL_BIT_2 = BIT_2; // Reserved, do not count on value
EINTEL_MONITOR = BIT_3; // Monitor/MWAIT
EINTEL_DSCPL = BIT_4; // CPL Qualified debug Store
- EINTEL_BIT_5 = BIT_5; // Reserved, do not count on value
+ EINTEL_VMX = BIT_5; // Virtual Machine Technology
EINTEL_BIT_6 = BIT_6; // Reserved, do not count on value
EINTEL_EST = BIT_7; // Enhanced Intel Speedstep technology
EINTEL_TM2 = BIT_8; // Thermal monitor 2
- EINTEL_BIT_9 = BIT_9; // Reserved, do not count on value
+ EINTEL_SSSE3 = BIT_9; // SSSE 3 extensions
EINTEL_CNXTID = BIT_10; // L1 Context ID
EINTEL_BIT_11 = BIT_11; // Reserved, do not count on value
EINTEL_BIT_12 = BIT_12; // Reserved, do not count on value
- EINTEL_BIT_13 = BIT_13; // Reserved, do not count on value
+ EINTEL_CMPXCHG16B = BIT_13; // CMPXCHG16B instruction
EINTEL_XTPR = BIT_14; // Send Task Priority messages
EINTEL_BIT_15 = BIT_15; // Reserved, do not count on value
EINTEL_BIT_16 = BIT_16; // Reserved, do not count on value
@@ -636,7 +653,7 @@
EINTEL64_BIT_17 = BIT_17; // Reserved, do not count on value
EINTEL64_BIT_18 = BIT_18; // Reserved, do not count on value
EINTEL64_BIT_19 = BIT_19; // Reserved, do not count on value
- EINTEL64_BIT_20 = BIT_20; // Reserved, do not count on value
+ EINTEL64_EDB = BIT_20; // Execute Disable Bit
EINTEL64_BIT_21 = BIT_21; // Reserved, do not count on value
EINTEL64_BIT_22 = BIT_22; // Reserved, do not count on value
EINTEL64_BIT_23 = BIT_23; // Reserved, do not count on value
@@ -649,6 +666,40 @@
EINTEL64_BIT_30 = BIT_30; // Reserved, do not count on value
EINTEL64_BIT_31 = BIT_31; // Reserved, do not count on value
+ { Extended Intel 64 Bits Feature Flags continued }
+ EINTEL64_2_LAHF = BIT_0; // LAHF/SAHF available in 64 bit mode
+ EINTEL64_2_BIT_1 = BIT_1; // Reserved, do not count on value
+ EINTEL64_2_BIT_2 = BIT_2; // Reserved, do not count on value
+ EINTEL64_2_BIT_3 = BIT_3; // Reserved, do not count on value
+ EINTEL64_2_BIT_4 = BIT_4; // Reserved, do not count on value
+ EINTEL64_2_BIT_5 = BIT_5; // Reserved, do not count on value
+ EINTEL64_2_BIT_6 = BIT_6; // Reserved, do not count on value
+ EINTEL64_2_BIT_7 = BIT_7; // Reserved, do not count on value
+ EINTEL64_2_BIT_8 = BIT_8; // Reserved, do not count on value
+ EINTEL64_2_BIT_9 = BIT_9; // Reserved, do not count on value
+ EINTEL64_2_BIT_10 = BIT_10; // Reserved, do not count on value
+ EINTEL64_2_BIT_11 = BIT_11; // Reserved, do not count on value
+ EINTEL64_2_BIT_12 = BIT_12; // Reserved, do not count on value
+ EINTEL64_2_BIT_13 = BIT_13; // Reserved, do not count on value
+ EINTEL64_2_BIT_14 = BIT_14; // Reserved, do not count on value
+ EINTEL64_2_BIT_15 = BIT_15; // Reserved, do not count on value
+ EINTEL64_2_BIT_16 = BIT_16; // Reserved, do not count on value
+ EINTEL64_2_BIT_17 = BIT_17; // Reserved, do not count on value
+ EINTEL64_2_BIT_18 = BIT_18; // Reserved, do not count on value
+ EINTEL64_2_BIT_19 = BIT_19; // Reserved, do not count on value
+ EINTEL64_2_BIT_20 = BIT_20; // Reserved, do not count on value
+ EINTEL64_2_BIT_21 = BIT_21; // Reserved, do not count on value
+ EINTEL64_2_BIT_22 = BIT_22; // Reserved, do not count on value
+ EINTEL64_2_BIT_23 = BIT_23; // Reserved, do not count on value
+ EINTEL64_2_BIT_24 = BIT_24; // Reserved, do not count on value
+ EINTEL64_2_BIT_25 = BIT_25; // Reserved, do not count on value
+ EINTEL64_2_BIT_26 = BIT_26; // Reserved, do not count on value
+ EINTEL64_2_BIT_27 = BIT_27; // Reserved, do not count on value
+ EINTEL64_2_BIT_28 = BIT_28; // Reserved, do not count on value
+ EINTEL64_2_BIT_29 = BIT_29; // Reserved, do not count on value
+ EINTEL64_2_BIT_30 = BIT_30; // Reserved, do not count on value
+ EINTEL64_2_BIT_31 = BIT_31; // Reserved, do not count on value
+
{ AMD Standard Feature Flags }
AMD_FPU = BIT_0; // Floating-Point unit on chip
AMD_VME = BIT_1; // Virtual Mode Extention
@@ -667,22 +718,56 @@
AMD_MCA = BIT_14; // Machine Check Architecture
AMD_CMOV = BIT_15; // Conditional Move Instruction
AMD_PAT = BIT_16; // Page Attribute Table
- AMD_PSE2 = BIT_17; // Page Size Extensions
+ AMD_PSE32 = BIT_17; // Page Size Extensions
AMD_BIT_18 = BIT_18; // Reserved, do not count on value
AMD_CLFLSH = BIT_19; // CLFLUSH instruction
AMD_BIT_20 = BIT_20; // Reserved, do not count on value
AMD_BIT_21 = BIT_21; // Reserved, do not count on value
AMD_BIT_22 = BIT_22; // Reserved, do not count on value
AMD_MMX = BIT_23; // MMX technology
- AMD_FX = BIT_24; // FXSAVE and FXSTORE instructions
+ AMD_FXSR = BIT_24; // FXSAVE and FXSTORE instructions
AMD_SSE = BIT_25; // SSE Extensions
AMD_SSE2 = BIT_26; // SSE2 Extensions
AMD_BIT_27 = BIT_27; // Reserved, do not count on value
- AMD_BIT_28 = BIT_28; // Reserved, do not count on value
+ AMD_HTT = BIT_28; // Hyper-Threading Technology
AMD_BIT_29 = BIT_29; // Reserved, do not count on value
AMD_BIT_30 = BIT_30; // Reserved, do not count on value
AMD_BIT_31 = BIT_31; // Reserved, do not count on value
+ { AMD Standard Feature Flags continued }
+ AMD2_SSE3 = BIT_0; // SSE3 extensions
+ AMD2_BIT_1 = BIT_1; // Reserved, do not count on value
+ AMD2_BIT_2 = BIT_2; // Reserved, do not count on value
+ AMD2_BIT_3 = BIT_3; // Reserved, do not count on value
+ AMD2_BIT_4 = BIT_4; // Reserved, do not count on value
+ AMD2_BIT_5 = BIT_5; // Reserved, do not count on value
+ AMD2_BIT_6 = BIT_6; // Reserved, do not count on value
+ AMD2_BIT_7 = BIT_7; // Reserved, do not count on value
+ AMD2_BIT_8 = BIT_8; // Reserved, do not count on value
+ AMD2_BIT_9 = BIT_9; // Reserved, do not count on value
+ AMD2_BIT_10 = BIT_10; // Reserved, do not count on value
+ AMD2_BIT_11 = BIT_11; // Reserved, do not count on value
+ AMD2_BIT_12 = BIT_12; // Reserved, do not count on value
+ AMD2_CMPXCHG16B = BIT_13; // CMPXCHG16B available
+ AMD2_BIT_14 = BIT_14; // Reserved, do not count on value
+ AMD2_BIT_15 = BIT_15; // Reserved, do not count on value
+ AMD2_BIT_16 = BIT_16; // Reserved, do not count on value
+ AMD2_BIT_17 = BIT_17; // Reserved, do not count on value
+ AMD2_BIT_18 = BIT_18; // Reserved, do not count on value
+ AMD2_BIT_19 = BIT_19; // Reserved, do not count on value
+ AMD2_BIT_20 = BIT_20; // Reserved, do not count on value
+ AMD2_BIT_21 = BIT_21; // Reserved, do not count on value
+ AMD2_BIT_22 = BIT_22; // Reserved, do not count on value
+ AMD2_BIT_23 = BIT_23; // Reserved, do not count on value
+ AMD2_BIT_24 = BIT_24; // Reserved, do not count on value
+ AMD2_BIT_25 = BIT_25; // Reserved, do not count on value
+ AMD2_BIT_26 = BIT_26; // Reserved, do not count on value
+ AMD2_BIT_27 = BIT_27; // Reserved, do not count on value
+ AMD2_BIT_28 = BIT_28; // Reserved, do not count on value
+ AMD2_BIT_29 = BIT_29; // Reserved, do not count on value
+ AMD2_BIT_30 = BIT_30; // Reserved, do not count on value
+ AMD2_RAZ = BIT_31; // RAZ
+
{ AMD Enhanced Feature Flags }
EAMD_FPU = BIT_0; // Floating-Point unit on chip
EAMD_VME = BIT_1; // Virtual Mode Extention
@@ -704,7 +789,7 @@
EAMD_PSE2 = BIT_17; // Page Size Extensions
EAMD_BIT_18 = BIT_18; // Reserved, do not count on value
EAMD_BIT_19 = BIT_19; // Reserved, do not count on value
- EAMD_NEPP = BIT_20; // No-Execute Page Protection
+ EAMD_NX = BIT_20; // No-Execute Page Protection
EAMD_BIT_21 = BIT_21; // Reserved, do not count on value
EAMD_EXMMX = BIT_22; // AMD Extensions to MMX technology
EAMD_MMX = BIT_23; // MMX technology
@@ -717,13 +802,73 @@
EAMD_EX3DNOW = BIT_30; // AMD Extensions to 3DNow! intructions
EAMD_3DNOW = BIT_31; // AMD 3DNOW! Technology
+ { AMD Extended Feature Flags continued }
+ EAMD2_LAHF = BIT_0; // LAHF/SAHF available in 64-bit mode
+ EAMD2_CMPLEGACY = BIT_1; // core multi-processing legacy mode
+ EAMD2_SVM = BIT_2; // Secure Virtual Machine
+ EAMD2_BIT_3 = BIT_3; // Reserved, do not count on value
+ EAMD2_ALTMOVCR8 = BIT_4; // LOCK MOV CR0 means MOV CR8
+ EAMD2_BIT_5 = BIT_5; // Reserved, do not count on value
+ EAMD2_BIT_6 = BIT_6; // Reserved, do not count on value
+ EAMD2_BIT_7 = BIT_7; // Reserved, do not count on value
+ EAMD2_BIT_8 = BIT_8; // Reserved, do not count on value
+ EAMD2_BIT_9 = BIT_9; // Reserved, do not count on value
+ EAMD2_BIT_10 = BIT_10; // Reserved, do not count on value
+ EAMD2_BIT_11 = BIT_11; // Reserved, do not count on value
+ EAMD2_BIT_12 = BIT_12; // Reserved, do not count on value
+ EAMD2_BIT_13 = BIT_13; // Reserved, do not count on value
+ EAMD2_BIT_14 = BIT_14; // Reserved, do not count on value
+ EAMD2_BIT_15 = BIT_15; // Reserved, do not count on value
+ EAMD2_BIT_16 = BIT_16; // Reserved, do not count on value
+ EAMD2_BIT_17 = BIT_17; // Reserved, do not count on value
+ EAMD2_BIT_18 = BIT_18; // Reserved, do not count on value
+ EAMD2_BIT_19 = BIT_19; // Reserved, do not count on value
+ EAMD2_BIT_20 = BIT_20; // Reserved, do not count on value
+ EAMD2_BIT_21 = BIT_21; // Reserved, do not count on value
+ EAMD2_BIT_22 = BIT_22; // Reserved, do not count on value
+ EAMD2_BIT_23 = BIT_23; // Reserved, do not count on value
+ EAMD2_BIT_24 = BIT_24; // Reserved, do not count on value
+ EAMD2_BIT_25 = BIT_25; // Reserved, do not count on value
+ EAMD2_BIT_26 = BIT_26; // Reserved, do not count on value
+ EAMD2_BIT_27 = BIT_27; // Reserved, do not count on value
+ EAMD2_BIT_28 = BIT_28; // Reserved, do not count on value
+ EAMD2_BIT_29 = BIT_29; // Reserved, do not count on value
+ EAMD2_BIT_30 = BIT_30; // Reserved, do not count on value
+ EAMD2_BIT_31 = BIT_31; // Reserved, do not count on value
+
{ AMD Power Management Features Flags }
- PAMD_TEMPSENSOR = $00000001; // Temperature Sensor
- PAMD_FREQUENCYID = $00000002; // Frequency ID Control
- PAMD_VOLTAGEID = $00000004; // Voltage ID Control
- PAMD_THERMALTRIP = $00000008; // Thermal Trip
- PAMD_THERMALMONITOR = $00000010; // Thermal Monitoring
- PAMD_SOFTTHERMCONTROL = $00000020; // Software Thermal Control
+ PAMD_TEMPSENSOR = BIT_0; // Temperature Sensor
+ PAMD_FREQUENCYID = BIT_1; // Frequency ID Control
+ PAMD_VOLTAGEID = BIT_2; // Voltage ID Control
+ PAMD_THERMALTRIP = BIT_3; // Thermal Trip
+ PAMD_THERMALMONITOR = BIT_4; // Thermal Monitoring
+ PAMD_SOFTTHERMCONTROL = BIT_5; // Software Thermal Control
+ PAMD_BIT_6 = BIT_6; // Reserved, do not count on value
+ PAMD_BIT_7 = BIT_7; // Reserved, do not count on value
+ PAMD_TSC_INVARIANT = BIT_8; // TSC rate is invariant
+ PAMD_BIT_9 = BIT_9; // Reserved, do not count on value
+ PAMD_BIT_10 = BIT_10; // Reserved, do not count on value
+ PAMD_BIT_11 = BIT_11; // Reserved, do not count on value
+ PAMD_BIT_12 = BIT_12; // Reserved, do not count on value
+ PAMD_BIT_13 = BIT_13; // Reserved, do not count on value
+ PAMD_BIT_14 = BIT_14; // Reserved, do not count on value
+ PAMD_BIT_15 = BIT_15; // Reserved, do not count on value
+ PAMD_BIT_16 = BIT_16; // Reserved, do not count on value
+ PAMD_BIT_17 = BIT_17; // Reserved, do not count on value
+ PAMD_BIT_18 = BIT_18; // Reserved, do not count on value
+ PAMD_BIT_19 = BIT_19; // Reserved, do not count on value
+ PAMD_BIT_20 = BIT_20; // Reserved, do not count on value
+ PAMD_BIT_21 = BIT_21; // Reserved, do not count on value
+ PAMD_BIT_22 = BIT_22; // Reserved, do not count on value
+ PAMD_BIT_23 = BIT_23; // Reserved, do not count on value
+ PAMD_BIT_24 = BIT_24; // Reserved, do not count on value
+ PAMD_BIT_25 = BIT_25; // Reserved, do not count on value
+ PAMD_BIT_26 = BIT_26; // Reserved, do not count on value
+ PAMD_BIT_27 = BIT_27; // Reserved, do not count on value
+ PAMD_BIT_28 = BIT_28; // Reserved, do not count on value
+ PAMD_BIT_29 = BIT_29; // Reserved, do not count on value
+ PAMD_BIT_30 = BIT_30; // Reserved, do not count on value
+ PAMD_BIT_31 = BIT_31; // Reserved, do not count on value
{ AMD TLB and L1 Associativity constants }
AMD_ASSOC_RESERVED = 0;
@@ -998,58 +1143,66 @@
MXCSR_FZ = BIT_15; // Flush to Zero
const
- IntelCacheDescription: array [0..50] of TCacheInfo = (
- (D: $00; Family: cfOther; I: RsIntelCacheDescr00),
- (D: $01; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 4; Entries: 32; I: RsIntelCacheDescr01), // Instruction TLB: 4 KByte Pages, 4-way set associative, 32 entries
- (D: $02; Family: cfInstructionTLB; Size: 4096; WaysOfAssoc: 4; Entries: 2; I: RsIntelCacheDescr02), // Instruction TLB: 4 MByte Pages, 4-way set associative, 2 entries
- (D: $03; Family: cfDataTLB; Size: 4; WaysOfAssoc: 4; Entries: 64; I: RsIntelCacheDescr03), // Data TLB: 4KByte Pages, 4-way set associative, 64 entries
- (D: $04; Family: cfDataTLB; Size: 4096; WaysOfAssoc: 4; Entries: 8; I: RsIntelCacheDescr04), // Data TLB: 4MByte Pages, 4-way set associative, 8 entries
- (D: $06; Family: cfL1InstructionCache; Size: 8; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr06), // 1st-level instruction cache: 8 KBytes, 4-way set associative, 32 byte line size
- (D: $08; Family: cfL1InstructionCache; Size: 16; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr08), // 1st-level instruction cache: 16 KBytes, 4-way set associative, 32 byte line size
- (D: $0A; Family: cfL1DataCache; Size: 8; WaysOfAssoc: 2; LineSize: 32; I: RsIntelCacheDescr0A), // 1st-level data cache: 8 KBytes, 2-way set associative, 32 byte line size
- (D: $0C; Family: cfL1DataCache; Size: 16; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr0C), // 1st-level data cache: 16 KBytes, 4-way set associative, 32 byte line size
- (D: $22; Family: cfL3Cache; Size: 512; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr22), // 3rd-level cache: 512 KBytes, 4-way set associative, 64 byte line size, 2 lines per sector
- (D: $23; Family: cfL3Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr23), // 3rd-level cache: 1 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector
- (D: $25; Family: cfL3Cache; Size: 2048; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr25), // 3rd-level cache: 2 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector
- (D: $29; Family: cfL3Cache; Size: 4096; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr29), // 3rd-level cache: 4M Bytes, 8-way set associative, 64 byte line size, 2 lines per sector
- (D: $2C; Family: cfL1DataCache; Size: 32; WaysOfAssoc: 8; LineSize: 64; I: RsIntelCacheDescr2C), // 1st-level data cache: 32K Bytes, 8-way set associative, 64 byte line size
- (D: $30; Family: cfL1InstructionCache; Size: 32; WaysOfAssoc: 8; LineSize: 64; I: RsIntelCacheDescr30), // 1st-level instruction cache: 32K Bytes, 8-way set associative, 64 byte line size
- (D: $40; Family: cfOther; I: RsIntelCacheDescr40), // No 2nd-level cache or, if processor contains a valid 2nd-level cache, no 3rd-level cache
- (D: $41; Family: cfL2Cache; Size: 128; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr41), // 2nd-level cache: 128 KBytes, 4-way set associative, 32 byte line size
- (D: $42; Family: cfL2Cache; Size: 256; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr42), // 2nd-level cache: 256 KBytes, 4-way set associative, 32 byte line size
- (D: $43; Family: cfL2Cache; Size: 512; WaysOfAsso...
[truncated message content] |
|
From: <ou...@us...> - 2006-12-30 09:05:02
|
Revision: 1856
http://svn.sourceforge.net/jcl/?rev=1856&view=rev
Author: outchy
Date: 2006-12-30 01:04:59 -0800 (Sat, 30 Dec 2006)
Log Message:
-----------
Changed ancestors of exception classes of the JCL to EJclError: making the debugger ignoring all JCL exceptions will be easier.
Modified Paths:
--------------
trunk/jcl/source/common/JclBorlandTools.pas
trunk/jcl/source/common/JclPCRE.pas
trunk/jcl/source/common/JclSimpleXml.pas
trunk/jcl/source/common/JclStreams.pas
trunk/jcl/source/common/JclStrings.pas
trunk/jcl/source/common/JclSysUtils.pas
trunk/jcl/source/common/JclUnitConv.pas
Modified: trunk/jcl/source/common/JclBorlandTools.pas
===================================================================
--- trunk/jcl/source/common/JclBorlandTools.pas 2006-12-29 12:38:12 UTC (rev 1855)
+++ trunk/jcl/source/common/JclBorlandTools.pas 2006-12-30 09:04:59 UTC (rev 1856)
@@ -73,7 +73,7 @@
// Various definitions
type
- EJclBorRADException = class(Exception);
+ EJclBorRADException = class(EJclError);
TJclBorRADToolKind = (brDelphi, brCppBuilder, brBorlandDevStudio);
{$IFDEF KYLIX}
Modified: trunk/jcl/source/common/JclPCRE.pas
===================================================================
--- trunk/jcl/source/common/JclPCRE.pas 2006-12-29 12:38:12 UTC (rev 1855)
+++ trunk/jcl/source/common/JclPCRE.pas 2006-12-30 09:04:59 UTC (rev 1856)
@@ -45,13 +45,13 @@
{$IFDEF HAS_UNIT_LIBC}
Libc,
{$ENDIF HAS_UNIT_LIBC}
- Classes, SysUtils;
+ Classes, SysUtils, JclBase;
const
JCL_PCRE_ERROR_STUDYFAILED = -999;
type
- EPCREError = class(Exception)
+ EPCREError = class(EJclError)
private
FErrorCode: Integer;
public
Modified: trunk/jcl/source/common/JclSimpleXml.pas
===================================================================
--- trunk/jcl/source/common/JclSimpleXml.pas 2006-12-29 12:38:12 UTC (rev 1855)
+++ trunk/jcl/source/common/JclSimpleXml.pas 2006-12-30 09:04:59 UTC (rev 1856)
@@ -44,7 +44,8 @@
{$IFDEF HAS_UNIT_VARIANTS}
Variants,
{$ENDIF HAS_UNIT_VARIANTS}
- IniFiles;
+ IniFiles,
+ JclBase;
type
{$IFDEF COMPILER5}
@@ -52,7 +53,7 @@
THandle = Longword;
{$ENDIF COMPILER5}
TJclSimpleXML = class;
- EJclSimpleXMLError = class(Exception);
+ EJclSimpleXMLError = class(EJclError);
{$M+} // generate RTTI for published properties
TJclSimpleXMLElem = class;
{$M-}
Modified: trunk/jcl/source/common/JclStreams.pas
===================================================================
--- trunk/jcl/source/common/JclStreams.pas 2006-12-29 12:38:12 UTC (rev 1855)
+++ trunk/jcl/source/common/JclStreams.pas 2006-12-30 09:04:59 UTC (rev 1856)
@@ -40,14 +40,15 @@
{$IFDEF LINUX}
Libc,
{$ENDIF LINUX}
- SysUtils, Classes;
+ SysUtils, Classes,
+ JclBase;
type
{$IFDEF COMPILER5}
TSeekOrigin = (soBeginning, soCurrent, soEnd);
{$ENDIF COMPILER5}
- EJclStreamError = class(Exception);
+ EJclStreamError = class(EJclError);
// abstraction layer to support Delphi 5 and C++Builder 5 streams
// 64 bit version of overloaded functions are introduced
@@ -329,7 +330,7 @@
implementation
uses
- JclBase, JclResources;
+ JclResources;
{$IFDEF KYLIX}
function __open(PathName: PChar; Flags: Integer; Mode: Integer): Integer; cdecl;
Modified: trunk/jcl/source/common/JclStrings.pas
===================================================================
--- trunk/jcl/source/common/JclStrings.pas 2006-12-29 12:38:12 UTC (rev 1855)
+++ trunk/jcl/source/common/JclStrings.pas 2006-12-30 09:04:59 UTC (rev 1856)
@@ -389,10 +389,10 @@
{$ELSE}
type
- FormatException = class(Exception);
- ArgumentException = class(Exception);
- ArgumentNullException = class(Exception);
- ArgumentOutOfRangeException = class(Exception);
+ FormatException = class(EJclError);
+ ArgumentException = class(EJclError);
+ ArgumentNullException = class(EJclError);
+ ArgumentOutOfRangeException = class(EJclError);
IToString = interface
['{C4ABABB4-1029-46E7-B5FA-99800F130C05}']
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2006-12-29 12:38:12 UTC (rev 1855)
+++ trunk/jcl/source/common/JclSysUtils.pas 2006-12-30 09:04:59 UTC (rev 1856)
@@ -109,7 +109,7 @@
// Functions for the shared memory owner
type
- ESharedMemError = class(Exception);
+ ESharedMemError = class(EJclError);
{$IFDEF MSWINDOWS}
Modified: trunk/jcl/source/common/JclUnitConv.pas
===================================================================
--- trunk/jcl/source/common/JclUnitConv.pas 2006-12-29 12:38:12 UTC (rev 1855)
+++ trunk/jcl/source/common/JclUnitConv.pas 2006-12-30 09:04:59 UTC (rev 1856)
@@ -94,7 +94,7 @@
type
{ Exception classes }
- EUnitConversionError = class(Exception);
+ EUnitConversionError = class(EJclError);
ETemperatureConversionError = class(EUnitConversionError);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ou...@us...> - 2006-12-30 13:53:49
|
Revision: 1860
http://svn.sourceforge.net/jcl/?rev=1860&view=rev
Author: outchy
Date: 2006-12-30 05:53:48 -0800 (Sat, 30 Dec 2006)
Log Message:
-----------
Introduction of 32/64 bit address types.
Modified Paths:
--------------
trunk/jcl/source/common/JclBase.pas
trunk/jcl/source/common/JclResources.pas
Modified: trunk/jcl/source/common/JclBase.pas
===================================================================
--- trunk/jcl/source/common/JclBase.pas 2006-12-30 13:12:32 UTC (rev 1859)
+++ trunk/jcl/source/common/JclBase.pas 2006-12-30 13:53:48 UTC (rev 1860)
@@ -219,6 +219,15 @@
AnsiHexDigits = ['0'..'9', 'A'..'F', 'a'..'f'];
AnsiValidIdentifierLetters = ['0'..'9', 'A'..'Z', 'a'..'z', '_'];
+ AnsiHexPrefixPascal = AnsiString('$');
+ AnsiHexPrefixC = AnsiString('0x');
+
+ {$IFDEF BCB}
+ AnsiHexPrefix = AnsiHexPrefixC;
+ {$ELSE ~BCB}
+ AnsiHexPrefix = AnsiHexPrefixPascal;
+ {$ENDIF ~BCB}
+
{$IFNDEF XPLATFORM_RTL}
procedure RaiseLastOSError;
{$ENDIF ~XPLATFORM_RTL}
@@ -239,6 +248,21 @@
function ByteArrayToString(const Data: TBytes; Count: Integer): string;
{$ENDIF CLR}
+type
+ TJclAddr64 = Int64;
+ TJclAddr32 = DWORD;
+
+ {$IFDEF 64BIT}
+ TJclAddr = TJclAddr64;
+ {$ELSE ~64BIT}
+ TJclAddr = TJclAddr32;
+ {$ENDIF}
+
+ EJclAddr64Exception = class(EJclError);
+
+function Addr64ToAddr32(const Value: TJclAddr64): TJclAddr32;
+function Addr32ToAddr64(const Value: TJclAddr32): TJclAddr64;
+
{$IFDEF UNITVERSIONING}
const
UnitVersioning: TUnitVersionInfo = (
@@ -509,6 +533,29 @@
end;
{$ENDIF ~XPLATFORM_RTL}
+{$OVERFLOWCHECKS OFF}
+
+function Addr64ToAddr32(const Value: TJclAddr64): TJclAddr32;
+begin
+ if (Value shr 32) = 0 then
+ Result := Value
+ else
+ {$IFDEF CLR}
+ raise EJclAddr64Exception.CreateFmt(RsCantConvertAddr64, [AnsiHexPrefix, Value]);
+ {$ELSE ~CLR}
+ raise EJclAddr64Exception.CreateResFmt(@RsCantConvertAddr64, [AnsiHexPrefix, Value]);
+ {$ENDIF ~CLR}
+end;
+
+function Addr32ToAddr64(const Value: TJclAddr32): TJclAddr64;
+begin
+ Result := Value;
+end;
+
+{$IFDEF OVERFLOWCHECKS_ON}
+{$OVERFLOWCHECKS ON}
+{$ENDIF OVERFLOWCHECKS_ON}
+
{$IFDEF UNITVERSIONING}
initialization
RegisterUnitVersion(HInstance, UnitVersioning);
Modified: trunk/jcl/source/common/JclResources.pas
===================================================================
--- trunk/jcl/source/common/JclResources.pas 2006-12-30 13:12:32 UTC (rev 1859)
+++ trunk/jcl/source/common/JclResources.pas 2006-12-30 13:53:48 UTC (rev 1860)
@@ -59,6 +59,7 @@
RsWin32Prefix = 'Win32: %s (%u)';
RsDynArrayError = 'DynArrayInitialize: ElementSize out of bounds';
RsSysErrorMessageFmt = 'Win32 Error %d (%x)';
+ RsCantConvertAddr64 = 'The address %s%.16x cannot be converted to 32 bit';
{$IFDEF CLR}
RsEGetBytesExFmt = 'GetBytesEx(): Unsupported value type: %s';
RsESetBytesExFmt = 'SetBytesEx(): Unsupported value type: %s';
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ou...@us...> - 2007-01-12 19:30:15
|
Revision: 1877
http://svn.sourceforge.net/jcl/?rev=1877&view=rev
Author: outchy
Date: 2007-01-12 11:30:13 -0800 (Fri, 12 Jan 2007)
Log Message:
-----------
Kylix compatibility
Modified Paths:
--------------
trunk/jcl/source/common/JclBase.pas
trunk/jcl/source/common/JclFileUtils.pas
Modified: trunk/jcl/source/common/JclBase.pas
===================================================================
--- trunk/jcl/source/common/JclBase.pas 2007-01-10 22:56:19 UTC (rev 1876)
+++ trunk/jcl/source/common/JclBase.pas 2007-01-12 19:30:13 UTC (rev 1877)
@@ -250,7 +250,7 @@
type
TJclAddr64 = Int64;
- TJclAddr32 = DWORD;
+ TJclAddr32 = Cardinal;
{$IFDEF 64BIT}
TJclAddr = TJclAddr64;
Modified: trunk/jcl/source/common/JclFileUtils.pas
===================================================================
--- trunk/jcl/source/common/JclFileUtils.pas 2007-01-10 22:56:19 UTC (rev 1876)
+++ trunk/jcl/source/common/JclFileUtils.pas 2007-01-12 19:30:13 UTC (rev 1877)
@@ -824,6 +824,8 @@
function Write(const Buffer; Count: Longint): Longint; override;
end;
+{$ENDIF Win32API}
+
TJclMappedTextReaderIndex = (tiNoIndex, tiFull);
{$IFNDEF FPC}
@@ -879,8 +881,6 @@
property Size: Integer read FSize;
end;
-{$ENDIF Win32API}
-
{ TODO : UNTESTED/UNDOCUMENTED }
type
@@ -1431,6 +1431,8 @@
end;
end;
+{$ENDIF MSWINDOWS}
+
//=== { TJclMappedTextReader } ===============================================
constructor TJclMappedTextReader.Create(MemoryStream: TCustomMemoryStream; FreeStream: Boolean;
@@ -1447,7 +1449,12 @@
const AIndexOption: TJclMappedTextReaderIndex);
begin
inherited Create;
+ {$IFDEF MSWINDOWS}
FMemoryStream := TJclFileMappingStream.Create(FileName);
+ {$ELSE ~ MSWINDOWS}
+ FMemoryStream := TMemoryStream.Create;
+ TMemoryStream(FMemoryStream).LoadFromFile(FileName);
+ {$ENDIF ~ MSWINDOWS}
FFreeStream := True;
FIndexOption := AIndexOption;
Init;
@@ -1776,8 +1783,7 @@
end;
end;
-{$ENDIF ~CLR}
-{$ENDIF MSWINDOWS}
+{$ENDIF ~ CLR}
//=== Path manipulation ======================================================
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ou...@us...> - 2007-01-13 13:23:00
|
Revision: 1879
http://svn.sourceforge.net/jcl/?rev=1879&view=rev
Author: outchy
Date: 2007-01-13 05:22:58 -0800 (Sat, 13 Jan 2007)
Log Message:
-----------
Merged pcre branch into the trunk
Modified Paths:
--------------
trunk/jcl/source/common/JclPCRE.pas
trunk/jcl/source/common/JclResources.pas
trunk/jcl/source/common/pcre.pas
Modified: trunk/jcl/source/common/JclPCRE.pas
===================================================================
--- trunk/jcl/source/common/JclPCRE.pas 2007-01-13 13:14:13 UTC (rev 1878)
+++ trunk/jcl/source/common/JclPCRE.pas 2007-01-13 13:22:58 UTC (rev 1879)
@@ -36,6 +36,7 @@
interface
uses
+ pcre,
{$IFDEF UNITVERSIONING}
JclUnitVersioning,
{$ENDIF UNITVERSIONING}
@@ -48,9 +49,15 @@
Classes, SysUtils, JclBase;
const
- JCL_PCRE_ERROR_STUDYFAILED = -999;
+ JCL_PCRE_CALLOUT_NOERROR = 0;
+ JCL_PCRE_CALLOUT_FAILCONTINUE = 1;
+ JCL_PCRE_ERROR_CALLOUTERROR = -998;
+ JCL_PCRE_ERROR_STUDYFAILED = -999;
+
type
+ TJclAnsiRegEx = class;
+
EPCREError = class(EJclError)
private
FErrorCode: Integer;
@@ -68,45 +75,70 @@
roPartial, roDfaShortest, roDfaRestart, roDfaFirstLine, roDupNames,
roNewLineCR, roNewLineLF);
TJclAnsiRegExOptions = set of TJclAnsiRegExOption;
- TJclAnsiCaptureOffset = record
+ TJclAnsiCaptureRange = record
FirstPos: Integer;
LastPos: Integer;
end;
+ TJclAnsiRegExCallout = procedure (Sender: TJclAnsiRegEx;
+ Index, MatchStart, SubjectPos, LastCapture, PatternPos, NextItemLength: Integer;
+ var ErrorCode: Integer) of object;
+ TPCRECalloutIndex = 0 .. 255;
+
TJclAnsiRegEx = class(TObject)
private
FCode: Pointer;
FExtra: Pointer;
FOptions: TJclAnsiRegExOptions;
- FSubject: String;
+ FPattern: AnsiString;
+ FDfaMode: Boolean;
+ FSubject: AnsiString;
FErrorCode: Integer;
- FErrorMessage: String;
+ FErrorMessage: AnsiString;
FErrorOffset: Integer;
FVector: PPCREIntArray;
FVectorSize: Integer;
- FStringCount: Integer;
+ FCaptureCount: Integer;
- function GetCaptureCount: Integer;
- function GetCaptures(Index: Integer): String;
+ FOnCallout: TJclAnsiRegExCallout;
+
+ function GetCapture(Index: Integer): AnsiString;
+ function GetCaptureRange(Index: Integer): TJclAnsiCaptureRange;
+ function GetNamedCapture(const Name: AnsiString): AnsiString;
+ function GetCaptureNameCount: Integer;
+ function GetCaptureName(Index: Integer): String;
function GetAPIOptions(RunTime: Boolean): Integer;
- function GetCapturesOffset(Index: Integer): TJclAnsiCaptureOffset;
+ function CalloutHandler(var CalloutBlock: pcre_callout_block): Integer;
public
destructor Destroy; override;
property Options: TJclAnsiRegExOptions read FOptions write FOptions;
- function Compile(const Pattern: String; Study: Boolean;
+ function Compile(const Pattern: AnsiString; Study: Boolean;
UserLocale: Boolean = False): Boolean;
- function Match(const Subject: String; StartOffset: Cardinal = 1): Boolean;
- property CaptureCount: Integer read GetCaptureCount;
- property Captures[Index: Integer]: String read GetCaptures;
- property CaptureOffset[Index: Integer]: TJclAnsiCaptureOffset read GetCapturesOffset;
+ property Pattern: AnsiString read FPattern;
+ property DfaMode: Boolean read FDfaMode write FDfaMode;
+ function Match(const Subject: AnsiString; StartOffset: Cardinal = 1): Boolean;
+ property Subject: AnsiString read FSubject;
+ property CaptureCount: Integer read FCaptureCount write FCaptureCount;
+ property Captures[Index: Integer]: AnsiString read GetCapture;
+ property CaptureRanges[Index: Integer]: TJclAnsiCaptureRange read GetCaptureRange;
+
+ property NamedCaptures[const Name: AnsiString]: AnsiString read GetNamedCapture;
+ property CaptureNameCount: Integer read GetCaptureNameCount;
+ property CaptureNames[Index: Integer]: AnsiString read GetCaptureName;
+ function IndexOfName(const Name: String): Integer;
+ function IsNameValid(const Name: String): Boolean;
+
property ErrorCode: Integer read FErrorCode;
- property ErrorMessage: String read FErrorMessage;
+ property ErrorMessage: AnsiString read FErrorMessage;
property ErrorOffset: Integer read FErrorOffset;
+
+ property oncallout: TJclAnsiRegExCallout
+ read FOnCallout write FOnCallout;
end;
procedure InitializeLocaleSupport;
@@ -125,7 +157,6 @@
implementation
uses
- pcre,
JclResources;
var
@@ -141,12 +172,18 @@
FreeMem(P);
end;
+function JclPCRECallout(var callout_block: pcre_callout_block): Integer; cdecl;
+begin
+ Result := TJclAnsiRegEx(callout_block.callout_data).CalloutHandler(callout_block);
+end;
+
function PCRECheck(Value: Integer): Boolean;
var
PErr: PResStringRec;
begin
- Result := False;
- PErr := nil;
+ Result := Value >= 0;
+ if Result then Exit;
+
case Value of
PCRE_ERROR_NOMATCH:
PErr := @RsErrNoMatch;
@@ -192,11 +229,13 @@
PErr := @RsErrRecursionLimit;
JCL_PCRE_ERROR_STUDYFAILED:
PErr := @RsErrStudyFailed;
+ JCL_PCRE_ERROR_CALLOUTERROR:
+ PErr := @RsErrCalloutError;
else
- Result := True;
+ PErr := @RsErrUnknownError;
end;
- if not Result then
- raise EPCREError.CreateRes(PErr, Value);
+
+ raise EPCREError.CreateRes(PErr, Value);
end;
//=== { TJclAnsiRegEx } ======================================================
@@ -213,7 +252,7 @@
inherited Destroy;
end;
-function TJclAnsiRegEx.Compile(const Pattern: String; Study: Boolean;
+function TJclAnsiRegEx.Compile(const Pattern: AnsiString; Study: Boolean;
UserLocale: Boolean = False): Boolean;
var
ErrMsgPtr: PChar;
@@ -227,12 +266,14 @@
else
Tables := nil;
- if Pattern = '' then
+ FPattern := Pattern;
+ if FPattern = '' then
raise EPCREError.CreateRes(@RsErrNull, PCRE_ERROR_NULL);
if Assigned(FCode) then pcre_free^(FCode);
- FCode := pcre_compile2(PChar(Pattern), GetAPIOptions(False),
+ FCode := pcre_compile2(PChar(FPattern), GetAPIOptions(False),
@FErrorCode, @ErrMsgPtr, @FErrorOffset, Tables);
+ Inc(FErrorOffset);
FErrorMessage := ErrMsgPtr;
Result := Assigned(FCode);
if Result then
@@ -249,11 +290,16 @@
end;
end;
- PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_CAPTURECOUNT, @FStringCount));
- if FStringCount > 0 then
- FVectorSize := (FStringCount + 1) * 3
+ if FDfaMode then
+ FVectorSize := FCaptureCount
else
- FVectorSize := 0;
+ begin
+ PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_CAPTURECOUNT, @FCaptureCount));
+ if FCaptureCount > 0 then
+ FVectorSize := (FCaptureCount + 1) * 3
+ else
+ FVectorSize := 0;
+ end;
ReAllocMem(FVector, FVectorSize * SizeOf(Integer));
end;
end;
@@ -292,16 +338,11 @@
end;
end;
-function TJclAnsiRegEx.GetCaptureCount: Integer;
-begin
- Result := FStringCount;
-end;
-
-function TJclAnsiRegEx.GetCaptures(Index: Integer): String;
+function TJclAnsiRegEx.GetCapture(Index: Integer): AnsiString;
var
From, Len: Integer;
begin
- if (Index < 0) or (Index >= FStringCount) then
+ if (Index < 0) or (Index >= FCaptureCount) then
PCRECheck(PCRE_ERROR_NOSUBSTRING)
else
begin
@@ -313,34 +354,127 @@
end;
end;
-function TJclAnsiRegEx.GetCapturesOffset(Index: Integer): TJclAnsiCaptureOffset;
+function TJclAnsiRegEx.GetCaptureRange(Index: Integer): TJclAnsiCaptureRange;
begin
- if (Index < 0) or (Index >= FStringCount) then
+ if (Index < 0) or (Index >= FCaptureCount) then
+ PCRECheck(PCRE_ERROR_NOSUBSTRING)
+ else
begin
- Result.FirstPos := -1;
- Result.LastPos := -1;
+ Index := Index * 2;
+ Result.FirstPos := FVector^[Index];
+ Result.LastPos := FVector^[Index + 1] - 1;
end;
- Index := Index * 2;
- Result.FirstPos := FVector^[Index];
- Result.LastPos := FVector^[Index + 1] - 1;
end;
-function TJclAnsiRegEx.Match(const Subject: String; StartOffset: Cardinal = 1): Boolean;
+function TJclAnsiRegEx.GetNamedCapture(const Name: AnsiString): AnsiString;
+var
+ Index: Integer;
begin
- if (not Assigned(FCode)) or (Subject = '') then
+ Index := pcre_get_stringnumber(FCode, PChar(Name));
+ PCRECheck(Index);
+
+ Result := GetCapture(Index);
+end;
+
+function TJclAnsiRegEx.GetCaptureNameCount: Integer;
+begin
+ PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_NAMECOUNT, @Result));
+end;
+
+function TJclAnsiRegEx.GetCaptureName(Index: Integer): String;
+var
+ NameTable: PChar;
+ EntrySize: Integer;
+begin
+ PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_NAMETABLE, @NameTable));
+ PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_NAMEENTRYSIZE, @EntrySize));
+
+ Result := NameTable + EntrySize * Index + 2;
+end;
+
+function TJclAnsiRegEx.CalloutHandler(var CalloutBlock: pcre_callout_block): Integer;
+begin
+ try
+ Result := JCL_PCRE_CALLOUT_NOERROR;
+ if Assigned(FOnCallout) then
+ begin
+ with CalloutBlock do
+ begin
+ FCaptureCount := capture_top;
+ FOnCallout(Self, callout_number, start_match + 1, current_position + 1,
+ capture_last, pattern_position + 1, next_item_length, Result);
+ end;
+ end;
+ except
+ on E: Exception do
+ begin
+ FErrorMessage := E.Message;
+ Result := JCL_PCRE_ERROR_CALLOUTERROR;
+ end;
+ end;
+end;
+
+function TJclAnsiRegEx.Match(const Subject: AnsiString; StartOffset: Cardinal = 1): Boolean;
+var
+ LocalExtra: real_pcre_extra;
+ Extra: Pointer;
+ WorkSpace: array [0 .. 19] of Integer;
+ ExecRslt: Integer;
+begin
+ if Assigned(FOnCallout) then
begin
- Result := False;
- Exit;
+ if Assigned(FExtra) then
+ begin
+ LocalExtra.flags := PCRE_EXTRA_STUDY_DATA or PCRE_EXTRA_CALLOUT_DATA;
+ LocalExtra.study_data := FExtra;
+ end
+ else
+ LocalExtra.flags := PCRE_EXTRA_CALLOUT_DATA;
+ LocalExtra.callout_data := Self;
+ Extra := @LocalExtra;
+ SetPCRECalloutCallback(JclPCRECallout);
+ end
+ else
+ begin
+ Extra := FExtra;
+ SetPCRECalloutCallback(nil);
end;
- if StartOffset < 1 then
- StartOffset := 1;
FSubject := Subject;
- FStringCount := pcre_exec(FCode, FExtra, PChar(FSubject), Length(FSubject),
- StartOffset - 1, GetAPIOptions(True), PInteger(FVector), FVectorSize);
- Result := FStringCount >= 0;
+ if FDfaMode then
+ begin
+ ExecRslt := pcre_dfa_exec(FCode, Extra, PChar(FSubject), Length(FSubject),
+ StartOffset - 1, GetAPIOptions(True), PInteger(FVector), FVectorSize, @Workspace, 20);
+ end
+ else
+ begin
+ ExecRslt := pcre_exec(FCode, Extra, PChar(FSubject), Length(FSubject),
+ StartOffset - 1, GetAPIOptions(True), PInteger(FVector), FVectorSize);
+ end;
+ Result := ExecRslt >= 0;
+ if Result then
+ begin
+ FCaptureCount := ExecRslt;
+ FErrorCode := 0;
+ end
+ else
+ begin
+ FErrorCode := ExecRslt;
+ if FErrorCode <> PCRE_ERROR_NOMATCH then
+ PCRECheck(FErrorCode);
+ end;
end;
+function TJclAnsiRegEx.IndexOfName(const Name: String): Integer;
+begin
+ Result := pcre_get_stringnumber(FCode, PChar(Name));
+end;
+
+function TJclAnsiRegEx.IsNameValid(const Name: String): Boolean;
+begin
+ Result := pcre_get_stringnumber(FCode, PChar(Name)) >= 0;
+end;
+
procedure InitializeLocaleSupport;
begin
if not Assigned(GTables) then
Modified: trunk/jcl/source/common/JclResources.pas
===================================================================
--- trunk/jcl/source/common/JclResources.pas 2007-01-13 13:14:13 UTC (rev 1878)
+++ trunk/jcl/source/common/JclResources.pas 2007-01-13 13:22:58 UTC (rev 1879)
@@ -1301,6 +1301,8 @@
RsErrLibNotLoaded = 'PCRE library not loaded';
RsErrMemFuncNotSet = 'PCRE memory management functions not set';
RsErrStudyFailed = 'Study failed';
+ RsErrCalloutError = 'Unhandled exception in callout';
+ RsErrUnknownError = 'Unknown error';
//=== JclPeImage =============================================================
resourcestring
Modified: trunk/jcl/source/common/pcre.pas
===================================================================
--- trunk/jcl/source/common/pcre.pas 2007-01-13 13:14:13 UTC (rev 1878)
+++ trunk/jcl/source/common/pcre.pas 2007-01-13 13:22:58 UTC (rev 1879)
@@ -219,14 +219,8 @@
type
(* Types *)
- PPChar = ^PChar;
- {$EXTERNALSYM PPChar}
PPPChar = ^PPChar;
{$EXTERNALSYM PPPChar}
- PInteger = ^Integer;
- {$EXTERNALSYM PInteger}
- PPointer = ^Pointer;
- {$EXTERNALSYM PPointer}
real_pcre = record
{magic_number: Longword;
@@ -288,7 +282,7 @@
{$EXTERNALSYM pcre_stack_malloc_callback}
pcre_stack_free_callback = procedure(P: Pointer); cdecl;
{$EXTERNALSYM pcre_stack_free_callback}
- pcre_callout_callback = procedure(var callout_block: pcre_callout_block); cdecl;
+ pcre_callout_callback = function(var callout_block: pcre_callout_block): Integer; cdecl;
{$EXTERNALSYM pcre_callout_callback}
var
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ou...@us...> - 2007-01-13 14:27:03
|
Revision: 1882
http://svn.sourceforge.net/jcl/?rev=1882&view=rev
Author: outchy
Date: 2007-01-13 06:26:58 -0800 (Sat, 13 Jan 2007)
Log Message:
-----------
Now compiles with Delphi 5 and C++Builder 5.
Modified Paths:
--------------
trunk/jcl/source/common/JclPCRE.pas
trunk/jcl/source/common/pcre.pas
Modified: trunk/jcl/source/common/JclPCRE.pas
===================================================================
--- trunk/jcl/source/common/JclPCRE.pas 2007-01-13 14:22:46 UTC (rev 1881)
+++ trunk/jcl/source/common/JclPCRE.pas 2007-01-13 14:26:58 UTC (rev 1882)
@@ -444,12 +444,12 @@
if FDfaMode then
begin
ExecRslt := pcre_dfa_exec(FCode, Extra, PChar(FSubject), Length(FSubject),
- StartOffset - 1, GetAPIOptions(True), PInteger(FVector), FVectorSize, @Workspace, 20);
+ StartOffset - 1, GetAPIOptions(True), pcre.PInteger(FVector), FVectorSize, @Workspace, 20);
end
else
begin
ExecRslt := pcre_exec(FCode, Extra, PChar(FSubject), Length(FSubject),
- StartOffset - 1, GetAPIOptions(True), PInteger(FVector), FVectorSize);
+ StartOffset - 1, GetAPIOptions(True), pcre.PInteger(FVector), FVectorSize);
end;
Result := ExecRslt >= 0;
if Result then
Modified: trunk/jcl/source/common/pcre.pas
===================================================================
--- trunk/jcl/source/common/pcre.pas 2007-01-13 14:22:46 UTC (rev 1881)
+++ trunk/jcl/source/common/pcre.pas 2007-01-13 14:26:58 UTC (rev 1882)
@@ -219,8 +219,12 @@
type
(* Types *)
+ PPChar = ^PChar;
+ {$EXTERNALSYM PPChar}
PPPChar = ^PPChar;
{$EXTERNALSYM PPPChar}
+ PInteger = ^Integer;
+ {$EXTERNALSYM PInteger}
real_pcre = record
{magic_number: Longword;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mo...@us...> - 2007-02-19 20:19:41
|
Revision: 1941
http://svn.sourceforge.net/jcl/?rev=1941&view=rev
Author: morrac
Date: 2007-02-19 12:19:31 -0800 (Mon, 19 Feb 2007)
Log Message:
-----------
- Fix Compile: it did not create the result vector for matches of
patterns without subpatterns. Fix propposed by octweak.
- Add a missing regex option and a new option introduced in v7.0, as
suggested by octweak.
Modified Paths:
--------------
trunk/jcl/source/common/JclPCRE.pas
trunk/jcl/source/common/pcre.pas
Modified: trunk/jcl/source/common/JclPCRE.pas
===================================================================
--- trunk/jcl/source/common/JclPCRE.pas 2007-02-16 21:32:52 UTC (rev 1940)
+++ trunk/jcl/source/common/JclPCRE.pas 2007-02-19 20:19:31 UTC (rev 1941)
@@ -24,7 +24,7 @@
{ }
{ Class wrapper for PCRE (PERL Compatible Regular Expression) }
{ }
-{ Unit owner: Peter Th\xF6rnqvist }
+{ Unit owner: Peter Th�nqvist }
{ Last modified: $Date$ }
{ }
{**************************************************************************************************}
@@ -73,7 +73,7 @@
roAnchored, roDollarEndOnly, roExtra, roNotBOL, roNotEOL, roUnGreedy,
roNotEmpty, roUTF8, roNoAutoCapture, roNoUTF8Check, roAutoCallout,
roPartial, roDfaShortest, roDfaRestart, roDfaFirstLine, roDupNames,
- roNewLineCR, roNewLineLF);
+ roNewLineCR, roNewLineLF, roNewLineCRLF, roNewLineAny);
TJclAnsiRegExOptions = set of TJclAnsiRegExOption;
TJclAnsiCaptureRange = record
FirstPos: Integer;
@@ -295,10 +295,7 @@
else
begin
PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_CAPTURECOUNT, @FCaptureCount));
- if FCaptureCount > 0 then
- FVectorSize := (FCaptureCount + 1) * 3
- else
- FVectorSize := 0;
+ FVectorSize := (FCaptureCount + 1) * 3;
end;
ReAllocMem(FVector, FVectorSize * SizeOf(Integer));
end;
@@ -310,7 +307,7 @@
roAnchored, roDollarEndOnly, roExtra, roNotBOL, roNotEOL, roUnGreedy,
roNotEmpty, roUTF8, roNoAutoCapture, roNoUTF8Check, roAutoCallout,
roPartial, roDfaShortest, roDfaRestart, roDfaFirstLine, roDupNames,
- roNewLineCR, roNewLineLF }
+ roNewLineCR, roNewLineLF, roNewLineCRLF, roNewLineAny }
cDesignOptions: array [TJclAnsiRegExOption] of Integer =
(PCRE_CASELESS, PCRE_MULTILINE, PCRE_DOTALL, PCRE_EXTENDED, PCRE_ANCHORED,
PCRE_DOLLAR_ENDONLY, PCRE_EXTRA, 0, 0, PCRE_UNGREEDY, 0, PCRE_UTF8,
@@ -319,7 +316,7 @@
cRunOptions: array [TJclAnsiRegExOption] of Integer =
(0, 0, 0, 0, 0, 0, 0, PCRE_NOTBOL, PCRE_NOTEOL, 0, PCRE_NOTEMPTY, 0, 0,
PCRE_NO_UTF8_CHECK, 0, PCRE_PARTIAL, 0, 0, 0, 0, PCRE_NEWLINE_CR,
- PCRE_NEWLINE_LF);
+ PCRE_NEWLINE_LF, PCRE_NEWLINE_CRLF, PCRE_NEWLINE_ANY);
var
I: TJclAnsiRegExOption;
begin
Modified: trunk/jcl/source/common/pcre.pas
===================================================================
--- trunk/jcl/source/common/pcre.pas 2007-02-16 21:32:52 UTC (rev 1940)
+++ trunk/jcl/source/common/pcre.pas 2007-02-19 20:19:31 UTC (rev 1941)
@@ -122,6 +122,8 @@
{$EXTERNALSYM PCRE_NEWLINE_LF}
PCRE_NEWLINE_CRLF = $00300000;
{$EXTERNALSYM PCRE_NEWLINE_CRLF}
+ PCRE_NEWLINE_ANY = $00400000;
+ {$EXTERNALSYM PCRE_NEWLINE_ANY}
(* Exec-time and get-time error codes *)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mar...@us...> - 2007-04-07 06:36:09
|
Revision: 1967
http://svn.sourceforge.net/jcl/?rev=1967&view=rev
Author: marquardt
Date: 2007-04-06 23:36:05 -0700 (Fri, 06 Apr 2007)
Log Message:
-----------
style cleaning
Modified Paths:
--------------
trunk/jcl/source/common/JclCompression.pas
trunk/jcl/source/common/JclStrings.pas
Modified: trunk/jcl/source/common/JclCompression.pas
===================================================================
--- trunk/jcl/source/common/JclCompression.pas 2007-04-07 06:34:48 UTC (rev 1966)
+++ trunk/jcl/source/common/JclCompression.pas 2007-04-07 06:36:05 UTC (rev 1967)
@@ -59,9 +59,8 @@
Libc,
{$ENDIF HAS_UNIT_LIBC}
SysUtils, Classes,
- JclBase,
zlibh,
- JclStreams;
+ JclBase, JclStreams;
{**************************************************************************************************}
{
@@ -182,11 +181,11 @@
const
// ID1 and ID2 fields
- JCL_GZIP_ID1 = $1F; // value for the ID1 field
- JCL_GZIP_ID2 = $8B; // value for the ID2 field
+ JCL_GZIP_ID1 = $1F; // value for the ID1 field
+ JCL_GZIP_ID2 = $8B; // value for the ID2 field
// Compression Model field
- JCL_GZIP_CM_DEFLATE = 8; // Zlib classic
+ JCL_GZIP_CM_DEFLATE = 8; // Zlib classic
// Flags field : extra fields for the header
JCL_GZIP_FLAG_TEXT = $01; // file is probably ASCII text
@@ -196,25 +195,25 @@
JCL_GZIP_FLAG_COMMENT = $10; // comment is present
// ExtraFlags field : compression level
- JCL_GZIP_EFLAG_MAX = 2; // compressor used maximum compression
- JCL_GZIP_EFLAG_FAST = 4; // compressor used fastest compression
+ JCL_GZIP_EFLAG_MAX = 2; // compressor used maximum compression
+ JCL_GZIP_EFLAG_FAST = 4; // compressor used fastest compression
// OS field : file system
- JCL_GZIP_OS_FAT = 0; // FAT filesystem (MS-DOS, OS/2, NT/Win32)
- JCL_GZIP_OS_AMIGA = 1; // Amiga
- JCL_GZIP_OS_VMS = 2; // VMS (or OpenVMS)
- JCL_GZIP_OS_UNIX = 3; // Unix
- JCL_GZIP_OS_VM = 4; // VM/CMS
- JCL_GZIP_OS_ATARI = 5; // Atari TOS
- JCL_GZIP_OS_HPFS = 6; // HPFS filesystem (OS/2, NT)
- JCL_GZIP_OS_MAC = 7; // Macintosh
- JCL_GZIP_OS_Z = 8; // Z-System
- JCL_GZIP_OS_CPM = 9; // CP/M
- JCL_GZIP_OS_TOPS = 10; // TOPS-20
- JCL_GZIP_OS_NTFS = 11; // NTFS filesystem (NT)
- JCL_GZIP_OS_QDOS = 12; // QDOS
- JCL_GZIP_OS_ACORN = 13; // Acorn RISCOS
- JCL_GZIP_OS_UNKNOWN = 255; // unknown
+ JCL_GZIP_OS_FAT = 0; // FAT filesystem (MS-DOS, OS/2, NT/Win32)
+ JCL_GZIP_OS_AMIGA = 1; // Amiga
+ JCL_GZIP_OS_VMS = 2; // VMS (or OpenVMS)
+ JCL_GZIP_OS_UNIX = 3; // Unix
+ JCL_GZIP_OS_VM = 4; // VM/CMS
+ JCL_GZIP_OS_ATARI = 5; // Atari TOS
+ JCL_GZIP_OS_HPFS = 6; // HPFS filesystem (OS/2, NT)
+ JCL_GZIP_OS_MAC = 7; // Macintosh
+ JCL_GZIP_OS_Z = 8; // Z-System
+ JCL_GZIP_OS_CPM = 9; // CP/M
+ JCL_GZIP_OS_TOPS = 10; // TOPS-20
+ JCL_GZIP_OS_NTFS = 11; // NTFS filesystem (NT)
+ JCL_GZIP_OS_QDOS = 12; // QDOS
+ JCL_GZIP_OS_ACORN = 13; // Acorn RISCOS
+ JCL_GZIP_OS_UNKNOWN = 255; // unknown
type
TJclGZIPSubFieldHeader = packed record
@@ -222,6 +221,7 @@
SI2: Byte;
Len: Word;
end;
+
// constants to identify sub fields in the extra field
// source: http://www.gzip.org/format.txt
const
@@ -241,12 +241,11 @@
JCL_GZIP_X_RO2 = $4F;
type
- TJclGZIPFlag = (gfDataIsText, gfHeaderCRC16, gfExtraField, gfOriginalFileName,
- gfComment);
+ TJclGZIPFlag = (gfDataIsText, gfHeaderCRC16, gfExtraField, gfOriginalFileName, gfComment);
TJclGZIPFlags = set of TJclGZIPFlag;
TJclGZIPFatSystem = (gfsFat, gfsAmiga, gfsVMS, gfsUnix, gfsVM, gfsAtari, gfsHPFS,
gfsMac, gfsZ, gfsCPM, gfsTOPS, gfsNTFS, gfsQDOS, gfsAcorn, gfsOther, gfsUnknown);
-
+
// Format is described in RFC 1952, http://www.faqs.org/rfcs/rfc1952.html
TJclGZIPCompressionStream = class(TJclCompressStream)
private
@@ -262,7 +261,7 @@
FOriginalSize: Cardinal;
FDataCRC32: Cardinal;
FHeaderWritten: Boolean;
- FFooterWritten :Boolean; // flag so we only write the footer once! (NEW 2007)
+ FFooterWritten: Boolean; // flag so we only write the footer once! (NEW 2007)
procedure WriteHeader;
function GetDosTime: TDateTime;
@@ -392,16 +391,14 @@
EJclCompressionError = class(EJclError);
// callback type used in helper functions below:
- TJclCompressStreamProgressCallback = procedure (filesize,position:Int64;userdata:Pointer) of Object;
-
+ TJclCompressStreamProgressCallback = procedure(FileSize, Position: Int64; UserData: Pointer) of object;
{helper functions - one liners by wpostma}
-function GZipFile( sourceFile,destinationFile:String; compressionLevel:Integer= Z_DEFAULT_COMPRESSION;
- progressCallback:TJclCompressStreamProgressCallback =nil;userdata:Pointer=nil):Boolean;
-function UnGZipFile( sourceFile,destinationFile:String;
- progressCallback:TJclCompressStreamProgressCallback =nil;userdata:Pointer=nil):Boolean;
+function GZipFile(SourceFile, DestinationFile: string; CompressionLevel: Integer = Z_DEFAULT_COMPRESSION;
+ ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil): Boolean;
+function UnGZipFile(SourceFile, DestinationFile: string;
+ ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil): Boolean;
-
{$IFDEF UNITVERSIONING}
const
UnitVersioning: TUnitVersionInfo = (
@@ -410,15 +407,12 @@
Date: '$Date$';
LogPath: 'JCL\source\common'
);
-{$ENDIF UNITVERSIONING}
+ {$ENDIF UNITVERSIONING}
-
implementation
uses
- JclResources,
- JclDateTime,
- JclFileUtils;
+ JclDateTime, JclFileUtils, JclResources;
const
JclDefaultBufferSize = 131072; // 128k
@@ -495,7 +489,6 @@
FStream := Source;
end;
-
//=== { TJclZLibCompressionStream } ==========================================
{ Error checking helper }
@@ -579,7 +572,7 @@
begin
ZLibCheck(deflate(ZLibRecord, Z_NO_FLUSH));
- if ZLibRecord.avail_out = 0 then // Output buffer empty. Write to stream and go on...
+ if ZLibRecord.avail_out = 0 then // Output buffer empty. Write to stream and go on...
begin
FStream.WriteBuffer(FBuffer^, FBufferSize);
Progress(Self);
@@ -613,7 +606,7 @@
if ZLibRecord.avail_out < FBufferSize then
begin
- FStream.WriteBuffer(FBuffer^, FBufferSize-ZLibRecord.avail_out);
+ FStream.WriteBuffer(FBuffer^, FBufferSize - ZLibRecord.avail_out);
Progress(Self);
Inc(Result, FBufferSize - ZLibRecord.avail_out);
ZLibRecord.next_out := FBuffer;
@@ -625,7 +618,7 @@
function TJclZLibCompressStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
if (Offset = 0) and (Origin = soCurrent) then
- Result := ZLibRecord.total_in
+ Result := ZLibRecord.total_in
else
if (Offset = 0) and (Origin = soBeginning) and (ZLibRecord.total_in = 0) then
Result := 0
@@ -671,7 +664,6 @@
end;
end;
-
//=== { TJclZLibDecompressionStream } =======================================
constructor TJclZLibDecompressStream.Create(Source: TStream; WindowBits: Integer = DEF_WBITS);
@@ -717,7 +709,7 @@
ZLibRecord.next_out := @Buffer;
ZLibRecord.avail_out := Count;
- while ZLibRecord.avail_out > 0 do // as long as we have data
+ while ZLibRecord.avail_out > 0 do // as long as we have data
begin
if ZLibRecord.avail_in = 0 then
begin
@@ -745,10 +737,10 @@
function TJclZLibDecompressStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
- if (Offset = 0) and (Origin = soCurrent) then
+ if (Offset = 0) and (Origin = soCurrent) then
Result := ZLibRecord.total_out
- else
- Result := inherited Seek(Offset, Origin);
+ else
+ Result := inherited Seek(Offset, Origin);
end;
procedure TJclZLibDecompressStream.SetWindowBits(Value: Integer);
@@ -758,8 +750,7 @@
//=== { TJclGZIPCompressionStream } ==========================================
-constructor TJclGZIPCompressionStream.Create(Destination: TStream;
- CompressionLevel: TJclCompressionLevel);
+constructor TJclGZIPCompressionStream.Create(Destination: TStream; CompressionLevel: TJclCompressionLevel);
begin
inherited Create(Destination);
@@ -776,9 +767,7 @@
// unless you called Flush manually. This is not correct Stream behaviour.
// Flush should be optional!
Flush;
-
FZLibStream.Free;
-
inherited Destroy;
end;
@@ -791,10 +780,10 @@
else
Result := 0;
- if (FFooterWritten) then
- exit;
- FFooterWritten := true;
-
+ if FFooterWritten then
+ Exit;
+ FFooterWritten := True;
+
// Write footer, CRC32 followed by ISIZE
AFooter.DataCRC32 := FDataCRC32;
AFooter.DataSize := FOriginalSize;
@@ -850,7 +839,7 @@
if not Assigned(FZLibStream) then
begin
FZLibStream := TJclZlibCompressStream.Create(FStream, FCompressionLevel);
- FZLibStream.WindowBits := -DEF_WBITS; // negative value for raw mode
+ FZLibStream.WindowBits := -DEF_WBITS; // negative value for raw mode
FZLibStream.OnProgress := ZLibStreamProgress;
end;
@@ -860,14 +849,24 @@
end;
procedure TJclGZIPCompressionStream.WriteHeader;
+const
+ FatSystemToByte: array[TJclGZIPFatSystem] of Byte =
+ (JCL_GZIP_OS_FAT, JCL_GZIP_OS_AMIGA, JCL_GZIP_OS_VMS, JCL_GZIP_OS_UNIX,
+ JCL_GZIP_OS_VM, JCL_GZIP_OS_ATARI, JCL_GZIP_OS_HPFS, JCL_GZIP_OS_MAC,
+ JCL_GZIP_OS_Z, JCL_GZIP_OS_CPM, JCL_GZIP_OS_TOPS, JCL_GZIP_OS_NTFS,
+ JCL_GZIP_OS_QDOS, JCL_GZIP_OS_ACORN, JCL_GZIP_OS_UNKNOWN, JCL_GZIP_OS_UNKNOWN);
var
+ AHeader: TJclGZIPHeader;
+ ExtraFieldLength, HeaderCRC16: Word;
HeaderCRC: Cardinal;
+
procedure StreamWriteBuffer(const Buffer; Count: Longint);
begin
FStream.WriteBuffer(Buffer, Count);
if gfHeaderCRC16 in Flags then
HeaderCRC := crc32(HeaderCRC, @Byte(Buffer), Count);
end;
+
function CheckCString(const Buffer: string): Boolean;
var
Index: Integer;
@@ -878,15 +877,7 @@
Exit;
Result := True;
end;
-const
- FatSystemToByte: array [TJclGZIPFatSystem] of Byte =
- ( JCL_GZIP_OS_FAT, JCL_GZIP_OS_AMIGA, JCL_GZIP_OS_VMS, JCL_GZIP_OS_UNIX,
- JCL_GZIP_OS_VM, JCL_GZIP_OS_ATARI, JCL_GZIP_OS_HPFS, JCL_GZIP_OS_MAC,
- JCL_GZIP_OS_Z, JCL_GZIP_OS_CPM, JCL_GZIP_OS_TOPS, JCL_GZIP_OS_NTFS,
- JCL_GZIP_OS_QDOS, JCL_GZIP_OS_ACORN, JCL_GZIP_OS_UNKNOWN, JCL_GZIP_OS_UNKNOWN );
-var
- AHeader: TJclGZIPHeader;
- ExtraFieldLength, HeaderCRC16: Word;
+
begin
if gfHeaderCRC16 in Flags then
HeaderCRC := crc32(0, nil, 0);
@@ -912,9 +903,9 @@
AHeader.ModifiedTime := FUnixTime;
case FCompressionLevel of
- Z_BEST_COMPRESSION :
+ Z_BEST_COMPRESSION:
AHeader.ExtraFlags := JCL_GZIP_EFLAG_MAX;
- Z_BEST_SPEED :
+ Z_BEST_SPEED:
AHeader.ExtraFlags := JCL_GZIP_EFLAG_FAST;
else
AHeader.ExtraFlags := 0;
@@ -965,6 +956,8 @@
var
HeaderCRC: Cardinal;
ComputeHeaderCRC: Boolean;
+ ExtraFieldLength: Word;
+
procedure ReadBuffer(var Buffer; SizeOfBuffer: Longint);
begin
Source.ReadBuffer(Buffer, SizeOfBuffer);
@@ -982,8 +975,7 @@
until Dummy = #0;
SetLength(FOriginalFileName, Length(FOriginalFileName) - 1);
end;
-var
- ExtraFieldLength: Word;
+
begin
inherited Create(Source);
@@ -1057,14 +1049,14 @@
function TJclGZIPDecompressionStream.GetFatSystem: TJclGZIPFatSystem;
const
- ByteToFatSystem: array [JCL_GZIP_OS_FAT..JCL_GZIP_OS_ACORN] of TJclGZIPFatSystem =
- ( gfsFat, gfsAmiga, gfsVMS, gfsUnix, gfsVM, gfsAtari, gfsHPFS, gfsMac, gfsZ,
- gfsCPM, gfsTOPS, gfsNTFS, gfsQDOS, gfsAcorn );
+ ByteToFatSystem: array[JCL_GZIP_OS_FAT..JCL_GZIP_OS_ACORN] of TJclGZIPFatSystem =
+ (gfsFat, gfsAmiga, gfsVMS, gfsUnix, gfsVM, gfsAtari, gfsHPFS, gfsMac, gfsZ,
+ gfsCPM, gfsTOPS, gfsNTFS, gfsQDOS, gfsAcorn);
begin
case FHeader.OS of
- JCL_GZIP_OS_FAT..JCL_GZIP_OS_ACORN :
+ JCL_GZIP_OS_FAT..JCL_GZIP_OS_ACORN:
Result := ByteToFatSystem[FHeader.OS];
- JCL_GZIP_OS_UNKNOWN :
+ JCL_GZIP_OS_UNKNOWN:
Result := gfsUnknown;
else
Result := gfsOther;
@@ -1088,7 +1080,7 @@
function TJclGZIPDecompressionStream.GetOriginalDataSize: Cardinal;
var
- StartPos: {$IFDEF COMPILER5}Longint;{$ELSE ~COMPILER5}Int64;{$ENDIF ~COMPILER5}
+ StartPos: {$IFDEF COMPILER5} Longint; {$ELSE} Int64; {$ENDIF}
AFooter: TJclGZIPFooter;
begin
if not FDataStarted then
@@ -1099,7 +1091,7 @@
FStream.ReadBuffer(AFooter, SizeOf(AFooter));
Result := AFooter.DataSize;
finally
- FStream.Seek(StartPos, {$IFDEF COMPILER5}soFromBeginning{$ELSE ~COMPILER5}soBeginning{$ENDIF ~COMPILER5});
+ FStream.Seek(StartPos, {$IFDEF COMPILER5} soFromBeginning {$ELSE} soBeginning {$ENDIF});
end;
end
else
@@ -1111,7 +1103,7 @@
function TJclGZIPDecompressionStream.GetStoredDataCRC32: Cardinal;
var
- StartPos: {$IFDEF COMPILER5}Longint;{$ELSE ~COMPILER5}Int64;{$ENDIF ~COMPILER5}
+ StartPos: {$IFDEF COMPILER5} Longint; {$ELSE} Int64; {$ENDIF}
AFooter: TJclGZIPFooter;
begin
if not FDataStarted then
@@ -1122,7 +1114,7 @@
FStream.ReadBuffer(AFooter, SizeOf(AFooter));
Result := AFooter.DataCRC32;
finally
- FStream.Seek(StartPos, {$IFDEF COMPILER5}soFromBeginning{$ELSE ~COMPILER5}soBeginning{$ENDIF ~COMPILER5});
+ FStream.Seek(StartPos, {$IFDEF COMPILER5} soFromBeginning {$ELSE} soBeginning {$ENDIF});
end;
end
else
@@ -1177,7 +1169,7 @@
BufferAddr := @Char(Buffer);
Move(FFooter, Buffer, SizeOf(FFooter));
Result := FStream.Read(BufferAddr[SizeOf(FFooter)], Count - SizeOf(FFooter))
- + FStream.Read(FFooter, SizeOf(FFooter));
+ + FStream.Read(FFooter, SizeOf(FFooter));
if Result < Count then
begin
@@ -1298,7 +1290,7 @@
begin
FStream.WriteBuffer(FBuffer^, FBufferSize);
Progress(Self);
-
+
BZLibRecord.next_out := FBuffer;
BZLibRecord.avail_out := FBufferSize;
Result := Result + FBufferSize;
@@ -1388,7 +1380,6 @@
BZLibRecord.next_in := FBuffer;
end;
-
if BZLibRecord.avail_in > 0 then
begin
BZIP2LibCheck(BZ2_bzDecompress(@BZLibRecord));
@@ -1408,138 +1399,128 @@
end;
*)
-//NEW MARCH 2007:
-
-
{ Compress to a .gz file - one liner - NEW MARCH 2007 }
-function GZipFile( sourceFile,destinationFile:String; compressionLevel:Integer=Z_DEFAULT_COMPRESSION;
- progressCallback:TJclCompressStreamProgressCallback =nil;
- userdata:Pointer=nil ):Boolean;
+
+function GZipFile(SourceFile, DestinationFile: string; CompressionLevel: Integer = Z_DEFAULT_COMPRESSION;
+ ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil): Boolean;
var
- zlibstr:TJclGZIPCompressionStream;
- destStr:TFileStream;
- sourceStr:TFileStream;
- Buffer:Pointer;
- ReadBytes:Integer;
- eofFlag:Boolean;
- sourceFileSize:Int64;
+ ZLibStream: TJclGZIPCompressionStream;
+ DestStream: TFileStream;
+ SourceStream: TFileStream;
+ Buffer: Pointer;
+ ReadBytes: Integer;
+ EofFlag: Boolean;
+ SourceFileSize: Int64;
begin
- result := false;
- if not FileExists(sourceFile) then // can't copy what doesn't exist!
- exit;
+ Result := False;
+ if not FileExists(SourceFile) then // can't copy what doesn't exist!
+ Exit;
-
{destination and source streams first and second}
- sourceStr := TFileStream.Create( sourceFile, {mode}fmOpenRead or fmShareDenyWrite );
- sourceFileSize := sourceStr.Size; // source file size
- destStr := TFileStream.Create( destinationFile, {mode}fmCreate ); // see SysUtils
- GetMem(Buffer, JclDefaultBufferSize+2);
+ SourceStream := TFileStream.Create(SourceFile, fmOpenRead or fmShareDenyWrite);
+ SourceFileSize := SourceStream.Size; // source file size
+ DestStream := TFileStream.Create(DestinationFile, fmCreate); // see SysUtils
+ GetMem(Buffer, JclDefaultBufferSize + 2);
+
+ // (rom) initial progress callback
+ if Assigned(ProgressCallback) then
+ ProgressCallback(SourceFileSize, 0, UserData);
try
{ create compressionstream third, and copy from source,
through zlib compress layer,
out through file stream}
- zlibstr := TJclGZIPCompressionStream.Create( destStr, compressionLevel{-1:default} );
- try
- // zlibStr.CopyFrom(sourceStr, 0 ); // One line way to do it! may not
- // // be reliable idea to do this! also,
- // //no progress callbacks!
- eofFlag := false;
- while not eofFlag do
- begin
- ReadBytes := sourceStr.Read(Buffer^, JclDefaultBufferSize);
- zlibstr.WriteBuffer(Buffer^, ReadBytes);
- if ReadBytes <> JclDefaultBufferSize then begin
- eofFlag := true;
- Break; // short block indicates end of zlib stream
- end;
- if Assigned(progressCallback) then
- progressCallback( sourceFileSize, sourceStr.Position, userdata );
-
- Sleep(80); // on purpose! make it visible! XXX delete later
- end; //while
-
-
- //destStr.Flush; // no such thing in streams.
-
+ ZLibStream := TJclGZIPCompressionStream.Create(DestStream, CompressionLevel);
+ try
+ // ZLibStream.CopyFrom(SourceStream, 0 ); // One line way to do it! may not
+ // // be reliable idea to do this! also,
+ // //no progress callbacks!
+ EofFlag := False;
+ while not EofFlag do
+ begin
+ ReadBytes := SourceStream.Read(Buffer^, JclDefaultBufferSize);
+ ZLibStream.WriteBuffer(Buffer^, ReadBytes);
+ if ReadBytes <> JclDefaultBufferSize then
+ Break; // short block indicates end of zlib stream
+ if Assigned(ProgressCallback) then
+ ProgressCallback(SourceFileSize, SourceStream.Position, UserData);
+ end;
+ //DestStream.Flush; // no such thing in streams.
+ finally
+ ZLibStream.Free;
+ end;
finally
- zlibStr.Free;
+ DestStream.Free;
+ SourceStream.Free;
+ FreeMem(Buffer);
end;
- finally
- destStr.Free;
- sourceStr.Free;
- FreeMem(Buffer);
+ Result := FileExists(DestinationFile);
+ if Result then
+ begin
+ if Assigned(ProgressCallback) then
+ ProgressCallback(SourceFileSize, SourceFileSize, UserData);
end;
- result := FileExists(destinationFile);
- if result then begin
- if Assigned(progressCallback) then
- progressCallback( sourceFileSize, sourceFileSize, userdata );
-
- end;
end;
+{ Decompress a .gz file }
-{ Decompress a .gz file - one liner - NEW MARCH 2007 }
-function UnGZipFile( sourceFile,destinationFile:String;
- progressCallback:TJclCompressStreamProgressCallback =nil;
- userdata:Pointer=nil):Boolean;
+function UnGZipFile(SourceFile, DestinationFile: string; ProgressCallback: TJclCompressStreamProgressCallback = nil;
+ UserData: Pointer = nil): Boolean;
var
- zlibstr:TJclGZIPDecompressionStream;
- destStr:TFileStream;
- sourceStr:TFileStream;
- Buffer:Pointer;
- ReadBytes:Integer;
- zlibstrDateTime:TDateTime;
- sourceFileSize:Int64;
+ ZLibStream: TJclGZIPDecompressionStream;
+ DestStream: TFileStream;
+ SourceStream: TFileStream;
+ Buffer: Pointer;
+ ReadBytes: Integer;
+ ZLibStreamDateTime: TDateTime;
+ SourceFileSize: Int64;
begin
- result := false;
- if not FileExists(sourceFile) then // can't copy what doesn't exist!
- exit;
+ Result := False;
+ if not FileExists(SourceFile) then // can't copy what doesn't exist!
+ exit;
-
-
{destination and source streams first and second}
- sourceStr := TFileStream.Create( sourceFile, {mode}fmOpenRead or fmShareDenyWrite );
- sourceFileSize := sourceStr.Size; // source file size
- destStr := TFileStream.Create( destinationFile, {mode}fmCreate ); // see SysUtils
- GetMem(Buffer, JclDefaultBufferSize+2);
- try
- { create decompressionstream third, and copy from source,
- through zlib decompress layer,
- out through file stream
- }
- zlibstr := TJclGZIPDecompressionStream.Create( sourceStr );
+ SourceStream := TFileStream.Create(SourceFile, {mode} fmOpenRead or fmShareDenyWrite);
+ SourceFileSize := SourceStream.Size; // source file size
+ DestStream := TFileStream.Create(DestinationFile, {mode} fmCreate); // see SysUtils
+ GetMem(Buffer, JclDefaultBufferSize + 2);
+ // (rom) initial progress callback
+ if Assigned(ProgressCallback) then
+ ProgressCallback(SourceFileSize, 0, UserData);
try
- { Copy in from sourceStr, through zlibstr, and out to DestStr }
- while not zlibstr.FDataEnded do
- begin
- ReadBytes := zlibstr.Read(Buffer^, JclDefaultBufferSize);
- destStr.WriteBuffer(Buffer^, ReadBytes);
- if ReadBytes <> JclDefaultBufferSize then
- Break; // short block indicates end of zlib stream
- if Assigned(progressCallback) then
- progressCallback( sourceFileSize, sourceStr.Position, userdata );
-
- Sleep(80); // on purpose! make it visible! XXX delete later
- end;
- zlibstrDateTime := zlibstr.DosTime;
-
+ { create decompressionstream third, and copy from source,
+ through zlib decompress layer, out through file stream
+ }
+ ZLibStream := TJclGZIPDecompressionStream.Create(SourceStream);
+ try
+ { Copy in from SourceStream, through ZLibStream, and out to DestStream }
+ while not ZLibStream.FDataEnded do
+ begin
+ ReadBytes := ZLibStream.Read(Buffer^, JclDefaultBufferSize);
+ DestStream.WriteBuffer(Buffer^, ReadBytes);
+ if ReadBytes <> JclDefaultBufferSize then
+ Break; // short block indicates end of zlib stream
+ if Assigned(ProgressCallback) then
+ ProgressCallback(SourceFileSize, SourceStream.Position, UserData);
+ end;
+ ZLibStreamDateTime := ZLibStream.DosTime;
+ finally
+ ZLibStream.Free;
+ end;
finally
- zlibStr.Free;
+ DestStream.Free;
+ SourceStream.Free;
+ FreeMem(Buffer);
end;
- finally
- destStr.Free;
- sourceStr.Free;
- FreeMem(Buffer);
- end;
- result := FileExists(destinationFile);
- if result then begin
- // one last progress update, for when we're finished!
- if Assigned(progressCallback) then
- progressCallback( sourceFileSize, sourceFileSize, userdata );
+ Result := FileExists(DestinationFile);
+ if Result then
+ begin
+ // one last progress update, for when we're finished!
+ if Assigned(ProgressCallback) then
+ ProgressCallback(SourceFileSize, SourceFileSize, UserData);
// preserve datetime when unpacking! (see JclFileUtils)
- SetFileLastWrite(destinationFile,zlibstrDateTime );
+ SetFileLastWrite(DestinationFile, ZLibStreamDateTime);
end;
end;
@@ -1549,7 +1530,7 @@
finalization
UnregisterUnitVersion(HInstance);
-{$ENDIF UNITVERSIONING}
+ {$ENDIF UNITVERSIONING}
end.
Modified: trunk/jcl/source/common/JclStrings.pas
===================================================================
--- trunk/jcl/source/common/JclStrings.pas 2007-04-07 06:34:48 UTC (rev 1966)
+++ trunk/jcl/source/common/JclStrings.pas 2007-04-07 06:36:05 UTC (rev 1967)
@@ -899,7 +899,7 @@
I: Integer;
C: Char;
begin
- for i := 1 to Length(s) do
+ for I := 1 to Length(S) do
begin
C := S[I];
@@ -4363,14 +4363,14 @@
const
BoolToStr: array[Boolean] of string[5] = ('false', 'true');
-{$IFDEF COMPILER5}
+ {$IFDEF COMPILER5}
MaxCurrency: Currency = 922337203685477.5807;
varShortInt = $0010; { vt_i1 16 }
varWord = $0012; { vt_ui2 18 }
varLongWord = $0013; { vt_ui4 19 }
varInt64 = $0014; { vt_i8 20 }
-{$ENDIF COMPILER5}
+ {$ENDIF COMPILER5}
type
TInterfacedObjectAccess = class(TInterfacedObject);
@@ -4945,7 +4945,7 @@
function TStringBuilder.Replace(OldChar, NewChar: Char; StartIndex,
Count: Integer): TStringBuilder;
var
- i: Integer;
+ I: Integer;
begin
if Count = -1 then
Count := FLength;
@@ -4953,17 +4953,16 @@
raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange);
if (Count > 0) and (OldChar <> NewChar) then
begin
- for i := StartIndex to StartIndex + Length - 1 do
- if FChars[i] = OldChar then
- FChars[i] := NewChar;
+ for I := StartIndex to StartIndex + Length - 1 do
+ if FChars[I] = OldChar then
+ FChars[I] := NewChar;
end;
Result := Self;
end;
-function TStringBuilder.Replace(OldValue, NewValue: string; StartIndex,
- Count: Integer): TStringBuilder;
+function TStringBuilder.Replace(OldValue, NewValue: string; StartIndex, Count: Integer): TStringBuilder;
var
- i: Integer;
+ I: Integer;
Offset: Integer;
NewLen, OldLen, Capacity: Integer;
begin
@@ -4980,11 +4979,11 @@
NewLen := System.Length(NewValue);
Offset := NewLen - OldLen;
Capacity := System.Length(FChars);
- for i := StartIndex to StartIndex + Length - 1 do
- if FChars[i] = OldValue[1] then
+ for I := StartIndex to StartIndex + Length - 1 do
+ if FChars[I] = OldValue[1] then
begin
if OldLen > 1 then
- if StrLComp(@FChars[i + 1], PChar(OldValue) + 1, OldLen - 1) <> 0 then
+ if StrLComp(@FChars[I + 1], PChar(OldValue) + 1, OldLen - 1) <> 0 then
Continue;
if Offset <> 0 then
begin
@@ -4996,17 +4995,17 @@
SetLength(FChars, Capacity);
end;
if Offset < 0 then
- MoveChar(FChars[i - Offset], FChars[i], FLength - i)
+ MoveChar(FChars[I - Offset], FChars[I], FLength - I)
else
- MoveChar(FChars[i + OldLen], FChars[i + OldLen + Offset], FLength - OldLen - i);
+ MoveChar(FChars[I + OldLen], FChars[I + OldLen + Offset], FLength - OldLen - I);
Inc(FLength, Offset);
end;
if NewLen > 0 then
begin
if (OldLen = 1) and (NewLen = 1) then
- FChars[i] := NewValue[1]
+ FChars[I] := NewValue[1]
else
- MoveChar(NewValue[1], FChars[i], NewLen);
+ MoveChar(NewValue[1], FChars[I], NewLen);
end;
end;
end;
@@ -5014,22 +5013,21 @@
end;
{$ENDIF CLR}
-{$IFNDEF CLR}
+{$IFDEF CLR}
+{$IFDEF UNITVERSIONING}
initialization
+ RegisterUnitVersion(HInstance, UnitVersioning);
+{$ENDIF UNITVERSIONING}
+{$ELSE}
+initialization
LoadCharTypes; // this table first
LoadCaseMap; // or this function does not work
{$IFDEF UNITVERSIONING}
RegisterUnitVersion(HInstance, UnitVersioning);
{$ENDIF UNITVERSIONING}
+{$ENDIF CLR}
-{$ELSE}
{$IFDEF UNITVERSIONING}
-initialization
- RegisterUnitVersion(HInstance, UnitVersioning);
-{$ENDIF UNITVERSIONING}
-{$ENDIF ~CLR}
-
-{$IFDEF UNITVERSIONING}
finalization
UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ah...@us...> - 2007-04-15 13:32:07
|
Revision: 1979
http://svn.sourceforge.net/jcl/?rev=1979&view=rev
Author: ahuser
Date: 2007-04-15 06:32:02 -0700 (Sun, 15 Apr 2007)
Log Message:
-----------
Delphi 5 is not supported by JclStringLists.
Modified Paths:
--------------
trunk/jcl/source/common/JclBorlandTools.pas
trunk/jcl/source/common/JclStringLists.pas
Modified: trunk/jcl/source/common/JclBorlandTools.pas
===================================================================
--- trunk/jcl/source/common/JclBorlandTools.pas 2007-04-15 13:16:30 UTC (rev 1978)
+++ trunk/jcl/source/common/JclBorlandTools.pas 2007-04-15 13:32:02 UTC (rev 1979)
@@ -531,7 +531,7 @@
{$ENDIF MSWINDOWS}
FPalette: TJclBorRADToolPalette;
FRepository: TJclBorRADToolRepository;
- FVersionNumber: Integer; // Delphi 2005: 3 - Delphi 7: 7 - Delphi 2007: 10
+ FVersionNumber: Integer; // Delphi 2005: 3 - Delphi 7: 7 - Delphi 2007: 11
FVersionNumberStr: string;
FIDEVersionNumber: Integer; // Delphi 2005: 3 - Delphi 7: 7 - Delphi 2007: 11
FIDEVersionNumberStr: string;
@@ -3914,9 +3914,15 @@
// If this is Spacely, then consider the version is equal to 4 (BDS2006)
// as it is a non breaking version (dcu wise)
- if (FIDEVersionNumber = 5) and (RadToolKind = brBorlandDevStudio) then
+
+ { ahuser: Delphi 2007 is a non breaking version in the case that you can use
+ BDS 2006 compiled units in Delphi 2007. But it completely breaks the BDS 2006
+ installation because if BDS 2006 uses the Delphi 2007 compile DCUs the
+ resulting executable is broken and will do strange things. So treat Delphi 2007
+ as version 11 what it actually is. }
+ {if (FIDEVersionNumber = 5) and (RadToolKind = brBorlandDevStudio) then
FVersionNumber := 4
- else
+ else}
FVersionNumber := FIDEVersionNumber;
{$ENDIF ~KYLIX}
Modified: trunk/jcl/source/common/JclStringLists.pas
===================================================================
--- trunk/jcl/source/common/JclStringLists.pas 2007-04-15 13:16:30 UTC (rev 1978)
+++ trunk/jcl/source/common/JclStringLists.pas 2007-04-15 13:32:02 UTC (rev 1979)
@@ -29,6 +29,8 @@
interface
+{$IFNDEF COMPILER5} // Delphi 5 isn't supported
+
uses
{$IFDEF UNITVERSIONING}
JclUnitVersioning,
@@ -201,8 +203,12 @@
);
{$ENDIF UNITVERSIONING}
+{$ENDIF ~COMPILER5} // Delphi 5 isn't supported
+
implementation
+{$IFNDEF COMPILER5} // Delphi 5 isn't supported
+
uses
TypInfo,
JclPCRE, JclStrings;
@@ -1306,4 +1312,6 @@
UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}
+{$ENDIF ~COMPILER5} // Delphi 5 isn't supported
+
end.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
Thanks for helping keep SourceForge clean.
X