abdfbase.pas

Lazarus is a free and open source development tool for the FreePascal Compiler. The purpose of the p

        begin
          FZipOption := aValue;
          FOptions := FOptions or $07; { no lazy matching}
          FAmpleLength := 4;
          FChainLength := 4;
          FMaxLazy := 4;
        end;
      'x' : {maximum compression}
        begin
          FZipOption := aValue;
          FOptions := FOptions or $0F;
          FAmpleLength := 64;{32;}
          FChainLength := 4096;
          FMaxLazy := 258;
        end;
    end;
  end;
end;
{====================================================================}


{===TAbLogger========================================================}
const
  LogBufferSize = 4096;
{--------}
constructor TAbLogger.Create(const aLogName : string);
begin
  Assert(aLogName <> '',
         'TAbLogger.Create: a filename must be provided for the logger');

  {create the ancestor}
  inherited Create;

  {set the default line terminator}
  {$IFDEF MSWINDOWS}
  FLineDelim := ldCRLF;
  {$ENDIF}
  {$IFDEF Linux}
  FLineDelim := ldLF;
  {$ENDIF}

  {create and initialize the buffer}
  GetMem(FBuffer, LogBufferSize);
  FCurPos := FBuffer;

  {create the log file}
  FStream := TFileStream.Create(aLogName, fmCreate);
end;
{--------}
destructor TAbLogger.Destroy;
begin
  {if there is a buffer ensure that it is flushed before freeing it}
  if (FBuffer <> nil) then begin
    if (FCurPos <> FBuffer) then
      logWriteBuffer;
    FreeMem(FBuffer, LogBufferSize);
  end;

  {free the stream}
  FStream.Free;

  {destroy the ancestor}
  inherited Destroy;
end;
{--------}
function TAbLogger.logWriteBuffer : boolean;
var
  BytesToWrite : longint;
  BytesWritten : longint;
begin
  BytesToWrite := FCurPos - FBuffer;
  BytesWritten := FStream.Write(FBuffer^, BytesToWrite);
  if (BytesWritten = BytesToWrite) then begin
    Result := true;
    FCurPos := FBuffer;
  end
  else begin
    Result := false;
    if (BytesWritten <> 0) then begin
      Move(FBuffer[BytesWritten], FBuffer^, BytesToWrite - BytesWritten);
      FCurPos := FBuffer + (BytesToWrite - BytesWritten);
    end;
  end;
end;
{--------}
function TAbLogger.Read(var Buffer; Count : longint) : longint;
begin
  Assert(false, 'TAbLogger.Read: loggers are write-only, no reading allowed');
  Result := 0;
end;
{--------}
function TAbLogger.Seek(Offset : longint; Origin : word) : longint;
begin
  case Origin of
    soFromBeginning :
      begin
      end;
    soFromCurrent :
      if (Offset = 0) then begin
        Result := FStream.Position + (FCurPos - FBuffer);
        Exit;
      end;
    soFromEnd :
      if (Offset = 0) then begin
        Result := FStream.Position + (FCurPos - FBuffer);
        Exit;
      end;
  end;

  Assert(false, 'TAbLogger.Seek: loggers are write-only, no seeking allowed');
  Result := 0;
end;
{--------}
function TAbLogger.Write(const Buffer; Count : longint) : longint;
var
  UserBuf      : PAnsiChar;
  BytesToGo    : longint;
  BytesToWrite : longint;
begin
  {reference the user's buffer as a PChar}
  UserBuf := @Buffer;

  {start the counter for the number of bytes written}
  Result := 0;

  {if needed, empty the internal buffer into the underlying stream}
  if (LogBufferSize = FCurPos - FBuffer) then
    if not logWriteBuffer then
      Exit;

  {calculate the number of bytes to copy this time from the user's
   buffer to the internal buffer}
  BytesToGo := Count;
  BytesToWrite := LogBufferSize - (FCurPos - FBuffer);
  if (BytesToWrite > BytesToGo) then
    BytesToWrite := BytesToGo;

  {copy the bytes}
  Move(UserBuf^, FCurPos^, BytesToWrite);

  {adjust the counters}
  inc(FCurPos, BytesToWrite);
  dec(BytesToGo, BytesToWrite);
  inc(Result, BytesToWrite);

  {while there are still more bytes to copy, do so}
  while (BytesToGo <> 0) do begin
    {advance the user's buffer}
    inc(UserBuf, BytesToWrite);

    {empty the internal buffer into the underlying stream}
    if not logWriteBuffer then
      Exit;

    {calculate the number of bytes to copy this time from the user's
     buffer to the internal buffer}
    BytesToWrite := LogBufferSize;
    if (BytesToWrite > BytesToGo) then
      BytesToWrite := BytesToGo;

    {copy the bytes}
    Move(UserBuf^, FCurPos^, BytesToWrite);

    {adjust the counters}
    inc(FCurPos, BytesToWrite);
    dec(BytesToGo, BytesToWrite);
    inc(Result, BytesToWrite);
  end;
end;
{--------}
procedure TAbLogger.WriteLine(const S : string);
const
  cLF : AnsiChar = ^J;
  cCRLF : array [0..1] of AnsiChar = ^M^J;
begin
  if (length(S) > 0) then
    Write(S[1], length(S));
  case FLineDelim of
    ldLF   : Write(cLF, sizeof(cLF));
    ldCRLF : Write(cCRLF, sizeof(cCRLF));
  end;
end;
{--------}
procedure TAbLogger.WriteStr(const S : string);
begin
  if (length(S) > 0) then
    Write(S[1], length(S));
end;
{====================================================================}


{===Calculate checksums==============================================}
procedure AbUpdateAdlerBuffer(var aAdler : longint;
                              var aBuffer; aCount : integer);
var
  S1 : DblWord;
  S2 : DblWord;
  i  : integer;
  Buffer     : PAnsiChar;
  BytesToUse : integer;
begin
  {Note: this algorithm will *only* work if the buffer is 4KB or less,
         which is why we go to such lengths to chop up the user buffer
         into usable chunks of 4KB.

         However, for Delphi 3 there is no proper 32-bit longword.
         Although the additions pose no problems in this situation,
         the mod operations below (especially for S2) will be signed
         integer divisions, producing an (invalid) signed result. In
         this case, the buffer is chopped up into 2KB chunks to avoid
         any signed problems.}

  {split the current Adler checksum into its halves}
  S1 := DblWord(aAdler) and $FFFF;
  S2 := DblWord(aAdler) shr 16;

  {reference the user buffer as a PChar: it makes it easier}
  Buffer := @aBuffer;

  {while there's still data to checksum...}
  while (aCount <> 0) do begin

    {calculate the number of bytes to checksum this time}
    {$IFDEF HasLongWord}
    BytesToUse := 4096;
    {$ELSE}
    BytesToUse := 2048;
    {$ENDIF}
    if (BytesToUse > aCount) then
      BytesToUse := aCount;

    {checksum the bytes}
    for i := 0 to pred(BytesToUse) do begin
      inc(S1, ord(Buffer^));
      inc(S2, S1);
      inc(Buffer);
    end;

    {recalibrate the Adler checksum halves}
    S1 := S1 mod 65521;
    S2 := S2 mod 65521;

    {calculate the number of bytes still to go}
    dec(aCount, BytesToUse);
  end;

  {join the halves to produce the complete Adler checksum}
  aAdler := longint((S2 shl 16) or S1);
end;
{--------}
procedure AbUpdateCRCBuffer(var aCRC : longint;
                            var aBuffer; aCount : integer);
var
  i      : integer;
  CRC    : DblWord;
  Buffer : PAnsiChar;
begin
{$R-}{$Q-}
  {reference the user buffer as a PChar: it makes it easier}
  Buffer := @aBuffer;

  {get the current CRC as a local variable, it's faster}
  CRC := aCRC;

  {checksum the bytes in the buffer}
  for i := 0 to pred(aCount) do begin
    CRC := AbCrc32Table[byte(CRC) xor byte(Buffer^)] xor (CRC shr 8);
    inc(Buffer);
  end;

  {return the new CRC}
  aCRC := CRC;
{$R+}{$Q+}
end;
{====================================================================}


{===EAbInflateError==================================================}
constructor EAbInflateError.Create(const aMsg : string);
begin
  inherited Create(
     'Abbrevia inflate error, possibly a corrupted compressed stream. ' +
     '(Internal cause: ' + aMsg + ')');
end;
{--------}
constructor EAbInflateError.CreateUnknown(const aMsg : string;
                                          const aErrorMsg : string);
begin
  inherited Create(aMsg + ': ' + aErrorMsg);
end;
{====================================================================}


{===EAbDeflateError==================================================}
constructor EAbDeflateError.Create(const aMsg : string);
begin
  inherited Create(
     'Abbrevia deflate error. ' +
     '(Internal cause: ' + aMsg + ')');
end;
{--------}
constructor EAbDeflateError.CreateUnknown(const aMsg : string;
                                          const aErrorMsg : string);
begin
  inherited Create(aMsg + ': ' + aErrorMsg);
end;
{====================================================================}


{===Node manager=====================================================}
const
  PageSize = 8 * 1024;
type
  PGenericNode = ^TGenericNode;
  TGenericNode = packed record
    gnNext : PGenericNode;
    gnData : record end;
  end;
{--------}
constructor TAbNodeManager.Create(aNodeSize : cardinal);
const
  Gran = sizeof(pointer);
  Mask = not (Gran - 1);
begin
  {create the ancestor}
  inherited Create;

  {save the node size rounded to nearest 4 bytes}
  if (aNodeSize <= sizeof(pointer)) then
    aNodeSize := sizeof(pointer)
  else
    aNodeSize := (aNodeSize + Gran - 1) and Mask;
  FNodeSize := aNodeSize;

  {calculate the page size (default 1024 bytes) and the number of
   nodes per page; if the default page size is not large enough for
   two or more nodes, force a single node per page}
  FNodesPerPage := (PageSize - sizeof(pointer)) div aNodeSize;
  if (FNodesPerPage > 1) then
    FPageSize := PageSize
  else begin
    FNodesPerPage := 1;
    FPagesize := aNodeSize + sizeof(pointer);
  end;
end;
{--------}
destructor TAbNodeManager.Destroy;
var
  Temp : pointer;
begin
  {dispose of all the pages, if there are any}
  while (FPageHead <> nil) do begin
    Temp := PGenericNode(FPageHead)^.gnNext;
    FreeMem(FPageHead, FPageSize);
    FPageHead := Temp;
  end;

  {destroy the ancestor}
  inherited Destroy;
end;
{--------}
function TAbNodeManager.AllocNode : pointer;
begin
  Result := FFreeList;
  if (Result = nil) then
    Result := nmAllocNewPage
  else
    FFreeList := PGenericNode(Result)^.gnNext;
end;
{--------}
function TAbNodeManager.AllocNodeClear : pointer;
begin
  Result := FFreeList;
  if (Result = nil) then
    Result := nmAllocNewPage
  else
    FFreeList := PGenericNode(Result)^.gnNext;
  FillChar(Result^, FNodeSize, 0);
end;
{--------}
procedure TAbNodeManager.FreeNode(aNode : pointer);
begin
  {add the node (if non-nil) to the top of the free list}
  if (aNode <> nil) then begin
    PGenericNode(aNode)^.gnNext := FFreeList;
    FFreeList := aNode;
  end;
end;
{--------}
function TAbNodeManager.nmAllocNewPage : pointer;
var
  NewPage  : PAnsiChar;
  i        : integer;
  FreeList : pointer;
  NodeSize : integer;
begin
  {allocate a new page and add it to the front of the page list}
  GetMem(NewPage, FPageSize);
  PGenericNode(NewPage)^.gnNext := FPageHead;
  FPageHead := NewPage;

  {now split up the new page into nodes and push them all onto the
   free list; note that the first 4 bytes of the page is a pointer to
   the next page, so remember to skip over it}
  inc(NewPage, sizeof(pointer));
  FreeList := FFreeList;
  NodeSize := FNodeSize;
  for i := 0 to pred(FNodesPerPage) do begin
    PGenericNode(NewPage)^.gnNext := FreeList;
    FreeList := NewPage;
    inc(NewPage, NodeSize);
  end;

  {return the top of the list}
  Result := FreeList;
  FFreeList := PGenericNode(Result)^.gnNext;
end;
{====================================================================}


{====================================================================}
procedure AbortProgress;
begin
  raise EAbAbortProgress.Create('Abort');
end;
{====================================================================}

end.