1 {
2 This file is part of the Free Pascal run time library.
3 Copyright (c) 2008 by the Free Pascal development team
4
5 GIF reader for fpImage.
6
7 See the file COPYING.FPC, included in this distribution,
8 for details about the copyright.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************
15
16 ToDo: read further images
17 }
18 unit FPReadGif;
19
20 {$mode objfpc}{$H+}
21
22 interface
23
24 uses
25 Classes, SysUtils, FPimage;
26
27 type
28 TGifRGB = packed record
29 Red, Green, Blue : Byte;
30 end;
31
32 TGIFHeader = packed record
33 Signature:array[0..2] of Char; //* Header Signature (always "GIF") */
34 Version:array[0..2] of Char; //* GIF format version("87a" or "89a") */
35 // Logical Screen Descriptor
36 ScreenWidth:word; //* Width of Display Screen in Pixels */
37 ScreenHeight:word; //* Height of Display Screen in Pixels */
38 Packedbit, //* Screen and Color Map Information */
39 BackgroundColor, //* Background Color Index */
40 AspectRatio:byte; //* Pixel Aspect Ratio */
41 end;
42
43 TGifImageDescriptor = packed record
44 Left, //* X position of image on the display */
45 Top, //* Y position of image on the display */
46 Width, //* Width of the image in pixels */
47 Height:word; //* Height of the image in pixels */
48 Packedbit:byte; //* Image and Color Table Data Information */
49 end;
50
51 TGifGraphicsControlExtension = packed record
52 BlockSize, //* Size of remaining fields (always 04h) */
53 Packedbit:byte; //* Method of graphics disposal to use */
54 DelayTime:word; //* Hundredths of seconds to wait */
55 ColorIndex, //* Transparent Color Index */
56 Terminator:byte; //* Block Terminator (always 0) */
57 end;
58
59 TFPReaderGif = class;
60
61 TGifCreateCompatibleImgEvent = procedure(Sender: TFPReaderGif;
62 var NewImage: TFPCustomImage) of object;
63
64 { TFPReaderGif }
65
66 TFPReaderGif = class(TFPCustomImageReader)
67 protected
68 FHeader: TGIFHeader;
69 FDescriptor: TGifImageDescriptor;
70 FGraphicsCtrlExt: TGifGraphicsControlExtension;
71 FTransparent: Boolean;
72 FGraphCtrlExt: Boolean;
73 FScanLine: PByte;
74 FLineSize: Integer;
75 FPalette: TFPPalette;
76 FWidth: integer;
77 FHeight: Integer;
78 FInterlace: boolean;
79 FBitsPerPixel: byte;
80 FBackground: byte;
81 FResolution: byte;
82 FOnCreateImage: TGifCreateCompatibleImgEvent;
83 procedure ReadPalette(Stream: TStream; Size: integer);
AnalyzeHeadernull84 function AnalyzeHeader: Boolean;
85 procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
ReadScanLinenull86 function ReadScanLine(Stream: TStream): boolean; virtual;
WriteScanLinenull87 function WriteScanLine(Img: TFPCustomImage): Boolean; virtual;
InternalChecknull88 function InternalCheck (Stream: TStream) : boolean; override;
SkipBlocknull89 function SkipBlock(Stream: TStream): byte;
90 public
91 constructor Create; override;
92 destructor Destroy; override;
93 property Header: TGIFHeader read FHeader;
94 property Descriptor: TGifImageDescriptor read FDescriptor;
95 property GraphCtrlExt: Boolean read FGraphCtrlExt;
96 property GraphicsCtrlExt: TGifGraphicsControlExtension read FGraphicsCtrlExt;
97 property Transparent: Boolean read FTransparent;
98 property Palette: TFPPalette read FPalette;
99 property Width: integer read FWidth;
100 property Height: Integer read FHeight;
101 property Interlace: boolean read FInterlace;
102 property BitsPerPixel: byte read FBitsPerPixel;
103 property Background: byte read FBackground;
104 property Resolution: byte read FResolution;
105 property OnCreateImage: TGifCreateCompatibleImgEvent read FOnCreateImage write FOnCreateImage;
106 end;
107
108 implementation
109
110 { TFPReaderGif }
111
112 procedure TFPReaderGif.ReadPalette(Stream: TStream; Size: integer);
113 Var
114 RGBEntry : TGifRGB;
115 I : Integer;
116 c : TFPColor;
117 begin
118 FPalette.count := 0;
119 For I:=0 To Size-1 Do
120 Begin
121 Stream.Read(RGBEntry, SizeOf(RGBEntry));
122 With c do
123 begin
124 Red:=RGBEntry.Red or (RGBEntry.Red shl 8);
125 Green:=RGBEntry.Green or (RGBEntry.Green shl 8);
126 Blue:=RGBEntry.Blue or (RGBEntry.Blue shl 8);
127 Alpha:=alphaOpaque;
128 end;
129 FPalette.Add(C);
130 End;
131 end;
132
TFPReaderGif.AnalyzeHeadernull133 function TFPReaderGif.AnalyzeHeader: Boolean;
134 var
135 C : TFPColor;
136 begin
137 Result:=false;
138 With FHeader do
139 begin
140 if (Signature = 'GIF') and
141 ((Version = '87a') or
142 (Version = '89a')) then
143 else
144 Raise Exception.Create('Unknown/Unsupported GIF image type');
145
146 FResolution := Packedbit and $70 shr 5 + 1;
147 FBitsPerPixel:=Packedbit and 7 + 1;
148 FBackground := BackgroundColor;
149
150 With FDescriptor do
151 begin
152 fWidth:=Width;
153 fHeight:=Height;
154 FInterlace := (Packedbit and $40 = $40);
155 end;
156 FTransparent:= FBackground <> 0;
157 if FGraphCtrlExt then
158 begin
159 FTransparent:=(FGraphicsCtrlExt.Packedbit and $01)<>0;
160 If FTransparent then
161 FBackground:=FGraphicsCtrlExt.ColorIndex;
162 end;
163 FLineSize:=FWidth*(FHeight+1);
164 GetMem(FScanLine,FLineSize);
165 If FTransparent then
166 begin
167 C:=FPalette.Color[FBackground];
168 C.alpha:=alphaTransparent;
169 FPalette.Color[FBackground]:=C;
170 end;
171 end;
172 Result:=true;
173 end;
174
175 procedure TFPReaderGif.InternalRead(Stream: TStream; Img: TFPCustomImage);
176 var
177 Introducer:byte;
178 ColorTableSize :Integer;
179 ContProgress: Boolean;
180 begin
181 FPalette:=nil;
182 FScanLine:=nil;
183 try
184 ContProgress:=true;
185 Progress(psStarting, 0, False, Rect(0,0,0,0), '', ContProgress);
186 if not ContProgress then exit;
187
188 FPalette := TFPPalette.Create(0);
189
190 Stream.Position:=0;
191 // header
192 Stream.Read(FHeader,SizeOf(FHeader));
193 Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)), False, Rect(0,0,0,0), '', ContProgress);
194 if not ContProgress then exit;
195
196 // Endian Fix Mantis 8541. Gif is always little endian
197 {$IFDEF ENDIAN_BIG}
198 with FHeader do
199 begin
200 ScreenWidth := LEtoN(ScreenWidth);
201 ScreenHeight := LEtoN(ScreenHeight);
202 end;
203 {$ENDIF}
204 // global palette
205 if (FHeader.Packedbit and $80) <> 0 then
206 begin
207 ColorTableSize := FHeader.Packedbit and 7 + 1;
208 ReadPalette(stream, 1 shl ColorTableSize);
209 end;
210
211 // skip extensions
212 Repeat
213 Introducer:=SkipBlock(Stream);
214 until (Introducer = $2C) or (Introducer = $3B) or (Stream.Position>=Stream.Size);
215
216 if Stream.Position>=Stream.Size then
217 Exit;
218
219 // descriptor
220 Stream.Read(FDescriptor, SizeOf(FDescriptor));
221 {$IFDEF ENDIAN_BIG}
222 with FDescriptor do
223 begin
224 Left := LEtoN(Left);
225 Top := LEtoN(Top);
226 Width := LEtoN(Width);
227 Height := LEtoN(Height);
228 end;
229 {$ENDIF}
230 // local palette
231 if (FDescriptor.Packedbit and $80) <> 0 then
232 begin
233 ColorTableSize := FDescriptor.Packedbit and 7 + 1;
234 ReadPalette(stream, 1 shl ColorTableSize);
235 end;
236
237 // parse header
238 if not AnalyzeHeader then exit;
239
240 // create image
241 if Assigned(OnCreateImage) then
242 OnCreateImage(Self,Img);
243 Img.SetSize(FWidth,FHeight);
244
245 // read pixels
246 if not ReadScanLine(Stream) then exit;
247 if not WriteScanLine(Img) then exit;
248
249 // ToDo: read further images
250 finally
251 FreeAndNil(FPalette);
252 ReAllocMem(FScanLine,0);
253 end;
254 Progress(FPimage.psEnding, 100, false, Rect(0,0,FWidth,FHeight), '', ContProgress);
255 end;
256
ReadScanLinenull257 function TFPReaderGif.ReadScanLine(Stream: TStream): Boolean;
258 var
259 OldPos,
260 UnpackedSize,
261 PackedSize:longint;
262 I: Integer;
263 Data,
264 Bits,
265 Code: Cardinal;
266 SourcePtr: PByte;
267 InCode: Cardinal;
268
269 CodeSize: Cardinal;
270 CodeMask: Cardinal;
271 FreeCode: Cardinal;
272 OldCode: Cardinal;
273 Prefix: array[0..4095] of Cardinal;
274 Suffix,
275 Stack: array [0..4095] of Byte;
276 StackPointer: PByte;
277 DataComp,
278 Target: PByte;
279 B,
280 FInitialCodeSize,
281 FirstChar: Byte;
282 ClearCode,
283 EOICode: Word;
284 ContProgress: Boolean;
285
286 begin
287 DataComp:=nil;
288 ContProgress:=true;
289 try
290 // read dictionary size
291 Stream.read(FInitialCodeSize, 1);
292
293 // search end of compressor table
294 OldPos:=Stream.Position;
295 PackedSize := 0;
296 Repeat
297 Stream.read(B, 1);
298 if B > 0 then
299 begin
300 inc(PackedSize, B);
301 Stream.Seek(B, soFromCurrent);
302 CodeMask := (1 shl CodeSize) - 1;
303 end;
304 until (B = 0) or (Stream.Position>=Stream.Size);
305
306 { if Stream.Position>=Stream.Size then
307 Exit(False); }
308
309 Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
310 False, Rect(0,0,0,0), '', ContProgress);
311 if not ContProgress then exit(false);
312
313 Getmem(DataComp, PackedSize);
314 // read compressor table
315 SourcePtr:=DataComp;
316 Stream.Position:=OldPos;
317 Repeat
318 Stream.read(B, 1);
319 if B > 0 then
320 begin
321 Stream.ReadBuffer(SourcePtr^, B);
322 Inc(SourcePtr,B);
323 end;
324 until (B = 0) or (Stream.Position>=Stream.Size);
325
326 { if Stream.Position>=Stream.Size then
327 Exit(False); }
328
329
330 Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
331 False, Rect(0,0,0,0), '', ContProgress);
332 if not ContProgress then exit(false);
333
334 SourcePtr:=DataComp;
335 Target := FScanLine;
336 CodeSize := FInitialCodeSize + 1;
337 ClearCode := 1 shl FInitialCodeSize;
338 EOICode := ClearCode + 1;
339 FreeCode := ClearCode + 2;
340 OldCode := 4096;
341 CodeMask := (1 shl CodeSize) - 1;
342 UnpackedSize:=FWidth * FHeight;
343 for I := 0 to ClearCode - 1 do
344 begin
345 Prefix[I] := 4096;
346 Suffix[I] := I;
347 end;
348 StackPointer := @Stack;
349 FirstChar := 0;
350 Data := 0;
351 Bits := 0;
352 // LZW decompression gif
353 while (UnpackedSize > 0) and (PackedSize > 0) do
354 begin
355 Inc(Data, SourcePtr^ shl Bits);
356 Inc(Bits, 8);
357 while Bits >= CodeSize do
358 begin
359 Code := Data and CodeMask;
360 Data := Data shr CodeSize;
361 Dec(Bits, CodeSize);
362 if Code = EOICode then Break;
363 if Code = ClearCode then
364 begin
365 CodeSize := FInitialCodeSize + 1;
366 CodeMask := (1 shl CodeSize) - 1;
367 FreeCode := ClearCode + 2;
368 OldCode := 4096;
369 Continue;
370 end;
371 if Code > FreeCode then Break;
372 if OldCode = 4096 then
373 begin
374 FirstChar := Suffix[Code];
375 Target^ := FirstChar;
376 Inc(Target);
377 Dec(UnpackedSize);
378 OldCode := Code;
379 Continue;
380 end;
381 InCode := Code;
382 if Code = FreeCode then
383 begin
384 StackPointer^ := FirstChar;
385 Inc(StackPointer);
386 Code := OldCode;
387 end;
388 while Code > ClearCode do
389 begin
390 StackPointer^ := Suffix[Code];
391 Inc(StackPointer);
392 Code := Prefix[Code];
393 end;
394 FirstChar := Suffix[Code];
395 StackPointer^ := FirstChar;
396 Inc(StackPointer);
397 Prefix[FreeCode] := OldCode;
398 Suffix[FreeCode] := FirstChar;
399 if (FreeCode = CodeMask) and
400 (CodeSize < 12) then
401 begin
402 Inc(CodeSize);
403 CodeMask := (1 shl CodeSize) - 1;
404 end;
405 if FreeCode < 4095 then Inc(FreeCode);
406 OldCode := InCode;
407 repeat
408 Dec(StackPointer);
409 Target^ := StackPointer^;
410 Inc(Target);
411 Dec(UnpackedSize);
412 until StackPointer = @Stack;
413 end;
414 Inc(SourcePtr);
415 Dec(PackedSize);
416 end;
417 Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
418 False, Rect(0,0,0,0), '', ContProgress);
419 if not ContProgress then exit(false);
420 finally
421 if DataComp<>nil then
422 FreeMem(DataComp);
423 end;
424 Result:=true;
425 end;
426
TFPReaderGif.WriteScanLinenull427 function TFPReaderGif.WriteScanLine(Img: TFPCustomImage): Boolean;
428 Var
429 Row, Col : Integer;
430 Pass, Every : byte;
431 P : PByte;
IsMultiplenull432 function IsMultiple(NumberA, NumberB: Integer): Boolean;
433 begin
434 Result := (NumberA >= NumberB) and
435 (NumberB > 0) and
436 (NumberA mod NumberB = 0);
437 end;
438 begin
439 Result:=false;
440 P:=FScanLine;
441 If FInterlace then
442 begin
443 For Pass := 1 to 4 do
444 begin
445 Case Pass of
446 1 : begin
447 Row := 0;
448 Every := 8;
449 end;
450 2 : begin
451 Row := 4;
452 Every := 8;
453 end;
454 3 : begin
455 Row := 2;
456 Every := 4;
457 end;
458 4 : begin
459 Row := 1;
460 Every := 2;
461 end;
462 end;
463 Repeat
464 for Col:=0 to Img.Width-1 do
465 begin
466 Img.Colors[Col,Row]:=FPalette[P^];
467 Inc(P);
468 end;
469 Inc(Row, Every);
470 until Row >= Img.Height;
471 end;
472 end
473 else
474 begin
475 for Row:=0 to Img.Height-1 do
476 for Col:=0 to Img.Width-1 do
477 begin
478 Img.Colors[Col,Row]:=FPalette[P^];
479 Inc(P);
480 end;
481 end;
482 Result:=true;
483 end;
484
TFPReaderGif.InternalChecknull485 function TFPReaderGif.InternalCheck(Stream: TStream): boolean;
486
487 var
488 OldPos: Int64;
489 n: Int64;
490
491 begin
492 Result:=False;
493 if Stream = nil then
494 exit;
495 OldPos:=Stream.Position;
496 try
497 n := SizeOf(FHeader);
498 Result:=(Stream.Read(FHeader,n)=n)
499 and (FHeader.Signature = 'GIF')
500 and ((FHeader.Version = '87a') or (FHeader.Version = '89a'));
501 finally
502 Stream.Position := OldPos;
503 end;
504 end;
505
SkipBlocknull506 function TFPReaderGif.SkipBlock(Stream: TStream): byte;
507 var
508 Introducer,
509 Labels,
510 SkipByte : byte;
511 begin
512 Stream.read(Introducer,1);
513 if Introducer = $21 then
514 begin
515 Stream.read(Labels,1);
516 Case Labels of
517 $FE, $FF : // Comment Extension block or Application Extension block
518 while true do
519 begin
520 Stream.Read(SkipByte, 1);
521 if SkipByte = 0 then Break;
522 Stream.Seek(SkipByte, soFromCurrent);
523 end;
524 $F9 : // Graphics Control Extension block
525 begin
526 Stream.Read(FGraphicsCtrlExt, SizeOf(FGraphicsCtrlExt));
527 FGraphCtrlExt:=True;
528 end;
529 $01 : // Plain Text Extension block
530 begin
531 Stream.Read(SkipByte, 1);
532 Stream.Seek(SkipByte, soFromCurrent);
533 while true do
534 begin
535 Stream.Read(SkipByte, 1);
536 if SkipByte = 0 then Break;
537 Stream.Seek(SkipByte, soFromCurrent);
538 end;
539 end;
540 end;
541 end;
542 Result:=Introducer;
543 end;
544
545 constructor TFPReaderGif.Create;
546 begin
547 inherited Create;
548
549 end;
550
551 destructor TFPReaderGif.Destroy;
552 begin
553
554 inherited Destroy;
555 end;
556
557 initialization
558 ImageHandlers.RegisterImageReader ('GIF Graphics', 'gif', TFPReaderGif);
559 end.
560
561