paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-10-23 17:01:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: improved stream of large objects (issue #7270)

Browse Source 
git-svn-id: trunk@10321 -
This commit is contained in:
vincents 2006-12-12 13:09:30 +00:00
parent 90251b1bdc
commit 69391d2648
2 changed files with 26 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
lcl/lclmemmanager.pas
View File

@ -27,7 +27,7 @@ unit LCLMemManager;
interface
uses
Classes;
Classes, Math;
type
PLCLMemManagerItem = ^TLCLMemManagerItem;
@ -92,6 +92,8 @@ type
{ TExtMemoryStream }
TExtMemoryStream = class(TMemoryStream)
protected
function Realloc(var NewCapacity: Longint): Pointer; override;
public
property Capacity: Longint read FCapacity write SetCapacity;
end;
@ -267,5 +269,15 @@ begin
end;
end;
{ TExtMemoryStream }
function TExtMemoryStream.Realloc(var NewCapacity: LongInt): Pointer;
begin
// if we are growing, grow at least a quarter
if (NewCapacity>Capacity) then
NewCapacity := Max(NewCapacity, Capacity + Capacity div 4);
Result:=inherited Realloc(NewCapacity);
end;
end.

16
lcl/lresources.pp
View File

@ -1933,9 +1933,12 @@ procedure LRSObjectBinaryToText(Input, Output: TStream);
procedure ProcessBinary;
var
ToDo, DoNow, i: LongInt;
ToDo, DoNow, StartPos, i: LongInt;
lbuf: array[0..31] of Byte;
s: String;
p: pchar;
const
HexDigits: array[0..$F] of char = '0123456789ABCDEF';
begin
ToDo := ReadLRSCardinal(Input);
OutLn('{');
@ -1944,9 +1947,16 @@ procedure LRSObjectBinaryToText(Input, Output: TStream);
if DoNow > 32 then DoNow := 32;
Dec(ToDo, DoNow);
s := Indent + ' ';
StartPos := length(s);
Input.Read(lbuf, DoNow);
for i := 0 to DoNow - 1 do
s := s + IntToHex(lbuf[i], 2);
setlength(s, StartPos+DoNow*2);
p := @s[StartPos];
for i := 0 to DoNow - 1 do begin
inc(p);
p^ := HexDigits[(lbuf[i] shr 4) and $F];
inc(p);
p^ := HexDigits[lbuf[i] and $F];
end;
OutLn(s);
end;
OutStr(indent);