mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity

DEL: Obsolete units

Browse source
This commit is contained in:
Alexander Koblov 2025-01-30 21:03:25 +03:00
commit 255ecc7bda
7 changed files with 0 additions and 4485 deletions
Download patch file Download diff file Expand all files Collapse all files

822
plugins/wcx/zip/src/fparchive/abdfdec.pas
View file

@ -1,822 +0,0 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfDec.pas *}
{*********************************************************}
{* Deflate decoding unit *}
{*********************************************************}
unit AbDfDec;
{$I AbDefine.inc}
interface
uses
Classes,
AbDfBase;
function Inflate(aSource : TStream; aDest : TStream;
aHelper : TAbDeflateHelper) : longint;
implementation
uses
SysUtils,
AbDfStrm,
AbDfHufD,
AbDfOutW,
AbDfCryS;
{===Helper routines==================================================}
procedure ReadLitDistCodeLengths(aInStrm : TAbDfInBitStream;
aCodeLenTree : TAbDfDecodeHuffmanTree;
var aCodeLens : array of integer;
aCount : integer;
var aTotalBits : integer);
var
i : integer;
SymbolCount : integer;
LookupValue : integer;
EncodedSymbol : longint;
Symbol : integer;
SymbolCodeLen : integer;
RepeatCount : integer;
BitBuffer : TAb32bit;
BitCount : integer;
begin
{$IFDEF UseLogging}
{we need to calculate the total number of bits in the code lengths
for reporting purposes, so zero the count}
aTotalBits := 0;
{$ENDIF}
{clear the code lengths array}
FillChar(aCodeLens, sizeof(aCodeLens), 0);
{read all the Symbols required in the bit stream}
SymbolCount := 0;
while (SymbolCount < aCount) do begin
{grab the lookup set of bits}
BitCount := aCodeLenTree.LookupBitLength + 7;
{$IFOPT C+}
BitBuffer := aInStrm.PeekBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
BitBuffer := aInStrm.PeekMoreBits(BitCount)
else
BitBuffer := aInStrm.BitBuffer and AbExtractMask[BitCount];
{$ENDIF}
LookupValue :=
BitBuffer and AbExtractMask[aCodeLenTree.LookupBitLength];
{get the encoded Symbol}
{$IFOPT C+} {if Assertions are on}
EncodedSymbol := aCodeLenTree.Decode(LookupValue);
{$ELSE}
EncodedSymbol := aCodeLenTree.Decodes^[LookupValue];
{$ENDIF}
{extract the data}
Symbol := EncodedSymbol and $FFFF;
SymbolCodeLen := (EncodedSymbol shr 16) and $FF;
{$IFDEF UseLogging}
{keep count of the total number of bits read}
inc(aTotalBits, SymbolCodeLen);
{$ENDIF}
{check that the symbol is between 0 and 18}
if not ((0 <= Symbol) and (Symbol <= 18)) then
raise EAbInternalInflateError.Create(
'decoded a symbol not between 0 and 18 {ReadLitDistCodeLengths}');
{check that the codelength is in range}
if not ((0 < SymbolCodeLen) and
(SymbolCodeLen <= aCodeLenTree.LookupBitLength)) then
raise EAbInternalInflateError.Create(
'decoded a code length out of range {ReadLitDistCodeLengths}');
{for a Symbol of 0..15, just save the value}
if (Symbol <= 15) then begin
aCodeLens[SymbolCount] := Symbol;
inc(SymbolCount);
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
{for a Symbol of 16, get two more bits and copy the previous
code length that many times + 3}
else if (Symbol = 16) then begin
RepeatCount := 3 + ((BitBuffer shr SymbolCodeLen) and $3);
Symbol := aCodeLens[SymbolCount-1];
for i := 0 to pred(RepeatCount) do
aCodeLens[SymbolCount+i] := Symbol;
inc(SymbolCount, RepeatCount);
BitCount := SymbolCodeLen + 2;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
{$IFDEF UseLogging}
inc(aTotalBits, 2);
{$ENDIF}
end
{for a Symbol of 17, get three more bits and copy a zero code
length that many times + 3}
else if (Symbol = 17) then begin
RepeatCount := 3 + ((BitBuffer shr SymbolCodeLen) and $7);
{note: the codelengths array was aet to zeros at the start so
the following two lines are not needed
for i := 0 to pred(RepeatCount) do
aCodeLens[SymbolCount+i] := 0;}
inc(SymbolCount, RepeatCount);
BitCount := SymbolCodeLen + 3;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
{$IFDEF UseLogging}
inc(aTotalBits, 3);
{$ENDIF}
end
{for a Symbol of 18, get seven more bits and copy a zero code
length that many times + 11}
else if (Symbol = 18) then begin
RepeatCount := 11 + ((BitBuffer shr SymbolCodeLen) and $7F);
{note: the codelengths array was aet to zeros at the start so
the following two lines are not needed
for i := 0 to pred(RepeatCount) do
aCodeLens[SymbolCount+i] := 0;}
inc(SymbolCount, RepeatCount);
BitCount := SymbolCodeLen + 7;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
{$IFDEF UseLogging}
inc(aTotalBits, 7);
{$ENDIF}
end;
end;
end;
{--------}
procedure DecodeData(aInStrm : TAbDfInBitStream;
aOutWindow : TAbDfOutputWindow;
aLiteralTree : TAbDfDecodeHuffmanTree;
aDistanceTree : TAbDfDecodeHuffmanTree;
aDeflate64 : boolean);
var
LookupValue : integer;
EncodedSymbol : longint;
Symbol : integer;
SymbolCodeLen : integer;
ExtraBitCount : integer;
Length : integer;
Distance : integer;
BitBuffer : TAb32bit;
BitCount : integer;
begin
{extract the first symbol (it's got to be a literal/length symbol)}
{..grab the lookup set of bits}
if aDeflate64 then
BitCount := aLiteralTree.LookupBitLength + 16
else
BitCount := aLiteralTree.LookupBitLength + 5;
{$IFOPT C+}
BitBuffer := aInStrm.PeekBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
BitBuffer := aInStrm.PeekMoreBits(BitCount)
else
BitBuffer := aInStrm.BitBuffer and AbExtractMask[BitCount];
{$ENDIF}
LookupValue :=
BitBuffer and AbExtractMask[aLiteralTree.LookupBitLength];
{..get the encoded symbol}
{$IFOPT C+} {if Assertions are on}
EncodedSymbol := aLiteralTree.Decode(LookupValue);
{$ELSE}
EncodedSymbol := aLiteralTree.Decodes^[LookupValue];
{$ENDIF}
{..extract the data}
Symbol := EncodedSymbol and $FFFF;
SymbolCodeLen := (EncodedSymbol shr 16) and $FF;
// ExtraBitCount := EncodedSymbol shr 24;
{repeat until we get the end-of-block symbol}
while ((Symbol <> 256) {and (ExtraBitCount <> 15)}) do begin
{for a literal, just output it to the sliding window}
if (Symbol < 256) then begin
aOutWindow.AddLiteral(AnsiChar(Symbol));
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
{for a length value, we need to get any extra bits, and then the
distance (plus any extra bits for that), and then add the
duplicated characters to the sliding window}
else begin
{check that the length symbol is less than or equal to 285}
if (Symbol > 285) then
raise EAbInternalInflateError.Create(
'decoded an invalid length symbol: greater than 285 [DecodeData]');
{calculate the length (if need be, by calculating the number of
extra bits that encode the length)}
if (not aDeflate64) and (Symbol = 285) then begin
Length := 258;
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
else begin
ExtraBitCount := EncodedSymbol shr 24;
if (ExtraBitCount = 0) then begin
Length := dfc_LengthBase[Symbol - 257];
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
else begin
Length := dfc_LengthBase[Symbol - 257] +
((BitBuffer shr SymbolCodeLen) and
AbExtractMask[ExtraBitCount]);
BitCount := SymbolCodeLen + ExtraBitCount;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
end;
end;
{extract the distance}
{..grab the lookup set of bits}
BitCount := aDistanceTree.LookupBitLength + 14;
{$IFOPT C+}
BitBuffer := aInStrm.PeekBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
BitBuffer := aInStrm.PeekMoreBits(BitCount)
else
BitBuffer := aInStrm.BitBuffer and AbExtractMask[BitCount];
{$ENDIF}
LookupValue :=
BitBuffer and AbExtractMask[aDistanceTree.LookupBitLength];
{..get the encoded symbol}
{$IFOPT C+} {if Assertions are on}
EncodedSymbol := aDistanceTree.Decode(LookupValue);
{$ELSE}
EncodedSymbol := aDistanceTree.Decodes^[LookupValue];
{$ENDIF}
{..extract the data}
Symbol := EncodedSymbol and $FFFF;
SymbolCodeLen := (EncodedSymbol shr 16) and $FF;
{check that the distance symbol is less than or equal to 29}
if (not aDeflate64) and (Symbol > 29) then
raise EAbInternalInflateError.Create(
'decoded an invalid distance symbol: greater than 29 [DecodeData]');
{..calculate the extra bits for the distance}
ExtraBitCount := EncodedSymbol shr 24;
{..calculate the distance}
if (ExtraBitCount = 0) then begin
Distance := dfc_DistanceBase[Symbol];
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end
else begin
Distance := dfc_DistanceBase[Symbol] +
((BitBuffer shr SymbolCodeLen) and
AbExtractMask[ExtraBitCount]);
BitCount := SymbolCodeLen + ExtraBitCount;
{$IFOPT C+}
aInStrm.DiscardBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
aInStrm.DiscardMoreBits(BitCount)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr BitCount;
aInStrm.BitsLeft := aInStrm.BitsLeft - BitCount;
end;
{$ENDIF}
end;
{duplicate the characters in the sliding window}
aOutWindow.AddLenDist(Length, Distance);
end;
{extract the next symbol}
{..grab the lookup set of bits}
if aDeflate64 then
BitCount := aLiteralTree.LookupBitLength + 16
else
BitCount := aLiteralTree.LookupBitLength + 5;
{$IFOPT C+}
BitBuffer := aInStrm.PeekBits(BitCount);
{$ELSE}
if (aInStrm.BitsLeft < BitCount) then
BitBuffer := aInStrm.PeekMoreBits(BitCount)
else
BitBuffer := aInStrm.BitBuffer and AbExtractMask[BitCount];
{$ENDIF}
LookupValue :=
BitBuffer and AbExtractMask[aLiteralTree.LookupBitLength];
{..get the encoded symbol}
{$IFOPT C+} {if Assertions are on}
EncodedSymbol := aLiteralTree.Decode(LookupValue);
{$ELSE}
EncodedSymbol := aLiteralTree.Decodes^[LookupValue];
{$ENDIF}
{..extract the data}
Symbol := EncodedSymbol and $FFFF;
SymbolCodeLen := (EncodedSymbol shr 16) and $FF;
end;
{discard the bits for the end-of-block marker}
{$IFOPT C+}
aInStrm.DiscardBits(SymbolCodeLen);
{$ELSE}
if (aInStrm.BitsLeft < SymbolCodeLen) then
aInStrm.DiscardMoreBits(SymbolCodeLen)
else begin
aInStrm.BitBuffer := aInStrm.BitBuffer shr SymbolCodeLen;
aInStrm.BitsLeft := aInStrm.BitsLeft - SymbolCodeLen;
end;
{$ENDIF}
end;
{--------}
procedure InflateStoredBlock(aInStrm : TAbDfInBitStream;
aOutWindow : TAbDfOutputWindow;
aLog : TAbLogger);
const
BufferSize = 16 * 1024;
var
LenNotLen : packed record
Len : word;
NotLen : word;
end;
BytesToGo : integer;
BytesToWrite : integer;
Buffer : pointer;
begin
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine('....a stored block');
{$ENDIF}
{align the input bit stream to the nearest byte boundary}
aInStrm.AlignToByte;
{read the length of the stored data and the notted length}
aInStrm.ReadBuffer(LenNotLen, sizeof(LenNotLen));
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine(Format('..block length: %d (%-4x, NOT %-4x)',
[LenNotLen.Len, LenNotLen.Len, LenNotLen.NotLen]));
{$ENDIF}
{check that NOT of the length equals the notted length}
if ((not LenNotLen.Len) <> LenNotLen.NotLen) then
raise EAbInternalInflateError.Create(
'invalid stored block (length and NOT length do not match) [InflateStoredBlock]');
{calculate the number of bytes to copy from the stored block}
BytesToGo := LenNotLen.Len;
{allocate a large buffer}
GetMem(Buffer, BufferSize);
{copy all the data in the stored block to the output window}
try
{while there are still some bytes to copy...}
while (BytesToGo <> 0) do begin
{calculate the number of bytes this time}
if (BytesToGo > BufferSize) then
BytesToWrite := BufferSize
else
BytesToWrite := BytesToGo;
{read that many bytes and write them to the output window}
aInStrm.ReadBuffer(Buffer^, BytesToWrite);
aOutWindow.AddBuffer(Buffer^, BytesToWrite);
{calculate the number of bytes still to copy}
dec(BytesToGo, BytesToWrite);
end;
finally
FreeMem(Buffer);
end;
end;
{--------}
procedure InflateStaticBlock(aInStrm : TAbDfInBitStream;
aOutWindow : TAbDfOutputWindow;
aLog : TAbLogger;
aDeflate64 : boolean);
begin
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine('....a static huffman tree block');
{$ENDIF}
{decode the data with the static trees}
DecodeData(aInStrm, aOutWindow,
AbStaticLiteralTree, AbStaticDistanceTree, aDeflate64);
end;
{--------}
procedure InflateDynamicBlock(aInStrm : TAbDfInBitStream;
aOutWindow : TAbDfOutputWindow;
aLog : TAbLogger;
aDeflate64 : boolean);
var
i : integer;
LitCount : integer;
DistCount : integer;
CodeLenCount : integer;
CodeLens : array [0..285+32] of integer;
CodeLenTree : TAbDfDecodeHuffmanTree;
LiteralTree : TAbDfDecodeHuffmanTree;
DistanceTree : TAbDfDecodeHuffmanTree;
TotalBits : integer;
begin
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then
aLog.WriteLine('....a dynamic huffman tree block');
{$ENDIF}
{prepare for the try..finally}
CodeLenTree := nil;
LiteralTree := nil;
DistanceTree := nil;
try
{decode the number of literal, distance and codelength codes}
LitCount := aInStrm.ReadBits(5) + 257;
DistCount := aInStrm.ReadBits(5) + 1;
CodeLenCount := aInStrm.ReadBits(4) + 4;
{$IFDEF UseLogging}
{log it}
if (aLog <> nil) then begin
aLog.WriteLine(Format('Count of literals: %d', [LitCount]));
aLog.WriteLine(Format('Count of distances: %d', [DistCount]));
aLog.WriteLine(Format('Count of code lengths: %d', [CodeLenCount]));
end;
{$ENDIF}
{verify that the counts are valid}
if (LitCount > 286) then
raise EAbInternalInflateError.Create(
'count of literal codes in dynamic block is greater than 286 [InflateDynamicBlock]');
if (not aDeflate64) and (DistCount > 30) then
raise EAbInternalInflateError.Create(
'count of distance codes in dynamic block is greater than 30 [InflateDynamicBlock]');
{read the codelengths}
FillChar(CodeLens, 19 * sizeof(integer), 0);
for i := 0 to pred(CodeLenCount) do
CodeLens[dfc_CodeLengthIndex[i]] := aInStrm.ReadBits(3);
{$IFDEF UseLogging}
{log them}
if (aLog <> nil) then begin
aLog.WriteLine('CodeLength Huffman tree: code lengths');
for i := 0 to 18 do
aLog.WriteStr(Format('%-3d', [CodeLens[i]]));
aLog.WriteLine('');
aLog.WriteLine(Format('..total bits: %d', [CodeLenCount * 3]));
end;
{$ENDIF}
{create the codelength huffman tree}
CodeLenTree := TAbDfDecodeHuffmanTree.Create(19, 7, huDecoding);
CodeLenTree.Build(CodeLens, 0, 19, [0], $FFFF);
{$IFDEF UseLogging}
{log the tree}
if (aLog <> nil) then begin
aLog.WriteLine('Code lengths tree');
CodeLenTree.DebugPrint(aLog);
end;
{$ENDIF}
{read the codelengths for both the literal/length and distance
huffman trees}
ReadLitDistCodeLengths(aInStrm, CodeLenTree, CodeLens,
LitCount + DistCount, TotalBits);
{$IFDEF UseLoggingx}
{log them}
if (aLog <> nil) then begin
aLog.WriteLine('Literal/length & Dist Huffman trees: code lengths');
for i := 0 to pred(LitCount + DistCount) do
aLog.WriteLine(Format('%3d: %3d', [i, CodeLens[i]]));
aLog.WriteLine('');
aLog.WriteLine(Format('..total bits: %d', [TotalBits]));
end;
{$ENDIF}
{create the literal huffman tree}
LiteralTree := TAbDfDecodeHuffmanTree.Create(286, 15, huDecoding);
LiteralTree.Build(CodeLens, 0, LitCount,
dfc_LitExtraBits, dfc_LitExtraOffset);
{$IFDEF UseLogging}
{log the tree}
if (aLog <> nil) then begin
aLog.WriteLine('Literal/length tree');
LiteralTree.DebugPrint(aLog);
end;
{$ENDIF}
{create the distance huffman tree}
if aDeflate64 then
DistanceTree := TAbDfDecodeHuffmanTree.Create(32, 15, huDecoding)
else
DistanceTree := TAbDfDecodeHuffmanTree.Create(30, 15, huDecoding);
DistanceTree.Build(CodeLens, LitCount, DistCount,
dfc_DistExtraBits, dfc_DistExtraOffset);
{$IFDEF UseLogging}
{log the tree}
if (aLog <> nil) then begin
aLog.WriteLine('Distance tree');
DistanceTree.DebugPrint(aLog);
end;
{$ENDIF}
{using the literal and distance trees, decode the bit stream}
DecodeData(aInStrm, aOutWindow,
LiteralTree, DistanceTree, aDeflate64);
finally
CodeLenTree.Free;
LiteralTree.Free;
DistanceTree.Free;
end;
end;
{====================================================================}
{===Interfaced routine===============================================}
function Inflate(aSource : TStream; aDest : TStream;
aHelper : TAbDeflateHelper) : longint;
var
Helper : TAbDeflateHelper;
InBitStrm : TAbDfInBitStream;
OutWindow : TAbDfOutputWindow;
Log : TAbLogger;
UseDeflate64 : boolean;
UseCRC32 : boolean;
IsFinalBlock : boolean;
BlockType : integer;
TestOnly : boolean;
SourceStartPos : longint;
DestStartPos : longint;
{$IFDEF UseLogging}
StartPosn : longint;
{$ENDIF}
begin
{$IFDEF DefeatWarnings}
Result := 0;
SourceStartPos := 0;
DestStartPos := 0;
TestOnly := False;
{$ENDIF}
{$IFDEF UseLogging}
StartPosn := 0;
{$ENDIF}
{pre-conditions: streams must be allocated of course}
Assert(aSource <> nil, 'Deflate: aSource stream cannot be nil');
Assert(aDest <> nil, 'Deflate: aDest stream cannot be nil');
{prepare for the try..finally}
Helper := nil;
InBitStrm := nil;
OutWindow := nil;
Log := nil;
try {finally}
try {except}
{create our helper; assign the passed one to it}
Helper := TAbDeflateHelper.Create;
if (aHelper <> nil) then
Helper.Assign(aHelper);
{get the initial start positions of both streams}
SourceStartPos := aSource.Position;
DestStartPos := aDest.Position;
{if the helper's stream size is -1, and it has a progress event
handler, calculate the stream size from the stream itself}
if Assigned(Helper.OnProgressStep) then begin
if (Helper.StreamSize = -1) then
Helper.StreamSize := aSource.Size;
end
{otherwise we certainly can't do any progress reporting}
else begin
Helper.OnProgressStep := nil;
Helper.StreamSize := 0;
end;
{create the logger, if requested}
if (Helper.LogFile <> '') then begin
Log := TAbLogger.Create(Helper.LogFile);
Log.WriteLine('INFLATING STREAM...');
{$IFNDEF UseLogging}
Log.WriteLine('Need to recompile the app with UseLogging turned on');
{$ENDIF}
end;
InBitStrm := TAbDfInBitStream.Create(aSource,
Helper.OnProgressStep,
Helper.StreamSize);
{create the output sliding window}
UseDeflate64 := (Helper.Options and dfc_UseDeflate64) <> 0;
UseCRC32 := (Helper.Options and dfc_UseAdler32) = 0;
TestOnly := (Helper.Options and dfc_TestOnly) <> 0;
OutWindow := TAbDfOutputWindow.Create(
aDest, UseDeflate64, UseCRC32, Helper.PartialSize,
TestOnly, Log);
{start decoding the deflated stream}
repeat
{read the final block flag and the block type}
IsFinalBlock := InBitStrm.ReadBit;
BlockType := InBitStrm.ReadBits(2);
{$IFDEF UseLogging}
{log it}
if (Log <> nil) then begin
Log.WriteLine('');
Log.WriteLine('Starting new block');
Log.WriteLine(Format('..final block? %d', [ord(IsFinalBlock)]));
Log.WriteLine(Format('..block type? %d', [BlockType]));
StartPosn := OutWindow.Position;
end;
{$ENDIF}
case BlockType of
0 : InflateStoredBlock(InBitStrm, OutWindow, Log);
1 : InflateStaticBlock(InBitStrm, OutWindow, Log, UseDeflate64);
2 : InflateDynamicBlock(InBitStrm, OutWindow, Log, UseDeflate64);
else
raise EAbInternalInflateError.Create(
'starting new block, but invalid block type [Inflate]');
end;
{$IFDEF UseLogging}
{log it}
if (Log <> nil) then
Log.WriteLine(Format('---block end--- (decoded size %d bytes)',
[OutWindow.Position - StartPosn]));
{$ENDIF}
until IsFinalBlock;
{get the uncompressed stream's checksum}
Result := OutWindow.Checksum;
if TestOnly and (aHelper <> nil) then
aHelper.NormalSize := OutWindow.Position;
{$IFDEF UseLogging}
{log it}
if (Log <> nil) then
Log.WriteLine(Format('End of compressed stream, checksum %-8x',
[Result]));
{$ENDIF}
except
on E : EAbPartSizedInflate do begin
{nothing, just swallow the exception}
Result := 0;
end;
on E : EAbAbortProgress do begin
{nothing, just swallow the exception}
Result := 0;
end;
on E : EAbInternalInflateError do begin
if (Log <> nil) then
Log.WriteLine(Format('Internal exception raised: %s',
[E.Message]));
raise EAbInflateError.Create(E.Message);
end;
end;
finally
Helper.Free;
OutWindow.Free;
InBitStrm.Free;
Log.Free;
end;
{if there's a helper return the compressed and uncompressed sizes}
if (aHelper <> nil) then begin
if not TestOnly then
aHelper.NormalSize := aDest.Position - DestStartPos;
aHelper.CompressedSize := aSource.Position - SourceStartPos;
end;
{WARNING NOTE: the compiler will warn that the return value of this
function might be undefined. However, it is wrong: it
has been fooled by the code. If you don't want to see
this warning again, enable the DefeatWarnings
compiler define in AbDefine.inc.}
end;
{====================================================================}
end.

530
plugins/wcx/zip/src/fparchive/abdfhufd.pas
View file

@ -1,530 +0,0 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfHufD.pas *}
{*********************************************************}
{* Deflate Huffman tree for decoder *}
{*********************************************************}
unit AbDfHufD;
{$I AbDefine.inc}
{Activate this compiler define and rebuild if you want the complete
huffman tree output to print to the current log. The output is
voluminous to say the least...}
{$IFDEF UseLogging}
{.$DEFINE EnableMegaLog}
{$ENDIF}
{Notes:
The object of this class is to build a decoder array, not to build a
Huffman tree particularly. We don't want to decode huffman strings bit
by bit. moving down the Huffman tree sometimes left, sometimes right.
Instead we want to grab a set of bits and look them up in an array.
Sometimes we'll grab too many bits, sure, but we can deal with that
later. So, the object of the exercise is to calculate the code for a
symbol, reverse it ('cos that's how the input bit stream will present
it to us) and set that element of the array to the decoded symbol
value (plus some extra information: bit lengths).
If the alphabet size were 19 (the codelengths huffman tree) and the
maximum code length 5, for example, the decoder array would be 2^5
elements long, much larger than the alphabet size. The user of this
class will be presenting sets of 5 bits for us to decode. We would
like to look up these 5 bits in the array (as an index) and have the
symbol returned. Now, since the alphabet size is much less than the
number of elements in the decoder array, we must set the other
elements in the array as well. Consider a symbol that has a code of
110 in this scenario. The reversed code is 011, or 3, so we'd be
setting element 3. However we should also be setting elements 01011,
10011, and 11011 to this symbol information as well, since the lookup
will be 5 bits long.
Because the code is a huffman code from a prefix tree, we won't get
any index clashes between actual codes by this "filling in" process.
For the codelength Huffman tree, the maximum code length is at most 7.
This equates to a 128 element array. For the literal and distance
trees, the max code length is at most 15. This equates to a 32768
element array.
For a given lookup value the decoder will return a 32-bit value. The
lower 16 bits is the decoded symbol, the next 8 bits is the code
length for that symbol, the last 8 bits (the most significant) are the
number of extra bits that must be extracted from the input bit stream.
}
interface
uses
AbDfBase;
type
TAbDfHuffmanUsage = ( {usage of a huffman decoder..}
huEncoding, {..encoding}
huDecoding, {..decoding}
huBoth); {..both (used for static trees)}
TAbDfDecodeHuffmanTree = class
private
FAlphaSize : integer;
FDecodes : PAbDfLongintList;
FDefMaxCodeLen : integer;
FEncodes : PAbDfLongintList;
{$IFOPT C+}
FMask : integer;
{$ENDIF}
FMaxCodeLen : integer;
FUsage : TAbDfHuffmanUsage;
protected
public
constructor Create(aAlphabetSize : integer;
aDefMaxCodeLen: integer;
aUsage : TAbDfHuffmanUsage);
destructor Destroy; override;
procedure Build(const aCodeLengths : array of integer;
aStartInx : integer;
aCount : integer;
const aExtraBits : array of byte;
aExtraOffset : integer);
function Decode(aLookupBits : integer) : longint;
function Encode(aSymbol : integer) : longint;
{$IFDEF UseLogging}
procedure DebugPrint(aLog : TAbLogger);
{$ENDIF}
property LookupBitLength : integer read FMaxCodeLen;
property Decodes : PAbDfLongintList read FDecodes;
property Encodes : PAbDfLongintList read FEncodes;
end;
var
AbStaticLiteralTree : TAbDfDecodeHuffmanTree;
AbStaticDistanceTree : TAbDfDecodeHuffmanTree;
implementation
uses
SysUtils;
const
PowerOfTwo : array [0..dfc_MaxCodeLength] of integer =
(1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048,
4096, 8192, 16384, 32768);
{===Debug helper routine=============================================}
{$IFDEF EnableMegaLog}
function CodeToStr(aCode : longint; aLen : integer) : string;
var
i : integer;
begin
if (aLen = 0) then
Result := 'no code'
else begin
SetLength(Result, 32);
FillChar(Result[1], 32, ' ');
for i := 32 downto (33-aLen) do begin
if Odd(aCode) then
Result[i] := '1'
else
Result[i] := '0';
aCode := aCode shr 1;
end;
end;
end;
{$ENDIF}
{====================================================================}
{===TAbDfDecodeHuffmanTree===========================================}
constructor TAbDfDecodeHuffmanTree.Create(
aAlphabetSize : integer;
aDefMaxCodeLen: integer;
aUsage : TAbDfHuffmanUsage);
begin
{protect against dumb programming mistakes}
Assert(aAlphabetSize >= 2,
'TAbDfDecodeHuffmanTree.Create: a huffman tree must be for at least two symbols');
{let the ancestor initialize}
inherited Create;
{save the alphabet size, etc}
FAlphaSize := aAlphabetSize;
FDefMaxCodeLen := aDefMaxCodeLen;
FUsage := aUsage;
{allocate the encoder array (needs to be initialized to zeros)}
if (aUsage <> huDecoding) then
FEncodes := AllocMem(FAlphaSize * sizeof(longint));
end;
{--------}
destructor TAbDfDecodeHuffmanTree.Destroy;
begin
{destroy the codes arrays}
if (FDecodes <> nil) then
FreeMem(FDecodes);
if (FEncodes <> nil) then
FreeMem(FEncodes);
{let the ancestor die}
inherited Destroy;
end;
{--------}
procedure TAbDfDecodeHuffmanTree.Build(
const aCodeLengths : array of integer;
aStartInx : integer;
aCount : integer;
const aExtraBits : array of byte;
aExtraOffset : integer);
const
ByteRevTable : array [0..255] of byte = (
$00, $80, $40, $C0, $20, $A0, $60, $E0, $10, $90, $50, $D0,
$30, $B0, $70, $F0, $08, $88, $48, $C8, $28, $A8, $68, $E8,
$18, $98, $58, $D8, $38, $B8, $78, $F8, $04, $84, $44, $C4,
$24, $A4, $64, $E4, $14, $94, $54, $D4, $34, $B4, $74, $F4,
$0C, $8C, $4C, $CC, $2C, $AC, $6C, $EC, $1C, $9C, $5C, $DC,
$3C, $BC, $7C, $FC, $02, $82, $42, $C2, $22, $A2, $62, $E2,
$12, $92, $52, $D2, $32, $B2, $72, $F2, $0A, $8A, $4A, $CA,
$2A, $AA, $6A, $EA, $1A, $9A, $5A, $DA, $3A, $BA, $7A, $FA,
$06, $86, $46, $C6, $26, $A6, $66, $E6, $16, $96, $56, $D6,
$36, $B6, $76, $F6, $0E, $8E, $4E, $CE, $2E, $AE, $6E, $EE,
$1E, $9E, $5E, $DE, $3E, $BE, $7E, $FE, $01, $81, $41, $C1,
$21, $A1, $61, $E1, $11, $91, $51, $D1, $31, $B1, $71, $F1,
$09, $89, $49, $C9, $29, $A9, $69, $E9, $19, $99, $59, $D9,
$39, $B9, $79, $F9, $05, $85, $45, $C5, $25, $A5, $65, $E5,
$15, $95, $55, $D5, $35, $B5, $75, $F5, $0D, $8D, $4D, $CD,
$2D, $AD, $6D, $ED, $1D, $9D, $5D, $DD, $3D, $BD, $7D, $FD,
$03, $83, $43, $C3, $23, $A3, $63, $E3, $13, $93, $53, $D3,
$33, $B3, $73, $F3, $0B, $8B, $4B, $CB, $2B, $AB, $6B, $EB,
$1B, $9B, $5B, $DB, $3B, $BB, $7B, $FB, $07, $87, $47, $C7,
$27, $A7, $67, $E7, $17, $97, $57, $D7, $37, $B7, $77, $F7,
$0F, $8F, $4F, $CF, $2F, $AF, $6F, $EF, $1F, $9F, $5F, $DF,
$3F, $BF, $7F, $FF);
var
i : integer;
Symbol : integer;
LengthCount : array [0..dfc_MaxCodeLength] of integer;
NextCode : array [0..dfc_MaxCodeLength] of integer;
Code : longint;
CodeLen : integer;
CodeData : longint;
DecoderLen : integer;
CodeIncr : integer;
Decodes : PAbDfLongintList;
Encodes : PAbDfLongintList;
{$IFDEF CPU386}
DecodesEnd : pointer;
{$ENDIF}
TablePtr : pointer;
begin
{count the number of instances of each code length and calculate the
maximum code length at the same time}
FillChar(LengthCount, sizeof(LengthCount), 0);
FMaxCodeLen := 0;
for i := 0 to pred(aCount) do begin
CodeLen := aCodeLengths[i + aStartInx];
Assert((CodeLen <= FDefMaxCodeLen),
Format('TAbDfDecodeHuffmanTree.Build: a code length is greater than %d',
[FDefMaxCodeLen]));
if (CodeLen > FMaxCodeLen) then
FMaxCodeLen := CodeLen;
inc(LengthCount[CodeLen]);
end;
{now we know the maximum code length we can allocate our decoder
array}
{$IFNDEF CPU386}
DecoderLen := 0;
{$ENDIF}
if (FUsage <> huEncoding) then begin
DecoderLen := PowerOfTwo[FMaxCodeLen];
GetMem(FDecodes, DecoderLen * sizeof(longint));
{$IFDEF CPU386}
DecodesEnd := PAnsiChar(FDecodes) + (DecoderLen * sizeof(longint));
{$ENDIF}
{$IFOPT C+}
FillChar(FDecodes^, DecoderLen * sizeof(longint), $FF);
FMask := not (DecoderLen - 1);
{$ENDIF}
end;
{calculate the start codes for each code length}
Code := 0;
LengthCount[0] := 0;
for i := 1 to FDefMaxCodeLen do begin
Code := (Code + LengthCount[i-1]) shl 1;
NextCode[i] := Code;
end;
{for speed and convenience}
Decodes := FDecodes;
Encodes := FEncodes;
TablePtr := @ByteRevTable;
{for each symbol...}
for Symbol := 0 to pred(aCount) do begin
{calculate the code length}
CodeLen := aCodeLengths[Symbol + aStartInx];
{if the code length were zero, just set the relevant entry in the
encoder array; the decoder array doesn't need anything}
if (CodeLen = 0) then begin
if (FUsage <> huDecoding) then
Encodes^[Symbol] := -1
end
{otherwise we need to fill elements in both the encoder and
decoder arrays}
else begin
{calculate *reversed* code}
Code := NextCode[CodeLen];
{$IFDEF CPU386}
asm
push esi
mov eax, Code
mov esi, TablePtr
xor ecx, ecx
xor edx, edx
mov cl, ah
mov dl, al
mov al, [esi+ecx]
mov ah, [esi+edx]
mov ecx, 16
pop esi
sub ecx, CodeLen
shr eax, cl
mov Code, eax
end;
{$ELSE}
CodeData:= Code;
LongRec(Code).Bytes[1]:= ByteRevTable[LongRec(CodeData).Bytes[0]];
LongRec(Code).Bytes[0]:= ByteRevTable[LongRec(CodeData).Bytes[1]];
Code:= Code shr (16-CodeLen);
{$ENDIF}
{set the code data (bit count, extra bits required, symbol),
everywhere the reversed code would appear in the decoder array;
set the code data in the encoder array as well}
if (Symbol >= aExtraOffset) then begin
if (FUsage <> huEncoding) then
CodeData := Symbol + { symbol}
(CodeLen shl 16) + { code length}
(aExtraBits[Symbol-aExtraOffset] shl 24);
{ extra bits required}
if (FUsage <> huDecoding) then
Encodes^[Symbol] := Code + { code}
(CodeLen shl 16) + { code length}
(aExtraBits[Symbol-aExtraOffset] shl 24)
{ extra bits required}
end
else begin
if (FUsage <> huEncoding) then
CodeData := Symbol + { symbol}
(CodeLen shl 16); { code length}
if (FUsage <> huDecoding) then
Encodes^[Symbol] := Code + { code}
(CodeLen shl 16); { code length}
end;
{OPTIMIZATION NOTE: the following code
CodeIncr := PowerOfTwo[CodeLen];
while Code < DecoderLen do begin
Decodes^[Code] := CodeData;
inc(Code, CodeIncr);
end;
was replaced by the asm code below to improve the speed. The
code in the loop is the big time sink in this routine so it was
best to replace it.}
if (FUsage <> huEncoding) then begin
{$IFDEF CPU386}
CodeIncr := PowerOfTwo[CodeLen] * sizeof(longint);
asm
push edi { save edi}
mov eax, Decodes { get the Decodes array}
mov edi, DecodesEnd { get the end of the Decodes array}
mov edx, Code { get Code and..}
shl edx, 1 { ..multiply by 4}
shl edx, 1
add eax, edx { eax => first element to be set}
mov edx, CodeData { get the CodeData}
mov ecx, CodeIncr { get the increment per loop}
@@1:
mov [eax], edx { set the element}
add eax, ecx { move to the next element}
cmp eax, edi { if we haven't gone past the end..}
jl @@1 { ..go back for the next one}
pop edi { retrieve edi}
end;
{$ELSE}
CodeIncr := PowerOfTwo[CodeLen];
while Code < DecoderLen do begin
Decodes^[Code] := CodeData;
inc(Code, CodeIncr);
end;
{$ENDIF}
end;
{we've used this code up for this symbol, so increment for the
next symbol at this code length}
inc(NextCode[CodeLen]);
end;
end;
end;
{--------}
{$IFDEF UseLogging}
procedure TAbDfDecodeHuffmanTree.DebugPrint(aLog : TAbLogger);
{$IFDEF EnableMegaLog}
var
i : integer;
Code : longint;
{$ENDIF}
begin
{to print the huffman tree, we must have a logger...}
Assert(aLog <> nil,
'TAbDfDecodeHuffmanTree.DebugPrint needs a logger object to which to print');
if (FUsage <> huEncoding) then begin
aLog.WriteLine('Huffman decoder array');
aLog.WriteLine(Format('Alphabet size: %d', [FAlphaSize]));
aLog.WriteLine(Format('Max codelength: %d', [FMaxCodeLen]));
{$IFDEF EnableMegaLog}
aLog.WriteLine('Index Len Xtra Symbol Reversed Code');
for i := 0 to pred(PowerOfTwo[FMaxCodeLen]) do begin
Code := FDecodes^[i];
if (Code = -1) then
aLog.WriteLine(Format('%5d%49s', [i, 'no code']))
else
aLog.WriteLine(Format('%5d%4d%5d%7d%33s',
[i,
((Code shr 16) and $FF),
((Code shr 24) and $FF),
(Code and $FFFF),
CodeToStr(i, ((Code shr 16) and $FF))]));
end;
aLog.WriteLine('---end decoder array---');
{$ENDIF}
end;
if (FUsage <> huDecoding) then begin
aLog.WriteLine('Huffman encoder array');
aLog.WriteLine(Format('Alphabet size: %d', [FAlphaSize]));
{$IFDEF EnableMegaLog}
aLog.WriteLine('Symbol Len Xtra Reversed Code');
for i := 0 to pred(FAlphaSize) do begin
Code := FEncodes^[i];
if (Code = -1) then
aLog.WriteLine(Format('%6d%42s', [i, 'no code']))
else
aLog.WriteLine(Format('%6d%4d%5d%33s',
[i,
((Code shr 16) and $FF),
((Code shr 24) and $FF),
CodeToStr((Code and $FFFF), ((Code shr 16) and $FF))]));
end;
aLog.WriteLine('---end encoder array---');
{$ENDIF}
end;
end;
{$ENDIF}
{--------}
function TAbDfDecodeHuffmanTree.Decode(aLookupBits : integer) : longint;
begin
{protect against dumb programming mistakes (note: FMask only exists
if assertions are on)}
{$IFOPT C+}
Assert((aLookupBits and FMask) = 0,
'TAbDfDecodeHuffmanTree.Decode: trying to decode too many bits, use LookupBitLength property');
{$ENDIF}
{return the code data}
Result := FDecodes^[aLookupBits];
end;
{--------}
function TAbDfDecodeHuffmanTree.Encode(aSymbol : integer) : longint;
begin
{protect against dumb programming mistakes}
Assert((0 <= aSymbol) and (aSymbol < FAlphaSize),
'TAbDfDecodeHuffmanTree.Encode: trying to encode a symbol that is not in the alphabet');
{return the code data}
Result := FEncodes^[aSymbol];
{if the result is -1, it's another programming mistake: the user is
attempting to get a code for a symbol that wasn't being used}
Assert(Result <> -1,
'TAbDfDecodeHuffmanTree.Encode: trying to encode a symbol that was not used');
end;
{====================================================================}
{===BuildStaticTrees=================================================}
procedure BuildStaticTrees;
var
i : integer;
CodeLens : array [0..287] of integer;
begin
{this routine builds the static huffman trees, those whose code
lengths are determined by the deflate spec}
{the static literal tree first}
for i := 0 to 143 do
CodeLens[i] := 8;
for i := 144 to 255 do
CodeLens[i] := 9;
for i := 256 to 279 do
CodeLens[i] := 7;
for i := 280 to 287 do
CodeLens[i] := 8;
AbStaticLiteralTree := TAbDfDecodeHuffmanTree.Create(288, 15, huBoth);
AbStaticLiteralTree.Build(CodeLens, 0, 288,
dfc_LitExtraBits, dfc_LitExtraOffset);
{the static distance tree afterwards}
for i := 0 to 31 do
CodeLens[i] := 5;
AbStaticDistanceTree := TAbDfDecodeHuffmanTree.Create(32, 15, huBoth);
AbStaticDistanceTree.Build(CodeLens, 0, 32,
dfc_DistExtraBits, dfc_DistExtraOffset);
end;
{====================================================================}
initialization
BuildStaticTrees;
finalization
AbStaticLiteralTree.Free;
AbStaticDistanceTree.Free;
end.

760
plugins/wcx/zip/src/fparchive/abdfinw.pas
View file

@ -1,760 +0,0 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfInW.pas *}
{*********************************************************}
{* Deflate input sliding window unit *}
{*********************************************************}
unit AbDfInW;
{$I AbDefine.inc}
interface
uses
Classes,
AbDfBase;
{Notes: TdfInputWindow implements a sliding window on data for the
LZ77 dictionary encoding.
The stream passed to the class is automatically read when
required to keep the internal buffer fully loaded.
}
type
TAbDfMatch = record
maLen : integer;
maDist : integer;
maLit : AnsiChar;
end;
type
PAbPointerList = ^TAbPointerList;
TAbPointerList = array[0..MaxInt div SizeOf(Pointer) - 1] of Pointer;
TAbDfInputWindow = class
private
FAdvanceStart : boolean;
FBuffer : PAnsiChar;
FBufferEnd : PAnsiChar;
FBytesUsed : longint;
FChainLen : integer;
FHashChains : PAbPointerList;
FHashHeads : PAbPointerList;
FHashIndex : integer;
FChecksum : longint;
FCurrent : PAnsiChar;
FLookAheadEnd : PAnsiChar;
FMaxMatchLen : integer;
FMustSlide : boolean;
FOnProgress : TAbProgressStep;
FSlidePoint : PAnsiChar;
FStart : PAnsiChar;
FStartOffset : Int64;
FStream : TStream;
FStreamSize : Int64;
FUseCRC32 : boolean;
FUseDeflate64 : boolean;
FWinMask : integer;
FWinSize : integer;
protected
function iwGetChecksum : longint;
procedure iwReadFromStream;
procedure iwSetCapacity(aValue : longint);
procedure iwSlide;
public
constructor Create(aStream : TStream;
aStreamSize : Int64;
aWinSize : integer;
aChainLength : integer;
aUseDeflate64 : boolean;
aUseCRC32 : boolean);
destructor Destroy; override;
procedure Advance(aCount : integer;
aHashCount : integer);
procedure AdvanceByOne;
function FindLongestMatch(aAmpleLength : integer;
var aMatch : TAbDfMatch;
const aPrevMatch : TAbDfMatch) : boolean;
function GetNextChar : AnsiChar;
function GetNextKeyLength : integer;
function Position : Int64;
procedure ReadBuffer(var aBuffer; aCount : longint;
aOffset : Int64);
property ChainLen : integer read FChainLen write FChainLen;
property Checksum : longint read iwGetChecksum;
property OnProgress : TAbProgressStep
read FOnProgress write FOnProgress;
end;
implementation
uses
SysUtils;
{Notes:
Meaning of the internal pointers:
|----------+===================+==+--------------------------|
| | | | |
FBuffer FStart FCurrent FLookAheadEnd FBufferEnd
FCurrent is the current match position. The valid data that
can be matched is between FStart and FLookAheadEnd, The data
between FStart and FCurrent has already been seen; the data
between FCurrent and FLookAheadEnd can be used for matching.
The buffer size depends on the requested window size (a
multiple of 1KB, up to 32KB for deflate, up to 64KB for
deflate64) and the lookahead size (up to 258 bytes for deflate
and 64KB for deflate64.)
The window of data continuously slides to the right, and is
slid back to FBuffer whenever FStart reaches a point 16KB
away, this point being given by FSlidePoint.
The hash table:
This is a chained hash table with some peculiarities. First
the table itself, FHashHeads. It contains pointers to strings
in the window buffer, not to chains. The chains are held is a
separate structure, FHashChains. The hash function on the
three-character keys is a Rabin-Karp function:
((((Ch1 shl 5) xor Ch2) shl 5) xor Ch3) and $3FFF
designed so that a running hash value can be kept and
calculated per character. The hash table is $4000 elements
long (obviously, given the hash function).
On insertion, the previous pointer in the hash table at the
calculated index is saved and replaced by the new pointer. The
old pointer is saved in the chains array. This has the same
number of elements as the sliding window has characters. The
pointer is placed at (Ptr and (WindowsSize-1)) overwriting the
value that's already there. In this fashion the individual
chains in the standard hash table are interwoven with each
other in this hash table, like a skein of threads.
}
const
c_HashCount = $4000; {the number of hash entries}
c_HashMask = c_HashCount - 1; {a mask for the hash function}
c_HashShift = 5; {shift value for the hash function}
{===TAbDfInputWindow=================================================}
constructor TAbDfInputWindow.Create(aStream : TStream;
aStreamSize : Int64;
aWinSize : integer;
aChainLength : integer;
aUseDeflate64 : boolean;
aUseCRC32 : boolean);
begin
{create the ancestor}
inherited Create;
{save parameters}
FStreamSize := aStreamSize;
FWinSize := aWinSize;
FWinMask := aWinSize - 1;
FStream := aStream;
FChainLen := aChainLength;
FUseDeflate64 := aUseDeflate64;
FUseCRC32 := aUseCRC32;
if aUseCRC32 then
FChecksum := -1 { CRC32 starts off with all bits set }
else
FCheckSum := 1; { Adler32 starts off with a value of 1 }
{set capacity of sliding window}
iwSetCapacity(aWinSize);
{create the hash table, first the hash table itself (and set all
entries to nil)}
FHashHeads := AllocMem(c_HashCount * sizeof(pointer));
{..now the chains (there's no need to set the entries to nil, since
the chain entries get fed from the head entries before searching)}
GetMem(FHashChains, aWinSize * sizeof(pointer));
{read the first chunk of data from the stream}
FMustSlide := true;
iwReadFromStream;
{if there are at least two bytes, prime the hash index}
if ((FLookAheadEnd - FBuffer) >= 2) then
FHashIndex := ((longint(FBuffer[0]) shl c_HashShift) xor
longint(FBuffer[1])) and
c_HashMask;
end;
{--------}
destructor TAbDfInputWindow.Destroy;
begin
{free the hash table}
FreeMem(FHashHeads);
FreeMem(FHashChains);
{free the buffer}
FreeMem(FBuffer);
{destroy the ancestor}
inherited Destroy;
end;
{--------}
procedure TAbDfInputWindow.Advance(aCount : integer;
aHashCount : integer);
var
i : integer;
ByteCount : integer;
Percent : integer;
HashChains: PAbPointerList;
HashHeads : PAbPointerList;
HashInx : integer;
CurPos : PAnsiChar;
begin
Assert((FLookAheadEnd - FCurrent) >= aCount,
'TAbDfInputWindow.Advance: seem to be advancing into the unknown');
Assert((aHashCount = aCount) or (aHashCount = pred(aCount)),
'TAbDfInputWindow.Advance: the parameters are plain wrong');
{use local var for speed}
CurPos := FCurrent;
{advance the current pointer if needed}
if (aCount > aHashCount) then
inc(CurPos);
{make sure we update the hash table; remember that the string[3] at
the current position has already been added to the hash table (for
notes on updating the hash table, see FindLongestMatch}
{use local vars for speed}
HashChains := FHashChains;
HashHeads := FHashHeads;
HashInx := FHashIndex;
{update the hash table}
for i := 0 to pred(aHashCount) do begin
HashInx :=
((HashInx shl c_HashShift) xor longint(CurPos[2])) and
c_HashMask;
HashChains^[PtrUInt(CurPos) and FWinMask] := HashHeads^[HashInx];
HashHeads^[HashInx] := CurPos;
inc(CurPos);
end;
{replace old values}
FHashChains := HashChains;
FHashHeads := HashHeads;
FHashIndex := HashInx;
FCurrent := CurPos;
{if we've seen at least FWinSize bytes...}
if FAdvanceStart then begin
{advance the start of the sliding window}
inc(FStart, aCount);
inc(FStartOffset, aCount);
{check to see if we have advanced into the slide zone}
if FMustSlide and (FStart >= FSlidePoint) then
iwSlide;
end
{otherwise check to see if we've seen at least FWinSize bytes}
else if ((CurPos - FStart) >= FWinSize) then begin
FAdvanceStart := true;
{note: we can't advance automatically aCount bytes here, we need
to calculate the actual count}
ByteCount := (CurPos - FWinSize) - FStart;
inc(FStart, ByteCount);
inc(FStartOffset, ByteCount);
end;
{show progress}
if Assigned(FOnProgress) then begin
inc(FBytesUsed, aCount);
if ((FBytesUsed and $FFF) = 0) then begin
Percent := Round((100.0 * FBytesUsed) / FStreamSize);
FOnProgress(Percent);
end;
end;
{check to see if we have advanced into the slide zone}
if (FStart >= FSlidePoint) then
iwSlide;
end;
{--------}
procedure TAbDfInputWindow.AdvanceByOne;
var
Percent : integer;
begin
{advance the current pointer}
inc(FCurrent);
{if we've seen at least FWinSize bytes...}
if FAdvanceStart then begin
{advance the start of the sliding window}
inc(FStart, 1);
inc(FStartOffset, 1);
{check to see if we have advanced into the slide zone}
if FMustSlide and (FStart >= FSlidePoint) then
iwSlide;
end
{otherwise check to see if we've seen FWinSize bytes}
else if ((FCurrent - FStart) = FWinSize) then
FAdvanceStart := true;
{show progress}
if Assigned(FOnProgress) then begin
inc(FBytesUsed, 1);
if ((FBytesUsed and $FFF) = 0) then begin
Percent := Round((100.0 * FBytesUsed) / FStreamSize);
FOnProgress(Percent);
end;
end;
end;
{--------}
function TAbDfInputWindow.FindLongestMatch(aAmpleLength : integer;
var aMatch : TAbDfMatch;
const aPrevMatch : TAbDfMatch)
: boolean;
{Note: this routine implements a greedy algorithm and is by far the
time sink for compression. There are two versions, one written
in Pascal for understanding, one in assembler for speed.
Activate one and only one of the following compiler defines.}
{$IFDEF CPU386}
{$DEFINE UseGreedyAsm}
{$ELSE}
{$DEFINE UseGreedyPascal}
{$ENDIF}
{Check to see that all is correct}
{$IFDEF UseGreedyAsm}
{$IFDEF UseGreedyPascal}
!! Compile Error: only one of the greedy compiler defines can be used
{$ENDIF}
{$ELSE}
{$IFNDEF UseGreedyPascal}
!! Compile Error: one of the greedy compiler defines must be used
{$ENDIF}
{$ENDIF}
type
PWord = ^word;
var
MaxLen : longint;
MaxDist : longint;
MaxMatch : integer;
ChainLen : integer;
PrevStrPos : PAnsiChar;
CurPos : PAnsiChar;
{$IFDEF UseGreedyAsm}
CurWord : word;
MaxWord : word;
{$ENDIF}
{$IFDEF UseGreedyPascal}
Len : longint;
MatchStr : PAnsiChar;
CurrentCh : PAnsiChar;
CurCh : AnsiChar;
MaxCh : AnsiChar;
{$ENDIF}
begin
{calculate the hash index for the current position; using the
Rabin-Karp algorithm this is equal to the previous index less the
effect of the character just lost plus the effect of the character
just gained}
CurPos := FCurrent;
FHashIndex :=
((FHashIndex shl c_HashShift) xor longint(CurPos[2])) and
c_HashMask;
{get the head of the hash chain: this is the position in the sliding
window of the previous 3-character string with this hash value}
PrevStrPos := FHashHeads^[FHashIndex];
{set the head of the hash chain equal to our current position}
FHashHeads^[FHashIndex] := CurPos;
{update the chain itself: set the entry for this position equal to
the previous string position}
FHashChains^[PtrUInt(CurPos) and FWinMask] := PrevStrPos;
{calculate the maximum match we could do at this position}
MaxMatch := (FLookAheadEnd - CurPos);
if (MaxMatch > FMaxMatchLen) then
MaxMatch := FMaxMatchLen;
if (aAmpleLength > MaxMatch) then
aAmpleLength := MaxMatch;
{calculate the current match length}
if (aPrevMatch.maLen = 0) then
MaxLen := 2
else begin
if (MaxMatch < aPrevMatch.maLen) then begin
Result := false;
aMatch.maLen := 0;
aMatch.maLit := CurPos^;
Exit;
end;
MaxLen := aPrevMatch.maLen;
end;
{get the bytes at the current position and at the end of the maximum
match we have to better}
{$IFDEF UseGreedyAsm}
CurWord := PWord(CurPos)^;
MaxWord := PWord(CurPos + pred(MaxLen))^;
{$ENDIF}
{$IFDEF UseGreedyPascal}
CurCh := CurPos^;
MaxCh := (CurPos + pred(MaxLen))^;
{$ENDIF}
{set the chain length to search based on the current maximum match
(basically: if we've already satisfied the ample length
requirement, don't search as far)}
if (MaxLen >= aAmpleLength) then
ChainLen := FChainLen div 4
else
ChainLen := FChainLen;
{get ready for the loop}
{$IFDEF DefeatWarnings}
MaxDist := 0;
{$ENDIF}
{$IFDEF UseGreedyAsm} { slip into assembler for speed...}
asm
push ebx { save those registers we should}
push esi
push edi
mov ebx, Self { ebx will store the Self pointer}
mov edi, PrevStrPos { edi => previous string}
mov esi, CurPos { esi => current string}
@@TestThisPosition:
{ check previous string is in range}
or edi, edi
je @@Exit
cmp edi, [ebx].TAbDfInputWindow.FStart
jb @@Exit
cmp edi, CurPos
jae @@Exit
mov ax, [edi] { check previous string starts with same}
cmp CurWord, ax { two bytes as current}
jne @@GetNextPosition { ..nope, they don't match}
mov edx, edi { check previous string ends with same}
add edi, MaxLen { two bytes as current (by "ends" we}
dec edi { mean the last two bytes at the}
mov ax, [edi] { current match length)}
cmp MaxWord, ax
mov edi, edx
jne @@GetNextPosition { ..nope, they don't match}
push edi { compare the previous string with the}
push esi { current string}
mov eax, MaxMatch
add edi, 2 { (we've already checked that the first}
sub eax, 2 { two characters are the same)}
add esi, 2
mov ecx, eax
@@CmpQuads:
cmp ecx, 4
jb @@CmpSingles
mov edx, [esi]
cmp edx, [edi]
jne @@CmpSingles
add esi, 4
add edi, 4
sub ecx, 4
jnz @@CmpQuads
jmp @@MatchCheck
@@CmpSingles:
or ecx, ecx
jb @@MatchCheck
mov dl, [esi]
cmp dl, [edi]
jne @@MatchCheck
inc esi
inc edi
dec ecx
jnz @@CmpSingles
@@MatchCheck:
sub eax, ecx
add eax, 2
pop esi
pop edi
cmp eax, MaxLen { have we found a longer match?}
jbe @@GetNextPosition { ..no}
mov MaxLen, eax { ..yes, so save it}
mov eax, esi { calculate the dist for this new match}
sub eax, edi
mov MaxDist, eax
cmp eax, aAmpleLength { if this match is ample enough, exit}
jae @@Exit
mov eax, esi { calculate the two bytes at the end of}
add eax, MaxLen { this new match}
dec eax
mov ax, [eax]
mov MaxWord, ax
@@GetNextPosition:
mov eax, ChainLen { we've visited one more link on the}
dec eax { chain, if that's the last one we}
je @@Exit { should visit, exit}
mov ChainLen, eax
{ advance along the chain}
mov edx, [ebx].TAbDfInputWindow.FHashChains
mov eax, [ebx].TAbDfInputWindow.FWinMask
and edi, eax
shl edi, 2
mov edi, [edx+edi]
jmp @@TestThisPosition
@@Exit:
pop edi
pop esi
pop ebx
end;
{$ENDIF}
{$IFDEF UseGreedyPascal}
{for all possible hash nodes in the chain...}
while (FStart <= PrevStrPos) and (PrevStrPos < CurPos) do begin
{if the initial and maximal characters match...}
if (PrevStrPos[0] = CurCh) and
(PrevStrPos[pred(MaxLen)] = MaxCh) then begin
{compare more characters}
Len := 1;
CurrentCh := CurPos + 1;
MatchStr := PrevStrPos + 1;
{compare away, but don't go above the maximum length}
while (Len < MaxMatch) and (MatchStr^ = CurrentCh^) do begin
inc(CurrentCh);
inc(MatchStr);
inc(Len);
end;
{have we reached another maximum for the length?}
if (Len > MaxLen) then begin
MaxLen := Len;
{calculate the distance}
MaxDist := CurPos - PrevStrPos;
MaxCh := CurPos[pred(MaxLen)];
{is the new best length ample enough?}
if MaxLen >= aAmpleLength then
Break;
end;
end;
{have we reached the end of this chain?}
dec(ChainLen);
if (ChainLen = 0) then
Break;
{otherwise move onto the next position}
PrevStrPos := FHashChains^[PtrUInt(PrevStrPos) and FWinMask];
end;
{$ENDIF}
{based on the results of our investigation, return the match values}
if (MaxLen < 3) or (MaxLen <= aPrevMatch.maLen) then begin
Result := false;
aMatch.maLen := 0;
aMatch.maLit := CurPos^;
end
else begin
Result := true;
aMatch.maLen := MaxLen;
aMatch.maDist := MaxDist;
aMatch.maLit := CurPos^; { just in case...}
end;
end;
{--------}
function TAbDfInputWindow.GetNextChar : AnsiChar;
begin
Result := FCurrent^;
inc(FCurrent);
end;
{--------}
function TAbDfInputWindow.GetNextKeyLength : integer;
begin
Result := FLookAheadEnd - FCurrent;
if (Result > 3) then
Result := 3;
end;
{--------}
function TAbDfInputWindow.iwGetChecksum : longint;
begin
{the CRC32 checksum algorithm requires a post-conditioning step
after being calculated (the result is NOTted), whereas Adler32 does
not}
if FUseCRC32 then
Result := not FChecksum
else
Result := FChecksum;
end;
{--------}
procedure TAbDfInputWindow.iwReadFromStream;
var
BytesRead : longint;
BytesToRead : longint;
begin
{read some more data into the look ahead zone}
BytesToRead := FBufferEnd - FLookAheadEnd;
BytesRead := FStream.Read(FLookAheadEnd^, BytesToRead);
{if nothing was read, we reached the end of the stream; hence
there's no more need to slide the window since we have all the
data}
if (BytesRead = 0) then
FMustSlide := false
{otherwise something was actually read...}
else begin
{update the checksum}
if FUseCRC32 then
AbUpdateCRCBuffer(FChecksum, FLookAheadEnd^, BytesRead)
else
AbUpdateAdlerBuffer(FChecksum, FLookAheadEnd^, BytesRead);
{reposition the pointer for the end of the lookahead area}
inc(FLookAheadEnd, BytesRead);
end;
end;
{--------}
procedure TAbDfInputWindow.iwSetCapacity(aValue : longint);
var
ActualSize : integer;
begin
{calculate the actual size; this will be the value passed in, plus
the correct look ahead size, plus 16KB}
ActualSize := aValue + (16 * 1024);
if FUseDeflate64 then begin
inc(ActualSize, dfc_MaxMatchLen64);
FMaxMatchLen := dfc_MaxMatchLen64;
end
else begin
inc(ActualSize, dfc_MaxMatchLen);
FMaxMatchLen := dfc_MaxMatchLen;
end;
{get the new buffer}
GetMem(FBuffer, ActualSize);
{set the other buffer pointers}
FStart := FBuffer;
FCurrent := FBuffer;
FLookAheadEnd := FBuffer;
FBufferEnd := FBuffer + ActualSize;
FSlidePoint := FBuffer + (16 * 1024);
end;
{--------}
procedure TAbDfInputWindow.iwSlide;
var
i : integer;
ByteCount : PtrInt;
Buffer : PAnsiChar;
ListItem : PPointer;
begin
{move current valid data back to the start of the buffer}
ByteCount := FLookAheadEnd - FStart;
Move(FStart^, FBuffer^, ByteCount);
{reset the various pointers}
ByteCount := FStart - FBuffer;
FStart := FBuffer;
dec(FCurrent, ByteCount);
dec(FLookAheadEnd, ByteCount);
{patch up the hash table: the head pointers}
Buffer := FBuffer;
ListItem := @FHashHeads^[0];
for i := 0 to pred(c_HashCount) do begin
dec(ListItem^, ByteCount);
if (ListItem^ < Buffer) then
ListItem^ := nil;
inc(ListItem);
end;
{..the chain pointers}
ListItem := @FHashChains^[0];
for i := 0 to pred(FWinSize) do begin
dec(ListItem^, ByteCount);
if (ListItem^ < Buffer) then
ListItem^ := nil;
inc(ListItem);
end;
{now read some more data from the stream}
iwReadFromStream;
end;
{--------}
function TAbDfInputWindow.Position : Int64;
begin
Result := (FCurrent - FStart) + FStartOffset;
end;
{--------}
procedure TAbDfInputWindow.ReadBuffer(var aBuffer; aCount : longint;
aOffset : Int64);
var
CurPos : Int64;
begin
CurPos := FStream.Seek(0, soCurrent);
FStream.Seek(aOffSet, soBeginning);
FStream.ReadBuffer(aBuffer, aCount);
FStream.Seek(CurPos, soBeginning);
end;
{====================================================================}
end.

377
plugins/wcx/zip/src/fparchive/abdfoutw.pas
View file

@ -1,377 +0,0 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfOutW.pas *}
{*********************************************************}
{* Deflate output sliding window *}
{*********************************************************}
unit AbDfOutW;
{$I AbDefine.inc}
interface
uses
Classes,
AbDfBase;
{Notes: TAbDfOutputWindow implements a sliding window on previously
written data for the LZ77 dictionary decoding.
AddLiteral will add a literal character at the current
position and advance by one. AddLenDist will copy the required
number of characters from the given position to the current
position, and advance the stream on by the length. The class
will periodically update the stream from the internal buffer.
For normal Deflate, the internal buffer is 48K + 512 bytes in
size. Once there is 48Kb worth of data, 16KB is written to
file, and the buffer is shifted left by 16KB. We need to keep
the last decoded 32KB in memory at all times.
For Deflate64, the internal buffer is 96K + 512 bytes in
size. Once there is 96Kb worth of data, 32KB is written to
file, and the buffer is shifted left by 32KB. We need to keep
the last decoded 64KB in memory at all times.
}
type
TAbDfOutputWindow = class
private
FBuffer : PAnsiChar;
FChecksum : longint;
FCurrent : PAnsiChar;
FLog : TAbLogger;
FPartSize : longint;
FSlideCount : integer;
FStream : TStream;
FStreamPos : longint;
FTestOnly : boolean;
FUseCRC32 : boolean;
FWritePoint : PAnsiChar;
protected
function swGetChecksum : longint;
procedure swWriteToStream(aFlush : boolean);
public
constructor Create(aStream : TStream;
aUseDeflate64 : boolean;
aUseCRC32 : boolean;
aPartSize : longint;
aTestOnly : boolean;
aLog : TAbLogger);
destructor Destroy; override;
procedure AddBuffer(var aBuffer; aCount : integer);
procedure AddLiteral(aCh : AnsiChar);
procedure AddLenDist(aLen : integer; aDist : integer);
function Position : longint;
property Checksum : longint read swGetChecksum;
property Log : TAbLogger read FLog;
end;
implementation
uses
SysUtils;
{Notes:
Meaning of the internal pointers:
|==============================+------------------------+----|
| | |
FBuffer FCurrent FWritePoint
Once FCurrent reaches or exceeds FWritePoint, FSlideCount
bytes of data from FBuffer are written to the stream and the
remaining data is moved back FSlideCount bytes, moving
FCurrent along with it as well.
}
{===TAbDfOutputWindow==================================================}
constructor TAbDfOutputWindow.Create(aStream : TStream;
aUseDeflate64 : boolean;
aUseCRC32 : boolean;
aPartSize : longint;
aTestOnly : boolean;
aLog : TAbLogger);
var
Size : integer;
LookAheadSize : integer;
begin
{allow the ancestor to initialize}
inherited Create;
{save parameters}
FLog := aLog;
FStream := aStream;
FTestOnly := aTestOnly;
if (aPartSize <= 0) then
FPartSize := 0
else
FPartSize := aPartSize;
FUseCRC32 := aUseCRC32;
if aUseCRC32 then
FChecksum := -1 { CRC32 starts off with all bits set}
else
FCheckSum := 1; { Adler32 starts off with a value of 1}
{set capacity of sliding window}
if aUseDeflate64 then begin
Size := 96 * 1024;
FSlideCount := 32 * 1024;
LookAheadSize := 64 * 1024;
end
else begin
Size := 64 * 1024;
FSlideCount := 32 * 1024;
LookAheadSize := 258;
end;
GetMem(FBuffer, Size + LookAheadSize);
{set the other internal pointers}
FCurrent := FBuffer;
FWritePoint := FBuffer + Size;
if (FPartSize > Size) then
FPartSize := Size;
end;
{--------}
destructor TAbDfOutputWindow.Destroy;
begin
{write remaining data and free the buffer}
if (FBuffer <> nil) then begin
if (FCurrent <> FBuffer) then
swWriteToStream(true);
FreeMem(FBuffer);
end;
{destroy the ancestor}
inherited Destroy;
end;
{--------}
procedure TAbDfOutputWindow.AddBuffer(var aBuffer; aCount : integer);
var
Buffer : PAnsiChar;
BytesToWrite : integer;
begin
{if we've advanced to the point when we need to write, do so}
if (FCurrent >= FWritePoint) then
swWriteToStream(false);
{cast the user buffer to a PChar, it's easier to use}
Buffer := @aBuffer;
{calculate the number of bytes to copy}
BytesToWrite := FWritePoint - FCurrent;
if (BytesToWrite > aCount) then
BytesToWrite := aCount;
{move this block of bytes}
Move(Buffer^, FCurrent^, BytesToWrite);
{advance pointers and counters}
inc(FCurrent, BytesToWrite);
dec(aCount, BytesToWrite);
{while there is still data to copy...}
while (aCount > 0) do begin
{advance the user buffer pointer}
inc(Buffer, BytesToWrite);
{write the sliding window chunk to the stream}
swWriteToStream(false);
{calculate the number of bytes to copy}
BytesToWrite := FWritePoint - FCurrent;
if (BytesToWrite > aCount) then
BytesToWrite := aCount;
{move this block of bytes}
Move(Buffer^, FCurrent^, BytesToWrite);
{advance pointers and counters}
inc(FCurrent, BytesToWrite);
dec(aCount, BytesToWrite);
end;
end;
{--------}
procedure AddLenDistToLog(aLog : TAbLogger;
aPosn : longint;
aLen : integer;
aDist : integer;
aOverLap : boolean);
begin
{NOTE the reason for this separate routine is to avoid string
allocations and try..finally blocks in the main method: an
optimization issue}
if aOverLap then
aLog.WriteLine(Format('%8x Len: %-3d, Dist: %-5d **overlap**',
[aPosn, aLen, aDist]))
else
aLog.WriteLine(Format('%8x Len: %-3d, Dist: %-5d',
[aPosn, aLen, aDist]));
end;
{--------}
procedure TAbDfOutputWindow.AddLenDist(aLen : integer; aDist : integer);
var
i : integer;
ToChar : PAnsiChar;
FromChar : PAnsiChar;
begin
{log it}
{$IFDEF UseLogging}
if (FLog <> nil) then
AddLenDistToLog(FLog, Position, aLen, aDist, (aLen > aDist));
{$ENDIF}
{if the length to copy is less than the distance, just do a move}
if (aLen <= aDist) then begin
Move((FCurrent - aDist)^ , FCurrent^, aLen);
end
{otherwise we have to use a byte-by-byte copy}
else begin
FromChar := FCurrent - aDist;
ToChar := FCurrent;
for i := 1 to aLen do begin
ToChar^ := FromChar^;
inc(FromChar);
inc(ToChar);
end;
end;
{increment the current pointer}
inc(FCurrent, aLen);
{if we've reached the point requested, abort}
if (FPartSize > 0) and ((FCurrent - FBuffer) >= FPartSize) then
raise EAbPartSizedInflate.Create(''); {NOTE: This exception is expected during detection of .GZ and .TGZ files. (VerifyGZip)}
{if we've advanced to the point when we need to write, do so}
if (FCurrent >= FWritePoint) then
swWriteToStream(false);
end;
{--------}
procedure AddLiteralToLog(aLog : TAbLogger;
aPosn : longint;
aCh : AnsiChar);
begin
{NOTE the reason for this separate routine is to avoid string
allocations and try..finally blocks in the main method: an
optimization issue}
if (' ' < aCh) and (aCh <= '~') then
aLog.WriteLine(Format('%8x Char: %3d $%2x [%s]', [aPosn, ord(aCh), ord(aCh), aCh]))
else
aLog.WriteLine(Format('%8x Char: %3d $%2x', [aPosn, ord(aCh), ord(aCh)]));
end;
{--------}
procedure TAbDfOutputWindow.AddLiteral(aCh : AnsiChar);
begin
{log it}
{$IFDEF UseLogging}
if (FLog <> nil) then
AddLiteralToLog(FLog, Position, aCh);
{$ENDIF}
{add the literal to the buffer}
FCurrent^ := aCh;
{increment the current pointer}
inc(FCurrent);
{if we've reached the point requested, abort}
if (FPartSize > 0) and ((FCurrent - FBuffer) >= FPartSize) then
raise EAbPartSizedInflate.Create('');
{if we've advanced to the point when we need to write, do so}
if (FCurrent >= FWritePoint) then
swWriteToStream(false);
end;
{--------}
function TAbDfOutputWindow.Position : longint;
begin
if FTestOnly then
Result := FStreamPos + (FCurrent - FBuffer)
else
Result := FStream.Position + (FCurrent - FBuffer);
end;
{--------}
function TAbDfOutputWindow.swGetChecksum : longint;
begin
{since the checksum is calculated by the method that flushes to the
stream, make sure any buffered data is written out first}
if (FCurrent <> FBuffer) then
swWriteToStream(true);
{the CRC32 checksum algorithm requires a post-conditioning step
after being calculated (the result is NOTted), whereas Adler32 does
not}
if FUseCRC32 then
Result := not FChecksum
else
Result := FChecksum;
end;
{--------}
procedure TAbDfOutputWindow.swWriteToStream(aFlush : boolean);
var
FromPtr : PAnsiChar;
begin
{if the request was to flush, write all remaining data after
updating the checksum}
if aFlush then begin
if FUseCRC32 then
AbUpdateCRCBuffer(FChecksum, FBuffer^, FCurrent - FBuffer)
else
AbUpdateAdlerBuffer(FChecksum, FBuffer^, FCurrent - FBuffer);
if FTestOnly then
inc(FStreamPos, FCurrent - FBuffer)
else
FStream.WriteBuffer(FBuffer^, FCurrent - FBuffer);
FCurrent := FBuffer;
end
{otherwise, update the checksum with the data in the sliding window
chunk, write it out to the stream, and move the rest of the buffer
back}
else begin
if FUseCRC32 then
AbUpdateCRCBuffer(FChecksum, FBuffer^, FSlideCount)
else
AbUpdateAdlerBuffer(FChecksum, FBuffer^, FSlideCount);
if FTestOnly then
inc(FStreamPos, FSlideCount)
else
FStream.WriteBuffer(FBuffer^, FSlideCount);
FromPtr := FBuffer + FSlideCount;
Move(FromPtr^, FBuffer^, FCurrent - FromPtr);
FCurrent := FCurrent - FSlideCount;
end;
end;
{====================================================================}
end.

282
plugins/wcx/zip/src/fparchive/abdfpkmg.pas
View file

@ -1,282 +0,0 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfPkMg.pas *}
{*********************************************************}
{* Deflate package-merge algorithm *}
{*********************************************************}
unit AbDfPkMg;
{$I AbDefine.inc}
interface
uses
AbDfBase;
procedure GenerateCodeLengths(aMaxCodeLen : integer;
const aWeights : array of integer;
var aCodeLengths : array of integer;
aStartInx : integer;
aLog : TAbLogger);
implementation
type
PPkgNode = ^TPkgNode;
TPkgNode = packed record
pnWeight : integer;
pnCount : integer;
pnLeft : PPkgNode;
pnRight : PPkgNode;
end;
PPkgNodeList = ^TPkgNodeList;
TPkgNodeList = array [0..pred(286 * 2)] of PPkgNode;
{Note: the "286" is the number of literal/length symbols, the
maximum number of weights we'll be calculating the optimal
code lengths for}
{===helper routines==================================================}
function IsCalcFeasible(aCount : integer;
aMaxCodeLen : integer) : boolean;
begin
{works out if length-limited codes can be calculated for a given
number of symbols and the maximum code length}
{return whether 2^aMaxCodeLen > aCount}
Result := (1 shl aMaxCodeLen) > aCount;
end;
{--------}
procedure QSS(aList : PPkgNodeList;
aFirst : integer;
aLast : integer);
var
L, R : integer;
Pivot : integer;
Temp : pointer;
begin
{while there are at least two items to sort}
while (aFirst < aLast) do begin
{the pivot is the middle item}
Pivot := aList^[(aFirst+aLast) div 2]^.pnWeight;
{set indexes and partition}
L := pred(aFirst);
R := succ(aLast);
while true do begin
repeat dec(R); until (aList^[R]^.pnWeight <= Pivot);
repeat inc(L); until (aList^[L]^.pnWeight >= Pivot);
if (L >= R) then Break;
Temp := aList^[L];
aList^[L] := aList^[R];
aList^[R] := Temp;
end;
{quicksort the first subfile}
if (aFirst < R) then
QSS(aList, aFirst, R);
{quicksort the second subfile - recursion removal}
aFirst := succ(R);
end;
end;
{--------}
procedure SortList(aList : PPkgNodeList; aCount : integer);
begin
QSS(aList, 0, pred(aCount));
end;
{--------}
procedure Accumulate(aNode : PPkgNode);
begin
while (aNode^.pnLeft <> nil) do begin
Accumulate(aNode^.pnLeft);
aNode := aNode^.pnRight;
end;
inc(aNode^.pnCount);
end;
{====================================================================}
{===Interfaced routine===============================================}
procedure GenerateCodeLengths(aMaxCodeLen : integer;
const aWeights : array of integer;
var aCodeLengths : array of integer;
aStartInx : integer;
aLog : TAbLogger);
var
i : integer;
Bit : integer;
WeightCount : integer;
OrigList : PPkgNodeList;
OrigListCount : integer;
MergeList : PPkgNodeList;
MergeListCount : integer;
PkgList : PPkgNodeList;
PkgListCount : integer;
OrigInx : integer;
PkgInx : integer;
Node : PPkgNode;
NodeMgr : TAbNodeManager;
begin
{calculate the number of weights}
WeightCount := succ(high(aWeights));
{check for dumb programming errors}
Assert((0 < aMaxCodeLen) and (aMaxCodeLen <= 15),
'GenerateCodeLengths: the maximum code length should be in the range 1..15');
Assert((1 <= WeightCount) and (WeightCount <= 286),
'GenerateCodeLengths: the weight array must have 1..286 elements');
Assert(IsCalcFeasible(WeightCount, aMaxCodeLen),
'GenerateCodeLengths: the package-merge algorithm should always be feasible');
{clear the code lengths array}
FillChar(aCodeLengths[aStartInx], WeightCount * sizeof(integer), 0);
{prepare for the try..finally}
OrigList := nil;
MergeList := nil;
PkgList := nil;
NodeMgr := nil;
try
{create the node manager}
NodeMgr := TAbNodeManager.Create(sizeof(TPkgNode));
{create the original list of nodes}
GetMem(OrigList, WeightCount * sizeof(PPkgNode));
OrigListCount := 0;
for i := 0 to pred(WeightCount) do
if (aWeights[i] <> 0) then begin
Node := NodeMgr.AllocNode;
Node^.pnLeft := nil; { this will indicate a leaf}
Node^.pnRight := pointer(i); { the index of the weight}
Node^.pnWeight := aWeights[i]; { the weight itself}
Node^.pnCount := 1; { how many times used}
OrigList^[OrigListCount] := Node;
inc(OrigListCount);
end;
{we need at least 2 items, so make anything less a special case}
if (OrigListCount <= 1) then begin
{if there are no items at all in the original list, we need to
pretend that there is one, since we shall eventually need to
calculate a Count-1 value that cannot be negative}
if (OrigListCount = 0) then begin
aCodeLengths[aStartInx] := 1;
Exit;
end;
{otherwise there is only one item: set its code length directly}
for i := 0 to pred(WeightCount) do
if (aWeights[i] <> 0) then begin
aCodeLengths[aStartInx + i] := 1;
Exit;
end;
end;
{there are at least 2 items in the list; so sort the list}
SortList(OrigList, OrigListCount);
{create the merge and package lists}
GetMem(MergeList, OrigListCount * 2 * sizeof(PPkgNode));
GetMem(PkgList, OrigListCount * 2 * sizeof(PPkgNode));
{initialize the merge list to have the same items as the
original list}
Move(OrigList^, MergeList^, OrigListCount * sizeof(PPkgNode));
MergeListCount := OrigListCount;
{do aMaxCodeLen - 2 times...}
for Bit := 1 to pred(aMaxCodeLen) do begin
{generate the package list from the merge list by grouping pairs
from the merge list and adding them to the package list}
PkgListCount := 0;
for i := 0 to pred(MergeListCount div 2) do begin
Node := NodeMgr.AllocNode;
Node^.pnLeft := MergeList^[i * 2];
Node^.pnRight := MergeList^[i * 2 + 1];
Node^.pnWeight := Node^.pnLeft^.pnWeight +
Node^.pnRight^.pnWeight;
{$IFOPT C+}
Node^.pnCount := 0;
{$ENDIF}
PkgList^[PkgListCount] := Node;
inc(PkgListCount);
end;
{merge the original list and the package list}
MergeListCount := 0;
OrigInx := 0;
PkgInx := 0;
{note the optimization here: the package list will *always* be
last to empty in the merge process since it will have at least
one item whose accumulated weight is greater than all of the
items in the original list}
while (OrigInx < OrigListCount) and (PkgInx < PkgListCount) do begin
if (OrigList^[OrigInx]^.pnWeight <= PkgList^[PkgInx]^.pnWeight) then begin
MergeList^[MergeListCount] := OrigList^[OrigInx];
inc(OrigInx);
end
else begin
MergeList^[MergeListCount] := PkgList^[PkgInx];
inc(PkgInx);
end;
inc(MergeListCount);
end;
if (OrigInx < OrigListCount) then begin
Move(OrigList^[OrigInx], MergeList^[MergeListCount],
(OrigListCount - OrigInx) * sizeof(PPkgNode));
inc(MergeListCount, (OrigListCount - OrigInx));
end
else begin
Move(PkgList^[PkgInx], MergeList^[MergeListCount],
(PkgListCount - PkgInx) * sizeof(PPkgNode));
inc(MergeListCount, (PkgListCount - PkgInx));
end;
end;
{calculate the code lengths}
for i := 0 to (OrigListCount * 2) - 3 do begin
Node := MergeList^[i];
if (Node^.pnLeft <> nil) then
Accumulate(Node);
end;
for i := 0 to pred(OrigListCount) do
aCodeLengths[aStartInx + integer(OrigList^[i].pnRight)] :=
OrigList^[i].pnCount;
finally
FreeMem(OrigList);
FreeMem(MergeList);
FreeMem(PkgList);
NodeMgr.Free;
end;
end;
{====================================================================}
end.

1520
plugins/wcx/zip/src/fparchive/abdfstrm.pas
View file

File diff suppressed because it is too large Load diff

194
plugins/wcx/zip/src/fparchive/abdfxlat.pas
View file

@ -1,194 +0,0 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Abbrevia
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1997-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbDfXlat.pas *}
{*********************************************************}
{* Deflate length/dist to symbol translator *}
{*********************************************************}
unit AbDfXlat;
{$I AbDefine.inc}
interface
uses
SysUtils;
type
TAbDfTranslator = class
private
FBuffer : PAnsiChar;
FLenSymbols : PByteArray;
{for lengths 3..258}
FLongDistSymbols : PByteArray;
{for distances 32769..65536 (deflate64)}
FMediumDistSymbols : PByteArray;
{for distances 257..32768}
FShortDistSymbols : PByteArray;
{for distances 1..256}
protected
procedure trBuild;
public
constructor Create;
destructor Destroy; override;
function TranslateLength(aLen : integer): integer;
function TranslateDistance(aDist : integer) : integer;
property LenSymbols : PByteArray read FLenSymbols;
property LongDistSymbols : PByteArray read FLongDistSymbols;
property MediumDistSymbols : PByteArray read FMediumDistSymbols;
property ShortDistSymbols : PByteArray read FShortDistSymbols;
end;
var
AbSymbolTranslator : TAbDfTranslator;
implementation
uses
AbDfBase;
{====================================================================}
constructor TAbDfTranslator.Create;
begin
{create the ancestor}
inherited Create;
{allocate the translation arrays (the buffer *must* be zeroed)}
FBuffer := AllocMem(256 + 2 + 256 + 256);
FLenSymbols := PByteArray(FBuffer);
FLongDistSymbols := PByteArray(FBuffer + 256);
FMediumDistSymbols := PByteArray(FBuffer + 256 + 2);
FShortDistSymbols := PByteArray(FBuffer + 256 + 2 + 256);
{build the translation arrays}
trBuild;
end;
{--------}
destructor TAbDfTranslator.Destroy;
begin
if (FBuffer <> nil) then
FreeMem(FBuffer);
inherited Destroy;
end;
{--------}
function TAbDfTranslator.TranslateDistance(aDist : integer) : integer;
begin
{save against dumb programming mistakes}
Assert((1 <= aDist) and (aDist <= 65536),
'TAbDfTranslator.Translate: distance should be 1..65536');
{translate the distance}
if (aDist <= 256) then
Result := FShortDistSymbols[aDist - 1]
else if (aDist <= 32768) then
Result := FMediumDistSymbols[((aDist - 1) div 128) - 2]
else
Result := FLongDistSymbols[((aDist - 1) div 16384) - 2];
end;
{--------}
function TAbDfTranslator.TranslateLength(aLen : integer): integer;
begin
{save against dumb programming mistakes}
Assert((3 <= aLen) and (aLen <= 65536),
'TAbDfTranslator.Translate: length should be 3..65536');
{translate the length}
dec(aLen, 3);
if (0 <= aLen) and (aLen <= 255) then
Result := FLenSymbols[aLen] + 257
else
Result := 285;
end;
{--------}
procedure TAbDfTranslator.trBuild;
var
i : integer;
Len : integer;
Dist : integer;
Value : integer;
begin
{initialize the length translation array; elements will contain
(Symbol - 257) for a given (length - 3)}
for i := low(dfc_LengthBase) to pred(high(dfc_LengthBase)) do begin
Len := dfc_LengthBase[i] - 3;
FLenSymbols[Len] := i;
end;
FLenSymbols[255] := 285 - 257;
Value := -1;
for i := 0 to 255 do begin
if (Value < FLenSymbols[i]) then
Value := FLenSymbols[i]
else
FLenSymbols[i] := Value;
end;
{initialize the short distance translation array: it will contain
the Symbol for a given (distance - 1) where distance <= 256}
for i := 0 to 15 do begin
Dist := dfc_DistanceBase[i] - 1;
FShortDistSymbols[Dist] := i;
end;
Value := -1;
for i := 0 to 255 do begin
if (Value < FShortDistSymbols[i]) then
Value := FShortDistSymbols[i]
else
FShortDistSymbols[i] := Value;
end;
{initialize the medium distance translation array: it will contain
the Symbol for a given (((distance - 1) div 128) - 2) where
distance is in the range 256..32768}
for i := 16 to 29 do begin
Dist := ((dfc_DistanceBase[i] - 1) div 128) - 2;
FMediumDistSymbols[Dist] := i;
end;
Value := -1;
for i := 0 to 255 do begin
if (Value < FMediumDistSymbols[i]) then
Value := FMediumDistSymbols[i]
else
FMediumDistSymbols[i] := Value;
end;
{initialize the long distance translation array: it will contain the
Symbol for a given ((distance - 1) div 16384) - 2) for distances
over 32768 in deflate64}
FLongDistSymbols[0] := 30;
FLongDistSymbols[1] := 31;
end;
{====================================================================}
initialization
AbSymbolTranslator := TAbDfTranslator.Create;
finalization
AbSymbolTranslator.Free;
end.