src/lib/vampimg/ImagingGif.pas

   1 {
   2   Vampyre Imaging Library
   3   by Marek Mauder
   4   http://imaginglib.sourceforge.net
   5
   6   The contents of this file are used with permission, subject to the Mozilla
   7   Public License Version 1.1 (the "License"); you may not use this file except
   8   in compliance with the License. You may obtain a copy of the License at
   9   http://www.mozilla.org/MPL/MPL-1.1.html
  10
  11   Software distributed under the License is distributed on an "AS IS" basis,
  12   WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  13   the specific language governing rights and limitations under the License.
  14
  15   Alternatively, the contents of this file may be used under the terms of the
  16   GNU Lesser General Public License (the  "LGPL License"), in which case the
  17   provisions of the LGPL License are applicable instead of those above.
  18   If you wish to allow use of your version of this file only under the terms
  19   of the LGPL License and not to allow others to use your version of this file
  20   under the MPL, indicate your decision by deleting  the provisions above and
  21   replace  them with the notice and other provisions required by the LGPL
  22   License.  If you do not delete the provisions above, a recipient may use
  23   your version of this file under either the MPL or the LGPL License.
  24
  25   For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  26 }
  27
  28 { This unit contains image format loader/saver for GIF images.}
  29 unit ImagingGif;
  30
  31 {$I ImagingOptions.inc}
  32
  33 interface
  34
  35 uses
  36   SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility;
  37
  38 type
  39   { GIF (Graphics Interchange Format) loader/saver class. GIF was
  40     (and is still used) popular format for storing images supporting
  41     multiple images per file and single color transparency.
  42     Pixel format is 8 bit indexed where each image frame can have
  43     its own color palette. GIF uses lossless LZW compression
  44     (patent expired few years ago).
  45     Imaging can load and save all GIFs with all frames and supports
  46     transparency. Imaging can load just raw ifIndex8 frames or
  47     also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.}
  48   TGIFFileFormat = class(TImageFileFormat)
  49   private
  50     FLoadAnimated: LongBool;
  51     function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
  52     procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle;
  53       Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
  54     procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
  55       Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
  56   protected
  57     procedure Define; override;
  58     function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
  59       OnlyFirstLevel: Boolean): Boolean; override;
  60     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
  61       Index: LongInt): Boolean; override;
  62     procedure ConvertToSupported(var Image: TImageData;
  63       const Info: TImageFormatInfo); override;
  64   public
  65     function TestFormat(Handle: TImagingHandle): Boolean; override;
  66   published
  67     property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
  68   end;
  69
  70 implementation
  71
  72 const
  73   SGIFFormatName = 'Graphics Interchange Format';
  74   SGIFMasks      = '*.gif';
  75   GIFSupportedFormats: TImageFormats = [ifIndex8];
  76   GIFDefaultLoadAnimated = True;
  77
  78 type
  79   TGIFVersion = (gv87, gv89);
  80   TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground,
  81     dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
  82
  83 const
  84   GIFSignature: TChar3 = 'GIF';
  85   GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');
  86   GIFDefaultDelay = 65;
  87
  88   // Masks for accessing fields in PackedFields of TGIFHeader
  89   GIFGlobalColorTable = $80;
  90   GIFColorResolution  = $70;
  91   GIFColorTableSorted = $08;
  92   GIFColorTableSize   = $07;
  93
  94   // Masks for accessing fields in PackedFields of TImageDescriptor
  95   GIFLocalColorTable  = $80;
  96   GIFInterlaced       = $40;
  97   GIFLocalTableSorted = $20;
  98
  99   // Block identifiers
 100   GIFPlainText: Byte               = $01;
 101   GIFGraphicControlExtension: Byte = $F9;
 102   GIFCommentExtension: Byte        = $FE;
 103   GIFApplicationExtension: Byte    = $FF;
 104   GIFImageDescriptor: Byte         = Ord(',');
 105   GIFExtensionIntroducer: Byte     = Ord('!');
 106   GIFTrailer: Byte                 = Ord(';');
 107   GIFBlockTerminator: Byte         = $00;
 108
 109   // Masks for accessing fields in PackedFields of TGraphicControlExtension
 110   GIFTransparent    = $01;
 111   GIFUserInput      = $02;
 112   GIFDisposalMethod = $1C;
 113
 114 const
 115   // Netscape sub block types
 116   GIFAppLoopExtension   = 1;
 117   GIFAppBufferExtension = 2;
 118
 119 type
 120   TGIFHeader = packed record
 121     // File header part
 122     Signature: TChar3;  // Header Signature (always "GIF")
 123     Version: TChar3;    // GIF format version("87a" or "89a")
 124     // Logical Screen Descriptor part
 125     ScreenWidth: Word;  // Width of Display Screen in Pixels
 126     ScreenHeight: Word; // Height of Display Screen in Pixels
 127     PackedFields: Byte; // Screen and color map information
 128     BackgroundColorIndex: Byte; // Background color index (in global color table)
 129     AspectRatio: Byte;  // Pixel aspect ratio, ratio = (AspectRatio + 15) / 64
 130   end;
 131
 132   TImageDescriptor = packed record
 133     //Separator: Byte; // leave that out since we always read one bye ahead
 134     Left: Word;        // X position of image with respect to logical screen
 135     Top: Word;         // Y position
 136     Width: Word;
 137     Height: Word;
 138     PackedFields: Byte;
 139   end;
 140
 141 const
 142   // GIF extension labels
 143   GIFExtTypeGraphic     = $F9;
 144   GIFExtTypePlainText   = $01;
 145   GIFExtTypeApplication = $FF;
 146   GIFExtTypeComment     = $FE;
 147
 148 type
 149   TGraphicControlExtension = packed record
 150     BlockSize: Byte;
 151     PackedFields: Byte;
 152     DelayTime: Word;
 153     TransparentColorIndex: Byte;
 154     Terminator: Byte;
 155   end;
 156
 157 type
 158   TGIFIdentifierCode = array[0..7] of AnsiChar;
 159   TGIFAuthenticationCode = array[0..2] of AnsiChar;
 160   TGIFApplicationRec = packed record
 161     Identifier: TGIFIdentifierCode;
 162     Authentication: TGIFAuthenticationCode;
 163   end;
 164
 165 const
 166   CodeTableSize = 4096;
 167   HashTableSize = 17777;
 168
 169 type
 170   TReadContext = record
 171     Inx: Integer;
 172     Size: Integer;
 173     Buf: array [0..255 + 4] of Byte;
 174     CodeSize: Integer;
 175     ReadMask: Integer;
 176   end;
 177   PReadContext = ^TReadContext;
 178
 179   TWriteContext = record
 180     Inx: Integer;
 181     CodeSize: Integer;
 182     Buf: array [0..255 + 4] of Byte;
 183   end;
 184   PWriteContext = ^TWriteContext;
 185
 186   TOutputContext = record
 187     W: Integer;
 188     H: Integer;
 189     X: Integer;
 190     Y: Integer;
 191     BitsPerPixel: Integer;
 192     Pass: Integer;
 193     Interlace: Boolean;
 194     LineIdent: Integer;
 195     Data: Pointer;
 196     CurrLineData: Pointer;
 197   end;
 198
 199   TImageDict = record
 200     Tail: Word;
 201     Index: Word;
 202     Col: Byte;
 203   end;
 204   PImageDict = ^TImageDict;
 205
 206   PIntCodeTable = ^TIntCodeTable;
 207   TIntCodeTable = array [0..CodeTableSize - 1] of Word;
 208
 209   TDictTable = array [0..CodeTableSize - 1] of TImageDict;
 210   PDictTable = ^TDictTable;
 211
 212 resourcestring
 213   SGIFDecodingError = 'Error when decoding GIF LZW data';
 214
 215 {
 216   TGIFFileFormat implementation
 217 }
 218
 219 procedure TGIFFileFormat.Define;
 220 begin
 221   inherited;
 222   FName := SGIFFormatName;
 223   FFeatures := [ffLoad, ffSave, ffMultiImage];
 224   FSupportedFormats := GIFSupportedFormats;
 225   FLoadAnimated := GIFDefaultLoadAnimated;
 226
 227   AddMasks(SGIFMasks);
 228   RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated);
 229 end;
 230
 231 function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
 232 begin
 233   Result := Y;
 234   case Pass of
 235     0, 1:
 236       Inc(Result, 8);
 237     2:
 238       Inc(Result, 4);
 239     3:
 240       Inc(Result, 2);
 241   end;
 242   if Result >= Height then
 243   begin
 244     if Pass = 0 then
 245     begin
 246       Pass := 1;
 247       Result := 4;
 248       if Result < Height then
 249         Exit;
 250     end;
 251     if Pass = 1 then
 252     begin
 253       Pass := 2;
 254       Result := 2;
 255       if Result < Height then
 256         Exit;
 257     end;
 258     if Pass = 2 then
 259     begin
 260       Pass := 3;
 261       Result := 1;
 262     end;
 263   end;
 264 end;
 265
 266 { GIF LZW decompresion code is from JVCL JvGIF.pas unit.}
 267 procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer;
 268   Interlaced: Boolean; Data: Pointer);
 269 var
 270   MinCodeSize: Byte;
 271   MaxCode, BitMask, InitCodeSize: Integer;
 272   ClearCode, EndingCode, FirstFreeCode, FreeCode: Word;
 273   I, OutCount, Code: Integer;
 274   CurCode, OldCode, InCode, FinalChar: Word;
 275   Prefix, Suffix, OutCode: PIntCodeTable;
 276   ReadCtxt: TReadContext;
 277   OutCtxt: TOutputContext;
 278   TableFull: Boolean;
 279
 280   function ReadCode(var Context: TReadContext): Integer;
 281   var
 282     RawCode: Integer;
 283     ByteIndex: Integer;
 284     Bytes: Byte;
 285     BytesToLose: Integer;
 286   begin
 287     while (Context.Inx + Context.CodeSize > Context.Size) and
 288       (Stream.Position < Stream.Size) do
 289     begin
 290       // Not enough bits in buffer - refill it - Not very efficient, but infrequently called
 291       BytesToLose := Context.Inx shr 3;
 292       // Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes
 293       Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
 294       Context.Inx := Context.Inx and 7;
 295       Context.Size := Context.Size - (BytesToLose shl 3);
 296       Stream.Read(Bytes, 1);
 297       if Bytes > 0 then
 298         Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes);
 299       Context.Size := Context.Size + (Bytes shl 3);
 300     end;
 301     ByteIndex := Context.Inx shr 3;
 302     RawCode := Context.Buf[Word(ByteIndex)] +
 303       (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
 304     if Context.CodeSize > 8 then
 305       RawCode := RawCode + (Integer(Context.Buf[ByteIndex + 2]) shl 16);
 306     RawCode := RawCode shr (Context.Inx and 7);
 307     Context.Inx := Context.Inx + Byte(Context.CodeSize);
 308     Result := RawCode and Context.ReadMask;
 309   end;
 310
 311   procedure Output(Value: Byte; var Context: TOutputContext);
 312   var
 313     P: PByte;
 314   begin
 315     if Context.Y >= Context.H then
 316       Exit;
 317
 318     // Only ifIndex8 supported
 319     P := @PByteArray(Context.CurrLineData)[Context.X];
 320     P^ := Value;
 321
 322     {case Context.BitsPerPixel of
 323       1:
 324         begin
 325           P := @PByteArray(Context.CurrLineData)[Context.X shr 3];
 326           if (Context.X and $07) <> 0 then
 327             P^ := P^ or Word(Value shl (7 - (Word(Context.X and 7))))
 328           else
 329             P^ := Byte(Value shl 7);
 330         end;
 331       4:
 332         begin
 333           P := @PByteArray(Context.CurrLineData)[Context.X shr 1];
 334           if (Context.X and 1) <> 0 then
 335             P^ := P^ or Value
 336           else
 337             P^ := Byte(Value shl 4);
 338         end;
 339       8:
 340         begin
 341           P := @PByteArray(Context.CurrLineData)[Context.X];
 342           P^ := Value;
 343         end;
 344     end;}
 345     Inc(Context.X);
 346
 347     if Context.X < Context.W then
 348       Exit;
 349     Context.X := 0;
 350     if Context.Interlace then
 351       Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass)
 352     else
 353       Inc(Context.Y);
 354
 355     Context.CurrLineData := @PByteArray(Context.Data)[Context.Y * Context.LineIdent];
 356   end;
 357
 358 begin
 359   OutCount := 0;
 360   OldCode := 0;
 361   FinalChar := 0;
 362   TableFull := False;
 363   GetMem(Prefix, SizeOf(TIntCodeTable));
 364   GetMem(Suffix, SizeOf(TIntCodeTable));
 365   GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
 366   try
 367     Stream.Read(MinCodeSize, 1);
 368     if (MinCodeSize < 2) or (MinCodeSize > 9) then
 369       RaiseImaging(SGIFDecodingError, []);
 370     // Initial read context
 371     ReadCtxt.Inx := 0;
 372     ReadCtxt.Size := 0;
 373     ReadCtxt.CodeSize := MinCodeSize + 1;
 374     ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
 375     // Initialise pixel-output context
 376     OutCtxt.X := 0;
 377     OutCtxt.Y := 0;
 378     OutCtxt.Pass := 0;
 379     OutCtxt.W := Width;
 380     OutCtxt.H := Height;
 381     OutCtxt.BitsPerPixel := MinCodeSize;
 382     OutCtxt.Interlace := Interlaced;
 383     OutCtxt.LineIdent := Width;
 384     OutCtxt.Data := Data;
 385     OutCtxt.CurrLineData := Data;
 386     BitMask := (1 shl OutCtxt.BitsPerPixel) - 1;
 387     // 2 ^ MinCodeSize accounts for all colours in file
 388     ClearCode := 1 shl MinCodeSize;
 389     EndingCode := ClearCode + 1;
 390     FreeCode := ClearCode + 2;
 391     FirstFreeCode := FreeCode;
 392     // 2^ (MinCodeSize + 1) includes clear and eoi Code and space too
 393     InitCodeSize := ReadCtxt.CodeSize;
 394     MaxCode := 1 shl ReadCtxt.CodeSize;
 395     Code := ReadCode(ReadCtxt);
 396     while (Code <> EndingCode) and (Code <> $FFFF) and
 397       (OutCtxt.Y < OutCtxt.H) do
 398     begin
 399       if Code = ClearCode then
 400       begin
 401         ReadCtxt.CodeSize := InitCodeSize;
 402         MaxCode := 1 shl ReadCtxt.CodeSize;
 403         ReadCtxt.ReadMask := MaxCode - 1;
 404         FreeCode := FirstFreeCode;
 405         Code := ReadCode(ReadCtxt);
 406         CurCode := Code;
 407         OldCode := Code;
 408         if Code = $FFFF then
 409           Break;
 410         FinalChar := (CurCode and BitMask);
 411         Output(Byte(FinalChar), OutCtxt);
 412         TableFull := False;
 413       end
 414       else
 415       begin
 416         CurCode := Code;
 417         InCode := Code;
 418         if CurCode >= FreeCode then
 419         begin
 420           CurCode := OldCode;
 421           OutCode^[OutCount] := FinalChar;
 422           Inc(OutCount);
 423         end;
 424         while CurCode > BitMask do
 425         begin
 426           if OutCount > CodeTableSize then
 427             RaiseImaging(SGIFDecodingError, []);
 428           OutCode^[OutCount] := Suffix^[CurCode];
 429           Inc(OutCount);
 430           CurCode := Prefix^[CurCode];
 431         end;
 432
 433         FinalChar := CurCode and BitMask;
 434         OutCode^[OutCount] := FinalChar;
 435         Inc(OutCount);
 436         for I := OutCount - 1 downto 0 do
 437           Output(Byte(OutCode^[I]), OutCtxt);
 438         OutCount := 0;
 439         // Update dictionary
 440         if not TableFull then
 441         begin
 442           Prefix^[FreeCode] := OldCode;
 443           Suffix^[FreeCode] := FinalChar;
 444           // Advance to next free slot
 445           Inc(FreeCode);
 446           if FreeCode >= MaxCode then
 447           begin
 448             if ReadCtxt.CodeSize < 12 then
 449             begin
 450               Inc(ReadCtxt.CodeSize);
 451               MaxCode := MaxCode shl 1;
 452               ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
 453             end
 454             else
 455               TableFull := True;
 456           end;
 457         end;
 458         OldCode := InCode;
 459       end;
 460       Code := ReadCode(ReadCtxt);
 461     end;
 462     if Code = $FFFF then
 463       RaiseImaging(SGIFDecodingError, []);
 464   finally
 465     FreeMem(Prefix);
 466     FreeMem(OutCode);
 467     FreeMem(Suffix);
 468   end;
 469 end;
 470
 471 { GIF LZW compresion code is from JVCL JvGIF.pas unit.}
 472 procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer;
 473     Interlaced: Boolean; Data: Pointer);
 474 var
 475   LineIdent: Integer;
 476   MinCodeSize, Col: Byte;
 477   InitCodeSize, X, Y: Integer;
 478   Pass: Integer;
 479   MaxCode: Integer; { 1 shl CodeSize }
 480   ClearCode, EndingCode, LastCode, Tail: Integer;
 481   I, HashValue: Integer;
 482   LenString: Word;
 483   Dict: PDictTable;
 484   HashTable: TList;
 485   PData: PByte;
 486   WriteCtxt: TWriteContext;
 487
 488   function InitHash(P: Integer): Integer;
 489   begin
 490     Result := (P + 3) * 301;
 491   end;
 492
 493   procedure WriteCode(Code: Integer; var Context: TWriteContext);
 494   var
 495     BufIndex: Integer;
 496     Bytes: Byte;
 497   begin
 498     BufIndex := Context.Inx shr 3;
 499     Code := Code shl (Context.Inx and 7);
 500     Context.Buf[BufIndex] := Context.Buf[BufIndex] or Byte(Code);
 501     Context.Buf[BufIndex + 1] := Byte(Code shr 8);
 502     Context.Buf[BufIndex + 2] := Byte(Code shr 16);
 503     Context.Inx := Context.Inx + Context.CodeSize;
 504     if Context.Inx >= 255 * 8 then
 505     begin
 506       // Flush out full buffer
 507       Bytes := 255;
 508       IO.Write(Handle, @Bytes, 1);
 509       IO.Write(Handle, @Context.Buf, Bytes);
 510       Move(Context.Buf[255], Context.Buf[0], 2);
 511       FillChar(Context.Buf[2], 255, 0);
 512       Context.Inx := Context.Inx - (255 * 8);
 513     end;
 514   end;
 515
 516   procedure FlushCode(var Context: TWriteContext);
 517   var
 518     Bytes: Byte;
 519   begin
 520     Bytes := (Context.Inx + 7) shr 3;
 521     if Bytes > 0 then
 522     begin
 523       IO.Write(Handle, @Bytes, 1);
 524       IO.Write(Handle, @Context.Buf, Bytes);
 525     end;
 526     // Data block terminator - a block of zero Size
 527     Bytes := 0;
 528     IO.Write(Handle, @Bytes, 1);
 529   end;
 530
 531 begin
 532   LineIdent := Width;
 533   Tail := 0;
 534   HashValue := 0;
 535   Col := 0;
 536   HashTable := TList.Create;
 537   GetMem(Dict, SizeOf(TDictTable));
 538   try
 539     for I := 0 to HashTableSize - 1 do
 540       HashTable.Add(nil);
 541
 542     // Initialise encoder variables
 543     InitCodeSize := BitCount + 1;
 544     if InitCodeSize = 2 then
 545       Inc(InitCodeSize);
 546     MinCodeSize := InitCodeSize - 1;
 547     IO.Write(Handle, @MinCodeSize, 1);
 548     ClearCode := 1 shl MinCodeSize;
 549     EndingCode := ClearCode + 1;
 550     LastCode := EndingCode;
 551     MaxCode := 1 shl InitCodeSize;
 552     LenString := 0;
 553     // Setup write context
 554     WriteCtxt.Inx := 0;
 555     WriteCtxt.CodeSize := InitCodeSize;
 556     FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);
 557     WriteCode(ClearCode, WriteCtxt);
 558     Y := 0;
 559     Pass := 0;
 560
 561     while Y < Height do
 562     begin
 563       PData := @PByteArray(Data)[Y * LineIdent];
 564       for X := 0 to Width - 1 do
 565       begin
 566         // Only ifIndex8 support
 567         case BitCount of
 568           8:
 569             begin
 570               Col := PData^;
 571               PData := @PByteArray(PData)[1];
 572             end;
 573           {4:
 574             begin
 575               if X and 1 <> 0 then
 576               begin
 577                 Col := PData^ and $0F;
 578                 PData := @PByteArray(PData)[1];
 579               end
 580               else
 581                 Col := PData^ shr 4;
 582             end;
 583           1:
 584             begin
 585               if X and 7 = 7 then
 586               begin
 587                 Col := PData^ and 1;
 588                 PData := @PByteArray(PData)[1];
 589               end
 590               else
 591                 Col := (PData^ shr (7 - (X and $07))) and $01;
 592             end;}
 593         end;
 594         Inc(LenString);
 595         if LenString = 1 then
 596         begin
 597           Tail := Col;
 598           HashValue := InitHash(Col);
 599         end
 600         else
 601         begin
 602           HashValue := HashValue * (Col + LenString + 4);
 603           I := HashValue mod HashTableSize;
 604           HashValue := HashValue mod HashTableSize;
 605           while (HashTable[I] <> nil) and
 606             ((PImageDict(HashTable[I])^.Tail <> Tail) or
 607             (PImageDict(HashTable[I])^.Col <> Col)) do
 608           begin
 609             Inc(I);
 610             if I >= HashTableSize then
 611               I := 0;
 612           end;
 613           if HashTable[I] <> nil then // Found in the strings table
 614             Tail := PImageDict(HashTable[I])^.Index
 615           else
 616           begin
 617             // Not found
 618             WriteCode(Tail, WriteCtxt);
 619             Inc(LastCode);
 620             HashTable[I] := @Dict^[LastCode];
 621             PImageDict(HashTable[I])^.Index := LastCode;
 622             PImageDict(HashTable[I])^.Tail := Tail;
 623             PImageDict(HashTable[I])^.Col := Col;
 624             Tail := Col;
 625             HashValue := InitHash(Col);
 626             LenString := 1;
 627             if LastCode >= MaxCode then
 628             begin
 629               // Next Code will be written longer
 630               MaxCode := MaxCode shl 1;
 631               Inc(WriteCtxt.CodeSize);
 632             end
 633             else
 634             if LastCode >= CodeTableSize - 2 then
 635             begin
 636               // Reset tables
 637               WriteCode(Tail, WriteCtxt);
 638               WriteCode(ClearCode, WriteCtxt);
 639               LenString := 0;
 640               LastCode := EndingCode;
 641               WriteCtxt.CodeSize := InitCodeSize;
 642               MaxCode := 1 shl InitCodeSize;
 643               for I := 0 to HashTableSize - 1 do
 644                 HashTable[I] := nil;
 645             end;
 646           end;
 647         end;
 648       end;
 649       if Interlaced then
 650         Y := InterlaceStep(Y, Height, Pass)
 651       else
 652         Inc(Y);
 653     end;
 654     WriteCode(Tail, WriteCtxt);
 655     WriteCode(EndingCode, WriteCtxt);
 656     FlushCode(WriteCtxt);
 657   finally
 658     HashTable.Free;
 659     FreeMem(Dict);
 660   end;
 661 end;
 662
 663 function TGIFFileFormat.LoadData(Handle: TImagingHandle;
 664   var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
 665 type
 666   TFrameInfo = record
 667     Left, Top: Integer;
 668     Width, Height: Integer;
 669     Disposal: TDisposalMethod;
 670     HasTransparency: Boolean;
 671     HasLocalPal: Boolean;
 672     TransIndex: Integer;
 673     BackIndex: Integer;
 674   end;
 675 var
 676   Header: TGIFHeader;
 677   HasGlobalPal: Boolean;
 678   GlobalPalLength: Integer;
 679   GlobalPal: TPalette32Size256;
 680   ScreenWidth, ScreenHeight, I, CachedIndex: Integer;
 681   BlockID: Byte;
 682   HasGraphicExt: Boolean;
 683   GraphicExt: TGraphicControlExtension;
 684   FrameInfos: array of TFrameInfo;
 685   AppRead: Boolean;
 686   CachedFrame: TImageData;
 687   AnimFrames: TDynImageDataArray;
 688
 689   function ReadBlockID: Byte;
 690   begin
 691     Result := GIFTrailer;
 692     if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then
 693       Result := GIFTrailer;
 694   end;
 695
 696   procedure ReadExtensions;
 697   var
 698     BlockSize, BlockType, ExtType: Byte;
 699     AppRec: TGIFApplicationRec;
 700     LoopCount: SmallInt;
 701
 702     procedure SkipBytes;
 703     begin
 704       with GetIO do
 705       repeat
 706         // Read block sizes and skip them
 707         Read(Handle, @BlockSize, SizeOf(BlockSize));
 708         Seek(Handle, BlockSize, smFromCurrent);
 709       until BlockSize = 0;
 710     end;
 711
 712   begin
 713     HasGraphicExt := False;
 714     AppRead := False;
 715
 716     // Read extensions until image descriptor is found. Only graphic extension
 717     // is stored now (for transparency), others are skipped.
 718     while BlockID = GIFExtensionIntroducer do
 719     with GetIO do
 720     begin
 721       Read(Handle, @ExtType, SizeOf(ExtType));
 722
 723       while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do
 724       begin
 725         if ExtType = GIFGraphicControlExtension then
 726         begin
 727           HasGraphicExt := True;
 728           Read(Handle, @GraphicExt, SizeOf(GraphicExt));
 729         end
 730         else if (ExtType = GIFApplicationExtension) and not AppRead then
 731         begin
 732           Read(Handle, @BlockSize, SizeOf(BlockSize));
 733           if BlockSize >= SizeOf(AppRec) then
 734           begin
 735             Read(Handle, @AppRec, SizeOf(AppRec));
 736             if ((AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0')) or
 737               ((AppRec.Identifier = 'ANIMEXTS') and (AppRec.Authentication = '1.0')) then
 738             begin
 739               Read(Handle, @BlockSize, SizeOf(BlockSize));
 740               while BlockSize <> 0 do
 741               begin
 742                 BlockType := ReadBlockID;
 743                 Dec(BlockSize);
 744
 745                 case BlockType of
 746                   GIFAppLoopExtension:
 747                     if (BlockSize >= SizeOf(LoopCount)) then
 748                     begin
 749                       // Read loop count
 750                       Read(Handle, @LoopCount, SizeOf(LoopCount));
 751                       Dec(BlockSize, SizeOf(LoopCount));
 752                       if LoopCount > 0 then
 753                         Inc(LoopCount); // Netscape extension is really "repeats" not "loops"
 754                       FMetadata.SetMetaItem(SMetaAnimationLoops, LoopCount);
 755                     end;
 756                   GIFAppBufferExtension:
 757                     begin
 758                       Dec(BlockSize, SizeOf(Word));
 759                       Seek(Handle, SizeOf(Word), smFromCurrent);
 760                     end;
 761                 end;
 762               end;
 763               SkipBytes;
 764               AppRead := True;
 765             end
 766             else
 767               begin
 768                 // Revert all bytes reading
 769                 Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent);
 770                 SkipBytes;
 771               end;
 772           end
 773           else
 774             begin
 775               Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent);
 776               SkipBytes;
 777             end;
 778         end
 779         else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then
 780         repeat
 781           // Read block sizes and skip them
 782           Read(Handle, @BlockSize, SizeOf(BlockSize));
 783           Seek(Handle, BlockSize, smFromCurrent);
 784         until BlockSize = 0;
 785
 786         // Read ID of following block
 787         BlockID := ReadBlockID;
 788         ExtType := BlockID;
 789       end
 790     end;
 791   end;
 792
 793   procedure CopyLZWData(Dest: TStream);
 794   var
 795     CodeSize, BlockSize: Byte;
 796     InputSize: Integer;
 797     Buff: array[Byte] of Byte;
 798   begin
 799     InputSize := ImagingIO.GetInputSize(GetIO, Handle);
 800     // Copy codesize to stream
 801     GetIO.Read(Handle, @CodeSize, 1);
 802     Dest.Write(CodeSize, 1);
 803     repeat
 804       // Read and write data blocks, last is block term value of 0
 805       GetIO.Read(Handle, @BlockSize, 1);
 806       Dest.Write(BlockSize, 1);
 807       if BlockSize > 0 then
 808       begin
 809         GetIO.Read(Handle, @Buff[0], BlockSize);
 810         Dest.Write(Buff[0], BlockSize);
 811       end;
 812     until (BlockSize = 0) or (GetIO.Tell(Handle) >= InputSize);
 813   end;
 814
 815   procedure ReadFrame;
 816   var
 817     ImageDesc: TImageDescriptor;
 818     Interlaced: Boolean;
 819     I, Idx, LocalPalLength: Integer;
 820     LocalPal: TPalette32Size256;
 821     LZWStream: TMemoryStream;
 822
 823     procedure RemoveBadFrame;
 824     begin
 825       FreeImage(Images[Idx]);
 826       SetLength(Images, Length(Images) - 1);
 827     end;
 828
 829   begin
 830     Idx := Length(Images);
 831     SetLength(Images, Idx + 1);
 832     SetLength(FrameInfos, Idx + 1);
 833     FillChar(LocalPal, SizeOf(LocalPal), 0);
 834
 835     with GetIO do
 836     begin
 837       // Read and parse image descriptor
 838       Read(Handle, @ImageDesc, SizeOf(ImageDesc));
 839       FrameInfos[Idx].HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
 840       Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced;
 841       LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize;
 842       LocalPalLength := 1 shl (LocalPalLength + 1);   // Total pal length is 2^(n+1)
 843
 844       // From Mozilla source
 845       if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then
 846         ImageDesc.Width := Header.ScreenWidth;
 847       if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight)  then
 848         ImageDesc.Height := Header.ScreenHeight;
 849
 850       FrameInfos[Idx].Left := ImageDesc.Left;
 851       FrameInfos[Idx].Top := ImageDesc.Top;
 852       FrameInfos[Idx].Width := ImageDesc.Width;
 853       FrameInfos[Idx].Height := ImageDesc.Height;
 854       FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex;
 855
 856       // Create new image for this frame which would be later pasted onto logical screen
 857       NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]);
 858
 859       // Load local palette if there is any
 860       if FrameInfos[Idx].HasLocalPal then
 861         for I := 0 to LocalPalLength - 1 do
 862         begin
 863           LocalPal[I].A := 255;
 864           Read(Handle, @LocalPal[I].R, SizeOf(LocalPal[I].R));
 865           Read(Handle, @LocalPal[I].G, SizeOf(LocalPal[I].G));
 866           Read(Handle, @LocalPal[I].B, SizeOf(LocalPal[I].B));
 867         end;
 868
 869       // Use local pal if present or global pal if present or create
 870       // default pal if neither of them is present
 871       if FrameInfos[Idx].HasLocalPal then
 872         Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal))
 873       else if HasGlobalPal then
 874         Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal))
 875       else
 876         FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2);
 877
 878       if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then
 879       begin
 880         // Resize the screen if needed to fit the frame
 881         ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left);
 882         ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top);
 883       end
 884       else
 885       begin
 886         // Remove frame outside logical screen
 887         RemoveBadFrame;
 888         Exit;
 889       end;
 890
 891       // If Grahic Control Extension is present make use of it
 892       if HasGraphicExt then
 893       begin
 894         FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
 895         FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
 896         if FrameInfos[Idx].HasTransparency then
 897         begin
 898           FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
 899           Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
 900         end;
 901         FMetadata.SetMetaItem(SMetaFrameDelay, Integer(GraphicExt.DelayTime * 10), Idx);
 902       end
 903       else
 904         FrameInfos[Idx].HasTransparency := False;
 905
 906       LZWStream := TMemoryStream.Create;
 907       try
 908         try
 909           // Copy LZW data to temp stream, needed for correct decompression
 910           CopyLZWData(LZWStream);
 911           LZWStream.Position := 0;
 912           // Data decompression finally
 913           LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits);
 914         except
 915           RemoveBadFrame;
 916           Exit;
 917         end;
 918       finally
 919         LZWStream.Free;
 920       end;
 921     end;
 922   end;
 923
 924   procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer);
 925   var
 926     X, Y: Integer;
 927     Src: PByte;
 928     Dst: PColor32;
 929   begin
 930     Src := Frame.Bits;
 931
 932     // Copy all pixels from frame to log screen but ignore the transparent ones
 933     for Y := 0 to Frame.Height - 1 do
 934     begin
 935       Dst := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left];
 936       for X := 0 to Frame.Width - 1 do
 937       begin
 938         if (Frame.Palette[Src^].A <> 0) then
 939           Dst^ := Frame.Palette[Src^].Color;
 940         Inc(Src);
 941         Inc(Dst);
 942       end;
 943     end;
 944   end;
 945
 946   procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData);
 947   var
 948     I, First, Last: Integer;
 949     UseCache: Boolean;
 950     BGColor: TColor32;
 951   begin
 952     // We may need to use raw frame 0 to n to correctly animate n-th frame
 953     Last := Index;
 954     First := Max(0, Last);
 955     // See if we can use last animate frame as a basis for this one
 956     // (so we don't have to use previous raw frames).
 957     UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and
 958       (FrameInfos[CachedIndex].Disposal <> dmRestorePrevious);
 959
 960     // Reuse or release cache
 961     if UseCache then
 962       CloneImage(CachedFrame, AnimFrame)
 963     else
 964       FreeImage(CachedFrame);
 965
 966     // Default color for clearing of the screen
 967     BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color;
 968
 969     // Now prepare logical screen for drawing of raw frame at Index.
 970     // We may need to use all previous raw frames to get the screen
 971     // to proper state (according to their disposal methods).
 972
 973     if not UseCache then
 974     begin
 975       if FrameInfos[Index].HasTransparency then
 976         BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
 977       // Clear whole screen
 978       FillMemoryLongWord(AnimFrame.Bits, AnimFrame.Size, BGColor);
 979
 980       // Try to maximize First so we don't have to use all 0 to n raw frames
 981       while First > 0 do
 982       begin
 983         if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then
 984         begin
 985           if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then
 986             Break;
 987         end;
 988         Dec(First);
 989       end;
 990
 991       for I := First to Last - 1 do
 992       begin
 993         case FrameInfos[I].Disposal of
 994           dmNoRemoval, dmLeave:
 995             begin
 996               // Copy previous raw frame  onto screen
 997               CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top);
 998             end;
 999           dmRestoreBackground:
1000             if (I > First) then
1001             begin
1002               // Restore background color
1003               FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top,
1004                 FrameInfos[I].Width, FrameInfos[I].Height, @BGColor);
1005             end;
1006           dmRestorePrevious: ; // Do nothing - previous state is already on screen
1007         end;
1008       end;
1009     end
1010     else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then
1011     begin
1012       // We have our cached result but also need to restore
1013       // background in a place of cached frame
1014       if FrameInfos[CachedIndex].HasTransparency then
1015         BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color;
1016       FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top,
1017         FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor);
1018     end;
1019
1020     // Copy current raw frame to prepared screen
1021     CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top);
1022
1023     // Cache animated result
1024     CloneImage(AnimFrame, CachedFrame);
1025     CachedIndex := Index;
1026   end;
1027
1028 begin
1029   AppRead := False;
1030
1031   SetLength(Images, 0);
1032   FillChar(GlobalPal, SizeOf(GlobalPal), 0);
1033
1034   with GetIO do
1035   begin
1036     // Read GIF header
1037     Read(Handle, @Header, SizeOf(Header));
1038     ScreenWidth := Header.ScreenWidth;
1039     ScreenHeight := Header.ScreenHeight;
1040     HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7
1041     GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2
1042     GlobalPalLength := 1 shl (GlobalPalLength + 1);   // Total pal length is 2^(n+1)
1043
1044     // Read global palette from file if present
1045     if HasGlobalPal then
1046     begin
1047       for I := 0 to GlobalPalLength - 1 do
1048       begin
1049         GlobalPal[I].A := 255;
1050         Read(Handle, @GlobalPal[I].R, SizeOf(GlobalPal[I].R));
1051         Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G));
1052         Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B));
1053       end;
1054     end;
1055
1056     // Read ID of the first block
1057     BlockID := ReadBlockID;
1058
1059     // Now read all data blocks in the file until file trailer is reached
1060     while BlockID <> GIFTrailer do
1061     begin
1062       // Read blocks until we find the one of known type
1063       while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do
1064         BlockID := ReadBlockID;
1065       // Read supported and skip unsupported extensions
1066       ReadExtensions;
1067       // If image frame is found read it
1068       if BlockID = GIFImageDescriptor then
1069         ReadFrame;
1070       // Read next block's ID
1071       BlockID := ReadBlockID;
1072       // If block ID is unknown set it to end-of-GIF marker
1073       if not (BlockID in [GIFExtensionIntroducer, GIFTrailer, GIFImageDescriptor]) then
1074         BlockID := GIFTrailer;
1075     end;
1076
1077     if FLoadAnimated then
1078     begin
1079       // Aniated frames will be stored in AnimFrames
1080       SetLength(AnimFrames, Length(Images));
1081       InitImage(CachedFrame);
1082       CachedIndex := -1;
1083
1084       for I := 0 to High(Images) do
1085       begin
1086         // Create new logical screen
1087         NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]);
1088         // Animate frames to current log screen
1089         AnimateFrame(I, AnimFrames[I]);
1090       end;
1091
1092       // Now release raw 8bit frames and put animated 32bit ones
1093       // to output array
1094       FreeImage(CachedFrame);
1095       for I := 0 to High(AnimFrames) do
1096       begin
1097         FreeImage(Images[I]);
1098         Images[I] := AnimFrames[I];
1099       end;
1100     end;
1101
1102     Result := True;
1103   end;
1104 end;
1105
1106 function TGIFFileFormat.SaveData(Handle: TImagingHandle;
1107   const Images: TDynImageDataArray; Index: Integer): Boolean;
1108 var
1109   Header: TGIFHeader;
1110   ImageDesc: TImageDescriptor;
1111   ImageToSave: TImageData;
1112   MustBeFreed: Boolean;
1113   I, J: Integer;
1114   GraphicExt: TGraphicControlExtension;
1115
1116   procedure FindMaxDimensions(var MaxWidth, MaxHeight: Word);
1117   var
1118     I: Integer;
1119   begin
1120     MaxWidth := Images[FFirstIdx].Width;
1121     MaxHeight := Images[FFirstIdx].Height;
1122
1123     for I := FFirstIdx + 1 to FLastIdx do
1124     begin
1125       MaxWidth := Iff(Images[I].Width > MaxWidth, Images[I].Width, MaxWidth);
1126       MaxHeight := Iff(Images[I].Height > MaxWidth, Images[I].Height, MaxHeight);
1127     end;
1128   end;
1129
1130   procedure SetFrameDelay(Idx: Integer; var Ext: TGraphicControlExtension);
1131   begin
1132     if FMetadata.HasMetaItemForSaving(SMetaFrameDelay, Idx) then
1133       Ext.DelayTime := FMetadata.MetaItemsForSavingMulti[SMetaFrameDelay, Idx] div 10
1134     else
1135       Ext.DelayTime := GIFDefaultDelay;
1136   end;
1137
1138   procedure SaveGlobalMetadata;
1139   var
1140     AppExt: TGIFApplicationRec;
1141     BlockSize, LoopExtId: Byte;
1142     Repeats: Word;
1143   begin
1144     if FMetadata.HasMetaItemForSaving(SMetaAnimationLoops) then
1145     with GetIO do
1146     begin
1147       FillChar(AppExt, SizeOf(AppExt), 0);
1148       AppExt.Identifier := 'NETSCAPE';
1149       AppExt.Authentication := '2.0';
1150       Repeats := FMetadata.MetaItemsForSaving[SMetaAnimationLoops];
1151       if Repeats > 0 then
1152         Dec(Repeats);
1153       LoopExtId := GIFAppLoopExtension;
1154
1155       Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
1156       Write(Handle, @GIFApplicationExtension, SizeOf(GIFApplicationExtension));
1157       BlockSize := 11;
1158       Write(Handle, @BlockSize, SizeOf(BlockSize));
1159       Write(Handle, @AppExt, SizeOf(AppExt));
1160       BlockSize := 3;
1161       Write(Handle, @BlockSize, SizeOf(BlockSize));
1162       Write(Handle, @LoopExtId, SizeOf(LoopExtId));
1163       Write(Handle, @Repeats, SizeOf(Repeats));
1164       Write(Handle, @GIFBlockTerminator, SizeOf(GIFBlockTerminator));
1165     end;
1166   end;
1167
1168 begin
1169   // Fill header with data, select size of largest image in array as
1170   // logical screen size
1171   FillChar(Header, Sizeof(Header), 0);
1172   Header.Signature := GIFSignature;
1173   Header.Version := GIFVersions[gv89];
1174   FindMaxDimensions(Header.ScreenWidth, Header.ScreenHeight);
1175   Header.PackedFields := GIFColorResolution; // Color resolution is 256
1176   GetIO.Write(Handle, @Header, SizeOf(Header));
1177
1178   // Prepare default GC extension with delay
1179   FillChar(GraphicExt, Sizeof(GraphicExt), 0);
1180   GraphicExt.DelayTime := GIFDefaultDelay;
1181   GraphicExt.BlockSize := 4;
1182
1183   SaveGlobalMetadata;
1184
1185   for I := FFirstIdx to FLastIdx do
1186   begin
1187     if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
1188     with GetIO, ImageToSave do
1189     try
1190       // Write Graphic Control Extension with default delay
1191       Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
1192       Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension));
1193       SetFrameDelay(I, GraphicExt);
1194       Write(Handle, @GraphicExt, SizeOf(GraphicExt));
1195       // Write frame marker and fill and write image descriptor for this frame
1196       Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor));
1197       FillChar(ImageDesc, Sizeof(ImageDesc), 0);
1198       ImageDesc.Width := Width;
1199       ImageDesc.Height := Height;
1200       ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use lccal color table with 256 entries
1201       Write(Handle, @ImageDesc, SizeOf(ImageDesc));
1202
1203       // Write local color table for each frame
1204       for J := 0 to 255 do
1205       begin
1206         Write(Handle, @Palette[J].R, SizeOf(Palette[J].R));
1207         Write(Handle, @Palette[J].G, SizeOf(Palette[J].G));
1208         Write(Handle, @Palette[J].B, SizeOf(Palette[J].B));
1209       end;
1210
1211       // Finally compress image data
1212       LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits);
1213
1214     finally
1215       if MustBeFreed then
1216         FreeImage(ImageToSave);
1217     end;
1218   end;
1219
1220   GetIO.Write(Handle, @GIFTrailer, SizeOf(GIFTrailer));
1221   Result := True;
1222 end;
1223
1224 procedure TGIFFileFormat.ConvertToSupported(var Image: TImageData;
1225   const Info: TImageFormatInfo);
1226 begin
1227   ConvertImage(Image, ifIndex8);
1228 end;
1229
1230 function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
1231 var
1232   Header: TGIFHeader;
1233   ReadCount: Integer;
1234 begin
1235   Result := False;
1236   if Handle <> nil then
1237   begin
1238     ReadCount := GetIO.Read(Handle, @Header, SizeOf(Header));
1239     GetIO.Seek(Handle, -ReadCount, smFromCurrent);
1240     Result := (ReadCount >= SizeOf(Header)) and
1241       (Header.Signature = GIFSignature) and
1242       ((Header.Version = GIFVersions[gv87]) or (Header.Version = GIFVersions[gv89]));
1243   end;
1244 end;
1245
1246 initialization
1247   RegisterImageFileFormat(TGIFFileFormat);
1248
1249 {
1250   File Notes:
1251
1252  -- TODOS ----------------------------------------------------
1253     - nothing now
1254
1255   -- 0.77 Changes/Bug Fixes -----------------------------------
1256     - Fixed crash when resaving GIF with animation metadata.
1257     - Writes frame delays of GIF animations from metadata.
1258     - Reads and writes looping of GIF animations stored into/from metadata.
1259
1260   -- 0.26.5 Changes/Bug Fixes ---------------------------------
1261     - Reads frame delays from GIF animations into metadata.
1262
1263   -- 0.26.3 Changes/Bug Fixes ---------------------------------
1264     - Fixed bug - loading of GIF with NETSCAPE app extensions
1265       failed with Delphi 2009.
1266
1267   -- 0.26.1 Changes/Bug Fixes ---------------------------------
1268     - GIF loading and animation mostly rewritten, based on
1269       modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib).
1270
1271   -- 0.25.0 Changes/Bug Fixes ---------------------------------
1272     - Fixed loading of some rare GIFs, problems with LZW
1273       decompression.
1274
1275   -- 0.24.3 Changes/Bug Fixes ---------------------------------
1276     - Better solution to transparency for some GIFs. Background not
1277       transparent by default.
1278
1279   -- 0.24.1 Changes/Bug Fixes ---------------------------------
1280     - Made backround color transparent by default (alpha = 0).
1281
1282   -- 0.23 Changes/Bug Fixes -----------------------------------
1283     - Fixed other loading bugs (local pal size, transparency).
1284     - Added GIF saving.
1285     - Fixed bug when loading multiframe GIFs and implemented few animation
1286       features (disposal methods, ...).
1287     - Loading of GIFs working.
1288     - Unit created with initial stuff!
1289 }
1290
1291 end.