gifdecl.pas

Delphi direct support for GIF files

  Pixel: Byte;
  TryIndex: Integer;
begin { TCodeTable.IsInTable }
  if PrevFoundIndex < FirstSlot
  then TryIndex := FirstSlot
  else TryIndex := PrevFoundIndex + 1;
  Pixel := PixelString.LastByte;
  Found := False;
  while not Found
        and (TryIndex < NextSlot)
  do begin
    Found := (Prefix[TryIndex] = PrevFoundIndex) and
             (Suffix[TryIndex] = Pixel);
    Inc(TryIndex)
  end;
  if Found
  then begin
    Dec(TryIndex);
    PrevFoundIndex := TryIndex;
    FoundIndex := TryIndex;
  end;
  Result := Found;
end;  { TCodeTable.IsInTable }

(***** end of methods of TCodeTable *****)
(***** TExtension and TExtensionList *****)

destructor TExtension.Destroy;
begin { TExtension.Destroy }
  case ExtRec.ExtensionType of
    etPTE:  ExtRec.PTE.PlainTextData.Free;
    etAPPE: ExtRec.APPE.AppData.Free;
    etCE:   ExtRec.Comment.Free;
  end;
  inherited Destroy;
end;  { TExtension.Destroy }

destructor TExtensionList.Destroy;
var
  ExtNo: Integer;
  Ext: TExtension;
begin { TExtensionList.Destroy }
  for ExtNo := Count downto 1
  do begin
    Ext := Self[ExtNo-1];
    Remove(Ext);
    Ext.Free;
  end;
  inherited Destroy;
end;  { TExtensionList.Destroy }

(***** end of TExtension and TExtensionList *****)
(***** methods of TByteBuffer *****)

constructor TByteBuffer.Create;
begin { TByteBuffer.Create }
  inherited Create;
  SL := TStringlist.Create;
  CurrString := '';
  CurrLength := 0;
  FTotalSize := 0;
end;  { TByteBuffer.Create }

destructor TByteBuffer.Destroy;
begin { TByteBuffer.Destroy }
  SL.Free;
  inherited Destroy;
end;  { TByteBuffer.Destroy }

procedure TByteBuffer.AddByte(ByteVal: Byte);
begin { TByteBuffer.AddByte }
  if CurrLength = 255
  then begin
    SL.Add(CurrString);
    CurrString := '';
    CurrLength := 0;
  end;
  CurrString := CurrString + Chr(ByteVal);
  Inc(CurrLength);
  Inc(FTotalSize);
end;  { TByteBuffer.AddByte }

procedure TByteBuffer.AddString(NewString: String);
begin { TByteBuffer.AddString }
  SL.Add(NewString);
  FTotalSize := FTotalSize + Length(NewString);
end;  { TByteBuffer.AddString }

procedure TByteBuffer.Clear;
begin { TByteBuffer.Clear }
  SL.Free;
  SL := TStringlist.Create;
  CurrString := '';
  CurrLength := 0;
  FTotalSize := 0;
end;  { TByteBuffer.Clear }

procedure TByteBuffer.DeleteLastByte;
begin { TByteBuffer.DeleteLastByte }
  if CurrLength = 0
  then begin
    CurrString := SL[SL.Count-1];
    SL.Delete(SL.Count-1);
    CurrLength := Length(CurrString);
  end;
  System.Delete(CurrString, CurrLength, 1);
  Dec(CurrLength);
  Dec(FTotalSize);
end;  { TByteBuffer.DeleteLastByte }

procedure TByteBuffer.Finish;
begin { TByteBuffer.AddString }
  SL.Add(CurrString);
end;  { TByteBuffer.AddString }

function TByteBuffer.FirstByte: Byte;
var FirstString: String;
begin { TByteBuffer.FirstByte }
  if SL.Count = 0
  then FirstString := CurrString
  else FirstString := SL[SL.Count-1];
  Result := Ord(FirstString[1]);
end;  { TByteBuffer.FirstByte }

function TByteBuffer.GetString(Index: Longint): String;
begin { TByteBuffer.GetString }
  Result := SL[Index-1];
end;  { TByteBuffer.GetString }

function TByteBuffer.GetNextByte: Byte;
begin { TByteBuffer.GetNextByte }
  if NextByte > Length(CurrString)
  then begin
    Inc(CurrStringNo);
    CurrString := Strings[CurrStringNo];
    NextByte := 1;
  end;
  Result := Ord(CurrString[NextByte]);
  Inc(NextByte);
end;  { TByteBuffer.GetNextByte }

function TByteBuffer.LastByte: Byte;
begin { TByteBuffer.LastByte }
  Result := Ord(CurrString[Length(CurrString)]);
end;  { TByteBuffer.LastByte }

procedure TByteBuffer.Reset;
begin { TByteBuffer.Reset }
  CurrStringNo := 1;
  CurrString := Strings[1];
  NextByte := 1;
end;  { TByteBuffer.Reset }

function TByteBuffer.StringCount: Integer;
begin { TByteBuffer.StringCount }
  Result := SL.Count;
end;  { TByteBuffer.StringCount }

(***** methods of TEncodedBytes *****)

constructor TEncodedBytes.Create;
begin { TEncodedBytes.Create }
  inherited Create;
  CurrentByte := 0;
  UsedBits := 0;
  Value := TByteBuffer.Create;
end;  { TEncodedBytes.Create }

procedure TEncodedBytes.AppendCode(CodeValue, CodeSize: Integer);
{ Adds the compression code to the bit stream }
var NewByte: Longint;
begin { TEncodedBytes.AppendCode }
  CurrentByte := CurrentByte + (Longint(CodeValue) shl UsedBits);
  UsedBits := UsedBits+CodeSize;
  while UsedBits >= 8
  do begin
    NewByte := CurrentByte shr 8;
    CurrentByte := CurrentByte and $ff;
    Value.AddByte(CurrentByte);
    CurrentByte := NewByte;
    UsedBits := UsedBits - 8;
  end
end;  { TEncodedBytes.AppendCode }

procedure TEncodedBytes.Finish(EndCode: Word; CodeSize: Byte);
begin { TEncodedBytes.Finish }
  AppendCode(EndCode, CodeSize);
  if UsedBits <> 0
  then Value.AddByte(CurrentByte);
  Value.Finish;
end;  { TEncodedBytes.Finish }

(***** end of methods of TEncodedBytes *****)

function CheckType(Filename: String): TGraphicFileType;
{ Finds out whether the file is a gif or bmp (or unknown) file }
var
  GraphicFile: File;
  Ext, TestStr: String; n: Integer;
begin { CheckType }
  Ext := ExtractFileExt(Filename);
  AssignFile(GraphicFile, Filename);
  Reset(GraphicFile, 1);
  try
    if UpperCase(Ext) = '.BMP'
    then begin
{$ifdef ver80}
      TestStr[0] := Chr(2);
{$else}
      SetLength(TestStr, 2);
{$endif ver80}
      BlockRead(GraphicFile, TestStr[1], 2);
      if UpperCase(TestStr) = 'BM'
      then Result := BMP
      else Result := unknown
    end
    else if UpperCase(Ext) = '.GIF'
    then begin
{$ifdef ver80}
      TestStr[0] := Chr(3);
{$else}
      SetLength(TestStr, 3);
{$endif ver80}
      BlockRead(GraphicFile, TestStr[1], 3, n);
      if UpperCase(TestStr) = 'GIF'
      then Result := GIF
      else Result := unknown
    end
    else Result := unknown;
  finally
    CloseFile(GraphicFile);
  end;
end;  { CheckType }

function NextLineNo(LineNo, ImageHeight: Integer;
                    var InterlacePass: Integer): Integer;
{ Interlace support }
begin { NextLineNo }
  case InterlacePass of
    1: Result := LineNo + 8;
    2: Result := LineNo + 8;
    3: Result := LineNo + 4;
    4: Result := LineNo + 2;
  end;
  if Result >= ImageHeight then
  begin
    Inc(InterLacePass);
    case InterLacePass of
      2: Result := 4;
      3: Result := 2;
      4: Result := 1;
    end;
  end;
end; { NextLineNo }

end. { Unit GifDecl }