gifunit.pas

Delphi direct support for GIF files

end;  { TGifFile.Create }

destructor TGifFile.Destroy;
var
  SubImageNo: Integer;
  SubImage: TGifSubImage;
begin { TGifFile.Destroy }
  GlobalColormap.Free;
  for SubImageNo := 1 to SubImages.Count
  do begin
    SubImage := SubImages[SubImageNo-1];
    SubImage.Free;
  end;
  SubImages.Free;
  inherited Destroy;
end;  { TGifFile.Destroy }

(***** end of constructor and destructor *****)
(***** property access methods *****)

(*function TGifFile.GetBGColor: TColor;
var BGCI: Byte;
begin { TGifFile.GetBGColor }
  BGCI := ScreenDescriptor.BackGroundColorIndex;
  Result := GlobalColorMap.GetColor(BGCI);
end;  { TGifFile.GetBGColor }*)

(***** end of property access methods *****)

procedure TGifFile.AddBitmap(Bitmap: TBitmap);
var NewSubImage: TGifSubImage;
begin { TGifFile.AddBitmap }
  NewSubImage := TGifSubImage.CreateEmpty;
  NewSubImage.FBitmap := Bitmap;
  SubImages.Add(NewSubImage);
end;  { TGifFile.AddBitmap }

(*function TGifFile.AnimateInterval: Word;
var SubImage: TGifSubImage;
    SubImageNo: Integer;
    Interval: Word;
begin { TGifFile.AnimateInterval }
  if SubImages.Count < 2
  then Result := 0
  else begin
    Result := 0;
    for SubImageNo := 1 to SubImages.Count
    do begin
      SubImage := SubImages[SubImageNo-1];
      Interval := SubImage.AnimateInterval;
{$ifdef debug}
      if Interval = 0
      then WarningMessage('Multiple subimages; no animation time interval found');
      if (Result <> 0) and (Result <> Interval)
      then WarningMessage('Multiple subimages; animation time intervals not equal');;
{$endif debug}
      if Interval <> 0
      then Result := Interval
    end;
  end;
end;  { TGifFile.AnimateInterval }*)

function TGifFile.AsBitmap: TBitmap;
var Stream: TMemoryStream;
begin { TGifFile.AsBitmap }
  Stream := TMemoryStream.Create;
  try
    TGifSubImage(Self.SubImages[0]).SaveToStream(Stream);
    Result := TBitmap.Create;
    Result.LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;  { TGifFile.AsBitmap }

function TGifFile.GetSubImage(Index: Integer): TGifSubImage;
begin
  Result := SubImages[Index-1]
end;  { TGifFile.GetSubImage }

(***** Read routines *****)

procedure TGifFile.ReadSignature(Stream: TStream);
begin { TGifFile.ReadSignature }
  Stream.Read(Header, SizeOf(TGifHeader));
  if (Header.Version <> '87a') and (Header.Version <> '89a') and
     (Header.Version <> '87A') and (Header.Version <> '89A')
  then raise EGifException.Create('Gif Version must be 87a or 89a');
end;  { TGifFile.ReadSignature }

procedure TGifFile.DecodeStatusByte;
var
  ColorResolutionBits: Byte;
begin { TGifFile.DecodeStatusByte }
  HasGlobalColorMap := (ScreenDescriptor.PackedFields and lsdGlobalColorTable) = lsdGlobalColorTable;  { M=1 }
  ColorResolutionbits := 1 + (ScreenDescriptor.PackedFields and lsdColorResolution) shr 4;
  {GlobalColorMap.Count := 1 shl ColorResolutionbits;}
  BitsPerPixel := 1 + ScreenDescriptor.PackedFields and $07;
  GlobalColorMap.Count := 1 shl BitsPerPixel;
end;  { TGifFile.DecodeStatusByte }

procedure TGifFile.ReadScreenDescriptor(Stream: TStream);
begin { TGifFile.ReadScreenDescriptor }
  Stream.Read(ScreenDescriptor, SizeOf(ScreenDescriptor));
  DecodeStatusByte;
end;  { TGifFile.ReadScreenDescriptor }

procedure TGifFile.ReadGlobalColorMap(Stream: TStream);
begin { TGifFile.ReadGlobalColorMap }
  if HasGlobalColorMap
  then
    with GlobalColorMap
    do Stream.Read(CT.Colors[0], Count*SizeOf(TColorItem));
end;  { TGifFile.ReadGlobalColorMap }

procedure TGifFile.ReadExtensionBlocks(Stream: TStream;
                                       var SeparatorChar: Char;
                                       var Extensions: TExtensionList);
{ The '!' has already been read before calling }

  procedure ReadDataBlocks(Stream: TStream; var Data: TStringList);
  { data not yet stored }
  var
    BlockSize: Byte;
    NewString: String;
  begin { ReadDataBlocks }
    Data := TStringlist.Create;
    repeat
      Stream.Read(BlockSize, 1);
      if BlockSize <> 0
      then begin
    {$ifdef ver80}
        NewString[0] := Chr(BlockSize);
    {$else}
        SetLength(NewString, BlockSize);
    {$endif ver80}
        Stream.Read(NewString[1], BlockSize);
        Data.Add(NewString);
      end;
    until BlockSize = 0;
  end;  { ReadDataBlocks }

var
  NewExtension: GifDecl.TExtension;
  ExtensionLabel: Byte;
begin { TGifFile.ReadExtensionBlocks }
  Extensions := TExtensionList.Create;
  while SeparatorChar = '!'
  do begin
    NewExtension := GifDecl.TExtension.Create;
    Extensions.Add(NewExtension);
    Stream.Read(ExtensionLabel, 1);
    with NewExtension.ExtRec do
    case ExtensionLabel of
      $F9: ExtensionType := etGCE;  { graphic control extension }
      $FE: ExtensionType := etCE;   { comment extension }
      $01: ExtensionType := etPTE;  { plain text extension }
      $FF: ExtensionType := etAPPE; { application extension }
      else raise EGifException.Create('Unrecognized extension block.'+
                 #13+#10 + 'Code = $' + IntToHex(ExtensionLabel, 2));
    end; { case }
    with NewExtension.ExtRec do
    case ExtensionLabel of
      $F9: Stream.Read(GCE, SizeOf(GCE));
      $FE: ReadDataBlocks(Stream, Comment);
      $01: begin
             Stream.Read(PTE, SizeOf(PTE)-SizeOf(PTE.PlainTextData));
             ReadDataBlocks(Stream, PTE.PlainTextData);
           end;
      $FF: begin
             Stream.Read(APPE, SizeOf(APPE)-SizeOf(APPE.AppData));
             ReadDataBlocks(Stream, APPE.AppData);
           end;
    end; { case }
    Stream.Read(SeparatorChar, 1);
  end;
end;  { TGifFile.ReadExtensionBlocks }

procedure TGifFile.LoadFromFile(filename: String);
var
  Stream: TMemoryStream;
begin { TGifFile.LoadFromFile }
  Stream := TMemoryStream.Create;
  try
    Stream.LoadFromFile(filename);
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;  { TGifFile.LoadFromFile }

procedure TGifFile.LoadFromStream(Stream: TStream);
var
  SeparatorChar: Char;
  NewSubImage: TGifSubimage;
  Extensions: TExtensionList;
  OldStreamPosition: Longint;
begin { TGifFile.LoadFromStream }
  Screen.Cursor := crHourGlass;
  try
    Stream.Position := 0;
    OldStreamPosition := 0;
    ReadSignature(Stream);
    ReadScreenDescriptor(Stream);
    ReadGlobalColorMap(Stream);
    Stream.Read(SeparatorChar, 1);
    while (SeparatorChar <> ';') and not (Stream.Position >= Stream.Size)
          and not (Stream.Position = OldStreamPosition)
    do begin
      OldStreamPosition := Stream.Position;
      ReadExtensionBlocks(Stream, SeparatorChar, Extensions);
      if SeparatorChar = ','
      then begin
        NewSubImage := TGifSubImage.Create(GlobalColormap.Count, Self);
        NewSubImage.Extensions.Free;
        NewSubImage.Extensions := Extensions;
        NewSubImage.LoadFromStream(Stream);
        SubImages.Add(NewSubImage);
        if not (Stream.Position >= Stream.Size)
        then Stream.Read(SeparatorChar, 1)
        else SeparatorChar := ';'
      end
      else Extensions.Free;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;  { TGifFile.LoadFromStream }

(***** write routines *****)

procedure TGifFile.EncodeGifFile;
{ Encodes the subimages which are (all) not yet encoded (just stored as
  bitmaps) }
var
  SubImage: TGifSubImage;
  Colormap: TColorTable;
  Pixels: TByteArray2D;
  SubImageNo: Integer;
begin { TGifFile.EncodeGifFile }
  for SubImageNo := 1 to SubImages.Count
  do begin
    SubImage := SubImages[SubImageNo-1];
    BitmapToPixelmatrix(SubImage.FBitmap, Colormap, Pixels);
    SubImages.Remove(SubImage);
    SubImage.Free;
    SubImage := TGifSubImage.Create(Colormap.Count, Self);
    SubImages.Add(SubImage);
    if GlobalColormap.Count = 0
    then GlobalColormap := Colormap
    else begin
      SubImage.HasLocalColorMap := True;
      SubImage.LocalColormap := Colormap;
    end;
    UpdateBitsPerPixel(GlobalColormap.Count, BitsPerPixel);
    SubImage.EncodeStatusByte;
    SubImage.Pixels.Free;
    SubImage.Pixels := Pixels;
    SubImage.ImageDescriptor.ImageWidth := Pixels.Count1;
    SubImage.ImageDescriptor.ImageHeight := Pixels.Count2;
    if ScreenDescriptor.ScreenWidth < Pixels.Count1
    then ScreenDescriptor.ScreenWidth := Pixels.Count1;
    if ScreenDescriptor.ScreenHeight < Pixels.Count2
    then ScreenDescriptor.ScreenHeight := Pixels.Count2;
    EncodeStatusByte;
  end;
end;  { TGifFile.EncodeGifFile }

procedure TGifFile.EncodeStatusByte;
var
  ColorResolutionBits: Byte;
begin { TGifFile.EncodeStatusByte }
  with ScreenDescriptor
  do begin
    PackedFields := 0;
    if HasGlobalColorMap
    then PackedFields := PackedFields + lsdGlobalColorTable;
    case GlobalColorMap.Count of
      2: ColorResolutionBits := 1;
      4: ColorResolutionBits := 2;
      8: ColorResolutionBits := 3;
      16: ColorResolutionBits := 4;
      32: ColorResolutionBits := 5;
      64: ColorResolutionBits := 6;
      128: ColorResolutionBits := 7;
      256: ColorResolutionBits := 8;
      else raise EGifException.Create('unexpected number of colors')
    end;
    PackedFields := PackedFields + (ColorResolutionBits-1) shl 4;
    PackedFields := PackedFields + (BitsPerPixel-1);
  end;
end;  { TGifFile.EncodeStatusByte }

procedure TGifFile.WriteSignature(Stream: TStream);
begin { TGifFile.WriteSignature }
  Stream.Write(Header, SizeOf(TGifHeader));
end;  { TGifFile.WriteSignature }

procedure TGifFile.WriteScreenDescriptor(Stream: TStream);
begin { TGifFile.WriteScreenDescriptor }
  EncodeStatusByte;
  Stream.Write(ScreenDescriptor, SizeOf(ScreenDescriptor));
end;  { TGifFile.WriteScreenDescriptor }

procedure TGifFile.WriteGlobalColorMap(Stream: TStream);
begin { TGifFile.WriteGlobalColorMap }
  if HasGlobalColorMap
  then
    with GlobalColorMap
    do Stream.Write(CT.Colors[0], Count*SizeOf(TColorItem))
end;  { TGifFile.WriteGlobalColorMap }

procedure TGifFile.SaveToFile(filename: String);
var
  Stream: TMemoryStream;
begin { TGifFile.SaveToFile }
  Stream := TMemoryStream.Create;
  SaveToStream(Stream);
  Stream.SaveToFile(filename);
  Stream.Free;
end;  { TGifFile.SaveToFile }

procedure TGifFile.SaveToStream(Stream: TStream);
var
  ImageSeparator: Char;
  ImageNo: Integer;
  SubImage: TGifSubimage;
begin { TGifFile.SaveToStream }
  Screen.Cursor := crHourGlass;
  if not Assigned(GetSubImage(1).FGifFile)
  then EncodeGifFile;
  WriteSignature(Stream);
  WriteScreenDescriptor(Stream);
  WriteGlobalColorMap(Stream);
  ImageSeparator := ',';
  for ImageNo := 1 to SubImages.Count
  do begin
    Stream.Write(ImageSeparator, 1);
    SubImage := SubImages[ImageNo-1];
    if SubImage.CompressedRasterData.TotalSize = 0
    then SubImage.EncodeRasterdata;
    SubImage.WriteImageDescriptor(Stream);
    SubImage.WriteLocalColorMap(Stream);
    SubImage.WriteRasterData(Stream);
  end;
  ImageSeparator := ';';
  Stream.Write(ImageSeparator, 1);
  Screen.Cursor := crDefault;
end;  { TGifFile.SaveToStream }

(***** end of methods of TGifFile *****)

(***** TGifBitmap *****)

procedure TGifBitmap.LoadFromStream(Stream: TStream);
{ Reads TGifBitmap from a (GIF) stream; necessary to make
  TPicture.RegisterFileFormat work }
var
  aGif: TGifFile;
  aStream: TMemoryStream;
begin { TGifBitmap.LoadFromStream }
  aGif := TGifFile.Create;
  try
    aGif.LoadFromStream(Stream);
    aStream := TMemoryStream.Create;
    try
      aGif.GetSubImage(1).SaveToStream(aStream);
      inherited LoadFromStream(aStream);
    finally
      aStream.Free;
    end;
  finally
    aGif.Free;
  end;
end;  { TGifBitmap.LoadFromStream }

(***** end of methods of TGifBitmap *****)

initialization
{ Register the TGifBitmap as a new graphic file format;
  now all the TPicture storage stuff can access our new
  GIF graphic format! }
  TPicture.RegisterFileFormat('gif','GIF-Format', TGifBitmap);

{$ifdef ver90}
  FileMode := 0; { now Reset can be used on ReadOnly files }
{$endif ver90}

{$ifndef ver80}
{$ifndef ver90}
finalization
  TPicture.UnRegisterGraphicClass(TGifBitmap);
{$endif ver90}
{$endif ver80}
end. { unit GifUnit }