source: cprs/branches/tmg-cprs/TPNGGraphics/pngimage.pas@ 1742

Last change on this file since 1742 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69

File size: 165.6 KB
RevLine 
[453]1{Portable Network Graphics Delphi 1.5 (29 June 2005) }
2
3{This is the latest implementation for TPngImage component }
4{It's meant to be a full replacement for the previous one. }
5{There are lots of new improvements, including cleaner code, }
6{full partial transparency support, speed improvements, }
7{saving using ADAM 7 interlacing, better error handling, also }
8{the best compression for the final image ever. And now it's }
9{truly able to read about any png image. }
10
11{
12 Version 1.5
13 2005-29-06 - Fixed a lot of bugs using tips from mails that I´ve
14 being receiving for some time
15 BUG 1 - Loosing palette when assigning to TBitmap. fixed
16 BUG 2 - SetPixels and GetPixels worked only with
17 parameters in range 0..255. fixed
18 BUG 3 - Force type address off using directive
19 BUG 4 - TChunkzTXt contained an error
20 BUG 5 - MaxIdatSize was not working correctly (fixed thanks
21 to Gabriel Corneanu
22 BUG 6 - Corrected german translation (thanks to Mael Horz)
23 And the following improvements:
24 IMPROVE 1 - Create ImageHandleValue properties as public in
25 TChunkIHDR to get access to this handle
26 IMPROVE 2 - Using SetStretchBltMode to improve stretch quality
27 IMPROVE 3 - Scale is now working for alpha transparent images
28 IMPROVE 4 - GammaTable propery is now public to support an
29 article in the help file
30
31 Version 1.4361
32 2003-03-04 - Fixed important bug for simple transparency when using
33 RGB, Grayscale color modes
34
35 Version 1.436
36 2003-03-04 - * NEW * Property Pixels for direct access to pixels
37 * IMPROVED * Palette property (TPngObject) (read only)
38 Slovenian traslation for the component (Miha Petelin)
39 Help file update (scanline article/png->jpg example)
40
41 Version 1.435
42 2003-11-03 - * NEW * New chunk implementation zTXt (method AddzTXt)
43 * NEW * New compiler flags to store the extra 8 bits
44 from 16 bits samples (when saving it is ignored), the
45 extra data may be acessed using ExtraScanline property
46 * Fixed * a bug on tIMe chunk
47 French translation included (Thanks to IBE Software)
48 Bugs fixed
49
50 Version 1.432
51 2002-08-24 - * NEW * A new method, CreateAlpha will transform the
52 current image into partial transparency.
53 Help file updated with a new article on how to handle
54 partial transparency.
55
56 Version 1.431
57 2002-08-14 - Fixed and tested to work on:
58 C++ Builder 3
59 C++ Builder 5
60 Delphi 3
61 There was an error when setting TransparentColor, fixed
62 New method, RemoveTransparency to remove image
63 BIT TRANSPARENCY
64
65 Version 1.43
66 2002-08-01 - * NEW * Support for Delphi 3 and C++ Builder 3
67 Implements mostly some things that were missing,
68 a few tweaks and fixes.
69
70 Version 1.428
71 2002-07-24 - More minor fixes (thanks to Ian Boyd)
72 Bit transparency fixes
73 * NEW * Finally support to bit transparency
74 (palette / rgb / grayscale -> all)
75
76 Version 1.427
77 2002-07-19 - Lots of bugs and leaks fixed
78 * NEW * method to easy adding text comments, AddtEXt
79 * NEW * property for setting bit transparency,
80 TransparentColor
81
82 Version 1.426
83 2002-07-18 - Clipboard finally fixed (hope)
84 Changed UseDelphi trigger to UseDelphi
85 * NEW * Support for bit transparency bitmaps
86 when assigning from/to TBitmap objects
87 Altough it does not support drawing transparent
88 parts of bit transparency pngs (only partial)
89 it is closer than ever
90
91 Version 1.425
92 2002-07-01 - Clipboard methods implemented
93 Lots of bugs fixed
94
95 Version 1.424
96 2002-05-16 - Scanline and AlphaScanline are now working correctly.
97 New methods for handling the clipboard
98
99 Version 1.423
100 2002-05-16 - * NEW * Partial transparency for 1, 2, 4 and 8 bits is
101 also supported using the tRNS chunk (for palette and
102 grayscaling).
103 New bug fixes (Peter Haas).
104
105 Version 1.422
106 2002-05-14 - Fixed some critical leaks, thanks to Peter Haas tips.
107 New translation for German (Peter Haas).
108
109 Version 1.421
110 2002-05-06 - Now uses new ZLIB version, 1.1.4 with some security
111 fixes.
112 LoadFromResourceID and LoadFromResourceName added and
113 help file updated for that.
114 The resources strings are now located in pnglang.pas.
115 New translation for Brazilian Portuguese.
116 Bugs fixed.
117
118 IMPORTANT: I'm currently looking for bugs on the library. If
119 anyone has found one, please send me an email and
120 I will fix right away. Thanks for all the help and
121 ideias I'm receiving so far.}
122
123{My new email is: gubadaud@terra.com.br}
124{Website link : pngdelphi.sourceforge.net}
125{Gustavo Huffenbacher Daud}
126
127unit pngimage;
128
129interface
130
131{Triggers avaliable (edit the fields bellow)}
132{$TYPEDADDRESS OFF}
133{$DEFINE UseDelphi} //Disable fat vcl units (perfect to small apps)
134{$DEFINE ErrorOnUnknownCritical} //Error when finds an unknown critical chunk
135{$DEFINE CheckCRC} //Enables CRC checking
136{$DEFINE RegisterGraphic} //Registers TPNGObject to use with TPicture
137{$DEFINE PartialTransparentDraw} //Draws partial transparent images
138{.$DEFINE Store16bits} //Stores the extra 8 bits from 16bits/sample
139{.$DEFINE Debug} //For programming purposes
140{$RANGECHECKS OFF} {$J+}
141
142
143
144uses
145 Windows {$IFDEF UseDelphi}, Classes, Graphics, SysUtils{$ENDIF} {$IFDEF Debug},
146 dialogs{$ENDIF}, pngzlib, pnglang;
147
148{$IFNDEF UseDelphi}
149 const
150 soFromBeginning = 0;
151 soFromCurrent = 1;
152 soFromEnd = 2;
153{$ENDIF}
154
155const
156 {ZLIB constants}
157 ZLIBErrors: Array[-6..2] of string = ('incompatible version (-6)',
158 'buffer error (-5)', 'insufficient memory (-4)', 'data error (-3)',
159 'stream error (-2)', 'file error (-1)', '(0)', 'stream end (1)',
160 'need dictionary (2)');
161 Z_NO_FLUSH = 0;
162 Z_FINISH = 4;
163 Z_STREAM_END = 1;
164
165 {Avaliable PNG filters for mode 0}
166 FILTER_NONE = 0;
167 FILTER_SUB = 1;
168 FILTER_UP = 2;
169 FILTER_AVERAGE = 3;
170 FILTER_PAETH = 4;
171
172 {Avaliable color modes for PNG}
173 COLOR_GRAYSCALE = 0;
174 COLOR_RGB = 2;
175 COLOR_PALETTE = 3;
176 COLOR_GRAYSCALEALPHA = 4;
177 COLOR_RGBALPHA = 6;
178
179
180type
181 {$IFNDEF UseDelphi}
182 {Custom exception handler}
183 Exception = class(TObject)
184 constructor Create(Msg: String);
185 end;
186 ExceptClass = class of Exception;
187 TColor = ColorRef;
188 {$ENDIF}
189
190 {Error types}
191 EPNGOutMemory = class(Exception);
192 EPngError = class(Exception);
193 EPngUnexpectedEnd = class(Exception);
194 EPngInvalidCRC = class(Exception);
195 EPngInvalidIHDR = class(Exception);
196 EPNGMissingMultipleIDAT = class(Exception);
197 EPNGZLIBError = class(Exception);
198 EPNGInvalidPalette = class(Exception);
199 EPNGInvalidFileHeader = class(Exception);
200 EPNGIHDRNotFirst = class(Exception);
201 EPNGNotExists = class(Exception);
202 EPNGSizeExceeds = class(Exception);
203 EPNGMissingPalette = class(Exception);
204 EPNGUnknownCriticalChunk = class(Exception);
205 EPNGUnknownCompression = class(Exception);
206 EPNGUnknownInterlace = class(Exception);
207 EPNGNoImageData = class(Exception);
208 EPNGCouldNotLoadResource = class(Exception);
209 EPNGCannotChangeTransparent = class(Exception);
210 EPNGHeaderNotPresent = class(Exception);
211
212type
213 {Direct access to pixels using R,G,B}
214 TRGBLine = array[word] of TRGBTriple;
215 pRGBLine = ^TRGBLine;
216
217 {Same as TBitmapInfo but with allocated space for}
218 {palette entries}
219 TMAXBITMAPINFO = packed record
220 bmiHeader: TBitmapInfoHeader;
221 bmiColors: packed array[0..255] of TRGBQuad;
222 end;
223
224 {Transparency mode for pngs}
225 TPNGTransparencyMode = (ptmNone, ptmBit, ptmPartial);
226 {Pointer to a cardinal type}
227 pCardinal = ^Cardinal;
228 {Access to a rgb pixel}
229 pRGBPixel = ^TRGBPixel;
230 TRGBPixel = packed record
231 B, G, R: Byte;
232 end;
233
234 {Pointer to an array of bytes type}
235 TByteArray = Array[Word] of Byte;
236 pByteArray = ^TByteArray;
237
238 {Forward}
239 TPNGObject = class;
240 pPointerArray = ^TPointerArray;
241 TPointerArray = Array[Word] of Pointer;
242
243 {Contains a list of objects}
244 TPNGPointerList = class
245 private
246 fOwner: TPNGObject;
247 fCount : Cardinal;
248 fMemory: pPointerArray;
249 function GetItem(Index: Cardinal): Pointer;
250 procedure SetItem(Index: Cardinal; const Value: Pointer);
251 protected
252 {Removes an item}
253 function Remove(Value: Pointer): Pointer; virtual;
254 {Inserts an item}
255 procedure Insert(Value: Pointer; Position: Cardinal);
256 {Add a new item}
257 procedure Add(Value: Pointer);
258 {Returns an item}
259 property Item[Index: Cardinal]: Pointer read GetItem write SetItem;
260 {Set the size of the list}
261 procedure SetSize(const Size: Cardinal);
262 {Returns owner}
263 property Owner: TPNGObject read fOwner;
264 public
265 {Returns number of items}
266 property Count: Cardinal read fCount write SetSize;
267 {Object being either created or destroyed}
268 constructor Create(AOwner: TPNGObject);
269 destructor Destroy; override;
270 end;
271
272 {Forward declaration}
273 TChunk = class;
274 TChunkClass = class of TChunk;
275
276 {Same as TPNGPointerList but providing typecasted values}
277 TPNGList = class(TPNGPointerList)
278 private
279 {Used with property Item}
280 function GetItem(Index: Cardinal): TChunk;
281 public
282 {Removes an item}
283 procedure RemoveChunk(Chunk: TChunk); overload;
284 {Add a new chunk using the class from the parameter}
285 function Add(ChunkClass: TChunkClass): TChunk;
286 {Returns pointer to the first chunk of class}
287 function ItemFromClass(ChunkClass: TChunkClass): TChunk;
288 {Returns a chunk item from the list}
289 property Item[Index: Cardinal]: TChunk read GetItem;
290 end;
291
292 {$IFNDEF UseDelphi}
293 {The STREAMs bellow are only needed in case delphi provided ones is not}
294 {avaliable (UseDelphi trigger not set)}
295 {Object becomes handles}
296 TCanvas = THandle;
297 TBitmap = HBitmap;
298 {Trick to work}
299 TPersistent = TObject;
300
301 {Base class for all streams}
302 TStream = class
303 protected
304 {Returning/setting size}
305 function GetSize: Longint; virtual;
306 procedure SetSize(const Value: Longint); virtual; abstract;
307 {Returns/set position}
308 function GetPosition: Longint; virtual;
309 procedure SetPosition(const Value: Longint); virtual;
310 public
311 {Returns/sets current position}
312 property Position: Longint read GetPosition write SetPosition;
313 {Property returns/sets size}
314 property Size: Longint read GetSize write SetSize;
315 {Allows reading/writing data}
316 function Read(var Buffer; Count: Longint): Cardinal; virtual; abstract;
317 function Write(const Buffer; Count: Longint): Cardinal; virtual; abstract;
318 {Copies from another Stream}
319 function CopyFrom(Source: TStream;
320 Count: Cardinal): Cardinal; virtual;
321 {Seeks a stream position}
322 function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
323 end;
324
325 {File stream modes}
326 TFileStreamMode = (fsmRead, fsmWrite, fsmCreate);
327 TFileStreamModeSet = set of TFileStreamMode;
328
329 {File stream for reading from files}
330 TFileStream = class(TStream)
331 private
332 {Opened mode}
333 Filemode: TFileStreamModeSet;
334 {Handle}
335 fHandle: THandle;
336 protected
337 {Set the size of the file}
338 procedure SetSize(const Value: Longint); override;
339 public
340 {Seeks a file position}
341 function Seek(Offset: Longint; Origin: Word): Longint; override;
342 {Reads/writes data from/to the file}
343 function Read(var Buffer; Count: Longint): Cardinal; override;
344 function Write(const Buffer; Count: Longint): Cardinal; override;
345 {Stream being created and destroy}
346 constructor Create(Filename: String; Mode: TFileStreamModeSet);
347 destructor Destroy; override;
348 end;
349
350 {Stream for reading from resources}
351 TResourceStream = class(TStream)
352 constructor Create(Instance: HInst; const ResName: String; ResType:PChar);
353 private
354 {Variables for reading}
355 Size: Integer;
356 Memory: Pointer;
357 Position: Integer;
358 protected
359 {Set the size of the file}
360 procedure SetSize(const Value: Longint); override;
361 public
362 {Stream processing}
363 function Read(var Buffer; Count: Integer): Cardinal; override;
364 function Seek(Offset: Integer; Origin: Word): Longint; override;
365 function Write(const Buffer; Count: Longint): Cardinal; override;
366 end;
367 {$ENDIF}
368
369 {Forward}
370 TChunkIHDR = class;
371 {Interlace method}
372 TInterlaceMethod = (imNone, imAdam7);
373 {Compression level type}
374 TCompressionLevel = 0..9;
375 {Filters type}
376 TFilter = (pfNone, pfSub, pfUp, pfAverage, pfPaeth);
377 TFilters = set of TFilter;
378
379 {Png implementation object}
380 TPngObject = class{$IFDEF UseDelphi}(TGraphic){$ENDIF}
381 protected
382 {Inverse gamma table values}
383 InverseGamma: Array[Byte] of Byte;
384 procedure InitializeGamma;
385 private
386 {Temporary palette}
387 TempPalette: HPalette;
388 {Filters to test to encode}
389 fFilters: TFilters;
390 {Compression level for ZLIB}
391 fCompressionLevel: TCompressionLevel;
392 {Maximum size for IDAT chunks}
393 fMaxIdatSize: Integer;
394 {Returns if image is interlaced}
395 fInterlaceMethod: TInterlaceMethod;
396 {Chunks object}
397 fChunkList: TPngList;
398 {Clear all chunks in the list}
399 procedure ClearChunks;
400 {Returns if header is present}
401 function HeaderPresent: Boolean;
402 {Returns linesize and byte offset for pixels}
403 procedure GetPixelInfo(var LineSize, Offset: Cardinal);
404 procedure SetMaxIdatSize(const Value: Integer);
405 function GetAlphaScanline(const LineIndex: Integer): pByteArray;
406 function GetScanline(const LineIndex: Integer): Pointer;
407 {$IFDEF Store16bits}
408 function GetExtraScanline(const LineIndex: Integer): Pointer;
409 {$ENDIF}
410 function GetTransparencyMode: TPNGTransparencyMode;
411 function GetTransparentColor: TColor;
412 procedure SetTransparentColor(const Value: TColor);
413 protected
414 {Returns the image palette}
415 function GetPalette: HPALETTE; {$IFDEF UseDelphi}override;{$ENDIF}
416 {Returns/sets image width and height}
417 function GetWidth: Integer; {$IFDEF UseDelphi}override;{$ENDIF}
418 function GetHeight: Integer; {$IFDEF UseDelphi}override; {$ENDIF}
419 procedure SetWidth(Value: Integer); {$IFDEF UseDelphi}override; {$ENDIF}
420 procedure SetHeight(Value: Integer); {$IFDEF UseDelphi}override;{$ENDIF}
421 {Assigns from another TPNGObject}
422 procedure AssignPNG(Source: TPNGObject);
423 {Returns if the image is empty}
424 function GetEmpty: Boolean; {$IFDEF UseDelphi}override; {$ENDIF}
425 {Used with property Header}
426 function GetHeader: TChunkIHDR;
427 {Draws using partial transparency}
428 procedure DrawPartialTrans(DC: HDC; Rect: TRect);
429 {$IFDEF UseDelphi}
430 {Returns if the image is transparent}
431 function GetTransparent: Boolean; override;
432 {$ENDIF}
433 {Returns a pixel}
434 function GetPixels(const X, Y: Integer): TColor; virtual;
435 procedure SetPixels(const X, Y: Integer; const Value: TColor); virtual;
436 public
437 {Gamma table array}
438 GammaTable: Array[Byte] of Byte;
439 {Generates alpha information}
440 procedure CreateAlpha;
441 {Removes the image transparency}
442 procedure RemoveTransparency;
443 {Transparent color}
444 property TransparentColor: TColor read GetTransparentColor write
445 SetTransparentColor;
446 {Add text chunk, TChunkTEXT, TChunkzTXT}
447 procedure AddtEXt(const Keyword, Text: String);
448 procedure AddzTXt(const Keyword, Text: String);
449 {$IFDEF UseDelphi}
450 {Saves to clipboard format (thanks to Antoine Pottern)}
451 procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
452 var APalette: HPalette); override;
453 procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
454 APalette: HPalette); override;
455 {$ENDIF}
456 {Calling errors}
457 procedure RaiseError(ExceptionClass: ExceptClass; Text: String);
458 {Returns a scanline from png}
459 property Scanline[const Index: Integer]: Pointer read GetScanline;
460 {$IFDEF Store16bits}
461 property ExtraScanline[const Index: Integer]: Pointer read GetExtraScanline;
462 {$ENDIF}
463 property AlphaScanline[const Index: Integer]: pByteArray read GetAlphaScanline;
464 {Returns pointer to the header}
465 property Header: TChunkIHDR read GetHeader;
466 {Returns the transparency mode used by this png}
467 property TransparencyMode: TPNGTransparencyMode read GetTransparencyMode;
468 {Assigns from another object}
469 procedure Assign(Source: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF}
470 {Assigns to another object}
471 procedure AssignTo(Dest: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF}
472 {Assigns from a windows bitmap handle}
473 procedure AssignHandle(Handle: HBitmap; Transparent: Boolean;
474 TransparentColor: ColorRef);
475 {Draws the image into a canvas}
476 procedure Draw(ACanvas: TCanvas; const Rect: TRect);
477 {$IFDEF UseDelphi}override;{$ENDIF}
478 {Width and height properties}
479 property Width: Integer read GetWidth;
480 property Height: Integer read GetHeight;
481 {Returns if the image is interlaced}
482 property InterlaceMethod: TInterlaceMethod read fInterlaceMethod
483 write fInterlaceMethod;
484 {Filters to test to encode}
485 property Filters: TFilters read fFilters write fFilters;
486 {Maximum size for IDAT chunks, default and minimum is 65536}
487 property MaxIdatSize: Integer read fMaxIdatSize write SetMaxIdatSize;
488 {Property to return if the image is empty or not}
489 property Empty: Boolean read GetEmpty;
490 {Compression level}
491 property CompressionLevel: TCompressionLevel read fCompressionLevel
492 write fCompressionLevel;
493 {Access to the chunk list}
494 property Chunks: TPngList read fChunkList;
495 {Object being created and destroyed}
496 constructor Create; {$IFDEF UseDelphi}override;{$ENDIF}
497 destructor Destroy; override;
498 {$IFNDEF UseDelphi}procedure LoadFromFile(const Filename: String);{$ENDIF}
499 {$IFNDEF UseDelphi}procedure SaveToFile(const Filename: String);{$ENDIF}
500 procedure LoadFromStream(Stream: TStream); {$IFDEF UseDelphi}override;{$ENDIF}
501 procedure SaveToStream(Stream: TStream); {$IFDEF UseDelphi}override;{$ENDIF}
502 {Loading the image from resources}
503 procedure LoadFromResourceName(Instance: HInst; const Name: String);
504 procedure LoadFromResourceID(Instance: HInst; ResID: Integer);
505 {Access to the png pixels}
506 property Pixels[const X, Y: Integer]: TColor read GetPixels write SetPixels;
507 {Palette property}
508 {$IFNDEF UseDelphi}property Palette: HPalette read GetPalette;{$ENDIF}
509 end;
510
511 {Chunk name object}
512 TChunkName = Array[0..3] of Char;
513
514 {Global chunk object}
515 TChunk = class
516 private
517 {Contains data}
518 fData: Pointer;
519 fDataSize: Cardinal;
520 {Stores owner}
521 fOwner: TPngObject;
522 {Stores the chunk name}
523 fName: TChunkName;
524 {Returns pointer to the TChunkIHDR}
525 function GetHeader: TChunkIHDR;
526 {Used with property index}
527 function GetIndex: Integer;
528 {Should return chunk class/name}
529 class function GetName: String; virtual;
530 {Returns the chunk name}
531 function GetChunkName: String;
532 public
533 {Returns index from list}
534 property Index: Integer read GetIndex;
535 {Returns pointer to the TChunkIHDR}
536 property Header: TChunkIHDR read GetHeader;
537 {Resize the data}
538 procedure ResizeData(const NewSize: Cardinal);
539 {Returns data and size}
540 property Data: Pointer read fData;
541 property DataSize: Cardinal read fDataSize;
542 {Assigns from another TChunk}
543 procedure Assign(Source: TChunk); virtual;
544 {Returns owner}
545 property Owner: TPngObject read fOwner;
546 {Being destroyed/created}
547 constructor Create(Owner: TPngObject); virtual;
548 destructor Destroy; override;
549 {Returns chunk class/name}
550 property Name: String read GetChunkName;
551 {Loads the chunk from a stream}
552 function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
553 Size: Integer): Boolean; virtual;
554 {Saves the chunk to a stream}
555 function SaveData(Stream: TStream): Boolean;
556 function SaveToStream(Stream: TStream): Boolean; virtual;
557 end;
558
559 {Chunk classes}
560 TChunkIEND = class(TChunk); {End chunk}
561
562 {IHDR data}
563 pIHDRData = ^TIHDRData;
564 TIHDRData = packed record
565 Width, Height: Cardinal;
566 BitDepth,
567 ColorType,
568 CompressionMethod,
569 FilterMethod,
570 InterlaceMethod: Byte;
571 end;
572
573 {Information header chunk}
574 TChunkIHDR = class(TChunk)
575 private
576 {Current image}
577 ImageHandle: HBitmap;
578 ImageDC: HDC;
579 {Output windows bitmap}
580 HasPalette: Boolean;
581 BitmapInfo: TMaxBitmapInfo;
582 BytesPerRow: Integer;
583 {Stores the image bytes}
584 {$IFDEF Store16bits}ExtraImageData: Pointer;{$ENDIF}
585 ImageData: pointer;
586 ImageAlpha: Pointer;
587
588 {Contains all the ihdr data}
589 IHDRData: TIHDRData;
590 protected
591 {Resizes the image data to fill the color type, bit depth, }
592 {width and height parameters}
593 procedure PrepareImageData;
594 {Release allocated ImageData memory}
595 procedure FreeImageData;
596 public
597 {Access to ImageHandle}
598 property ImageHandleValue: HBitmap read ImageHandle;
599 {Properties}
600 property Width: Cardinal read IHDRData.Width write IHDRData.Width;
601 property Height: Cardinal read IHDRData.Height write IHDRData.Height;
602 property BitDepth: Byte read IHDRData.BitDepth write IHDRData.BitDepth;
603 property ColorType: Byte read IHDRData.ColorType write IHDRData.ColorType;
604 property CompressionMethod: Byte read IHDRData.CompressionMethod
605 write IHDRData.CompressionMethod;
606 property FilterMethod: Byte read IHDRData.FilterMethod
607 write IHDRData.FilterMethod;
608 property InterlaceMethod: Byte read IHDRData.InterlaceMethod
609 write IHDRData.InterlaceMethod;
610 {Loads the chunk from a stream}
611 function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
612 Size: Integer): Boolean; override;
613 {Saves the chunk to a stream}
614 function SaveToStream(Stream: TStream): Boolean; override;
615 {Destructor/constructor}
616 constructor Create(Owner: TPngObject); override;
617 destructor Destroy; override;
618 {Assigns from another TChunk}
619 procedure Assign(Source: TChunk); override;
620 end;
621
622 {Gamma chunk}
623 TChunkgAMA = class(TChunk)
624 private
625 {Returns/sets the value for the gamma chunk}
626 function GetValue: Cardinal;
627 procedure SetValue(const Value: Cardinal);
628 public
629 {Returns/sets gamma value}
630 property Gamma: Cardinal read GetValue write SetValue;
631 {Loading the chunk from a stream}
632 function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
633 Size: Integer): Boolean; override;
634 {Being created}
635 constructor Create(Owner: TPngObject); override;
636 {Assigns from another TChunk}
637 procedure Assign(Source: TChunk); override;
638 end;
639
640 {ZLIB Decompression extra information}
641 TZStreamRec2 = packed record
642 {From ZLIB}
643 ZLIB: TZStreamRec;
644 {Additional info}
645 Data: Pointer;
646 fStream : TStream;
647 end;
648
649 {Palette chunk}
650 TChunkPLTE = class(TChunk)
651 private
652 {Number of items in the palette}
653 fCount: Integer;
654 {Contains the palette handle}
655 function GetPaletteItem(Index: Byte): TRGBQuad;
656 public
657 {Returns the color for each item in the palette}
658 property Item[Index: Byte]: TRGBQuad read GetPaletteItem;
659 {Returns the number of items in the palette}
660 property Count: Integer read fCount;
661 {Loads the chunk from a stream}
662 function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
663 Size: Integer): Boolean; override;
664 {Saves the chunk to a stream}
665 function SaveToStream(Stream: TStream): Boolean; override;
666 {Assigns from another TChunk}
667 procedure Assign(Source: TChunk); override;
668 end;
669
670 {Transparency information}
671 TChunktRNS = class(TChunk)
672 private
673 fBitTransparency: Boolean;
674 function GetTransparentColor: ColorRef;
675 {Returns the transparent color}
676 procedure SetTransparentColor(const Value: ColorRef);
677 public
678 {Palette values for transparency}
679 PaletteValues: Array[Byte] of Byte;
680 {Returns if it uses bit transparency}
681 property BitTransparency: Boolean read fBitTransparency;
682 {Returns the transparent color}
683 property TransparentColor: ColorRef read GetTransparentColor write
684 SetTransparentColor;
685 {Loads/saves the chunk from/to a stream}
686 function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
687 Size: Integer): Boolean; override;
688 function SaveToStream(Stream: TStream): Boolean; override;
689 {Assigns from another TChunk}
690 procedure Assign(Source: TChunk); override;
691 end;
692
693 {Actual image information}
694 TChunkIDAT = class(TChunk)
695 private
696 {Holds another pointer to the TChunkIHDR}
697 Header: TChunkIHDR;
698 {Stores temporary image width and height}
699 ImageWidth, ImageHeight: Integer;
700 {Size in bytes of each line and offset}
701 Row_Bytes, Offset : Cardinal;
702 {Contains data for the lines}
703 Encode_Buffer: Array[0..5] of pByteArray;
704 Row_Buffer: Array[Boolean] of pByteArray;
705 {Variable to invert the Row_Buffer used}
706 RowUsed: Boolean;
707 {Ending position for the current IDAT chunk}
708 EndPos: Integer;
709 {Filter the current line}
710 procedure FilterRow;
711 {Filter to encode and returns the best filter}
712 function FilterToEncode: Byte;
713 {Reads ZLIB compressed data}
714 function IDATZlibRead(var ZLIBStream: TZStreamRec2; Buffer: Pointer;
715 Count: Integer; var EndPos: Integer; var crcfile: Cardinal): Integer;
716 {Compress and writes IDAT data}
717 procedure IDATZlibWrite(var ZLIBStream: TZStreamRec2; Buffer: Pointer;
718 const Length: Cardinal);
719 procedure FinishIDATZlib(var ZLIBStream: TZStreamRec2);
720 {Prepares the palette}
721 procedure PreparePalette;
722 protected
723 {Decode interlaced image}
724 procedure DecodeInterlacedAdam7(Stream: TStream;
725 var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal);
726 {Decode non interlaced imaged}
727 procedure DecodeNonInterlaced(Stream: TStream;
728 var ZLIBStream: TZStreamRec2; const Size: Integer;
729 var crcfile: Cardinal);
730 protected
731 {Encode non interlaced images}
732 procedure EncodeNonInterlaced(Stream: TStream;
733 var ZLIBStream: TZStreamRec2);
734 {Encode interlaced images}
735 procedure EncodeInterlacedAdam7(Stream: TStream;
736 var ZLIBStream: TZStreamRec2);
737 protected
738 {Memory copy methods to decode}
739 procedure CopyNonInterlacedRGB8(
740 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
741 procedure CopyNonInterlacedRGB16(
742 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
743 procedure CopyNonInterlacedPalette148(
744 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
745 procedure CopyNonInterlacedPalette2(
746 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
747 procedure CopyNonInterlacedGray2(
748 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
749 procedure CopyNonInterlacedGrayscale16(
750 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
751 procedure CopyNonInterlacedRGBAlpha8(
752 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
753 procedure CopyNonInterlacedRGBAlpha16(
754 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
755 procedure CopyNonInterlacedGrayscaleAlpha8(
756 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
757 procedure CopyNonInterlacedGrayscaleAlpha16(
758 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
759 procedure CopyInterlacedRGB8(const Pass: Byte;
760 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
761 procedure CopyInterlacedRGB16(const Pass: Byte;
762 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
763 procedure CopyInterlacedPalette148(const Pass: Byte;
764 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
765 procedure CopyInterlacedPalette2(const Pass: Byte;
766 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
767 procedure CopyInterlacedGray2(const Pass: Byte;
768 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
769 procedure CopyInterlacedGrayscale16(const Pass: Byte;
770 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
771 procedure CopyInterlacedRGBAlpha8(const Pass: Byte;
772 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
773 procedure CopyInterlacedRGBAlpha16(const Pass: Byte;
774 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
775 procedure CopyInterlacedGrayscaleAlpha8(const Pass: Byte;
776 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
777 procedure CopyInterlacedGrayscaleAlpha16(const Pass: Byte;
778 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
779 protected
780 {Memory copy methods to encode}
781 procedure EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar);
782 procedure EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar);
783 procedure EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar);
784 procedure EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar);
785 procedure EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar);
786 procedure EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar);
787 procedure EncodeNonInterlacedGrayscaleAlpha8(Src, Dest, Trans: pChar);
788 procedure EncodeNonInterlacedGrayscaleAlpha16(Src, Dest, Trans: pChar);
789 procedure EncodeInterlacedRGB8(const Pass: Byte; Src, Dest, Trans: pChar);
790 procedure EncodeInterlacedRGB16(const Pass: Byte; Src, Dest, Trans: pChar);
791 procedure EncodeInterlacedPalette148(const Pass: Byte;
792 Src, Dest, Trans: pChar);
793 procedure EncodeInterlacedGrayscale16(const Pass: Byte;
794 Src, Dest, Trans: pChar);
795 procedure EncodeInterlacedRGBAlpha8(const Pass: Byte;
796 Src, Dest, Trans: pChar);
797 procedure EncodeInterlacedRGBAlpha16(const Pass: Byte;
798 Src, Dest, Trans: pChar);
799 procedure EncodeInterlacedGrayscaleAlpha8(const Pass: Byte;
800 Src, Dest, Trans: pChar);
801 procedure EncodeInterlacedGrayscaleAlpha16(const Pass: Byte;
802 Src, Dest, Trans: pChar);
803 public
804 {Loads the chunk from a stream}
805 function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
806 Size: Integer): Boolean; override;
807 {Saves the chunk to a stream}
808 function SaveToStream(Stream: TStream): Boolean; override;
809 end;
810
811 {Image last modification chunk}
812 TChunktIME = class(TChunk)
813 private
814 {Holds the variables}
815 fYear: Word;
816 fMonth, fDay, fHour, fMinute, fSecond: Byte;
817 public
818 {Returns/sets variables}
819 property Year: Word read fYear write fYear;
820 property Month: Byte read fMonth write fMonth;
821 property Day: Byte read fDay write fDay;
822 property Hour: Byte read fHour write fHour;
823 property Minute: Byte read fMinute write fMinute;
824 property Second: Byte read fSecond write fSecond;
825 {Loads the chunk from a stream}
826 function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
827 Size: Integer): Boolean; override;
828 {Saves the chunk to a stream}
829 function SaveToStream(Stream: TStream): Boolean; override;
830 end;
831
832 {Textual data}
833 TChunktEXt = class(TChunk)
834 private
835 fKeyword, fText: String;
836 public
837 {Keyword and text}
838 property Keyword: String read fKeyword write fKeyword;
839 property Text: String read fText write fText;
840 {Loads the chunk from a stream}
841 function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
842 Size: Integer): Boolean; override;
843 {Saves the chunk to a stream}
844 function SaveToStream(Stream: TStream): Boolean; override;
845 {Assigns from another TChunk}
846 procedure Assign(Source: TChunk); override;
847 end;
848
849 {zTXT chunk}
850 TChunkzTXt = class(TChunktEXt)
851 {Loads the chunk from a stream}
852 function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
853 Size: Integer): Boolean; override;
854 {Saves the chunk to a stream}
855 function SaveToStream(Stream: TStream): Boolean; override;
856 end;
857
858{Here we test if it's c++ builder or delphi version 3 or less}
859{$IFDEF VER110}{$DEFINE DelphiBuilder3Less}{$ENDIF}
860{$IFDEF VER100}{$DEFINE DelphiBuilder3Less}{$ENDIF}
861{$IFDEF VER93}{$DEFINE DelphiBuilder3Less}{$ENDIF}
862{$IFDEF VER90}{$DEFINE DelphiBuilder3Less}{$ENDIF}
863{$IFDEF VER80}{$DEFINE DelphiBuilder3Less}{$ENDIF}
864
865
866{Registers a new chunk class}
867procedure RegisterChunk(ChunkClass: TChunkClass);
868{Calculates crc}
869function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer
870 {$ENDIF}; buf: pByteArray; len: Integer): Cardinal;
871{Invert bytes using assembly}
872function ByteSwap(const a: integer): integer;
873
874implementation
875
876var
877 ChunkClasses: TPngPointerList;
878 {Table of CRCs of all 8-bit messages}
879 crc_table: Array[0..255] of Cardinal;
880 {Flag: has the table been computed? Initially false}
881 crc_table_computed: Boolean;
882
883{Draw transparent image using transparent color}
884procedure DrawTransparentBitmap(dc: HDC; srcBits: Pointer;
885 var srcHeader: TBitmapInfoHeader;
886 srcBitmapInfo: pBitmapInfo; Rect: TRect; cTransparentColor: COLORREF);
887var
888 cColor: COLORREF;
889 bmAndBack, bmAndObject, bmAndMem: HBITMAP;
890 bmBackOld, bmObjectOld, bmMemOld: HBITMAP;
891 hdcMem, hdcBack, hdcObject, hdcTemp: HDC;
892 ptSize, orgSize: TPOINT;
893 OldBitmap, DrawBitmap: HBITMAP;
894begin
895 hdcTemp := CreateCompatibleDC(dc);
896 // Select the bitmap
897 DrawBitmap := CreateDIBitmap(dc, srcHeader, CBM_INIT, srcBits, srcBitmapInfo^,
898 DIB_RGB_COLORS);
899 OldBitmap := SelectObject(hdcTemp, DrawBitmap);
900
901 // Sizes
902 OrgSize.x := abs(srcHeader.biWidth);
903 OrgSize.y := abs(srcHeader.biHeight);
904 ptSize.x := Rect.Right - Rect.Left; // Get width of bitmap
905 ptSize.y := Rect.Bottom - Rect.Top; // Get height of bitmap
906
907 // Create some DCs to hold temporary data.
908 hdcBack := CreateCompatibleDC(dc);
909 hdcObject := CreateCompatibleDC(dc);
910 hdcMem := CreateCompatibleDC(dc);
911
912 // Create a bitmap for each DC. DCs are required for a number of
913 // GDI functions.
914
915 // Monochrome DCs
916 bmAndBack := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
917 bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
918
919 bmAndMem := CreateCompatibleBitmap(dc, ptSize.x, ptSize.y);
920
921 // Each DC must select a bitmap object to store pixel data.
922 bmBackOld := SelectObject(hdcBack, bmAndBack);
923 bmObjectOld := SelectObject(hdcObject, bmAndObject);
924 bmMemOld := SelectObject(hdcMem, bmAndMem);
925
926 // Set the background color of the source DC to the color.
927 // contained in the parts of the bitmap that should be transparent
928 cColor := SetBkColor(hdcTemp, cTransparentColor);
929
930 // Create the object mask for the bitmap by performing a BitBlt
931 // from the source bitmap to a monochrome bitmap.
932 StretchBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0,
933 orgSize.x, orgSize.y, SRCCOPY);
934
935 // Set the background color of the source DC back to the original
936 // color.
937 SetBkColor(hdcTemp, cColor);
938
939 // Create the inverse of the object mask.
940 BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0,
941 NOTSRCCOPY);
942
943 // Copy the background of the main DC to the destination.
944 BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, dc, Rect.Left, Rect.Top,
945 SRCCOPY);
946
947 // Mask out the places where the bitmap will be placed.
948 BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);
949
950 // Mask out the transparent colored pixels on the bitmap.
951// BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);
952 StretchBlt(hdcTemp, 0, 0, OrgSize.x, OrgSize.y, hdcBack, 0, 0,
953 PtSize.x, PtSize.y, SRCAND);
954
955 // XOR the bitmap with the background on the destination DC.
956 StretchBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0,
957 OrgSize.x, OrgSize.y, SRCPAINT);
958
959 // Copy the destination to the screen.
960 BitBlt(dc, Rect.Left, Rect.Top, ptSize.x, ptSize.y, hdcMem, 0, 0,
961 SRCCOPY);
962
963 // Delete the memory bitmaps.
964 DeleteObject(SelectObject(hdcBack, bmBackOld));
965 DeleteObject(SelectObject(hdcObject, bmObjectOld));
966 DeleteObject(SelectObject(hdcMem, bmMemOld));
967 DeleteObject(SelectObject(hdcTemp, OldBitmap));
968
969 // Delete the memory DCs.
970 DeleteDC(hdcMem);
971 DeleteDC(hdcBack);
972 DeleteDC(hdcObject);
973 DeleteDC(hdcTemp);
974end;
975
976{Make the table for a fast CRC.}
977procedure make_crc_table;
978var
979 c: Cardinal;
980 n, k: Integer;
981begin
982
983 {fill the crc table}
984 for n := 0 to 255 do
985 begin
986 c := Cardinal(n);
987 for k := 0 to 7 do
988 begin
989 if Boolean(c and 1) then
990 c := $edb88320 xor (c shr 1)
991 else
992 c := c shr 1;
993 end;
994 crc_table[n] := c;
995 end;
996
997 {The table has already being computated}
998 crc_table_computed := true;
999end;
1000
1001{Update a running CRC with the bytes buf[0..len-1]--the CRC
1002 should be initialized to all 1's, and the transmitted value
1003 is the 1's complement of the final running CRC (see the
1004 crc() routine below)).}
1005function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer
1006 {$ENDIF}; buf: pByteArray; len: Integer): Cardinal;
1007var
1008 c: Cardinal;
1009 n: Integer;
1010begin
1011 c := crc;
1012
1013 {Create the crc table in case it has not being computed yet}
1014 if not crc_table_computed then make_crc_table;
1015
1016 {Update}
1017 for n := 0 to len - 1 do
1018 c := crc_table[(c XOR buf^[n]) and $FF] XOR (c shr 8);
1019
1020 {Returns}
1021 Result := c;
1022end;
1023
1024{$IFNDEF UseDelphi}
1025 function FileExists(Filename: String): Boolean;
1026 var
1027 FindFile: THandle;
1028 FindData: TWin32FindData;
1029 begin
1030 FindFile := FindFirstFile(PChar(Filename), FindData);
1031 Result := FindFile <> INVALID_HANDLE_VALUE;
1032 if Result then Windows.FindClose(FindFile);
1033 end;
1034
1035
1036{$ENDIF}
1037
1038{$IFNDEF UseDelphi}
1039 {Exception implementation}
1040 constructor Exception.Create(Msg: String);
1041 begin
1042 end;
1043{$ENDIF}
1044
1045{Calculates the paeth predictor}
1046function PaethPredictor(a, b, c: Byte): Byte;
1047var
1048 pa, pb, pc: Integer;
1049begin
1050 { a = left, b = above, c = upper left }
1051 pa := abs(b - c); { distances to a, b, c }
1052 pb := abs(a - c);
1053 pc := abs(a + b - c * 2);
1054
1055 { return nearest of a, b, c, breaking ties in order a, b, c }
1056 if (pa <= pb) and (pa <= pc) then
1057 Result := a
1058 else
1059 if pb <= pc then
1060 Result := b
1061 else
1062 Result := c;
1063end;
1064
1065{Invert bytes using assembly}
1066function ByteSwap(const a: integer): integer;
1067asm
1068 bswap eax
1069end;
1070function ByteSwap16(inp:word): word;
1071asm
1072 bswap eax
1073 shr eax, 16
1074end;
1075
1076{Calculates number of bytes for the number of pixels using the}
1077{color mode in the paramenter}
1078function BytesForPixels(const Pixels: Integer; const ColorType,
1079 BitDepth: Byte): Integer;
1080begin
1081 case ColorType of
1082 {Palette and grayscale contains a single value, for palette}
1083 {an value of size 2^bitdepth pointing to the palette index}
1084 {and grayscale the value from 0 to 2^bitdepth with color intesity}
1085 COLOR_GRAYSCALE, COLOR_PALETTE:
1086 Result := (Pixels * BitDepth + 7) div 8;
1087 {RGB contains 3 values R, G, B with size 2^bitdepth each}
1088 COLOR_RGB:
1089 Result := (Pixels * BitDepth * 3) div 8;
1090 {Contains one value followed by alpha value booth size 2^bitdepth}
1091 COLOR_GRAYSCALEALPHA:
1092 Result := (Pixels * BitDepth * 2) div 8;
1093 {Contains four values size 2^bitdepth, Red, Green, Blue and alpha}
1094 COLOR_RGBALPHA:
1095 Result := (Pixels * BitDepth * 4) div 8;
1096 else
1097 Result := 0;
1098 end {case ColorType}
1099end;
1100
1101type
1102 pChunkClassInfo = ^TChunkClassInfo;
1103 TChunkClassInfo = record
1104 ClassName: TChunkClass;
1105 end;
1106
1107{Register a chunk type}
1108procedure RegisterChunk(ChunkClass: TChunkClass);
1109var
1110 NewClass: pChunkClassInfo;
1111begin
1112 {In case the list object has not being created yet}
1113 if ChunkClasses = nil then ChunkClasses := TPngPointerList.Create(nil);
1114
1115 {Add this new class}
1116 new(NewClass);
1117 NewClass^.ClassName := ChunkClass;
1118 ChunkClasses.Add(NewClass);
1119end;
1120
1121{Free chunk class list}
1122procedure FreeChunkClassList;
1123var
1124 i: Integer;
1125begin
1126 if (ChunkClasses <> nil) then
1127 begin
1128 FOR i := 0 TO ChunkClasses.Count - 1 do
1129 Dispose(pChunkClassInfo(ChunkClasses.Item[i]));
1130 ChunkClasses.Free;
1131 end;
1132end;
1133
1134{Registering of common chunk classes}
1135procedure RegisterCommonChunks;
1136begin
1137 {Important chunks}
1138 RegisterChunk(TChunkIEND);
1139 RegisterChunk(TChunkIHDR);
1140 RegisterChunk(TChunkIDAT);
1141 RegisterChunk(TChunkPLTE);
1142 RegisterChunk(TChunkgAMA);
1143 RegisterChunk(TChunktRNS);
1144
1145 {Not so important chunks}
1146 RegisterChunk(TChunktIME);
1147 RegisterChunk(TChunktEXt);
1148 RegisterChunk(TChunkzTXt);
1149end;
1150
1151{Creates a new chunk of this class}
1152function CreateClassChunk(Owner: TPngObject; Name: TChunkName): TChunk;
1153var
1154 i : Integer;
1155 NewChunk: TChunkClass;
1156begin
1157 {Looks for this chunk}
1158 NewChunk := TChunk; {In case there is no registered class for this}
1159
1160 {Looks for this class in all registered chunks}
1161 if Assigned(ChunkClasses) then
1162 FOR i := 0 TO ChunkClasses.Count - 1 DO
1163 begin
1164 if pChunkClassInfo(ChunkClasses.Item[i])^.ClassName.GetName = Name then
1165 begin
1166 NewChunk := pChunkClassInfo(ChunkClasses.Item[i])^.ClassName;
1167 break;
1168 end;
1169 end;
1170
1171 {Returns chunk class}
1172 Result := NewChunk.Create(Owner);
1173 Result.fName := Name;
1174end;
1175
1176{ZLIB support}
1177
1178const
1179 ZLIBAllocate = High(Word);
1180
1181{Initializes ZLIB for decompression}
1182function ZLIBInitInflate(Stream: TStream): TZStreamRec2;
1183begin
1184 {Fill record}
1185 Fillchar(Result, SIZEOF(TZStreamRec2), #0);
1186
1187 {Set internal record information}
1188 with Result do
1189 begin
1190 GetMem(Data, ZLIBAllocate);
1191 fStream := Stream;
1192 end;
1193
1194 {Init decompression}
1195 InflateInit_(Result.zlib, zlib_version, SIZEOF(TZStreamRec));
1196end;
1197
1198{Initializes ZLIB for compression}
1199function ZLIBInitDeflate(Stream: TStream;
1200 Level: TCompressionlevel; Size: Cardinal): TZStreamRec2;
1201begin
1202 {Fill record}
1203 Fillchar(Result, SIZEOF(TZStreamRec2), #0);
1204
1205 {Set internal record information}
1206 with Result, ZLIB do
1207 begin
1208 GetMem(Data, Size);
1209 fStream := Stream;
1210 next_out := Data;
1211 avail_out := Size;
1212 end;
1213
1214 {Inits compression}
1215 deflateInit_(Result.zlib, Level, zlib_version, sizeof(TZStreamRec));
1216end;
1217
1218{Terminates ZLIB for compression}
1219procedure ZLIBTerminateDeflate(var ZLIBStream: TZStreamRec2);
1220begin
1221 {Terminates decompression}
1222 DeflateEnd(ZLIBStream.zlib);
1223 {Free internal record}
1224 FreeMem(ZLIBStream.Data, ZLIBAllocate);
1225end;
1226
1227{Terminates ZLIB for decompression}
1228procedure ZLIBTerminateInflate(var ZLIBStream: TZStreamRec2);
1229begin
1230 {Terminates decompression}
1231 InflateEnd(ZLIBStream.zlib);
1232 {Free internal record}
1233 FreeMem(ZLIBStream.Data, ZLIBAllocate);
1234end;
1235
1236{Decompresses ZLIB into a memory address}
1237function DecompressZLIB(const Input: Pointer; InputSize: Integer;
1238 var Output: Pointer; var OutputSize: Integer;
1239 var ErrorOutput: String): Boolean;
1240var
1241 StreamRec : TZStreamRec;
1242 Buffer : Array[Byte] of Byte;
1243 InflateRet: Integer;
1244begin
1245 with StreamRec do
1246 begin
1247 {Initializes}
1248 Result := True;
1249 OutputSize := 0;
1250
1251 {Prepares the data to decompress}
1252 FillChar(StreamRec, SizeOf(TZStreamRec), #0);
1253 InflateInit_(StreamRec, zlib_version, SIZEOF(TZStreamRec));
1254 next_in := Input;
1255 avail_in := InputSize;
1256
1257 {Decodes data}
1258 repeat
1259 {In case it needs an output buffer}
1260 if (avail_out = 0) then
1261 begin
1262 next_out := @Buffer;
1263 avail_out := SizeOf(Buffer);
1264 end {if (avail_out = 0)};
1265
1266 {Decompress and put in output}
1267 InflateRet := inflate(StreamRec, 0);
1268 if (InflateRet = Z_STREAM_END) or (InflateRet = 0) then
1269 begin
1270 {Reallocates output buffer}
1271 inc(OutputSize, total_out);
1272 if Output = nil then
1273 GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize);
1274 {Copies the new data}
1275 CopyMemory(Ptr(Longint(Output) + OutputSize - total_out),
1276 @Buffer, total_out);
1277 end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)}
1278 {Now tests for errors}
1279 else if InflateRet < 0 then
1280 begin
1281 Result := False;
1282 ErrorOutput := StreamRec.msg;
1283 InflateEnd(StreamRec);
1284 Exit;
1285 end {if InflateRet < 0}
1286 until InflateRet = Z_STREAM_END;
1287
1288 {Terminates decompression}
1289 InflateEnd(StreamRec);
1290 end {with StreamRec}
1291
1292end;
1293
1294{Compresses ZLIB into a memory address}
1295function CompressZLIB(Input: Pointer; InputSize, CompressionLevel: Integer;
1296 var Output: Pointer; var OutputSize: Integer;
1297 var ErrorOutput: String): Boolean;
1298var
1299 StreamRec : TZStreamRec;
1300 Buffer : Array[Byte] of Byte;
1301 DeflateRet: Integer;
1302begin
1303 with StreamRec do
1304 begin
1305 Result := True; {By default returns TRUE as everything might have gone ok}
1306 OutputSize := 0; {Initialize}
1307 {Prepares the data to compress}
1308 FillChar(StreamRec, SizeOf(TZStreamRec), #0);
1309 DeflateInit_(StreamRec, CompressionLevel,zlib_version, SIZEOF(TZStreamRec));
1310
1311 next_in := Input;
1312 avail_in := InputSize;
1313
1314 while avail_in > 0 do
1315 begin
1316 {When it needs new buffer to stores the compressed data}
1317 if avail_out = 0 then
1318 begin
1319 {Restore buffer}
1320 next_out := @Buffer;
1321 avail_out := SizeOf(Buffer);
1322 end {if avail_out = 0};
1323
1324 {Compresses}
1325 DeflateRet := deflate(StreamRec, Z_FINISH);
1326
1327 if (DeflateRet = Z_STREAM_END) or (DeflateRet = 0) then
1328 begin
1329 {Updates the output memory}
1330 inc(OutputSize, total_out);
1331 if Output = nil then
1332 GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize);
1333
1334 {Copies the new data}
1335 CopyMemory(Ptr(Longint(Output) + OutputSize - total_out),
1336 @Buffer, total_out);
1337 end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)}
1338 {Now tests for errors}
1339 else if DeflateRet < 0 then
1340 begin
1341 Result := False;
1342 ErrorOutput := StreamRec.msg;
1343 DeflateEnd(StreamRec);
1344 Exit;
1345 end {if InflateRet < 0}
1346
1347 end {while avail_in > 0};
1348
1349 {Finishes compressing}
1350 DeflateEnd(StreamRec);
1351 end {with StreamRec}
1352
1353end;
1354
1355{TPngPointerList implementation}
1356
1357{Object being created}
1358constructor TPngPointerList.Create(AOwner: TPNGObject);
1359begin
1360 inherited Create; {Let ancestor work}
1361 {Holds owner}
1362 fOwner := AOwner;
1363 {Memory pointer not being used yet}
1364 fMemory := nil;
1365 {No items yet}
1366 fCount := 0;
1367end;
1368
1369{Removes value from the list}
1370function TPngPointerList.Remove(Value: Pointer): Pointer;
1371var
1372 I, Position: Integer;
1373begin
1374 {Gets item position}
1375 Position := -1;
1376 FOR I := 0 TO Count - 1 DO
1377 if Value = Item[I] then Position := I;
1378 {In case a match was found}
1379 if Position >= 0 then
1380 begin
1381 Result := Item[Position]; {Returns pointer}
1382 {Remove item and move memory}
1383 Dec(fCount);
1384 if Position < Integer(FCount) then
1385 System.Move(fMemory^[Position + 1], fMemory^[Position],
1386 (Integer(fCount) - Position) * SizeOf(Pointer));
1387 end {if Position >= 0} else Result := nil
1388end;
1389
1390{Add a new value in the list}
1391procedure TPngPointerList.Add(Value: Pointer);
1392begin
1393 Count := Count + 1;
1394 Item[Count - 1] := Value;
1395end;
1396
1397
1398{Object being destroyed}
1399destructor TPngPointerList.Destroy;
1400begin
1401 {Release memory if needed}
1402 if fMemory <> nil then
1403 FreeMem(fMemory, fCount * sizeof(Pointer));
1404
1405 {Free things}
1406 inherited Destroy;
1407end;
1408
1409{Returns one item from the list}
1410function TPngPointerList.GetItem(Index: Cardinal): Pointer;
1411begin
1412 if (Index <= Count - 1) then
1413 Result := fMemory[Index]
1414 else
1415 {In case it's out of bounds}
1416 Result := nil;
1417end;
1418
1419{Inserts a new item in the list}
1420procedure TPngPointerList.Insert(Value: Pointer; Position: Cardinal);
1421begin
1422 if (Position < Count) then
1423 begin
1424 {Increase item count}
1425 SetSize(Count + 1);
1426 {Move other pointers}
1427 if Position < Count then
1428 System.Move(fMemory^[Position], fMemory^[Position + 1],
1429 (Count - Position - 1) * SizeOf(Pointer));
1430 {Sets item}
1431 Item[Position] := Value;
1432 end;
1433end;
1434
1435{Sets one item from the list}
1436procedure TPngPointerList.SetItem(Index: Cardinal; const Value: Pointer);
1437begin
1438 {If index is in bounds, set value}
1439 if (Index <= Count - 1) then
1440 fMemory[Index] := Value
1441end;
1442
1443{This method resizes the list}
1444procedure TPngPointerList.SetSize(const Size: Cardinal);
1445begin
1446 {Sets the size}
1447 if (fMemory = nil) and (Size > 0) then
1448 GetMem(fMemory, Size * SIZEOF(Pointer))
1449 else
1450 if Size > 0 then {Only realloc if the new size is greater than 0}
1451 ReallocMem(fMemory, Size * SIZEOF(Pointer))
1452 else
1453 {In case user is resize to 0 items}
1454 begin
1455 FreeMem(fMemory);
1456 fMemory := nil;
1457 end;
1458 {Update count}
1459 fCount := Size;
1460end;
1461
1462{TPNGList implementation}
1463
1464{Removes an item}
1465procedure TPNGList.RemoveChunk(Chunk: TChunk);
1466begin
1467 Remove(Chunk);
1468 Chunk.Free
1469end;
1470
1471{Add a new item}
1472function TPNGList.Add(ChunkClass: TChunkClass): TChunk;
1473var
1474 IHDR: TChunkIHDR;
1475 IEND: TChunkIEND;
1476
1477 IDAT: TChunkIDAT;
1478 PLTE: TChunkPLTE;
1479begin
1480 Result := nil; {Default result}
1481 {Adding these is not allowed}
1482 if (ChunkClass = TChunkIHDR) or (ChunkClass = TChunkIDAT) or
1483 (ChunkClass = TChunkPLTE) or (ChunkClass = TChunkIEND) then
1484 fOwner.RaiseError(EPngError, EPNGCannotAddChunkText)
1485 {Two of these is not allowed}
1486 else if ((ChunkClass = TChunkgAMA) and (ItemFromClass(TChunkgAMA) <> nil)) or
1487 ((ChunkClass = TChunktRNS) and (ItemFromClass(TChunktRNS) <> nil)) then
1488 fOwner.RaiseError(EPngError, EPNGCannotAddChunkText)
1489 {There must have an IEND and IHDR chunk}
1490 else if (ItemFromClass(TChunkIEND) = nil) or
1491 (ItemFromClass(TChunkIHDR) = nil) then
1492 fOwner.RaiseError(EPngError, EPNGCannotAddInvalidImageText)
1493 else
1494 begin
1495 {Get common chunks}
1496 IHDR := ItemFromClass(TChunkIHDR) as TChunkIHDR;
1497 IEND := ItemFromClass(TChunkIEND) as TChunkIEND;
1498 {Create new chunk}
1499 Result := ChunkClass.Create(Owner);
1500 {Add to the list}
1501 if (ChunkClass = TChunkgAMA) then
1502 Insert(Result, IHDR.Index + 1)
1503 {Transparency chunk (fix by Ian Boyd)}
1504 else if (ChunkClass = TChunktRNS) then
1505 begin
1506 {Transparecy chunk must be after PLTE; before IDAT}
1507 IDAT := ItemFromClass(TChunkIDAT) as TChunkIDAT;
1508 PLTE := ItemFromClass(TChunkPLTE) as TChunkPLTE;
1509
1510 if Assigned(PLTE) then
1511 Insert(Result, PLTE.Index + 1)
1512 else if Assigned(IDAT) then
1513 Insert(Result, IDAT.Index)
1514 else
1515 Insert(Result, IHDR.Index + 1)
1516 end
1517 else {All other chunks}
1518 Insert(Result, IEND.Index);
1519 end {if}
1520end;
1521
1522{Returns item from the list}
1523function TPNGList.GetItem(Index: Cardinal): TChunk;
1524begin
1525 Result := inherited GetItem(Index);
1526end;
1527
1528{Returns first item from the list using the class from parameter}
1529function TPNGList.ItemFromClass(ChunkClass: TChunkClass): TChunk;
1530var
1531 i: Integer;
1532begin
1533 Result := nil; {Initial result}
1534 FOR i := 0 TO Count - 1 DO
1535 {Test if this item has the same class}
1536 if Item[i] is ChunkClass then
1537 begin
1538 {Returns this item and exit}
1539 Result := Item[i];
1540 break;
1541 end {if}
1542end;
1543
1544{$IFNDEF UseDelphi}
1545
1546 {TStream implementation}
1547
1548 {Copies all from another stream}
1549 function TStream.CopyFrom(Source: TStream; Count: Cardinal): Cardinal;
1550 const
1551 MaxBytes = $f000;
1552 var
1553 Buffer: PChar;
1554 BufSize, N: Cardinal;
1555 begin
1556 {If count is zero, copy everything from Source}
1557 if Count = 0 then
1558 begin
1559 Source.Seek(0, soFromBeginning);
1560 Count := Source.Size;
1561 end;
1562
1563 Result := Count; {Returns the number of bytes readed}
1564 {Allocates memory}
1565 if Count > MaxBytes then BufSize := MaxBytes else BufSize := Count;
1566 GetMem(Buffer, BufSize);
1567
1568 {Copy memory}
1569 while Count > 0 do
1570 begin
1571 if Count > BufSize then N := BufSize else N := Count;
1572 Source.Read(Buffer^, N);
1573 Write(Buffer^, N);
1574 dec(Count, N);
1575 end;
1576
1577 {Deallocates memory}
1578 FreeMem(Buffer, BufSize);
1579 end;
1580
1581{Set current stream position}
1582procedure TStream.SetPosition(const Value: Longint);
1583begin
1584 Seek(Value, soFromBeginning);
1585end;
1586
1587{Returns position}
1588function TStream.GetPosition: Longint;
1589begin
1590 Result := Seek(0, soFromCurrent);
1591end;
1592
1593 {Returns stream size}
1594function TStream.GetSize: Longint;
1595 var
1596 Pos: Cardinal;
1597 begin
1598 Pos := Seek(0, soFromCurrent);
1599 Result := Seek(0, soFromEnd);
1600 Seek(Pos, soFromCurrent);
1601 end;
1602
1603 {TFileStream implementation}
1604
1605 {Filestream object being created}
1606 constructor TFileStream.Create(Filename: String; Mode: TFileStreamModeSet);
1607 {Makes file mode}
1608 function OpenMode: DWORD;
1609 begin
1610 Result := 0;
1611 if fsmRead in Mode then Result := GENERIC_READ;
1612 if (fsmWrite in Mode) or (fsmCreate in Mode) then
1613 Result := Result OR GENERIC_WRITE;
1614 end;
1615 const
1616 IsCreate: Array[Boolean] of Integer = (OPEN_ALWAYS, CREATE_ALWAYS);
1617 begin
1618 {Call ancestor}
1619 inherited Create;
1620
1621 {Create handle}
1622 fHandle := CreateFile(PChar(Filename), OpenMode, FILE_SHARE_READ or
1623 FILE_SHARE_WRITE, nil, IsCreate[fsmCreate in Mode], 0, 0);
1624 {Store mode}
1625 FileMode := Mode;
1626 end;
1627
1628 {Filestream object being destroyed}
1629 destructor TFileStream.Destroy;
1630 begin
1631 {Terminates file and close}
1632 if FileMode = [fsmWrite] then
1633 SetEndOfFile(fHandle);
1634 CloseHandle(fHandle);
1635
1636 {Call ancestor}
1637 inherited Destroy;
1638 end;
1639
1640 {Writes data to the file}
1641 function TFileStream.Write(const Buffer; Count: Longint): Cardinal;
1642 begin
1643 if not WriteFile(fHandle, Buffer, Count, Result, nil) then
1644 Result := 0;
1645 end;
1646
1647 {Reads data from the file}
1648 function TFileStream.Read(var Buffer; Count: Longint): Cardinal;
1649 begin
1650 if not ReadFile(fHandle, Buffer, Count, Result, nil) then
1651 Result := 0;
1652 end;
1653
1654 {Seeks the file position}
1655 function TFileStream.Seek(Offset: Integer; Origin: Word): Longint;
1656 begin
1657 Result := SetFilePointer(fHandle, Offset, nil, Origin);
1658 end;
1659
1660 {Sets the size of the file}
1661 procedure TFileStream.SetSize(const Value: Longint);
1662 begin
1663 Seek(Value, soFromBeginning);
1664 SetEndOfFile(fHandle);
1665 end;
1666
1667 {TResourceStream implementation}
1668
1669 {Creates the resource stream}
1670 constructor TResourceStream.Create(Instance: HInst; const ResName: String;
1671 ResType: PChar);
1672 var
1673 ResID: HRSRC;
1674 ResGlobal: HGlobal;
1675 begin
1676 {Obtains the resource ID}
1677 ResID := FindResource(hInstance, PChar(ResName), RT_RCDATA);
1678 if ResID = 0 then raise EPNGError.Create('');
1679 {Obtains memory and size}
1680 ResGlobal := LoadResource(hInstance, ResID);
1681 Size := SizeOfResource(hInstance, ResID);
1682 Memory := LockResource(ResGlobal);
1683 if (ResGlobal = 0) or (Memory = nil) then EPNGError.Create('');
1684 end;
1685
1686
1687 {Setting resource stream size is not supported}
1688 procedure TResourceStream.SetSize(const Value: Integer);
1689 begin
1690 end;
1691
1692 {Writing into a resource stream is not supported}
1693 function TResourceStream.Write(const Buffer; Count: Integer): Cardinal;
1694 begin
1695 Result := 0;
1696 end;
1697
1698 {Reads data from the stream}
1699 function TResourceStream.Read(var Buffer; Count: Integer): Cardinal;
1700 begin
1701 //Returns data
1702 CopyMemory(@Buffer, Ptr(Longint(Memory) + Position), Count);
1703 //Update position
1704 inc(Position, Count);
1705 //Returns
1706 Result := Count;
1707 end;
1708
1709 {Seeks data}
1710 function TResourceStream.Seek(Offset: Integer; Origin: Word): Longint;
1711 begin
1712 {Move depending on the origin}
1713 case Origin of
1714 soFromBeginning: Position := Offset;
1715 soFromCurrent: inc(Position, Offset);
1716 soFromEnd: Position := Size + Offset;
1717 end;
1718
1719 {Returns the current position}
1720 Result := Position;
1721 end;
1722
1723{$ENDIF}
1724
1725{TChunk implementation}
1726
1727{Resizes the data}
1728procedure TChunk.ResizeData(const NewSize: Cardinal);
1729begin
1730 fDataSize := NewSize;
1731 ReallocMem(fData, NewSize + 1);
1732end;
1733
1734{Returns index from list}
1735function TChunk.GetIndex: Integer;
1736var
1737 i: Integer;
1738begin
1739 Result := -1; {Avoiding warnings}
1740 {Searches in the list}
1741 FOR i := 0 TO Owner.Chunks.Count - 1 DO
1742 if Owner.Chunks.Item[i] = Self then
1743 begin
1744 {Found match}
1745 Result := i;
1746 exit;
1747 end {for i}
1748end;
1749
1750{Returns pointer to the TChunkIHDR}
1751function TChunk.GetHeader: TChunkIHDR;
1752begin
1753 Result := Owner.Chunks.Item[0] as TChunkIHDR;
1754end;
1755
1756{Assigns from another TChunk}
1757procedure TChunk.Assign(Source: TChunk);
1758begin
1759 {Copy properties}
1760 fName := Source.fName;
1761 {Set data size and realloc}
1762 ResizeData(Source.fDataSize);
1763
1764 {Copy data (if there's any)}
1765 if fDataSize > 0 then CopyMemory(fData, Source.fData, fDataSize);
1766end;
1767
1768{Chunk being created}
1769constructor TChunk.Create(Owner: TPngObject);
1770var
1771 ChunkName: String;
1772begin
1773 {Ancestor create}
1774 inherited Create;
1775
1776 {If it's a registered class, set the chunk name based on the class}
1777 {name. For instance, if the class name is TChunkgAMA, the GAMA part}
1778 {will become the chunk name}
1779 ChunkName := Copy(ClassName, Length('TChunk') + 1, Length(ClassName));
1780 if Length(ChunkName) = 4 then CopyMemory(@fName[0], @ChunkName[1], 4);
1781
1782 {Initialize data holder}
1783 GetMem(fData, 1);
1784 fDataSize := 0;
1785 {Record owner}
1786 fOwner := Owner;
1787end;
1788
1789{Chunk being destroyed}
1790destructor TChunk.Destroy;
1791begin
1792 {Free data holder}
1793 FreeMem(fData, fDataSize + 1);
1794 {Let ancestor destroy}
1795 inherited Destroy;
1796end;
1797
1798{Returns the chunk name 1}
1799function TChunk.GetChunkName: String;
1800begin
1801 Result := fName
1802end;
1803
1804{Returns the chunk name 2}
1805class function TChunk.GetName: String;
1806begin
1807 {For avoid writing GetName for each TChunk descendent, by default for}
1808 {classes which don't declare GetName, it will look for the class name}
1809 {to extract the chunk kind. Example, if the class name is TChunkIEND }
1810 {this method extracts and returns IEND}
1811 Result := Copy(ClassName, Length('TChunk') + 1, Length(ClassName));
1812end;
1813
1814{Saves the data to the stream}
1815function TChunk.SaveData(Stream: TStream): Boolean;
1816var
1817 ChunkSize, ChunkCRC: Cardinal;
1818begin
1819 {First, write the size for the following data in the chunk}
1820 ChunkSize := ByteSwap(DataSize);
1821 Stream.Write(ChunkSize, 4);
1822 {The chunk name}
1823 Stream.Write(fName, 4);
1824 {If there is data for the chunk, write it}
1825 if DataSize > 0 then Stream.Write(Data^, DataSize);
1826 {Calculates and write CRC}
1827 ChunkCRC := update_crc($ffffffff, @fName[0], 4);
1828 ChunkCRC := Byteswap(update_crc(ChunkCRC, Data, DataSize) xor $ffffffff);
1829 Stream.Write(ChunkCRC, 4);
1830
1831 {Returns that everything went ok}
1832 Result := TRUE;
1833end;
1834
1835{Saves the chunk to the stream}
1836function TChunk.SaveToStream(Stream: TStream): Boolean;
1837begin
1838 Result := SaveData(Stream)
1839end;
1840
1841
1842{Loads the chunk from a stream}
1843function TChunk.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
1844 Size: Integer): Boolean;
1845var
1846 CheckCRC: Cardinal;
1847 {$IFDEF CheckCRC}RightCRC: Cardinal;{$ENDIF}
1848begin
1849 {Copies data from source}
1850 ResizeData(Size);
1851 if Size > 0 then Stream.Read(fData^, Size);
1852 {Reads CRC}
1853 Stream.Read(CheckCRC, 4);
1854 CheckCrc := ByteSwap(CheckCRC);
1855
1856 {Check if crc readed is valid}
1857 {$IFDEF CheckCRC}
1858 RightCRC := update_crc($ffffffff, @ChunkName[0], 4);
1859 RightCRC := update_crc(RightCRC, fData, Size) xor $ffffffff;
1860 Result := RightCRC = CheckCrc;
1861
1862 {Handle CRC error}
1863 if not Result then
1864 begin
1865 {In case it coult not load chunk}
1866 Owner.RaiseError(EPngInvalidCRC, EPngInvalidCRCText);
1867 exit;
1868 end
1869 {$ELSE}Result := TRUE; {$ENDIF}
1870
1871end;
1872
1873{TChunktIME implementation}
1874
1875{Chunk being loaded from a stream}
1876function TChunktIME.LoadFromStream(Stream: TStream;
1877 const ChunkName: TChunkName; Size: Integer): Boolean;
1878begin
1879 {Let ancestor load the data}
1880 Result := inherited LoadFromStream(Stream, ChunkName, Size);
1881 if not Result or (Size <> 7) then exit; {Size must be 7}
1882
1883 {Reads data}
1884 fYear := ((pByte(Longint(Data) )^) * 256)+ (pByte(Longint(Data) + 1)^);
1885 fMonth := pByte(Longint(Data) + 2)^;
1886 fDay := pByte(Longint(Data) + 3)^;
1887 fHour := pByte(Longint(Data) + 4)^;
1888 fMinute := pByte(Longint(Data) + 5)^;
1889 fSecond := pByte(Longint(Data) + 6)^;
1890end;
1891
1892{Saving the chunk to a stream}
1893function TChunktIME.SaveToStream(Stream: TStream): Boolean;
1894begin
1895 {Update data}
1896 ResizeData(7); {Make sure the size is 7}
1897 pWord(Data)^ := Year;
1898 pByte(Longint(Data) + 2)^ := Month;
1899 pByte(Longint(Data) + 3)^ := Day;
1900 pByte(Longint(Data) + 4)^ := Hour;
1901 pByte(Longint(Data) + 5)^ := Minute;
1902 pByte(Longint(Data) + 6)^ := Second;
1903
1904 {Let inherited save data}
1905 Result := inherited SaveToStream(Stream);
1906end;
1907
1908{TChunkztXt implementation}
1909
1910{Loading the chunk from a stream}
1911function TChunkzTXt.LoadFromStream(Stream: TStream;
1912 const ChunkName: TChunkName; Size: Integer): Boolean;
1913var
1914 ErrorOutput: String;
1915 CompressionMethod: Byte;
1916 Output: Pointer;
1917 OutputSize: Integer;
1918begin
1919 {Load data from stream and validate}
1920 Result := inherited LoadFromStream(Stream, ChunkName, Size);
1921 if not Result or (Size < 4) then exit;
1922 fKeyword := PChar(Data); {Get keyword and compression method bellow}
1923 CompressionMethod := pByte(Longint(fKeyword) + Length(fKeyword))^;
1924 fText := '';
1925
1926 {In case the compression is 0 (only one accepted by specs), reads it}
1927 if CompressionMethod = 0 then
1928 begin
1929 Output := nil;
1930 if DecompressZLIB(PChar(Longint(Data) + Length(fKeyword) + 2),
1931 Size - Length(fKeyword) - 2, Output, OutputSize, ErrorOutput) then
1932 begin
1933 SetLength(fText, OutputSize);
1934 CopyMemory(@fText[1], Output, OutputSize);
1935 end {if DecompressZLIB(...};
1936 FreeMem(Output);
1937 end {if CompressionMethod = 0}
1938
1939end;
1940
1941{Saving the chunk to a stream}
1942function TChunkztXt.SaveToStream(Stream: TStream): Boolean;
1943var
1944 Output: Pointer;
1945 OutputSize: Integer;
1946 ErrorOutput: String;
1947begin
1948 Output := nil; {Initializes output}
1949 if fText = '' then fText := ' ';
1950
1951 {Compresses the data}
1952 if CompressZLIB(@fText[1], Length(fText), Owner.CompressionLevel, Output,
1953 OutputSize, ErrorOutput) then
1954 begin
1955 {Size is length from keyword, plus a null character to divide}
1956 {plus the compression method, plus the length of the text (zlib compressed)}
1957 ResizeData(Length(fKeyword) + 2 + OutputSize);
1958
1959 Fillchar(Data^, DataSize, #0);
1960 {Copies the keyword data}
1961 if Keyword <> '' then
1962 CopyMemory(Data, @fKeyword[1], Length(Keyword));
1963 {Compression method 0 (inflate/deflate)}
1964 pByte(Ptr(Longint(Data) + Length(Keyword) + 1))^ := 0;
1965 if OutputSize > 0 then
1966 CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 2), Output, OutputSize);
1967
1968 {Let ancestor calculate crc and save}
1969 Result := SaveData(Stream);
1970 end {if CompressZLIB(...} else Result := False;
1971
1972 {Frees output}
1973 if Output <> nil then FreeMem(Output)
1974end;
1975
1976{TChunktEXt implementation}
1977
1978{Assigns from another text chunk}
1979procedure TChunktEXt.Assign(Source: TChunk);
1980begin
1981 fKeyword := TChunktEXt(Source).fKeyword;
1982 fText := TChunktEXt(Source).fText;
1983end;
1984
1985{Loading the chunk from a stream}
1986function TChunktEXt.LoadFromStream(Stream: TStream;
1987 const ChunkName: TChunkName; Size: Integer): Boolean;
1988begin
1989 {Load data from stream and validate}
1990 Result := inherited LoadFromStream(Stream, ChunkName, Size);
1991 if not Result or (Size < 3) then exit;
1992 {Get text}
1993 fKeyword := PChar(Data);
1994 SetLength(fText, Size - Length(fKeyword) - 1);
1995 CopyMemory(@fText[1], Ptr(Longint(Data) + Length(fKeyword) + 1),
1996 Length(fText));
1997end;
1998
1999{Saving the chunk to a stream}
2000function TChunktEXt.SaveToStream(Stream: TStream): Boolean;
2001begin
2002 {Size is length from keyword, plus a null character to divide}
2003 {plus the length of the text}
2004 ResizeData(Length(fKeyword) + 1 + Length(fText));
2005 Fillchar(Data^, DataSize, #0);
2006 {Copy data}
2007 if Keyword <> '' then
2008 CopyMemory(Data, @fKeyword[1], Length(Keyword));
2009 if Text <> '' then
2010 CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 1), @fText[1],
2011 Length(Text));
2012 {Let ancestor calculate crc and save}
2013 Result := inherited SaveToStream(Stream);
2014end;
2015
2016
2017{TChunkIHDR implementation}
2018
2019{Chunk being created}
2020constructor TChunkIHDR.Create(Owner: TPngObject);
2021begin
2022 {Call inherited}
2023 inherited Create(Owner);
2024 {Prepare pointers}
2025 ImageHandle := 0;
2026 ImageDC := 0;
2027end;
2028
2029{Chunk being destroyed}
2030destructor TChunkIHDR.Destroy;
2031begin
2032 {Free memory}
2033 FreeImageData();
2034
2035 {Calls TChunk destroy}
2036 inherited Destroy;
2037end;
2038
2039{Assigns from another IHDR chunk}
2040procedure TChunkIHDR.Assign(Source: TChunk);
2041begin
2042 {Copy the IHDR data}
2043 if Source is TChunkIHDR then
2044 begin
2045 {Copy IHDR values}
2046 IHDRData := TChunkIHDR(Source).IHDRData;
2047
2048 {Prepare to hold data by filling BitmapInfo structure and}
2049 {resizing ImageData and ImageAlpha memory allocations}
2050 PrepareImageData();
2051
2052 {Copy image data}
2053 CopyMemory(ImageData, TChunkIHDR(Source).ImageData,
2054 BytesPerRow * Integer(Height));
2055 CopyMemory(ImageAlpha, TChunkIHDR(Source).ImageAlpha,
2056 Integer(Width) * Integer(Height));
2057
2058 {Copy palette colors}
2059 BitmapInfo.bmiColors := TChunkIHDR(Source).BitmapInfo.bmiColors;
2060 end
2061 else
2062 Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText);
2063end;
2064
2065{Release allocated image data}
2066procedure TChunkIHDR.FreeImageData;
2067begin
2068 {Free old image data}
2069 if ImageHandle <> 0 then DeleteObject(ImageHandle);
2070 if ImageDC <> 0 then DeleteDC(ImageDC);
2071 if ImageAlpha <> nil then FreeMem(ImageAlpha);
2072 {$IFDEF Store16bits}
2073 if ExtraImageData <> nil then FreeMem(ExtraImageData);
2074 {$ENDIF}
2075 ImageHandle := 0; ImageDC := 0; ImageAlpha := nil; ImageData := nil;
2076end;
2077
2078{Chunk being loaded from a stream}
2079function TChunkIHDR.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
2080 Size: Integer): Boolean;
2081begin
2082 {Let TChunk load it}
2083 Result := inherited LoadFromStream(Stream, ChunkName, Size);
2084 if not Result then Exit;
2085
2086 {Now check values}
2087 {Note: It's recommended by png specification to make sure that the size}
2088 {must be 13 bytes to be valid, but some images with 14 bytes were found}
2089 {which could be loaded by internet explorer and other tools}
2090 if (fDataSize < SIZEOF(TIHdrData)) then
2091 begin
2092 {Ihdr must always have at least 13 bytes}
2093 Result := False;
2094 Owner.RaiseError(EPNGInvalidIHDR, EPNGInvalidIHDRText);
2095 exit;
2096 end;
2097
2098 {Everything ok, reads IHDR}
2099 IHDRData := pIHDRData(fData)^;
2100 IHDRData.Width := ByteSwap(IHDRData.Width);
2101 IHDRData.Height := ByteSwap(IHDRData.Height);
2102
2103 {The width and height must not be larger than 65535 pixels}
2104 if (IHDRData.Width > High(Word)) or (IHDRData.Height > High(Word)) then
2105 begin
2106 Result := False;
2107 Owner.RaiseError(EPNGSizeExceeds, EPNGSizeExceedsText);
2108 exit;
2109 end {if IHDRData.Width > High(Word)};
2110 {Compression method must be 0 (inflate/deflate)}
2111 if (IHDRData.CompressionMethod <> 0) then
2112 begin
2113 Result := False;
2114 Owner.RaiseError(EPNGUnknownCompression, EPNGUnknownCompressionText);
2115 exit;
2116 end;
2117 {Interlace must be either 0 (none) or 7 (adam7)}
2118 if (IHDRData.InterlaceMethod <> 0) and (IHDRData.InterlaceMethod <> 1) then
2119 begin
2120 Result := False;
2121 Owner.RaiseError(EPNGUnknownInterlace, EPNGUnknownInterlaceText);
2122 exit;
2123 end;
2124
2125 {Updates owner properties}
2126 Owner.InterlaceMethod := TInterlaceMethod(IHDRData.InterlaceMethod);
2127
2128 {Prepares data to hold image}
2129 PrepareImageData();
2130end;
2131
2132{Saving the IHDR chunk to a stream}
2133function TChunkIHDR.SaveToStream(Stream: TStream): Boolean;
2134begin
2135 {Ignore 2 bits images}
2136 if BitDepth = 2 then BitDepth := 4;
2137
2138 {It needs to do is update the data with the IHDR data}
2139 {structure containing the write values}
2140 ResizeData(SizeOf(TIHDRData));
2141 pIHDRData(fData)^ := IHDRData;
2142 {..byteswap 4 byte types}
2143 pIHDRData(fData)^.Width := ByteSwap(pIHDRData(fData)^.Width);
2144 pIHDRData(fData)^.Height := ByteSwap(pIHDRData(fData)^.Height);
2145 {..update interlace method}
2146 pIHDRData(fData)^.InterlaceMethod := Byte(Owner.InterlaceMethod);
2147 {..and then let the ancestor SaveToStream do the hard work}
2148 Result := inherited SaveToStream(Stream);
2149end;
2150
2151{Resizes the image data to fill the color type, bit depth, }
2152{width and height parameters}
2153procedure TChunkIHDR.PrepareImageData();
2154
2155 {Set the bitmap info}
2156 procedure SetInfo(const Bitdepth: Integer; const Palette: Boolean);
2157 begin
2158
2159 {Copy if the bitmap contain palette entries}
2160 HasPalette := Palette;
2161 {Initialize the structure with zeros}
2162 fillchar(BitmapInfo, sizeof(BitmapInfo), #0);
2163 {Fill the strucutre}
2164 with BitmapInfo.bmiHeader do
2165 begin
2166 biSize := sizeof(TBitmapInfoHeader);
2167 biHeight := Height;
2168 biWidth := Width;
2169 biPlanes := 1;
2170 biBitCount := BitDepth;
2171 biCompression := BI_RGB;
2172 end {with BitmapInfo.bmiHeader}
2173 end;
2174begin
2175 {Prepare bitmap info header}
2176 Fillchar(BitmapInfo, sizeof(TMaxBitmapInfo), #0);
2177 {Release old image data}
2178 FreeImageData();
2179
2180 {Obtain number of bits for each pixel}
2181 case ColorType of
2182 COLOR_GRAYSCALE, COLOR_PALETTE, COLOR_GRAYSCALEALPHA:
2183 case BitDepth of
2184 {These are supported by windows}
2185 1, 4, 8: SetInfo(BitDepth, TRUE);
2186 {2 bits for each pixel is not supported by windows bitmap}
2187 2 : SetInfo(4, TRUE);
2188 {Also 16 bits (2 bytes) for each pixel is not supported}
2189 {and should be transormed into a 8 bit grayscale}
2190 16 : SetInfo(8, TRUE);
2191 end;
2192 {Only 1 byte (8 bits) is supported}
2193 COLOR_RGB, COLOR_RGBALPHA: SetInfo(24, FALSE);
2194 end {case ColorType};
2195 {Number of bytes for each scanline}
2196 BytesPerRow := (((BitmapInfo.bmiHeader.biBitCount * Width) + 31)
2197 and not 31) div 8;
2198
2199 {Build array for alpha information, if necessary}
2200 if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then
2201 begin
2202 GetMem(ImageAlpha, Integer(Width) * Integer(Height));
2203 FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #0);
2204 end;
2205
2206 {Build array for extra byte information}
2207 {$IFDEF Store16bits}
2208 if (BitDepth = 16) then
2209 begin
2210 GetMem(ExtraImageData, BytesPerRow * Integer(Height));
2211 FillChar(ExtraImageData^, BytesPerRow * Integer(Height), #0);
2212 end;
2213 {$ENDIF}
2214
2215 {Creates the image to hold the data, CreateDIBSection does a better}
2216 {work in allocating necessary memory}
2217 ImageDC := CreateCompatibleDC(0);
2218 ImageHandle := CreateDIBSection(ImageDC, pBitmapInfo(@BitmapInfo)^,
2219 DIB_RGB_COLORS, ImageData, 0, 0);
2220
2221 {Clears the old palette (if any)}
2222 with Owner do
2223 if TempPalette <> 0 then
2224 begin
2225 DeleteObject(TempPalette);
2226 TempPalette := 0;
2227 end {with Owner, if TempPalette <> 0};
2228
2229 {Build array and allocate bytes for each row}
2230 zeromemory(ImageData, BytesPerRow * Integer(Height));
2231end;
2232
2233{TChunktRNS implementation}
2234
2235{$IFNDEF UseDelphi}
2236function CompareMem(P1, P2: pByte; const Size: Integer): Boolean;
2237var i: Integer;
2238begin
2239 Result := True;
2240 for i := 1 to Size do
2241 begin
2242 if P1^ <> P2^ then Result := False;
2243 inc(P1); inc(P2);
2244 end {for i}
2245end;
2246{$ENDIF}
2247
2248{Sets the transpararent color}
2249procedure TChunktRNS.SetTransparentColor(const Value: ColorRef);
2250var
2251 i: Byte;
2252 LookColor: TRGBQuad;
2253begin
2254 {Clears the palette values}
2255 Fillchar(PaletteValues, SizeOf(PaletteValues), #0);
2256 {Sets that it uses bit transparency}
2257 fBitTransparency := True;
2258
2259
2260 {Depends on the color type}
2261 with Header do
2262 case ColorType of
2263 COLOR_GRAYSCALE:
2264 begin
2265 Self.ResizeData(2);
2266 pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value));
2267 end;
2268 COLOR_RGB:
2269 begin
2270 Self.ResizeData(6);
2271 pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value));
2272 pWord(@PaletteValues[2])^ := ByteSwap16(GetGValue(Value));
2273 pWord(@PaletteValues[4])^ := ByteSwap16(GetBValue(Value));
2274 end;
2275 COLOR_PALETTE:
2276 begin
2277 {Creates a RGBQuad to search for the color}
2278 LookColor.rgbRed := GetRValue(Value);
2279 LookColor.rgbGreen := GetGValue(Value);
2280 LookColor.rgbBlue := GetBValue(Value);
2281 {Look in the table for the entry}
2282 for i := 0 to 255 do
2283 if CompareMem(@BitmapInfo.bmiColors[i], @LookColor, 3) then
2284 Break;
2285 {Fill the transparency table}
2286 Fillchar(PaletteValues, i, 255);
2287 Self.ResizeData(i + 1)
2288
2289 end
2290 end {case / with};
2291
2292end;
2293
2294{Returns the transparent color for the image}
2295function TChunktRNS.GetTransparentColor: ColorRef;
2296var
2297 PaletteChunk: TChunkPLTE;
2298 i: Integer;
2299begin
2300 Result := 0; {Default: Unknown transparent color}
2301
2302 {Depends on the color type}
2303 with Header do
2304 case ColorType of
2305 COLOR_GRAYSCALE:
2306 Result := RGB(PaletteValues[0], PaletteValues[0],
2307 PaletteValues[0]);
2308 COLOR_RGB:
2309 Result := RGB(PaletteValues[1], PaletteValues[3], PaletteValues[5]);
2310 COLOR_PALETTE:
2311 begin
2312 {Obtains the palette chunk}
2313 PaletteChunk := Owner.Chunks.ItemFromClass(TChunkPLTE) as TChunkPLTE;
2314
2315 {Looks for an entry with 0 transparency meaning that it is the}
2316 {full transparent entry}
2317 for i := 0 to Self.DataSize - 1 do
2318 if PaletteValues[i] = 0 then
2319 with PaletteChunk.GetPaletteItem(i) do
2320 begin
2321 Result := RGB(rgbRed, rgbGreen, rgbBlue);
2322 break
2323 end
2324 end {COLOR_PALETTE}
2325 end {case Header.ColorType};
2326end;
2327
2328{Saving the chunk to a stream}
2329function TChunktRNS.SaveToStream(Stream: TStream): Boolean;
2330begin
2331 {Copy palette into data buffer}
2332 if DataSize <= 256 then
2333 CopyMemory(fData, @PaletteValues[0], DataSize);
2334
2335 Result := inherited SaveToStream(Stream);
2336end;
2337
2338{Assigns from another chunk}
2339procedure TChunktRNS.Assign(Source: TChunk);
2340begin
2341 CopyMemory(@PaletteValues[0], @TChunkTrns(Source).PaletteValues[0], 256);
2342 fBitTransparency := TChunkTrns(Source).fBitTransparency;
2343 inherited Assign(Source);
2344end;
2345
2346{Loads the chunk from a stream}
2347function TChunktRNS.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
2348 Size: Integer): Boolean;
2349var
2350 i, Differ255: Integer;
2351begin
2352 {Let inherited load}
2353 Result := inherited LoadFromStream(Stream, ChunkName, Size);
2354
2355 if not Result then Exit;
2356
2357 {Make sure size is correct}
2358 if Size > 256 then Owner.RaiseError(EPNGInvalidPalette,
2359 EPNGInvalidPaletteText);
2360
2361 {The unset items should have value 255}
2362 Fillchar(PaletteValues[0], 256, 255);
2363 {Copy the other values}
2364 CopyMemory(@PaletteValues[0], fData, Size);
2365
2366 {Create the mask if needed}
2367 case Header.ColorType of
2368 {Mask for grayscale and RGB}
2369 COLOR_RGB, COLOR_GRAYSCALE: fBitTransparency := True;
2370 COLOR_PALETTE:
2371 begin
2372 Differ255 := 0; {Count the entries with a value different from 255}
2373 {Tests if it uses bit transparency}
2374 for i := 0 to Size - 1 do
2375 if PaletteValues[i] <> 255 then inc(Differ255);
2376
2377 {If it has one value different from 255 it is a bit transparency}
2378 fBitTransparency := (Differ255 = 1);
2379 end {COLOR_PALETTE}
2380 end {case Header.ColorType};
2381
2382end;
2383
2384{Prepares the image palette}
2385procedure TChunkIDAT.PreparePalette;
2386var
2387 Entries: Word;
2388 j : Integer;
2389begin
2390 {In case the image uses grayscale, build a grayscale palette}
2391 with Header do
2392 if (ColorType = COLOR_GRAYSCALE) or (ColorType = COLOR_GRAYSCALEALPHA) then
2393 begin
2394 {Calculate total number of palette entries}
2395 Entries := (1 shl Byte(BitmapInfo.bmiHeader.biBitCount));
2396
2397 FOR j := 0 TO Entries - 1 DO
2398 with BitmapInfo.bmiColors[j] do
2399 begin
2400
2401 {Calculate each palette entry}
2402 rgbRed := fOwner.GammaTable[MulDiv(j, 255, Entries - 1)];
2403 rgbGreen := rgbRed;
2404 rgbBlue := rgbRed;
2405 end {with BitmapInfo.bmiColors[j]}
2406 end {if ColorType = COLOR_GRAYSCALE..., with Header}
2407end;
2408
2409{Reads from ZLIB}
2410function TChunkIDAT.IDATZlibRead(var ZLIBStream: TZStreamRec2;
2411 Buffer: Pointer; Count: Integer; var EndPos: Integer;
2412 var crcfile: Cardinal): Integer;
2413var
2414 ProcResult : Integer;
2415 IDATHeader : Array[0..3] of char;
2416 IDATCRC : Cardinal;
2417begin
2418 {Uses internal record pointed by ZLIBStream to gather information}
2419 with ZLIBStream, ZLIBStream.zlib do
2420 begin
2421 {Set the buffer the zlib will read into}
2422 next_out := Buffer;
2423 avail_out := Count;
2424
2425 {Decode until it reach the Count variable}
2426 while avail_out > 0 do
2427 begin
2428 {In case it needs more data and it's in the end of a IDAT chunk,}
2429 {it means that there are more IDAT chunks}
2430 if (fStream.Position = EndPos) and (avail_out > 0) and
2431 (avail_in = 0) then
2432 begin
2433 {End this chunk by reading and testing the crc value}
2434 fStream.Read(IDATCRC, 4);
2435
2436 {$IFDEF CheckCRC}
2437 if crcfile xor $ffffffff <> Cardinal(ByteSwap(IDATCRC)) then
2438 begin
2439 Result := -1;
2440 Owner.RaiseError(EPNGInvalidCRC, EPNGInvalidCRCText);
2441 exit;
2442 end;
2443 {$ENDIF}
2444
2445 {Start reading the next chunk}
2446 fStream.Read(EndPos, 4); {Reads next chunk size}
2447 fStream.Read(IDATHeader[0], 4); {Next chunk header}
2448 {It must be a IDAT chunk since image data is required and PNG}
2449 {specification says that multiple IDAT chunks must be consecutive}
2450 if IDATHeader <> 'IDAT' then
2451 begin
2452 Owner.RaiseError(EPNGMissingMultipleIDAT, EPNGMissingMultipleIDATText);
2453 result := -1;
2454 exit;
2455 end;
2456
2457 {Calculate chunk name part of the crc}
2458 {$IFDEF CheckCRC}
2459 crcfile := update_crc($ffffffff, @IDATHeader[0], 4);
2460 {$ENDIF}
2461 EndPos := fStream.Position + ByteSwap(EndPos);
2462 end;
2463
2464
2465 {In case it needs compressed data to read from}
2466 if avail_in = 0 then
2467 begin
2468 {In case it's trying to read more than it is avaliable}
2469 if fStream.Position + ZLIBAllocate > EndPos then
2470 avail_in := fStream.Read(Data^, EndPos - fStream.Position)
2471 else
2472 avail_in := fStream.Read(Data^, ZLIBAllocate);
2473 {Update crc}
2474 {$IFDEF CheckCRC}
2475 crcfile := update_crc(crcfile, Data, avail_in);
2476 {$ENDIF}
2477
2478 {In case there is no more compressed data to read from}
2479 if avail_in = 0 then
2480 begin
2481 Result := Count - avail_out;
2482 Exit;
2483 end;
2484
2485 {Set next buffer to read and record current position}
2486 next_in := Data;
2487
2488 end {if avail_in = 0};
2489
2490 ProcResult := inflate(zlib, 0);
2491
2492 {In case the result was not sucessfull}
2493 if (ProcResult < 0) then
2494 begin
2495 Result := -1;
2496 Owner.RaiseError(EPNGZLIBError,
2497 EPNGZLIBErrorText + zliberrors[procresult]);
2498 exit;
2499 end;
2500
2501 end {while avail_out > 0};
2502
2503 end {with};
2504
2505 {If everything gone ok, it returns the count bytes}
2506 Result := Count;
2507end;
2508
2509{TChunkIDAT implementation}
2510
2511const
2512 {Adam 7 interlacing values}
2513 RowStart: array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1);
2514 ColumnStart: array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0);
2515 RowIncrement: array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2);
2516 ColumnIncrement: array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1);
2517
2518{Copy interlaced images with 1 byte for R, G, B}
2519procedure TChunkIDAT.CopyInterlacedRGB8(const Pass: Byte;
2520 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2521var
2522 Col: Integer;
2523begin
2524 {Get first column and enter in loop}
2525 Col := ColumnStart[Pass];
2526 Dest := pChar(Longint(Dest) + Col * 3);
2527 repeat
2528 {Copy this row}
2529 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
2530 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
2531 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
2532
2533 {Move to next column}
2534 inc(Src, 3);
2535 inc(Dest, ColumnIncrement[Pass] * 3 - 3);
2536 inc(Col, ColumnIncrement[Pass]);
2537 until Col >= ImageWidth;
2538end;
2539
2540{Copy interlaced images with 2 bytes for R, G, B}
2541procedure TChunkIDAT.CopyInterlacedRGB16(const Pass: Byte;
2542 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2543var
2544 Col: Integer;
2545begin
2546 {Get first column and enter in loop}
2547 Col := ColumnStart[Pass];
2548 Dest := pChar(Longint(Dest) + Col * 3);
2549 repeat
2550 {Copy this row}
2551 Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
2552 Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
2553 Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
2554 {$IFDEF Store16bits}
2555 {Copy extra pixel values}
2556 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
2557 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
2558 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
2559 {$ENDIF}
2560
2561 {Move to next column}
2562 inc(Src, 6);
2563 inc(Dest, ColumnIncrement[Pass] * 3 - 3);
2564 inc(Col, ColumnIncrement[Pass]);
2565 until Col >= ImageWidth;
2566end;
2567
2568{Copy ímages with palette using bit depths 1, 4 or 8}
2569procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte;
2570 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2571const
2572 BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF);
2573 StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0);
2574var
2575 CurBit, Col: Integer;
2576 Dest2: PChar;
2577begin
2578 {Get first column and enter in loop}
2579 Col := ColumnStart[Pass];
2580 repeat
2581 {Copy data}
2582 CurBit := StartBit[Header.BitDepth];
2583 repeat
2584 {Adjust pointer to pixel byte bounds}
2585 Dest2 := pChar(Longint(Dest) + (Header.BitDepth * Col) div 8);
2586 {Copy data}
2587 Byte(Dest2^) := Byte(Dest2^) or
2588 ( ((Byte(Src^) shr CurBit) and BitTable[Header.BitDepth])
2589 shl (StartBit[Header.BitDepth] - (Col * Header.BitDepth mod 8)));
2590
2591 {Move to next column}
2592 inc(Col, ColumnIncrement[Pass]);
2593 {Will read next bits}
2594 dec(CurBit, Header.BitDepth);
2595 until CurBit < 0;
2596
2597 {Move to next byte in source}
2598 inc(Src);
2599 until Col >= ImageWidth;
2600end;
2601
2602{Copy ímages with palette using bit depth 2}
2603procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest,
2604 Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2605var
2606 CurBit, Col: Integer;
2607 Dest2: PChar;
2608begin
2609 {Get first column and enter in loop}
2610 Col := ColumnStart[Pass];
2611 repeat
2612 {Copy data}
2613 CurBit := 6;
2614 repeat
2615 {Adjust pointer to pixel byte bounds}
2616 Dest2 := pChar(Longint(Dest) + Col div 2);
2617 {Copy data}
2618 Byte(Dest2^) := Byte(Dest2^) or (((Byte(Src^) shr CurBit) and $3)
2619 shl (4 - (4 * Col) mod 8));
2620 {Move to next column}
2621 inc(Col, ColumnIncrement[Pass]);
2622 {Will read next bits}
2623 dec(CurBit, 2);
2624 until CurBit < 0;
2625
2626 {Move to next byte in source}
2627 inc(Src);
2628 until Col >= ImageWidth;
2629end;
2630
2631{Copy ímages with grayscale using bit depth 2}
2632procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte;
2633 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2634var
2635 CurBit, Col: Integer;
2636 Dest2: PChar;
2637begin
2638 {Get first column and enter in loop}
2639 Col := ColumnStart[Pass];
2640 repeat
2641 {Copy data}
2642 CurBit := 6;
2643 repeat
2644 {Adjust pointer to pixel byte bounds}
2645 Dest2 := pChar(Longint(Dest) + Col div 2);
2646 {Copy data}
2647 Byte(Dest2^) := Byte(Dest2^) or ((((Byte(Src^) shr CurBit) shl 2) and $F)
2648 shl (4 - (Col*4) mod 8));
2649 {Move to next column}
2650 inc(Col, ColumnIncrement[Pass]);
2651 {Will read next bits}
2652 dec(CurBit, 2);
2653 until CurBit < 0;
2654
2655 {Move to next byte in source}
2656 inc(Src);
2657 until Col >= ImageWidth;
2658end;
2659
2660{Copy ímages with palette using 2 bytes for each pixel}
2661procedure TChunkIDAT.CopyInterlacedGrayscale16(const Pass: Byte;
2662 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2663var
2664 Col: Integer;
2665begin
2666 {Get first column and enter in loop}
2667 Col := ColumnStart[Pass];
2668 Dest := pChar(Longint(Dest) + Col);
2669 repeat
2670 {Copy this row}
2671 Dest^ := Src^; inc(Dest);
2672 {$IFDEF Store16bits}
2673 Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
2674 {$ENDIF}
2675
2676 {Move to next column}
2677 inc(Src, 2);
2678 inc(Dest, ColumnIncrement[Pass] - 1);
2679 inc(Col, ColumnIncrement[Pass]);
2680 until Col >= ImageWidth;
2681end;
2682
2683{Decodes interlaced RGB alpha with 1 byte for each sample}
2684procedure TChunkIDAT.CopyInterlacedRGBAlpha8(const Pass: Byte;
2685 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2686var
2687 Col: Integer;
2688begin
2689 {Get first column and enter in loop}
2690 Col := ColumnStart[Pass];
2691 Dest := pChar(Longint(Dest) + Col * 3);
2692 Trans := pChar(Longint(Trans) + Col);
2693 repeat
2694 {Copy this row and alpha value}
2695 Trans^ := pChar(Longint(Src) + 3)^;
2696 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
2697 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
2698 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
2699
2700 {Move to next column}
2701 inc(Src, 4);
2702 inc(Dest, ColumnIncrement[Pass] * 3 - 3);
2703 inc(Trans, ColumnIncrement[Pass]);
2704 inc(Col, ColumnIncrement[Pass]);
2705 until Col >= ImageWidth;
2706end;
2707
2708{Decodes interlaced RGB alpha with 2 bytes for each sample}
2709procedure TChunkIDAT.CopyInterlacedRGBAlpha16(const Pass: Byte;
2710 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2711var
2712 Col: Integer;
2713begin
2714 {Get first column and enter in loop}
2715 Col := ColumnStart[Pass];
2716 Dest := pChar(Longint(Dest) + Col * 3);
2717 Trans := pChar(Longint(Trans) + Col);
2718 repeat
2719 {Copy this row and alpha value}
2720 Trans^ := pChar(Longint(Src) + 6)^;
2721 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
2722 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
2723 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
2724 {$IFDEF Store16bits}
2725 {Copy extra pixel values}
2726 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
2727 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
2728 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
2729 {$ENDIF}
2730
2731 {Move to next column}
2732 inc(Src, 8);
2733 inc(Dest, ColumnIncrement[Pass] * 3 - 3);
2734 inc(Trans, ColumnIncrement[Pass]);
2735 inc(Col, ColumnIncrement[Pass]);
2736 until Col >= ImageWidth;
2737end;
2738
2739{Decodes 8 bit grayscale image followed by an alpha sample}
2740procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha8(const Pass: Byte;
2741 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2742var
2743 Col: Integer;
2744begin
2745 {Get first column, pointers to the data and enter in loop}
2746 Col := ColumnStart[Pass];
2747 Dest := pChar(Longint(Dest) + Col);
2748 Trans := pChar(Longint(Trans) + Col);
2749 repeat
2750 {Copy this grayscale value and alpha}
2751 Dest^ := Src^; inc(Src);
2752 Trans^ := Src^; inc(Src);
2753
2754 {Move to next column}
2755 inc(Dest, ColumnIncrement[Pass]);
2756 inc(Trans, ColumnIncrement[Pass]);
2757 inc(Col, ColumnIncrement[Pass]);
2758 until Col >= ImageWidth;
2759end;
2760
2761{Decodes 16 bit grayscale image followed by an alpha sample}
2762procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha16(const Pass: Byte;
2763 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2764var
2765 Col: Integer;
2766begin
2767 {Get first column, pointers to the data and enter in loop}
2768 Col := ColumnStart[Pass];
2769 Dest := pChar(Longint(Dest) + Col);
2770 Trans := pChar(Longint(Trans) + Col);
2771 repeat
2772 {$IFDEF Store16bits}
2773 Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
2774 {$ENDIF}
2775 {Copy this grayscale value and alpha, transforming 16 bits into 8}
2776 Dest^ := Src^; inc(Src, 2);
2777 Trans^ := Src^; inc(Src, 2);
2778
2779 {Move to next column}
2780 inc(Dest, ColumnIncrement[Pass]);
2781 inc(Trans, ColumnIncrement[Pass]);
2782 inc(Col, ColumnIncrement[Pass]);
2783 until Col >= ImageWidth;
2784end;
2785
2786{Decodes an interlaced image}
2787procedure TChunkIDAT.DecodeInterlacedAdam7(Stream: TStream;
2788 var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal);
2789var
2790 CurrentPass: Byte;
2791 PixelsThisRow: Integer;
2792 CurrentRow: Integer;
2793 Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar;
2794 CopyProc: procedure(const Pass: Byte; Src, Dest,
2795 Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object;
2796begin
2797
2798 CopyProc := nil; {Initialize}
2799 {Determine method to copy the image data}
2800 case Header.ColorType of
2801 {R, G, B values for each pixel}
2802 COLOR_RGB:
2803 case Header.BitDepth of
2804 8: CopyProc := CopyInterlacedRGB8;
2805 16: CopyProc := CopyInterlacedRGB16;
2806 end {case Header.BitDepth};
2807 {Palette}
2808 COLOR_PALETTE, COLOR_GRAYSCALE:
2809 case Header.BitDepth of
2810 1, 4, 8: CopyProc := CopyInterlacedPalette148;
2811 2 : if Header.ColorType = COLOR_PALETTE then
2812 CopyProc := CopyInterlacedPalette2
2813 else
2814 CopyProc := CopyInterlacedGray2;
2815 16 : CopyProc := CopyInterlacedGrayscale16;
2816 end;
2817 {RGB followed by alpha}
2818 COLOR_RGBALPHA:
2819 case Header.BitDepth of
2820 8: CopyProc := CopyInterlacedRGBAlpha8;
2821 16: CopyProc := CopyInterlacedRGBAlpha16;
2822 end;
2823 {Grayscale followed by alpha}
2824 COLOR_GRAYSCALEALPHA:
2825 case Header.BitDepth of
2826 8: CopyProc := CopyInterlacedGrayscaleAlpha8;
2827 16: CopyProc := CopyInterlacedGrayscaleAlpha16;
2828 end;
2829 end {case Header.ColorType};
2830
2831 {Adam7 method has 7 passes to make the final image}
2832 FOR CurrentPass := 0 TO 6 DO
2833 begin
2834 {Calculates the number of pixels and bytes for this pass row}
2835 PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] +
2836 ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass];
2837 Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType,
2838 Header.BitDepth);
2839 {Clear buffer for this pass}
2840 ZeroMemory(Row_Buffer[not RowUsed], Row_Bytes);
2841
2842 {Get current row index}
2843 CurrentRow := RowStart[CurrentPass];
2844 {Get a pointer to the current row image data}
2845 Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow *
2846 (ImageHeight - 1 - CurrentRow));
2847 Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow);
2848 {$IFDEF Store16bits}
2849 Extra := Ptr(Longint(Header.ExtraImageData) + Header.BytesPerRow *
2850 (ImageHeight - 1 - CurrentRow));
2851 {$ENDIF}
2852
2853 if Row_Bytes > 0 then {There must have bytes for this interlaced pass}
2854 while CurrentRow < ImageHeight do
2855 begin
2856 {Reads this line and filter}
2857 if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1,
2858 EndPos, CRCFile) = 0 then break;
2859
2860 FilterRow;
2861 {Copy image data}
2862
2863 CopyProc(CurrentPass, @Row_Buffer[RowUsed][1], Data, Trans
2864 {$IFDEF Store16bits}, Extra{$ENDIF});
2865
2866 {Use the other RowBuffer item}
2867 RowUsed := not RowUsed;
2868
2869 {Move to the next row}
2870 inc(CurrentRow, RowIncrement[CurrentPass]);
2871 {Move pointer to the next line}
2872 dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow);
2873 inc(Trans, RowIncrement[CurrentPass] * ImageWidth);
2874 {$IFDEF Store16bits}
2875 dec(Extra, RowIncrement[CurrentPass] * Header.BytesPerRow);
2876 {$ENDIF}
2877 end {while CurrentRow < ImageHeight};
2878
2879 end {FOR CurrentPass};
2880
2881end;
2882
2883{Copy 8 bits RGB image}
2884procedure TChunkIDAT.CopyNonInterlacedRGB8(
2885 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2886var
2887 I: Integer;
2888begin
2889 FOR I := 1 TO ImageWidth DO
2890 begin
2891 {Copy pixel values}
2892 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
2893 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
2894 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
2895 {Move to next pixel}
2896 inc(Src, 3);
2897 end {for I}
2898end;
2899
2900{Copy 16 bits RGB image}
2901procedure TChunkIDAT.CopyNonInterlacedRGB16(
2902 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2903var
2904 I: Integer;
2905begin
2906 FOR I := 1 TO ImageWidth DO
2907 begin
2908 //Since windows does not supports 2 bytes for
2909 //each R, G, B value, the method will read only 1 byte from it
2910 {Copy pixel values}
2911 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
2912 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
2913 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
2914 {$IFDEF Store16bits}
2915 {Copy extra pixel values}
2916 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
2917 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
2918 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
2919 {$ENDIF}
2920
2921 {Move to next pixel}
2922 inc(Src, 6);
2923 end {for I}
2924end;
2925
2926{Copy types using palettes (1, 4 or 8 bits per pixel)}
2927procedure TChunkIDAT.CopyNonInterlacedPalette148(
2928 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2929begin
2930 {It's simple as copying the data}
2931 CopyMemory(Dest, Src, Row_Bytes);
2932end;
2933
2934{Copy grayscale types using 2 bits for each pixel}
2935procedure TChunkIDAT.CopyNonInterlacedGray2(
2936 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2937var
2938 i: Integer;
2939begin
2940 {2 bits is not supported, this routine will converted into 4 bits}
2941 FOR i := 1 TO Row_Bytes do
2942 begin
2943 Byte(Dest^) := ((Byte(Src^) shr 2) and $F) or ((Byte(Src^)) and $F0); inc(Dest);
2944 Byte(Dest^) := ((Byte(Src^) shl 2) and $F) or ((Byte(Src^) shl 4) and $F0); inc(Dest);
2945 inc(Src);
2946 end {FOR i}
2947end;
2948
2949{Copy types using palette with 2 bits for each pixel}
2950procedure TChunkIDAT.CopyNonInterlacedPalette2(
2951 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2952var
2953 i: Integer;
2954begin
2955 {2 bits is not supported, this routine will converted into 4 bits}
2956 FOR i := 1 TO Row_Bytes do
2957 begin
2958 Byte(Dest^) := ((Byte(Src^) shr 4) and $3) or ((Byte(Src^) shr 2) and $30); inc(Dest);
2959 Byte(Dest^) := (Byte(Src^) and $3) or ((Byte(Src^) shl 2) and $30); inc(Dest);
2960 inc(Src);
2961 end {FOR i}
2962end;
2963
2964{Copy grayscale images with 16 bits}
2965procedure TChunkIDAT.CopyNonInterlacedGrayscale16(
2966 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2967var
2968 I: Integer;
2969begin
2970 FOR I := 1 TO ImageWidth DO
2971 begin
2972 {Windows does not supports 16 bits for each pixel in grayscale}
2973 {mode, so reduce to 8}
2974 Dest^ := Src^; inc(Dest);
2975 {$IFDEF Store16bits}
2976 Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
2977 {$ENDIF}
2978
2979 {Move to next pixel}
2980 inc(Src, 2);
2981 end {for I}
2982end;
2983
2984{Copy 8 bits per sample RGB images followed by an alpha byte}
2985procedure TChunkIDAT.CopyNonInterlacedRGBAlpha8(
2986 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
2987var
2988 i: Integer;
2989begin
2990 FOR I := 1 TO ImageWidth DO
2991 begin
2992 {Copy pixel values and transparency}
2993 Trans^ := pChar(Longint(Src) + 3)^;
2994 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
2995 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
2996 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
2997 {Move to next pixel}
2998 inc(Src, 4); inc(Trans);
2999 end {for I}
3000end;
3001
3002{Copy 16 bits RGB image with alpha using 2 bytes for each sample}
3003procedure TChunkIDAT.CopyNonInterlacedRGBAlpha16(
3004 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
3005var
3006 I: Integer;
3007begin
3008 FOR I := 1 TO ImageWidth DO
3009 begin
3010 //Copy rgb and alpha values (transforming from 16 bits to 8 bits)
3011 {Copy pixel values}
3012 Trans^ := pChar(Longint(Src) + 6)^;
3013 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
3014 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
3015 Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
3016 {$IFDEF Store16bits}
3017 {Copy extra pixel values}
3018 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
3019 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
3020 Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
3021 {$ENDIF}
3022 {Move to next pixel}
3023 inc(Src, 8); inc(Trans);
3024 end {for I}
3025end;
3026
3027{Copy 8 bits per sample grayscale followed by alpha}
3028procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha8(
3029 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
3030var
3031 I: Integer;
3032begin
3033 FOR I := 1 TO ImageWidth DO
3034 begin
3035 {Copy alpha value and then gray value}
3036 Dest^ := Src^; inc(Src);
3037 Trans^ := Src^; inc(Src);
3038 inc(Dest); inc(Trans);
3039 end;
3040end;
3041
3042{Copy 16 bits per sample grayscale followed by alpha}
3043procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha16(
3044 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
3045var
3046 I: Integer;
3047begin
3048 FOR I := 1 TO ImageWidth DO
3049 begin
3050 {Copy alpha value and then gray value}
3051 {$IFDEF Store16bits}
3052 Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
3053 {$ENDIF}
3054 Dest^ := Src^; inc(Src, 2);
3055 Trans^ := Src^; inc(Src, 2);
3056 inc(Dest); inc(Trans);
3057 end;
3058end;
3059
3060{Decode non interlaced image}
3061procedure TChunkIDAT.DecodeNonInterlaced(Stream: TStream;
3062 var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal);
3063var
3064 j: Cardinal;
3065 Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar;
3066 CopyProc: procedure(
3067 Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object;
3068begin
3069 CopyProc := nil; {Initialize}
3070 {Determines the method to copy the image data}
3071 case Header.ColorType of
3072 {R, G, B values}
3073 COLOR_RGB:
3074 case Header.BitDepth of
3075 8: CopyProc := CopyNonInterlacedRGB8;
3076 16: CopyProc := CopyNonInterlacedRGB16;
3077 end;
3078 {Types using palettes}
3079 COLOR_PALETTE, COLOR_GRAYSCALE:
3080 case Header.BitDepth of
3081 1, 4, 8: CopyProc := CopyNonInterlacedPalette148;
3082 2 : if Header.ColorType = COLOR_PALETTE then
3083 CopyProc := CopyNonInterlacedPalette2
3084 else
3085 CopyProc := CopyNonInterlacedGray2;
3086 16 : CopyProc := CopyNonInterlacedGrayscale16;
3087 end;
3088 {R, G, B followed by alpha}
3089 COLOR_RGBALPHA:
3090 case Header.BitDepth of
3091 8 : CopyProc := CopyNonInterlacedRGBAlpha8;
3092 16 : CopyProc := CopyNonInterlacedRGBAlpha16;
3093 end;
3094 {Grayscale followed by alpha}
3095 COLOR_GRAYSCALEALPHA:
3096 case Header.BitDepth of
3097 8 : CopyProc := CopyNonInterlacedGrayscaleAlpha8;
3098 16 : CopyProc := CopyNonInterlacedGrayscaleAlpha16;
3099 end;
3100 end;
3101
3102 {Get the image data pointer}
3103 Longint(Data) := Longint(Header.ImageData) +
3104 Header.BytesPerRow * (ImageHeight - 1);
3105 Trans := Header.ImageAlpha;
3106 {$IFDEF Store16bits}
3107 Longint(Extra) := Longint(Header.ExtraImageData) +
3108 Header.BytesPerRow * (ImageHeight - 1);
3109 {$ENDIF}
3110 {Reads each line}
3111 FOR j := 0 to ImageHeight - 1 do
3112 begin
3113 {Read this line Row_Buffer[RowUsed][0] if the filter type for this line}
3114 if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1, EndPos,
3115 CRCFile) = 0 then break;
3116
3117 {Filter the current row}
3118 FilterRow;
3119 {Copies non interlaced row to image}
3120 CopyProc(@Row_Buffer[RowUsed][1], Data, Trans{$IFDEF Store16bits}, Extra
3121 {$ENDIF});
3122
3123 {Invert line used}
3124 RowUsed := not RowUsed;
3125 dec(Data, Header.BytesPerRow);
3126 {$IFDEF Store16bits}dec(Extra, Header.BytesPerRow);{$ENDIF}
3127 inc(Trans, ImageWidth);
3128 end {for I};
3129
3130
3131end;
3132
3133{Filter the current line}
3134procedure TChunkIDAT.FilterRow;
3135var
3136 pp: Byte;
3137 vv, left, above, aboveleft: Integer;
3138 Col: Cardinal;
3139begin
3140 {Test the filter}
3141 case Row_Buffer[RowUsed]^[0] of
3142 {No filtering for this line}
3143 FILTER_NONE: begin end;
3144 {AND 255 serves only to never let the result be larger than one byte}
3145 {Sub filter}
3146 FILTER_SUB:
3147 FOR Col := Offset + 1 to Row_Bytes DO
3148 Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] +
3149 Row_Buffer[RowUsed][Col - Offset]) and 255;
3150 {Up filter}
3151 FILTER_UP:
3152 FOR Col := 1 to Row_Bytes DO
3153 Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] +
3154 Row_Buffer[not RowUsed][Col]) and 255;
3155 {Average filter}
3156 FILTER_AVERAGE:
3157 FOR Col := 1 to Row_Bytes DO
3158 begin
3159 {Obtains up and left pixels}
3160 above := Row_Buffer[not RowUsed][Col];
3161 if col - 1 < Offset then
3162 left := 0
3163 else
3164 Left := Row_Buffer[RowUsed][Col - Offset];
3165
3166 {Calculates}
3167 Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] +
3168 (left + above) div 2) and 255;
3169 end;
3170 {Paeth filter}
3171 FILTER_PAETH:
3172 begin
3173 {Initialize}
3174 left := 0;
3175 aboveleft := 0;
3176 {Test each byte}
3177 FOR Col := 1 to Row_Bytes DO
3178 begin
3179 {Obtains above pixel}
3180 above := Row_Buffer[not RowUsed][Col];
3181 {Obtains left and top-left pixels}
3182 if (col - 1 >= offset) Then
3183 begin
3184 left := row_buffer[RowUsed][col - offset];
3185 aboveleft := row_buffer[not RowUsed][col - offset];
3186 end;
3187
3188 {Obtains current pixel and paeth predictor}
3189 vv := row_buffer[RowUsed][Col];
3190 pp := PaethPredictor(left, above, aboveleft);
3191
3192 {Calculates}
3193 Row_Buffer[RowUsed][Col] := (pp + vv) and $FF;
3194 end {for};
3195 end;
3196
3197 end {case};
3198end;
3199
3200{Reads the image data from the stream}
3201function TChunkIDAT.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
3202 Size: Integer): Boolean;
3203var
3204 ZLIBStream: TZStreamRec2;
3205 CRCCheck,
3206 CRCFile : Cardinal;
3207begin
3208 {Get pointer to the header chunk}
3209 Header := Owner.Chunks.Item[0] as TChunkIHDR;
3210 {Build palette if necessary}
3211 if Header.HasPalette then PreparePalette();
3212
3213 {Copy image width and height}
3214 ImageWidth := Header.Width;
3215 ImageHeight := Header.Height;
3216
3217 {Initialize to calculate CRC}
3218 {$IFDEF CheckCRC}
3219 CRCFile := update_crc($ffffffff, @ChunkName[0], 4);
3220 {$ENDIF}
3221
3222 Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information}
3223 ZLIBStream := ZLIBInitInflate(Stream); {Initializes decompression}
3224
3225 {Calculate ending position for the current IDAT chunk}
3226 EndPos := Stream.Position + Size;
3227
3228 {Allocate memory}
3229 GetMem(Row_Buffer[false], Row_Bytes + 1);
3230 GetMem(Row_Buffer[true], Row_Bytes + 1);
3231 ZeroMemory(Row_Buffer[false], Row_bytes + 1);
3232 {Set the variable to alternate the Row_Buffer item to use}
3233 RowUsed := TRUE;
3234
3235 {Call special methods for the different interlace methods}
3236 case Owner.InterlaceMethod of
3237 imNone: DecodeNonInterlaced(stream, ZLIBStream, Size, crcfile);
3238 imAdam7: DecodeInterlacedAdam7(stream, ZLIBStream, size, crcfile);
3239 end;
3240
3241 {Free memory}
3242 ZLIBTerminateInflate(ZLIBStream); {Terminates decompression}
3243 FreeMem(Row_Buffer[False], Row_Bytes + 1);
3244 FreeMem(Row_Buffer[True], Row_Bytes + 1);
3245
3246 {Now checks CRC}
3247 Stream.Read(CRCCheck, 4);
3248 {$IFDEF CheckCRC}
3249 CRCFile := CRCFile xor $ffffffff;
3250 CRCCheck := ByteSwap(CRCCheck);
3251 Result := CRCCheck = CRCFile;
3252
3253 {Handle CRC error}
3254 if not Result then
3255 begin
3256 {In case it coult not load chunk}
3257 Owner.RaiseError(EPngInvalidCRC, EPngInvalidCRCText);
3258 exit;
3259 end;
3260 {$ELSE}Result := TRUE; {$ENDIF}
3261end;
3262
3263const
3264 IDATHeader: Array[0..3] of char = ('I', 'D', 'A', 'T');
3265 BUFFER = 5;
3266
3267{Saves the IDAT chunk to a stream}
3268function TChunkIDAT.SaveToStream(Stream: TStream): Boolean;
3269var
3270 ZLIBStream : TZStreamRec2;
3271begin
3272 {Get pointer to the header chunk}
3273 Header := Owner.Chunks.Item[0] as TChunkIHDR;
3274 {Copy image width and height}
3275 ImageWidth := Header.Width;
3276 ImageHeight := Header.Height;
3277 Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information}
3278
3279 {Allocate memory}
3280 GetMem(Encode_Buffer[BUFFER], Row_Bytes);
3281 ZeroMemory(Encode_Buffer[BUFFER], Row_Bytes);
3282 {Allocate buffers for the filters selected}
3283 {Filter none will always be calculated to the other filters to work}
3284 GetMem(Encode_Buffer[FILTER_NONE], Row_Bytes);
3285 ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes);
3286 if pfSub in Owner.Filters then
3287 GetMem(Encode_Buffer[FILTER_SUB], Row_Bytes);
3288 if pfUp in Owner.Filters then
3289 GetMem(Encode_Buffer[FILTER_UP], Row_Bytes);
3290 if pfAverage in Owner.Filters then
3291 GetMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes);
3292 if pfPaeth in Owner.Filters then
3293 GetMem(Encode_Buffer[FILTER_PAETH], Row_Bytes);
3294
3295 {Initialize ZLIB}
3296 ZLIBStream := ZLIBInitDeflate(Stream, Owner.fCompressionLevel,
3297 Owner.MaxIdatSize);
3298 {Write data depending on the interlace method}
3299 case Owner.InterlaceMethod of
3300 imNone: EncodeNonInterlaced(stream, ZLIBStream);
3301 imAdam7: EncodeInterlacedAdam7(stream, ZLIBStream);
3302 end;
3303 {Terminates ZLIB}
3304 ZLIBTerminateDeflate(ZLIBStream);
3305
3306 {Release allocated memory}
3307 FreeMem(Encode_Buffer[BUFFER], Row_Bytes);
3308 FreeMem(Encode_Buffer[FILTER_NONE], Row_Bytes);
3309 if pfSub in Owner.Filters then
3310 FreeMem(Encode_Buffer[FILTER_SUB], Row_Bytes);
3311 if pfUp in Owner.Filters then
3312 FreeMem(Encode_Buffer[FILTER_UP], Row_Bytes);
3313 if pfAverage in Owner.Filters then
3314 FreeMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes);
3315 if pfPaeth in Owner.Filters then
3316 FreeMem(Encode_Buffer[FILTER_PAETH], Row_Bytes);
3317
3318 {Everything went ok}
3319 Result := True;
3320end;
3321
3322{Writes the IDAT using the settings}
3323procedure WriteIDAT(Stream: TStream; Data: Pointer; const Length: Cardinal);
3324var
3325 ChunkLen, CRC: Cardinal;
3326begin
3327 {Writes IDAT header}
3328 ChunkLen := ByteSwap(Length);
3329 Stream.Write(ChunkLen, 4); {Chunk length}
3330 Stream.Write(IDATHeader[0], 4); {Idat header}
3331 CRC := update_crc($ffffffff, @IDATHeader[0], 4); {Crc part for header}
3332
3333 {Writes IDAT data and calculates CRC for data}
3334 Stream.Write(Data^, Length);
3335 CRC := Byteswap(update_crc(CRC, Data, Length) xor $ffffffff);
3336 {Writes final CRC}
3337 Stream.Write(CRC, 4);
3338end;
3339
3340{Compress and writes IDAT chunk data}
3341procedure TChunkIDAT.IDATZlibWrite(var ZLIBStream: TZStreamRec2;
3342 Buffer: Pointer; const Length: Cardinal);
3343begin
3344 with ZLIBStream, ZLIBStream.ZLIB do
3345 begin
3346 {Set data to be compressed}
3347 next_in := Buffer;
3348 avail_in := Length;
3349
3350 {Compress all the data avaliable to compress}
3351 while avail_in > 0 do
3352 begin
3353 deflate(ZLIB, Z_NO_FLUSH);
3354
3355 {The whole buffer was used, save data to stream and restore buffer}
3356 if avail_out = 0 then
3357 begin
3358 {Writes this IDAT chunk}
3359 WriteIDAT(fStream, Data, Owner.MaxIdatSize);
3360
3361 {Restore buffer}
3362 next_out := Data;
3363 avail_out := Owner.MaxIdatSize;
3364 end {if avail_out = 0};
3365
3366 end {while avail_in};
3367
3368 end {with ZLIBStream, ZLIBStream.ZLIB}
3369end;
3370
3371{Finishes compressing data to write IDAT chunk}
3372procedure TChunkIDAT.FinishIDATZlib(var ZLIBStream: TZStreamRec2);
3373begin
3374 with ZLIBStream, ZLIBStream.ZLIB do
3375 begin
3376 {Set data to be compressed}
3377 next_in := nil;
3378 avail_in := 0;
3379
3380 while deflate(ZLIB,Z_FINISH) <> Z_STREAM_END do
3381 begin
3382 {Writes this IDAT chunk}
3383 WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out);
3384 {Re-update buffer}
3385 next_out := Data;
3386 avail_out := Owner.MaxIdatSize;
3387 end;
3388
3389 if avail_out < Owner.MaxIdatSize then
3390 {Writes final IDAT}
3391 WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out);
3392
3393 end {with ZLIBStream, ZLIBStream.ZLIB};
3394end;
3395
3396{Copy memory to encode RGB image with 1 byte for each color sample}
3397procedure TChunkIDAT.EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar);
3398var
3399 I: Integer;
3400begin
3401 FOR I := 1 TO ImageWidth DO
3402 begin
3403 {Copy pixel values}
3404 Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest);
3405 Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest);
3406 Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest);
3407 {Move to next pixel}
3408 inc(Src, 3);
3409 end {for I}
3410end;
3411
3412{Copy memory to encode RGB images with 16 bits for each color sample}
3413procedure TChunkIDAT.EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar);
3414var
3415 I: Integer;
3416begin
3417 FOR I := 1 TO ImageWidth DO
3418 begin
3419 //Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word)
3420 //for sample
3421 {Copy pixel values}
3422 pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2);
3423 pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2);
3424 pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2);
3425 {Move to next pixel}
3426 inc(Src, 3);
3427 end {for I}
3428
3429end;
3430
3431{Copy memory to encode types using palettes (1, 4 or 8 bits per pixel)}
3432procedure TChunkIDAT.EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar);
3433begin
3434 {It's simple as copying the data}
3435 CopyMemory(Dest, Src, Row_Bytes);
3436end;
3437
3438{Copy memory to encode grayscale images with 2 bytes for each sample}
3439procedure TChunkIDAT.EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar);
3440var
3441 I: Integer;
3442begin
3443 FOR I := 1 TO ImageWidth DO
3444 begin
3445 //Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word)
3446 //for sample
3447 pWORD(Dest)^ := pByte(Longint(Src))^; inc(Dest, 2);
3448 {Move to next pixel}
3449 inc(Src);
3450 end {for I}
3451end;
3452
3453{Encode images using RGB followed by an alpha value using 1 byte for each}
3454procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar);
3455var
3456 i: Integer;
3457begin
3458 {Copy the data to the destination, including data from Trans pointer}
3459 FOR i := 1 TO ImageWidth do
3460 begin
3461 Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest);
3462 Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest);
3463 Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest);
3464 Dest^ := Trans^; inc(Dest);
3465 inc(Src, 3); inc(Trans);
3466 end {for i};
3467end;
3468
3469{Encode images using RGB followed by an alpha value using 2 byte for each}
3470procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar);
3471var
3472 i: Integer;
3473begin
3474 {Copy the data to the destination, including data from Trans pointer}
3475 FOR i := 1 TO ImageWidth do
3476 begin
3477 pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest, 2);
3478 pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest, 2);
3479 pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest, 2);
3480 pWord(Dest)^ := PByte(Longint(Trans) )^; inc(Dest, 2);
3481 inc(Src, 3); inc(Trans);
3482 end {for i};
3483end;
3484
3485{Encode grayscale images followed by an alpha value using 1 byte for each}
3486procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha8(
3487 Src, Dest, Trans: pChar);
3488var
3489 i: Integer;
3490begin
3491 {Copy the data to the destination, including data from Trans pointer}
3492 FOR i := 1 TO ImageWidth do
3493 begin
3494 Dest^ := Src^; inc(Dest);
3495 Dest^ := Trans^; inc(Dest);
3496 inc(Src); inc(Trans);
3497 end {for i};
3498end;
3499
3500{Encode grayscale images followed by an alpha value using 2 byte for each}
3501procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha16(
3502 Src, Dest, Trans: pChar);
3503var
3504 i: Integer;
3505begin
3506 {Copy the data to the destination, including data from Trans pointer}
3507 FOR i := 1 TO ImageWidth do
3508 begin
3509 pWord(Dest)^ := pByte(Src)^; inc(Dest, 2);
3510 pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2);
3511 inc(Src); inc(Trans);
3512 end {for i};
3513end;
3514
3515{Encode non interlaced images}
3516procedure TChunkIDAT.EncodeNonInterlaced(Stream: TStream;
3517 var ZLIBStream: TZStreamRec2);
3518var
3519 {Current line}
3520 j: Cardinal;
3521 {Pointers to image data}
3522 Data, Trans: PChar;
3523 {Filter used for this line}
3524 Filter: Byte;
3525 {Method which will copy the data into the buffer}
3526 CopyProc: procedure(Src, Dest, Trans: pChar) of object;
3527begin
3528 CopyProc := nil; {Initialize to avoid warnings}
3529 {Defines the method to copy the data to the buffer depending on}
3530 {the image parameters}
3531 case Header.ColorType of
3532 {R, G, B values}
3533 COLOR_RGB:
3534 case Header.BitDepth of
3535 8: CopyProc := EncodeNonInterlacedRGB8;
3536 16: CopyProc := EncodeNonInterlacedRGB16;
3537 end;
3538 {Palette and grayscale values}
3539 COLOR_GRAYSCALE, COLOR_PALETTE:
3540 case Header.BitDepth of
3541 1, 4, 8: CopyProc := EncodeNonInterlacedPalette148;
3542 16: CopyProc := EncodeNonInterlacedGrayscale16;
3543 end;
3544 {RGB with a following alpha value}
3545 COLOR_RGBALPHA:
3546 case Header.BitDepth of
3547 8: CopyProc := EncodeNonInterlacedRGBAlpha8;
3548 16: CopyProc := EncodeNonInterlacedRGBAlpha16;
3549 end;
3550 {Grayscale images followed by an alpha}
3551 COLOR_GRAYSCALEALPHA:
3552 case Header.BitDepth of
3553 8: CopyProc := EncodeNonInterlacedGrayscaleAlpha8;
3554 16: CopyProc := EncodeNonInterlacedGrayscaleAlpha16;
3555 end;
3556 end {case Header.ColorType};
3557
3558 {Get the image data pointer}
3559 Longint(Data) := Longint(Header.ImageData) +
3560 Header.BytesPerRow * (ImageHeight - 1);
3561 Trans := Header.ImageAlpha;
3562
3563 {Writes each line}
3564 FOR j := 0 to ImageHeight - 1 do
3565 begin
3566 {Copy data into buffer}
3567 CopyProc(Data, @Encode_Buffer[BUFFER][0], Trans);
3568 {Filter data}
3569 Filter := FilterToEncode;
3570
3571 {Compress data}
3572 IDATZlibWrite(ZLIBStream, @Filter, 1);
3573 IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes);
3574
3575 {Adjust pointers to the actual image data}
3576 dec(Data, Header.BytesPerRow);
3577 inc(Trans, ImageWidth);
3578 end;
3579
3580 {Compress and finishes copying the remaining data}
3581 FinishIDATZlib(ZLIBStream);
3582end;
3583
3584{Copy memory to encode interlaced images using RGB value with 1 byte for}
3585{each color sample}
3586procedure TChunkIDAT.EncodeInterlacedRGB8(const Pass: Byte;
3587 Src, Dest, Trans: pChar);
3588var
3589 Col: Integer;
3590begin
3591 {Get first column and enter in loop}
3592 Col := ColumnStart[Pass];
3593 Src := pChar(Longint(Src) + Col * 3);
3594 repeat
3595 {Copy this row}
3596 Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest);
3597 Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest);
3598 Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest);
3599
3600 {Move to next column}
3601 inc(Src, ColumnIncrement[Pass] * 3);
3602 inc(Col, ColumnIncrement[Pass]);
3603 until Col >= ImageWidth;
3604end;
3605
3606{Copy memory to encode interlaced RGB images with 2 bytes each color sample}
3607procedure TChunkIDAT.EncodeInterlacedRGB16(const Pass: Byte;
3608 Src, Dest, Trans: pChar);
3609var
3610 Col: Integer;
3611begin
3612 {Get first column and enter in loop}
3613 Col := ColumnStart[Pass];
3614 Src := pChar(Longint(Src) + Col * 3);
3615 repeat
3616 {Copy this row}
3617 pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2);
3618 pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2);
3619 pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2);
3620
3621 {Move to next column}
3622 inc(Src, ColumnIncrement[Pass] * 3);
3623 inc(Col, ColumnIncrement[Pass]);
3624 until Col >= ImageWidth;
3625end;
3626
3627{Copy memory to encode interlaced images using palettes using bit depths}
3628{1, 4, 8 (each pixel in the image)}
3629procedure TChunkIDAT.EncodeInterlacedPalette148(const Pass: Byte;
3630 Src, Dest, Trans: pChar);
3631const
3632 BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF);
3633 StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0);
3634var
3635 CurBit, Col: Integer;
3636 Src2: PChar;
3637begin
3638 {Clean the line}
3639 fillchar(Dest^, Row_Bytes, #0);
3640 {Get first column and enter in loop}
3641 Col := ColumnStart[Pass];
3642 with Header.BitmapInfo.bmiHeader do
3643 repeat
3644 {Copy data}
3645 CurBit := StartBit[biBitCount];
3646 repeat
3647 {Adjust pointer to pixel byte bounds}
3648 Src2 := pChar(Longint(Src) + (biBitCount * Col) div 8);
3649 {Copy data}
3650 Byte(Dest^) := Byte(Dest^) or
3651 (((Byte(Src2^) shr (StartBit[Header.BitDepth] - (biBitCount * Col)
3652 mod 8))) and (BitTable[biBitCount])) shl CurBit;
3653
3654 {Move to next column}
3655 inc(Col, ColumnIncrement[Pass]);
3656 {Will read next bits}
3657 dec(CurBit, biBitCount);
3658 until CurBit < 0;
3659
3660 {Move to next byte in source}
3661 inc(Dest);
3662 until Col >= ImageWidth;
3663end;
3664
3665{Copy to encode interlaced grayscale images using 16 bits for each sample}
3666procedure TChunkIDAT.EncodeInterlacedGrayscale16(const Pass: Byte;
3667 Src, Dest, Trans: pChar);
3668var
3669 Col: Integer;
3670begin
3671 {Get first column and enter in loop}
3672 Col := ColumnStart[Pass];
3673 Src := pChar(Longint(Src) + Col);
3674 repeat
3675 {Copy this row}
3676 pWord(Dest)^ := Byte(Src^); inc(Dest, 2);
3677
3678 {Move to next column}
3679 inc(Src, ColumnIncrement[Pass]);
3680 inc(Col, ColumnIncrement[Pass]);
3681 until Col >= ImageWidth;
3682end;
3683
3684{Copy to encode interlaced rgb images followed by an alpha value, all using}
3685{one byte for each sample}
3686procedure TChunkIDAT.EncodeInterlacedRGBAlpha8(const Pass: Byte;
3687 Src, Dest, Trans: pChar);
3688var
3689 Col: Integer;
3690begin
3691 {Get first column and enter in loop}
3692 Col := ColumnStart[Pass];
3693 Src := pChar(Longint(Src) + Col * 3);
3694 Trans := pChar(Longint(Trans) + Col);
3695 repeat
3696 {Copy this row}
3697 Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest);
3698 Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest);
3699 Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest);
3700 Dest^ := Trans^; inc(Dest);
3701
3702 {Move to next column}
3703 inc(Src, ColumnIncrement[Pass] * 3);
3704 inc(Trans, ColumnIncrement[Pass]);
3705 inc(Col, ColumnIncrement[Pass]);
3706 until Col >= ImageWidth;
3707end;
3708
3709{Copy to encode interlaced rgb images followed by an alpha value, all using}
3710{two byte for each sample}
3711procedure TChunkIDAT.EncodeInterlacedRGBAlpha16(const Pass: Byte;
3712 Src, Dest, Trans: pChar);
3713var
3714 Col: Integer;
3715begin
3716 {Get first column and enter in loop}
3717 Col := ColumnStart[Pass];
3718 Src := pChar(Longint(Src) + Col * 3);
3719 Trans := pChar(Longint(Trans) + Col);
3720 repeat
3721 {Copy this row}
3722 pWord(Dest)^ := pByte(Longint(Src) + 2)^; inc(Dest, 2);
3723 pWord(Dest)^ := pByte(Longint(Src) + 1)^; inc(Dest, 2);
3724 pWord(Dest)^ := pByte(Longint(Src) )^; inc(Dest, 2);
3725 pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2);
3726
3727 {Move to next column}
3728 inc(Src, ColumnIncrement[Pass] * 3);
3729 inc(Trans, ColumnIncrement[Pass]);
3730 inc(Col, ColumnIncrement[Pass]);
3731 until Col >= ImageWidth;
3732end;
3733
3734{Copy to encode grayscale interlaced images followed by an alpha value, all}
3735{using 1 byte for each sample}
3736procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha8(const Pass: Byte;
3737 Src, Dest, Trans: pChar);
3738var
3739 Col: Integer;
3740begin
3741 {Get first column and enter in loop}
3742 Col := ColumnStart[Pass];
3743 Src := pChar(Longint(Src) + Col);
3744 Trans := pChar(Longint(Trans) + Col);
3745 repeat
3746 {Copy this row}
3747 Dest^ := Src^; inc(Dest);
3748 Dest^ := Trans^; inc(Dest);
3749
3750 {Move to next column}
3751 inc(Src, ColumnIncrement[Pass]);
3752 inc(Trans, ColumnIncrement[Pass]);
3753 inc(Col, ColumnIncrement[Pass]);
3754 until Col >= ImageWidth;
3755end;
3756
3757{Copy to encode grayscale interlaced images followed by an alpha value, all}
3758{using 2 bytes for each sample}
3759procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha16(const Pass: Byte;
3760 Src, Dest, Trans: pChar);
3761var
3762 Col: Integer;
3763begin
3764 {Get first column and enter in loop}
3765 Col := ColumnStart[Pass];
3766 Src := pChar(Longint(Src) + Col);
3767 Trans := pChar(Longint(Trans) + Col);
3768 repeat
3769 {Copy this row}
3770 pWord(Dest)^ := pByte(Src)^; inc(Dest, 2);
3771 pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2);
3772
3773 {Move to next column}
3774 inc(Src, ColumnIncrement[Pass]);
3775 inc(Trans, ColumnIncrement[Pass]);
3776 inc(Col, ColumnIncrement[Pass]);
3777 until Col >= ImageWidth;
3778end;
3779
3780{Encode interlaced images}
3781procedure TChunkIDAT.EncodeInterlacedAdam7(Stream: TStream;
3782 var ZLIBStream: TZStreamRec2);
3783var
3784 CurrentPass, Filter: Byte;
3785 PixelsThisRow: Integer;
3786 CurrentRow : Integer;
3787 Trans, Data: pChar;
3788 CopyProc: procedure(const Pass: Byte;
3789 Src, Dest, Trans: pChar) of object;
3790begin
3791 CopyProc := nil; {Initialize to avoid warnings}
3792 {Defines the method to copy the data to the buffer depending on}
3793 {the image parameters}
3794 case Header.ColorType of
3795 {R, G, B values}
3796 COLOR_RGB:
3797 case Header.BitDepth of
3798 8: CopyProc := EncodeInterlacedRGB8;
3799 16: CopyProc := EncodeInterlacedRGB16;
3800 end;
3801 {Grayscale and palette}
3802 COLOR_PALETTE, COLOR_GRAYSCALE:
3803 case Header.BitDepth of
3804 1, 4, 8: CopyProc := EncodeInterlacedPalette148;
3805 16: CopyProc := EncodeInterlacedGrayscale16;
3806 end;
3807 {RGB followed by alpha}
3808 COLOR_RGBALPHA:
3809 case Header.BitDepth of
3810 8: CopyProc := EncodeInterlacedRGBAlpha8;
3811 16: CopyProc := EncodeInterlacedRGBAlpha16;
3812 end;
3813 COLOR_GRAYSCALEALPHA:
3814 {Grayscale followed by alpha}
3815 case Header.BitDepth of
3816 8: CopyProc := EncodeInterlacedGrayscaleAlpha8;
3817 16: CopyProc := EncodeInterlacedGrayscaleAlpha16;
3818 end;
3819 end {case Header.ColorType};
3820
3821 {Compress the image using the seven passes for ADAM 7}
3822 FOR CurrentPass := 0 TO 6 DO
3823 begin
3824 {Calculates the number of pixels and bytes for this pass row}
3825 PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] +
3826 ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass];
3827 Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType,
3828 Header.BitDepth);
3829 ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes);
3830
3831 {Get current row index}
3832 CurrentRow := RowStart[CurrentPass];
3833 {Get a pointer to the current row image data}
3834 Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow *
3835 (ImageHeight - 1 - CurrentRow));
3836 Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow);
3837
3838 {Process all the image rows}
3839 if Row_Bytes > 0 then
3840 while CurrentRow < ImageHeight do
3841 begin
3842 {Copy data into buffer}
3843 CopyProc(CurrentPass, Data, @Encode_Buffer[BUFFER][0], Trans);
3844 {Filter data}
3845 Filter := FilterToEncode;
3846
3847 {Compress data}
3848 IDATZlibWrite(ZLIBStream, @Filter, 1);
3849 IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes);
3850
3851 {Move to the next row}
3852 inc(CurrentRow, RowIncrement[CurrentPass]);
3853 {Move pointer to the next line}
3854 dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow);
3855 inc(Trans, RowIncrement[CurrentPass] * ImageWidth);
3856 end {while CurrentRow < ImageHeight}
3857
3858 end {CurrentPass};
3859
3860 {Compress and finishes copying the remaining data}
3861 FinishIDATZlib(ZLIBStream);
3862end;
3863
3864{Filters the row to be encoded and returns the best filter}
3865function TChunkIDAT.FilterToEncode: Byte;
3866var
3867 Run, LongestRun, ii, jj: Cardinal;
3868 Last, Above, LastAbove: Byte;
3869begin
3870 {Selecting more filters using the Filters property from TPngObject}
3871 {increases the chances to the file be much smaller, but decreases}
3872 {the performace}
3873
3874 {This method will creates the same line data using the different}
3875 {filter methods and select the best}
3876
3877 {Sub-filter}
3878 if pfSub in Owner.Filters then
3879 for ii := 0 to Row_Bytes - 1 do
3880 begin
3881 {There is no previous pixel when it's on the first pixel, so}
3882 {set last as zero when in the first}
3883 if (ii >= Offset) then
3884 last := Encode_Buffer[BUFFER]^[ii - Offset]
3885 else
3886 last := 0;
3887 Encode_Buffer[FILTER_SUB]^[ii] := Encode_Buffer[BUFFER]^[ii] - last;
3888 end;
3889
3890 {Up filter}
3891 if pfUp in Owner.Filters then
3892 for ii := 0 to Row_Bytes - 1 do
3893 Encode_Buffer[FILTER_UP]^[ii] := Encode_Buffer[BUFFER]^[ii] -
3894 Encode_Buffer[FILTER_NONE]^[ii];
3895
3896 {Average filter}
3897 if pfAverage in Owner.Filters then
3898 for ii := 0 to Row_Bytes - 1 do
3899 begin
3900 {Get the previous pixel, if the current pixel is the first, the}
3901 {previous is considered to be 0}
3902 if (ii >= Offset) then
3903 last := Encode_Buffer[BUFFER]^[ii - Offset]
3904 else
3905 last := 0;
3906 {Get the pixel above}
3907 above := Encode_Buffer[FILTER_NONE]^[ii];
3908
3909 {Calculates formula to the average pixel}
3910 Encode_Buffer[FILTER_AVERAGE]^[ii] := Encode_Buffer[BUFFER]^[ii] -
3911 (above + last) div 2 ;
3912 end;
3913
3914 {Paeth filter (the slower)}
3915 if pfPaeth in Owner.Filters then
3916 begin
3917 {Initialize}
3918 last := 0;
3919 lastabove := 0;
3920 for ii := 0 to Row_Bytes - 1 do
3921 begin
3922 {In case this pixel is not the first in the line obtains the}
3923 {previous one and the one above the previous}
3924 if (ii >= Offset) then
3925 begin
3926 last := Encode_Buffer[BUFFER]^[ii - Offset];
3927 lastabove := Encode_Buffer[FILTER_NONE]^[ii - Offset];
3928 end;
3929 {Obtains the pixel above}
3930 above := Encode_Buffer[FILTER_NONE]^[ii];
3931 {Calculate paeth filter for this byte}
3932 Encode_Buffer[FILTER_PAETH]^[ii] := Encode_Buffer[BUFFER]^[ii] -
3933 PaethPredictor(last, above, lastabove);
3934 end;
3935 end;
3936
3937 {Now calculates the same line using no filter, which is necessary}
3938 {in order to have data to the filters when the next line comes}
3939 CopyMemory(@Encode_Buffer[FILTER_NONE]^[0],
3940 @Encode_Buffer[BUFFER]^[0], Row_Bytes);
3941
3942 {If only filter none is selected in the filter list, we don't need}
3943 {to proceed and further}
3944 if (Owner.Filters = [pfNone]) or (Owner.Filters = []) then
3945 begin
3946 Result := FILTER_NONE;
3947 exit;
3948 end {if (Owner.Filters = [pfNone...};
3949
3950 {Check which filter is the best by checking which has the larger}
3951 {sequence of the same byte, since they are best compressed}
3952 LongestRun := 0; Result := FILTER_NONE;
3953 for ii := FILTER_NONE TO FILTER_PAETH do
3954 {Check if this filter was selected}
3955 if TFilter(ii) in Owner.Filters then
3956 begin
3957 Run := 0;
3958 {Check if it's the only filter}
3959 if Owner.Filters = [TFilter(ii)] then
3960 begin
3961 Result := ii;
3962 exit;
3963 end;
3964
3965 {Check using a sequence of four bytes}
3966 for jj := 2 to Row_Bytes - 1 do
3967 if (Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-1]) or
3968 (Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-2]) then
3969 inc(Run); {Count the number of sequences}
3970
3971 {Check if this one is the best so far}
3972 if (Run > LongestRun) then
3973 begin
3974 Result := ii;
3975 LongestRun := Run;
3976 end {if (Run > LongestRun)};
3977
3978 end {if TFilter(ii) in Owner.Filters};
3979end;
3980
3981{TChunkPLTE implementation}
3982
3983{Returns an item in the palette}
3984function TChunkPLTE.GetPaletteItem(Index: Byte): TRGBQuad;
3985begin
3986 {Test if item is valid, if not raise error}
3987 if Index > Count - 1 then
3988 Owner.RaiseError(EPNGError, EPNGUnknownPalEntryText)
3989 else
3990 {Returns the item}
3991 Result := Header.BitmapInfo.bmiColors[Index];
3992end;
3993
3994{Loads the palette chunk from a stream}
3995function TChunkPLTE.LoadFromStream(Stream: TStream;
3996 const ChunkName: TChunkName; Size: Integer): Boolean;
3997type
3998 pPalEntry = ^PalEntry;
3999 PalEntry = record
4000 r, g, b: Byte;
4001 end;
4002var
4003 j : Integer; {For the FOR}
4004 PalColor : pPalEntry;
4005begin
4006 {Let ancestor load data and check CRC}
4007 Result := inherited LoadFromStream(Stream, ChunkName, Size);
4008 if not Result then exit;
4009
4010 {This chunk must be divisible by 3 in order to be valid}
4011 if (Size mod 3 <> 0) or (Size div 3 > 256) then
4012 begin
4013 {Raise error}
4014 Result := FALSE;
4015 Owner.RaiseError(EPNGInvalidPalette, EPNGInvalidPaletteText);
4016 exit;
4017 end {if Size mod 3 <> 0};
4018
4019 {Fill array with the palette entries}
4020 fCount := Size div 3;
4021 PalColor := Data;
4022 FOR j := 0 TO fCount - 1 DO
4023 with Header.BitmapInfo.bmiColors[j] do
4024 begin
4025 rgbRed := Owner.GammaTable[PalColor.r];
4026 rgbGreen := Owner.GammaTable[PalColor.g];
4027 rgbBlue := Owner.GammaTable[PalColor.b];
4028 rgbReserved := 0;
4029 {Move to next palette entry}
4030 inc(PalColor);
4031 end;
4032end;
4033
4034{Saves the PLTE chunk to a stream}
4035function TChunkPLTE.SaveToStream(Stream: TStream): Boolean;
4036var
4037 J: Integer;
4038 DataPtr: pByte;
4039begin
4040 {Adjust size to hold all the palette items}
4041 ResizeData(fCount * 3);
4042 {Copy pointer to data}
4043 DataPtr := fData;
4044
4045 {Copy palette items}
4046 with Header do
4047 FOR j := 0 TO fCount - 1 DO
4048 with BitmapInfo.bmiColors[j] do
4049 begin
4050 DataPtr^ := Owner.InverseGamma[rgbRed]; inc(DataPtr);
4051 DataPtr^ := Owner.InverseGamma[rgbGreen]; inc(DataPtr);
4052 DataPtr^ := Owner.InverseGamma[rgbBlue]; inc(DataPtr);
4053 end {with BitmapInfo};
4054
4055 {Let ancestor do the rest of the work}
4056 Result := inherited SaveToStream(Stream);
4057end;
4058
4059{Assigns from another PLTE chunk}
4060procedure TChunkPLTE.Assign(Source: TChunk);
4061begin
4062 {Copy the number of palette items}
4063 if Source is TChunkPLTE then
4064 fCount := TChunkPLTE(Source).fCount
4065 else
4066 Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText);
4067end;
4068
4069{TChunkgAMA implementation}
4070
4071{Assigns from another chunk}
4072procedure TChunkgAMA.Assign(Source: TChunk);
4073begin
4074 {Copy the gamma value}
4075 if Source is TChunkgAMA then
4076 Gamma := TChunkgAMA(Source).Gamma
4077 else
4078 Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText);
4079end;
4080
4081{Gamma chunk being created}
4082constructor TChunkgAMA.Create(Owner: TPngObject);
4083begin
4084 {Call ancestor}
4085 inherited Create(Owner);
4086 Gamma := 1; {Initial value}
4087end;
4088
4089{Returns gamma value}
4090function TChunkgAMA.GetValue: Cardinal;
4091begin
4092 {Make sure that the size is four bytes}
4093 if DataSize <> 4 then
4094 begin
4095 {Adjust size and returns 1}
4096 ResizeData(4);
4097 Result := 1;
4098 end
4099 {If it's right, read the value}
4100 else Result := Cardinal(ByteSwap(pCardinal(Data)^))
4101end;
4102
4103function Power(Base, Exponent: Extended): Extended;
4104begin
4105 if Exponent = 0.0 then
4106 Result := 1.0 {Math rule}
4107 else if (Base = 0) or (Exponent = 0) then Result := 0
4108 else
4109 Result := Exp(Exponent * Ln(Base));
4110end;
4111
4112
4113{Loading the chunk from a stream}
4114function TChunkgAMA.LoadFromStream(Stream: TStream;
4115 const ChunkName: TChunkName; Size: Integer): Boolean;
4116var
4117 i: Integer;
4118 Value: Cardinal;
4119begin
4120 {Call ancestor and test if it went ok}
4121 Result := inherited LoadFromStream(Stream, ChunkName, Size);
4122 if not Result then exit;
4123 Value := Gamma;
4124 {Build gamma table and inverse table for saving}
4125 if Value <> 0 then
4126 with Owner do
4127 FOR i := 0 TO 255 DO
4128 begin
4129 GammaTable[I] := Round(Power((I / 255), 1 /
4130 (Value / 100000 * 2.2)) * 255);
4131 InverseGamma[Round(Power((I / 255), 1 /
4132 (Value / 100000 * 2.2)) * 255)] := I;
4133 end
4134end;
4135
4136{Sets the gamma value}
4137procedure TChunkgAMA.SetValue(const Value: Cardinal);
4138begin
4139 {Make sure that the size is four bytes}
4140 if DataSize <> 4 then ResizeData(4);
4141 {If it's right, set the value}
4142 pCardinal(Data)^ := ByteSwap(Value);
4143end;
4144
4145{TPngObject implementation}
4146
4147{Assigns from another object}
4148procedure TPngObject.Assign(Source: TPersistent);
4149begin
4150 {Being cleared}
4151 if Source = nil then
4152 ClearChunks
4153 {Assigns contents from another TPNGObject}
4154 else if Source is TPNGObject then
4155 AssignPNG(Source as TPNGObject)
4156 {Copy contents from a TBitmap}
4157 {$IFDEF UseDelphi}else if Source is TBitmap then
4158 with Source as TBitmap do
4159 AssignHandle(Handle, Transparent,
4160 ColorToRGB(TransparentColor)){$ENDIF}
4161 {Unknown source, let ancestor deal with it}
4162 else
4163 inherited;
4164end;
4165
4166{Clear all the chunks in the list}
4167procedure TPngObject.ClearChunks;
4168var
4169 i: Integer;
4170begin
4171 {Initialize gamma}
4172 InitializeGamma();
4173 {Free all the objects and memory (0 chunks Bug fixed by Noel Sharpe)}
4174 for i := 0 TO Integer(Chunks.Count) - 1 do
4175 TChunk(Chunks.Item[i]).Free;
4176 Chunks.Count := 0;
4177end;
4178
4179{Portable Network Graphics object being created}
4180constructor TPngObject.Create;
4181begin
4182 {Let it be created}
4183 inherited Create;
4184
4185 {Initial properties}
4186 TempPalette := 0;
4187 fFilters := [pfSub];
4188 fCompressionLevel := 7;
4189 fInterlaceMethod := imNone;
4190 fMaxIdatSize := High(Word);
4191 {Create chunklist object}
4192 fChunkList := TPngList.Create(Self);
4193end;
4194
4195{Portable Network Graphics object being destroyed}
4196destructor TPngObject.Destroy;
4197begin
4198 {Free object list}
4199 ClearChunks;
4200 fChunkList.Free;
4201 {Free the temporary palette}
4202 if TempPalette <> 0 then DeleteObject(TempPalette);
4203
4204 {Call ancestor destroy}
4205 inherited Destroy;
4206end;
4207
4208{Returns linesize and byte offset for pixels}
4209procedure TPngObject.GetPixelInfo(var LineSize, Offset: Cardinal);
4210begin
4211 {There must be an Header chunk to calculate size}
4212 if HeaderPresent then
4213 begin
4214 {Calculate number of bytes for each line}
4215 LineSize := BytesForPixels(Header.Width, Header.ColorType, Header.BitDepth);
4216
4217 {Calculates byte offset}
4218 Case Header.ColorType of
4219 {Grayscale}
4220 COLOR_GRAYSCALE:
4221 If Header.BitDepth = 16 Then
4222 Offset := 2
4223 Else
4224 Offset := 1 ;
4225 {It always smaller or equal one byte, so it occupes one byte}
4226 COLOR_PALETTE:
4227 offset := 1;
4228 {It might be 3 or 6 bytes}
4229 COLOR_RGB:
4230 offset := 3 * Header.BitDepth Div 8;
4231 {It might be 2 or 4 bytes}
4232 COLOR_GRAYSCALEALPHA:
4233 offset := 2 * Header.BitDepth Div 8;
4234 {4 or 8 bytes}
4235 COLOR_RGBALPHA:
4236 offset := 4 * Header.BitDepth Div 8;
4237 else
4238 Offset := 0;
4239 End ;
4240
4241 end
4242 else
4243 begin
4244 {In case if there isn't any Header chunk}
4245 Offset := 0;
4246 LineSize := 0;
4247 end;
4248
4249end;
4250
4251{Returns image height}
4252function TPngObject.GetHeight: Integer;
4253begin
4254 {There must be a Header chunk to get the size, otherwise returns 0}
4255 if HeaderPresent then
4256 Result := TChunkIHDR(Chunks.Item[0]).Height
4257 else Result := 0;
4258end;
4259
4260{Returns image width}
4261function TPngObject.GetWidth: Integer;
4262begin
4263 {There must be a Header chunk to get the size, otherwise returns 0}
4264 if HeaderPresent then
4265 Result := Header.Width
4266 else Result := 0;
4267end;
4268
4269{Returns if the image is empty}
4270function TPngObject.GetEmpty: Boolean;
4271begin
4272 Result := (Chunks.Count = 0);
4273end;
4274
4275{Raises an error}
4276procedure TPngObject.RaiseError(ExceptionClass: ExceptClass; Text: String);
4277begin
4278 raise ExceptionClass.Create(Text);
4279end;
4280
4281{Set the maximum size for IDAT chunk}
4282procedure TPngObject.SetMaxIdatSize(const Value: Integer);
4283begin
4284 {Make sure the size is at least 65535}
4285 if Value < High(Word) then
4286 fMaxIdatSize := High(Word) else fMaxIdatSize := Value;
4287end;
4288
4289{$IFNDEF UseDelphi}
4290 {Creates a file stream reading from the filename in the parameter and load}
4291 procedure TPngObject.LoadFromFile(const Filename: String);
4292 var
4293 FileStream: TFileStream;
4294 begin
4295 {Test if the file exists}
4296 if not FileExists(Filename) then
4297 begin
4298 {In case it does not exists, raise error}
4299 RaiseError(EPNGNotExists, EPNGNotExistsText);
4300 exit;
4301 end;
4302
4303 {Creates the file stream to read}
4304 FileStream := TFileStream.Create(Filename, [fsmRead]);
4305 LoadFromStream(FileStream); {Loads the data}
4306 FileStream.Free; {Free file stream}
4307 end;
4308
4309 {Saves the current png image to a file}
4310 procedure TPngObject.SaveToFile(const Filename: String);
4311 var
4312 FileStream: TFileStream;
4313 begin
4314 {Creates the file stream to write}
4315 FileStream := TFileStream.Create(Filename, [fsmWrite]);
4316 SaveToStream(FileStream); {Saves the data}
4317 FileStream.Free; {Free file stream}
4318 end;
4319
4320{$ENDIF}
4321
4322{Returns pointer to the chunk TChunkIHDR which should be the first}
4323function TPngObject.GetHeader: TChunkIHDR;
4324begin
4325 {If there is a TChunkIHDR returns it, otherwise returns nil}
4326 if (Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR) then
4327 Result := Chunks.Item[0] as TChunkIHDR
4328 else
4329 begin
4330 {No header, throw error message}
4331 RaiseError(EPNGHeaderNotPresent, EPNGHeaderNotPresentText);
4332 Result := nil
4333 end
4334end;
4335
4336{Draws using partial transparency}
4337procedure TPngObject.DrawPartialTrans(DC: HDC; Rect: TRect);
4338 {Adjust the rectangle structure}
4339 procedure AdjustRect(var Rect: TRect);
4340 var
4341 t: Integer;
4342 begin
4343 if Rect.Right < Rect.Left then
4344 begin
4345 t := Rect.Right;
4346 Rect.Right := Rect.Left;
4347 Rect.Left := t;
4348 end;
4349 if Rect.Bottom < Rect.Top then
4350 begin
4351 t := Rect.Bottom;
4352 Rect.Bottom := Rect.Top;
4353 Rect.Top := t;
4354 end
4355 end;
4356
4357type
4358 {Access to pixels}
4359 TPixelLine = Array[Word] of TRGBQuad;
4360 pPixelLine = ^TPixelLine;
4361const
4362 {Structure used to create the bitmap}
4363 BitmapInfoHeader: TBitmapInfoHeader =
4364 (biSize: sizeof(TBitmapInfoHeader);
4365 biWidth: 100;
4366 biHeight: 100;
4367 biPlanes: 1;
4368 biBitCount: 32;
4369 biCompression: BI_RGB;
4370 biSizeImage: 0;
4371 biXPelsPerMeter: 0;
4372 biYPelsPerMeter: 0;
4373 biClrUsed: 0;
4374 biClrImportant: 0);
4375var
4376 {Buffer bitmap creation}
4377 BitmapInfo : TBitmapInfo;
4378 BufferDC : HDC;
4379 BufferBits : Pointer;
4380 OldBitmap,
4381 BufferBitmap: HBitmap;
4382 Header: TChunkIHDR;
4383
4384 {Transparency/palette chunks}
4385 TransparencyChunk: TChunktRNS;
4386 PaletteChunk: TChunkPLTE;
4387 TransValue, PaletteIndex: Byte;
4388 CurBit: Integer;
4389 Data: PByte;
4390
4391 {Buffer bitmap modification}
4392 BytesPerRowDest,
4393 BytesPerRowSrc,
4394 BytesPerRowAlpha: Integer;
4395 ImageSource, ImageSourceOrg,
4396 AlphaSource : pByteArray;
4397 ImageData : pPixelLine;
4398 i, j, i2, j2 : Integer;
4399
4400 {For bitmap stretching}
4401 W, H : Cardinal;
4402 Stretch : Boolean;
4403 FactorX, FactorY: Double;
4404begin
4405 {Prepares the rectangle structure to stretch draw}
4406 if (Rect.Right = Rect.Left) or (Rect.Bottom = Rect.Top) then exit;
4407 AdjustRect(Rect);
4408 {Gets the width and height}
4409 W := Rect.Right - Rect.Left;
4410 H := Rect.Bottom - Rect.Top;
4411 Header := Self.Header; {Fast access to header}
4412 Stretch := (W <> Header.Width) or (H <> Header.Height);
4413 if Stretch then FactorX := W / Header.Width else FactorX := 1;
4414 if Stretch then FactorY := H / Header.Height else FactorY := 1;
4415
4416 {Prepare to create the bitmap}
4417 Fillchar(BitmapInfo, sizeof(BitmapInfo), #0);
4418 BitmapInfoHeader.biWidth := W;
4419 BitmapInfoHeader.biHeight := -Integer(H);
4420 BitmapInfo.bmiHeader := BitmapInfoHeader;
4421
4422 {Create the bitmap which will receive the background, the applied}
4423 {alpha blending and then will be painted on the background}
4424 BufferDC := CreateCompatibleDC(0);
4425 {In case BufferDC could not be created}
4426 if (BufferDC = 0) then RaiseError(EPNGOutMemory, EPNGOutMemoryText);
4427 BufferBitmap := CreateDIBSection(BufferDC, BitmapInfo, DIB_RGB_COLORS,
4428 BufferBits, 0, 0);
4429 {In case buffer bitmap could not be created}
4430 if (BufferBitmap = 0) or (BufferBits = Nil) then
4431 begin
4432 if BufferBitmap <> 0 then DeleteObject(BufferBitmap);
4433 DeleteDC(BufferDC);
4434 RaiseError(EPNGOutMemory, EPNGOutMemoryText);
4435 end;
4436
4437 {Selects new bitmap and release old bitmap}
4438 OldBitmap := SelectObject(BufferDC, BufferBitmap);
4439
4440 {Draws the background on the buffer image}
4441 BitBlt(BufferDC, 0, 0, W, H, DC, Rect.Left, Rect.Top, SRCCOPY);
4442
4443 {Obtain number of bytes for each row}
4444 BytesPerRowAlpha := Header.Width;
4445 BytesPerRowDest := (((BitmapInfo.bmiHeader.biBitCount * W) + 31)
4446 and not 31) div 8; {Number of bytes for each image row in destination}
4447 BytesPerRowSrc := (((Header.BitmapInfo.bmiHeader.biBitCount * Header.Width) +
4448 31) and not 31) div 8; {Number of bytes for each image row in source}
4449
4450 {Obtains image pointers}
4451 ImageData := BufferBits;
4452 AlphaSource := Header.ImageAlpha;
4453 Longint(ImageSource) := Longint(Header.ImageData) +
4454 Header.BytesPerRow * Longint(Header.Height - 1);
4455 ImageSourceOrg := ImageSource;
4456
4457 case Header.BitmapInfo.bmiHeader.biBitCount of
4458 {R, G, B images}
4459 24:
4460 FOR j := 1 TO H DO
4461 begin
4462 {Process all the pixels in this line}
4463 FOR i := 0 TO W - 1 DO
4464 begin
4465 if Stretch then i2 := trunc(i / FactorX) else i2 := i;
4466 {Optmize when we don´t have transparency}
4467 if (AlphaSource[i2] <> 0) then
4468 if (AlphaSource[i2] = 255) then
4469 ImageData[i] := pRGBQuad(@ImageSource[i2 * 3])^
4470 else
4471 with ImageData[i] do
4472 begin
4473 rgbRed := (255+ImageSource[2+i2*3] * AlphaSource[i2] + rgbRed *
4474 (not AlphaSource[i2])) shr 8;
4475 rgbGreen := (255+ImageSource[1+i2*3] * AlphaSource[i2] +
4476 rgbGreen * (not AlphaSource[i2])) shr 8;
4477 rgbBlue := (255+ImageSource[i2*3] * AlphaSource[i2] + rgbBlue *
4478 (not AlphaSource[i2])) shr 8;
4479 end;
4480 end;
4481
4482 {Move pointers}
4483 inc(Longint(ImageData), BytesPerRowDest);
4484 if Stretch then j2 := trunc(j / FactorY) else j2 := j;
4485 Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
4486 Longint(AlphaSource) := Longint(Header.ImageAlpha) +
4487 BytesPerRowAlpha * j2;
4488 end;
4489 {Palette images with 1 byte for each pixel}
4490 1,4,8: if Header.ColorType = COLOR_GRAYSCALEALPHA then
4491 FOR j := 1 TO H DO
4492 begin
4493 {Process all the pixels in this line}
4494 FOR i := 0 TO W - 1 DO
4495 with ImageData[i], Header.BitmapInfo do begin
4496 if Stretch then i2 := trunc(i / FactorX) else i2 := i;
4497 rgbRed := (255 + ImageSource[i2] * AlphaSource[i2] +
4498 rgbRed * (255 - AlphaSource[i2])) shr 8;
4499 rgbGreen := (255 + ImageSource[i2] * AlphaSource[i2] +
4500 rgbGreen * (255 - AlphaSource[i2])) shr 8;
4501 rgbBlue := (255 + ImageSource[i2] * AlphaSource[i2] +
4502 rgbBlue * (255 - AlphaSource[i2])) shr 8;
4503 end;
4504
4505 {Move pointers}
4506 Longint(ImageData) := Longint(ImageData) + BytesPerRowDest;
4507 if Stretch then j2 := trunc(j / FactorY) else j2 := j;
4508 Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
4509 Longint(AlphaSource) := Longint(Header.ImageAlpha) +
4510 BytesPerRowAlpha * j2;
4511 end
4512 else {Palette images}
4513 begin
4514 {Obtain pointer to the transparency chunk}
4515 TransparencyChunk := TChunktRNS(Chunks.ItemFromClass(TChunktRNS));
4516 PaletteChunk := TChunkPLTE(Chunks.ItemFromClass(TChunkPLTE));
4517
4518 FOR j := 1 TO H DO
4519 begin
4520 {Process all the pixels in this line}
4521 i := 0;
4522 repeat
4523 CurBit := 0;
4524 if Stretch then i2 := trunc(i / FactorX) else i2 := i;
4525 Data := @ImageSource[i2];
4526
4527 repeat
4528 {Obtains the palette index}
4529 case Header.BitDepth of
4530 1: PaletteIndex := (Data^ shr (7-(I Mod 8))) and 1;
4531 2,4: PaletteIndex := (Data^ shr ((1-(I Mod 2))*4)) and $0F;
4532 else PaletteIndex := Data^;
4533 end;
4534
4535 {Updates the image with the new pixel}
4536 with ImageData[i] do
4537 begin
4538 TransValue := TransparencyChunk.PaletteValues[PaletteIndex];
4539 rgbRed := (255 + PaletteChunk.Item[PaletteIndex].rgbRed *
4540 TransValue + rgbRed * (255 - TransValue)) shr 8;
4541 rgbGreen := (255 + PaletteChunk.Item[PaletteIndex].rgbGreen *
4542 TransValue + rgbGreen * (255 - TransValue)) shr 8;
4543 rgbBlue := (255 + PaletteChunk.Item[PaletteIndex].rgbBlue *
4544 TransValue + rgbBlue * (255 - TransValue)) shr 8;
4545 end;
4546
4547 {Move to next data}
4548 inc(i); inc(CurBit, Header.BitmapInfo.bmiHeader.biBitCount);
4549 until CurBit >= 8;
4550 {Move to next source data}
4551 //inc(Data);
4552 until i >= Integer(W);
4553
4554 {Move pointers}
4555 Longint(ImageData) := Longint(ImageData) + BytesPerRowDest;
4556 if Stretch then j2 := trunc(j / FactorY) else j2 := j;
4557 Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
4558 end
4559 end {Palette images}
4560 end {case Header.BitmapInfo.bmiHeader.biBitCount};
4561
4562 {Draws the new bitmap on the foreground}
4563 BitBlt(DC, Rect.Left, Rect.Top, W, H, BufferDC, 0, 0, SRCCOPY);
4564
4565 {Free bitmap}
4566 SelectObject(BufferDC, OldBitmap);
4567 DeleteObject(BufferBitmap);
4568 DeleteDC(BufferDC);
4569end;
4570
4571{Draws the image into a canvas}
4572procedure TPngObject.Draw(ACanvas: TCanvas; const Rect: TRect);
4573var
4574 Header: TChunkIHDR;
4575begin
4576 {Quit in case there is no header, otherwise obtain it}
4577 if Empty then Exit;
4578 Header := Chunks.GetItem(0) as TChunkIHDR;
4579
4580 {Copy the data to the canvas}
4581 case Self.TransparencyMode of
4582 {$IFDEF PartialTransparentDraw}
4583 ptmPartial:
4584 DrawPartialTrans(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect);
4585 {$ENDIF}
4586 ptmBit: DrawTransparentBitmap(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF},
4587 Header.ImageData, Header.BitmapInfo.bmiHeader,
4588 pBitmapInfo(@Header.BitmapInfo), Rect,
4589 {$IFDEF UseDelphi}ColorToRGB({$ENDIF}TransparentColor)
4590 {$IFDEF UseDelphi}){$ENDIF}
4591 else
4592 begin
4593 SetStretchBltMode(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, COLORONCOLOR);
4594 StretchDiBits(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect.Left,
4595 Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, 0, 0,
4596 Header.Width, Header.Height, Header.ImageData,
4597 pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS, SRCCOPY)
4598 end
4599 end {case}
4600end;
4601
4602{Characters for the header}
4603const
4604 PngHeader: Array[0..7] of Char = (#137, #80, #78, #71, #13, #10, #26, #10);
4605
4606{Loads the image from a stream of data}
4607procedure TPngObject.LoadFromStream(Stream: TStream);
4608var
4609 Header : Array[0..7] of Char;
4610 HasIDAT : Boolean;
4611
4612 {Chunks reading}
4613 ChunkCount : Cardinal;
4614 ChunkLength: Cardinal;
4615 ChunkName : TChunkName;
4616begin
4617 {Initialize before start loading chunks}
4618 ChunkCount := 0;
4619 ClearChunks();
4620 {Reads the header}
4621 Stream.Read(Header[0], 8);
4622
4623 {Test if the header matches}
4624 if Header <> PngHeader then
4625 begin
4626 RaiseError(EPNGInvalidFileHeader, EPNGInvalidFileHeaderText);
4627 Exit;
4628 end;
4629
4630
4631 HasIDAT := FALSE;
4632 Chunks.Count := 10;
4633
4634 {Load chunks}
4635 repeat
4636 inc(ChunkCount); {Increment number of chunks}
4637 if Chunks.Count < ChunkCount then {Resize the chunks list if needed}
4638 Chunks.Count := Chunks.Count + 10;
4639
4640 {Reads chunk length and invert since it is in network order}
4641 {also checks the Read method return, if it returns 0, it}
4642 {means that no bytes was readed, probably because it reached}
4643 {the end of the file}
4644 if Stream.Read(ChunkLength, 4) = 0 then
4645 begin
4646 {In case it found the end of the file here}
4647 Chunks.Count := ChunkCount - 1;
4648 RaiseError(EPNGUnexpectedEnd, EPNGUnexpectedEndText);
4649 end;
4650
4651 ChunkLength := ByteSwap(ChunkLength);
4652 {Reads chunk name}
4653 Stream.Read(Chunkname, 4);
4654
4655 {Here we check if the first chunk is the Header which is necessary}
4656 {to the file in order to be a valid Portable Network Graphics image}
4657 if (ChunkCount = 1) and (ChunkName <> 'IHDR') then
4658 begin
4659 Chunks.Count := ChunkCount - 1;
4660 RaiseError(EPNGIHDRNotFirst, EPNGIHDRNotFirstText);
4661 exit;
4662 end;
4663
4664 {Has a previous IDAT}
4665 if (HasIDAT and (ChunkName = 'IDAT')) or (ChunkName = 'cHRM') then
4666 begin
4667 dec(ChunkCount);
4668 Stream.Seek(ChunkLength + 4, soFromCurrent);
4669 Continue;
4670 end;
4671 {Tell it has an IDAT chunk}
4672 if ChunkName = 'IDAT' then HasIDAT := TRUE;
4673
4674 {Creates object for this chunk}
4675 Chunks.SetItem(ChunkCount - 1, CreateClassChunk(Self, ChunkName));
4676
4677 {Check if the chunk is critical and unknown}
4678 {$IFDEF ErrorOnUnknownCritical}
4679 if (TChunk(Chunks.Item[ChunkCount - 1]).ClassType = TChunk) and
4680 ((Byte(ChunkName[0]) AND $20) = 0) and (ChunkName <> '') then
4681 begin
4682 Chunks.Count := ChunkCount;
4683 RaiseError(EPNGUnknownCriticalChunk, EPNGUnknownCriticalChunkText);
4684 end;
4685 {$ENDIF}
4686
4687 {Loads it}
4688 try if not TChunk(Chunks.Item[ChunkCount - 1]).LoadFromStream(Stream,
4689 ChunkName, ChunkLength) then break;
4690 except
4691 Chunks.Count := ChunkCount;
4692 raise;
4693 end;
4694
4695 {Terminates when it reaches the IEND chunk}
4696 until (ChunkName = 'IEND');
4697
4698 {Resize the list to the appropriate size}
4699 Chunks.Count := ChunkCount;
4700
4701 {Check if there is data}
4702 if not HasIDAT then
4703 RaiseError(EPNGNoImageData, EPNGNoImageDataText);
4704end;
4705
4706{Changing height is not supported}
4707procedure TPngObject.SetHeight(Value: Integer);
4708begin
4709 RaiseError(EPNGError, EPNGCannotChangeSizeText);
4710end;
4711
4712{Changing width is not supported}
4713procedure TPngObject.SetWidth(Value: Integer);
4714begin
4715 RaiseError(EPNGError, EPNGCannotChangeSizeText);
4716end;
4717
4718{$IFDEF UseDelphi}
4719{Saves to clipboard format (thanks to Antoine Pottern)}
4720procedure TPNGObject.SaveToClipboardFormat(var AFormat: Word;
4721 var AData: THandle; var APalette: HPalette);
4722begin
4723 with TBitmap.Create do
4724 try
4725 Width := Self.Width;
4726 Height := Self.Height;
4727 Self.Draw(Canvas, Rect(0, 0, Width, Height));
4728 SaveToClipboardFormat(AFormat, AData, APalette);
4729 finally
4730 Free;
4731 end {try}
4732end;
4733
4734{Loads data from clipboard}
4735procedure TPngObject.LoadFromClipboardFormat(AFormat: Word;
4736 AData: THandle; APalette: HPalette);
4737begin
4738 with TBitmap.Create do
4739 try
4740 LoadFromClipboardFormat(AFormat, AData, APalette);
4741 Self.AssignHandle(Handle, False, 0);
4742 finally
4743 Free;
4744 end {try}
4745end;
4746
4747{Returns if the image is transparent}
4748function TPngObject.GetTransparent: Boolean;
4749begin
4750 Result := (TransparencyMode <> ptmNone);
4751end;
4752
4753{$ENDIF}
4754
4755{Saving the PNG image to a stream of data}
4756procedure TPngObject.SaveToStream(Stream: TStream);
4757var
4758 j: Integer;
4759begin
4760 {Reads the header}
4761 Stream.Write(PNGHeader[0], 8);
4762 {Write each chunk}
4763 FOR j := 0 TO Chunks.Count - 1 DO
4764 Chunks.Item[j].SaveToStream(Stream)
4765end;
4766
4767{Prepares the Header chunk}
4768procedure BuildHeader(Header: TChunkIHDR; Handle: HBitmap; Info: pBitmap;
4769 HasPalette: Boolean);
4770var
4771 DC: HDC;
4772begin
4773 {Set width and height}
4774 Header.Width := Info.bmWidth;
4775 Header.Height := abs(Info.bmHeight);
4776 {Set bit depth}
4777 if Info.bmBitsPixel >= 16 then
4778 Header.BitDepth := 8 else Header.BitDepth := Info.bmBitsPixel;
4779 {Set color type}
4780 if Info.bmBitsPixel >= 16 then
4781 Header.ColorType := COLOR_RGB else Header.ColorType := COLOR_PALETTE;
4782 {Set other info}
4783 Header.CompressionMethod := 0; {deflate/inflate}
4784 Header.InterlaceMethod := 0; {no interlace}
4785
4786 {Prepares bitmap headers to hold data}
4787 Header.PrepareImageData();
4788 {Copy image data}
4789 DC := CreateCompatibleDC(0);
4790 GetDIBits(DC, Handle, 0, Header.Height, Header.ImageData,
4791 pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS);
4792 DeleteDC(DC);
4793end;
4794
4795{Loads the image from a resource}
4796procedure TPngObject.LoadFromResourceName(Instance: HInst;
4797 const Name: String);
4798var
4799 ResStream: TResourceStream;
4800begin
4801 {Creates an especial stream to load from the resource}
4802 try ResStream := TResourceStream.Create(Instance, Name, RT_RCDATA);
4803 except RaiseError(EPNGCouldNotLoadResource, EPNGCouldNotLoadResourceText);
4804 exit; end;
4805
4806 {Loads the png image from the resource}
4807 try
4808 LoadFromStream(ResStream);
4809 finally
4810 ResStream.Free;
4811 end;
4812end;
4813
4814{Loads the png from a resource ID}
4815procedure TPngObject.LoadFromResourceID(Instance: HInst; ResID: Integer);
4816begin
4817 LoadFromResourceName(Instance, String(ResID));
4818end;
4819
4820{Assigns this tpngobject to another object}
4821procedure TPngObject.AssignTo(Dest: TPersistent);
4822{$IFDEF UseDelphi}
4823var
4824 DeskDC: HDC;
4825 TRNS: TChunkTRNS;
4826{$ENDIF}
4827begin
4828 {If the destination is also a TPNGObject make it assign}
4829 {this one}
4830 if Dest is TPNGObject then
4831 TPNGObject(Dest).AssignPNG(Self)
4832 {$IFDEF UseDelphi}
4833 {In case the destination is a bitmap}
4834 else if (Dest is TBitmap) and HeaderPresent then
4835 begin
4836 {Tests for the best pixelformat
4837 case Header.BitmapInfo.bmiHeader.biBitCount of
4838 1: TBitmap(Dest).PixelFormat := pf1Bit;
4839 4: TBitmap(Dest).PixelFormat := pf4Bit;
4840 8: TBitmap(Dest).PixelFormat := pf8Bit;
4841 24: TBitmap(Dest).PixelFormat := pf24Bit;
4842 32: TBitmap(Dest).PixelFormat := pf32Bit;
4843 end {case Header.BitmapInfo.bmiHeader.biBitCount};
4844
4845 {Device context}
4846 DeskDC := GetDC(0);
4847 {Copy the data}
4848 TBitmap(Dest).Handle := CreateDIBitmap(DeskDC,
4849 Header.BitmapInfo.bmiHeader, CBM_INIT, Header.ImageData,
4850 pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS);
4851 ReleaseDC(0, DeskDC);
4852
4853 {Copy transparency mode}
4854 if (TransparencyMode = ptmBit) then
4855 begin
4856 TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
4857 TBitmap(Dest).TransparentColor := TRNS.TransparentColor;
4858 TBitmap(Dest).Transparent := True
4859 end {if (TransparencyMode = ptmBit)}
4860
4861 end
4862 else
4863 {Unknown destination kind, }
4864 inherited AssignTo(Dest);
4865 {$ENDIF}
4866end;
4867
4868{Assigns from a bitmap object}
4869procedure TPngObject.AssignHandle(Handle: HBitmap; Transparent: Boolean;
4870 TransparentColor: ColorRef);
4871var
4872 BitmapInfo: Windows.TBitmap;
4873 HasPalette: Boolean;
4874
4875 {Chunks}
4876 Header: TChunkIHDR;
4877 PLTE: TChunkPLTE;
4878 IDAT: TChunkIDAT;
4879 IEND: TChunkIEND;
4880 TRNS: TChunkTRNS;
4881begin
4882 {Obtain bitmap info}
4883 GetObject(Handle, SizeOf(BitmapInfo), @BitmapInfo);
4884
4885 {Only bit depths 1, 4 and 8 needs a palette}
4886 HasPalette := (BitmapInfo.bmBitsPixel < 16);
4887
4888 {Clear old chunks and prepare}
4889 ClearChunks();
4890
4891 {Create the chunks}
4892 Header := TChunkIHDR.Create(Self);
4893 if HasPalette then PLTE := TChunkPLTE.Create(Self) else PLTE := nil;
4894 if Transparent then TRNS := TChunkTRNS.Create(Self) else TRNS := nil;
4895 IDAT := TChunkIDAT.Create(Self);
4896 IEND := TChunkIEND.Create(Self);
4897
4898 {Add chunks}
4899 TPNGPointerList(Chunks).Add(Header);
4900 if HasPalette then TPNGPointerList(Chunks).Add(PLTE);
4901 if Transparent then TPNGPointerList(Chunks).Add(TRNS);
4902 TPNGPointerList(Chunks).Add(IDAT);
4903 TPNGPointerList(Chunks).Add(IEND);
4904
4905 {This method will fill the Header chunk with bitmap information}
4906 {and copy the image data}
4907 BuildHeader(Header, Handle, @BitmapInfo, HasPalette);
4908 {In case there is a image data, set the PLTE chunk fCount variable}
4909 {to the actual number of palette colors which is 2^(Bits for each pixel)}
4910 if HasPalette then PLTE.fCount := 1 shl BitmapInfo.bmBitsPixel;
4911
4912 {In case it is a transparent bitmap, prepares it}
4913 if Transparent then TRNS.TransparentColor := TransparentColor;
4914
4915end;
4916
4917{Assigns from another PNG}
4918procedure TPngObject.AssignPNG(Source: TPNGObject);
4919var
4920 J: Integer;
4921begin
4922 {Copy properties}
4923 InterlaceMethod := Source.InterlaceMethod;
4924 MaxIdatSize := Source.MaxIdatSize;
4925 CompressionLevel := Source.CompressionLevel;
4926 Filters := Source.Filters;
4927
4928 {Clear old chunks and prepare}
4929 ClearChunks();
4930 Chunks.Count := Source.Chunks.Count;
4931 {Create chunks and makes a copy from the source}
4932 FOR J := 0 TO Chunks.Count - 1 DO
4933 with Source.Chunks do
4934 begin
4935 Chunks.SetItem(J, TChunkClass(TChunk(Item[J]).ClassType).Create(Self));
4936 TChunk(Chunks.Item[J]).Assign(TChunk(Item[J]));
4937 end {with};
4938end;
4939
4940{Returns a alpha data scanline}
4941function TPngObject.GetAlphaScanline(const LineIndex: Integer): pByteArray;
4942begin
4943 with Header do
4944 if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then
4945 Longint(Result) := Longint(ImageAlpha) + (LineIndex * Longint(Width))
4946 else Result := nil; {In case the image does not use alpha information}
4947end;
4948
4949{$IFDEF Store16bits}
4950{Returns a png data extra scanline}
4951function TPngObject.GetExtraScanline(const LineIndex: Integer): Pointer;
4952begin
4953 with Header do
4954 Longint(Result) := (Longint(ExtraImageData) + ((Longint(Height) - 1) *
4955 BytesPerRow)) - (LineIndex * BytesPerRow);
4956end;
4957{$ENDIF}
4958
4959{Returns a png data scanline}
4960function TPngObject.GetScanline(const LineIndex: Integer): Pointer;
4961begin
4962 with Header do
4963 Longint(Result) := (Longint(ImageData) + ((Longint(Height) - 1) *
4964 BytesPerRow)) - (LineIndex * BytesPerRow);
4965end;
4966
4967{Initialize gamma table}
4968procedure TPngObject.InitializeGamma;
4969var
4970 i: Integer;
4971begin
4972 {Build gamma table as if there was no gamma}
4973 FOR i := 0 to 255 do
4974 begin
4975 GammaTable[i] := i;
4976 InverseGamma[i] := i;
4977 end {for i}
4978end;
4979
4980{Returns the transparency mode used by this png}
4981function TPngObject.GetTransparencyMode: TPNGTransparencyMode;
4982var
4983 TRNS: TChunkTRNS;
4984begin
4985 with Header do
4986 begin
4987 Result := ptmNone; {Default result}
4988 {Gets the TRNS chunk pointer}
4989 TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
4990
4991 {Test depending on the color type}
4992 case ColorType of
4993 {This modes are always partial}
4994 COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Result := ptmPartial;
4995 {This modes support bit transparency}
4996 COLOR_RGB, COLOR_GRAYSCALE: if TRNS <> nil then Result := ptmBit;
4997 {Supports booth translucid and bit}
4998 COLOR_PALETTE:
4999 {A TRNS chunk must be present, otherwise it won't support transparency}
5000 if TRNS <> nil then
5001 if TRNS.BitTransparency then
5002 Result := ptmBit else Result := ptmPartial
5003 end {case}
5004
5005 end {with Header}
5006end;
5007
5008{Add a text chunk}
5009procedure TPngObject.AddtEXt(const Keyword, Text: String);
5010var
5011 TextChunk: TChunkTEXT;
5012begin
5013 TextChunk := Chunks.Add(TChunkText) as TChunkTEXT;
5014 TextChunk.Keyword := Keyword;
5015 TextChunk.Text := Text;
5016end;
5017
5018{Add a text chunk}
5019procedure TPngObject.AddzTXt(const Keyword, Text: String);
5020var
5021 TextChunk: TChunkzTXt;
5022begin
5023 TextChunk := Chunks.Add(TChunkzTXt) as TChunkzTXt;
5024 TextChunk.Keyword := Keyword;
5025 TextChunk.Text := Text;
5026end;
5027
5028{Removes the image transparency}
5029procedure TPngObject.RemoveTransparency;
5030var
5031 TRNS: TChunkTRNS;
5032begin
5033 TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
5034 if TRNS <> nil then Chunks.RemoveChunk(TRNS)
5035end;
5036
5037{Generates alpha information}
5038procedure TPngObject.CreateAlpha;
5039var
5040 TRNS: TChunkTRNS;
5041begin
5042 {Generates depending on the color type}
5043 with Header do
5044 case ColorType of
5045 {Png allocates different memory space to hold alpha information}
5046 {for these types}
5047 COLOR_GRAYSCALE, COLOR_RGB:
5048 begin
5049 {Transform into the appropriate color type}
5050 if ColorType = COLOR_GRAYSCALE then
5051 ColorType := COLOR_GRAYSCALEALPHA
5052 else ColorType := COLOR_RGBALPHA;
5053 {Allocates memory to hold alpha information}
5054 GetMem(ImageAlpha, Integer(Width) * Integer(Height));
5055 FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #255);
5056 end;
5057 {Palette uses the TChunktRNS to store alpha}
5058 COLOR_PALETTE:
5059 begin
5060 {Gets/creates TRNS chunk}
5061 if Chunks.ItemFromClass(TChunkTRNS) = nil then
5062 TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS
5063 else
5064 TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
5065
5066 {Prepares the TRNS chunk}
5067 with TRNS do
5068 begin
5069 Fillchar(PaletteValues[0], 256, 255);
5070 fDataSize := 1 shl Header.BitDepth;
5071 fBitTransparency := False
5072 end {with Chunks.Add};
5073 end;
5074 end {case Header.ColorType}
5075
5076end;
5077
5078{Returns transparent color}
5079function TPngObject.GetTransparentColor: TColor;
5080var
5081 TRNS: TChunkTRNS;
5082begin
5083 TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
5084 {Reads the transparency chunk to get this info}
5085 if Assigned(TRNS) then Result := TRNS.TransparentColor
5086 else Result := 0
5087end;
5088
5089{$OPTIMIZATION OFF}
5090procedure TPngObject.SetTransparentColor(const Value: TColor);
5091var
5092 TRNS: TChunkTRNS;
5093begin
5094 if HeaderPresent then
5095 {Tests the ColorType}
5096 case Header.ColorType of
5097 {Not allowed for this modes}
5098 COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Self.RaiseError(
5099 EPNGCannotChangeTransparent, EPNGCannotChangeTransparentText);
5100 {Allowed}
5101 COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE:
5102 begin
5103 TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
5104 if not Assigned(TRNS) then TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS;
5105
5106 {Sets the transparency value from TRNS chunk}
5107 TRNS.TransparentColor := {$IFDEF UseDelphi}ColorToRGB({$ENDIF}Value{$IFDEF UseDelphi}){$ENDIF}
5108 end {COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE)}
5109 end {case}
5110end;
5111
5112{Returns if header is present}
5113function TPngObject.HeaderPresent: Boolean;
5114begin
5115 Result := ((Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR))
5116end;
5117
5118{Returns pixel for png using palette and grayscale}
5119function GetByteArrayPixel(const png: TPngObject; const X, Y: Integer): TColor;
5120var
5121 ByteData: Byte;
5122 DataDepth: Byte;
5123begin
5124 with png, Header do
5125 begin
5126 {Make sure the bitdepth is not greater than 8}
5127 DataDepth := BitDepth;
5128 if DataDepth > 8 then DataDepth := 8;
5129 {Obtains the byte containing this pixel}
5130 ByteData := pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)];
5131 {Moves the bits we need to the right}
5132 ByteData := (ByteData shr ((8 - DataDepth) -
5133 (X mod (8 div DataDepth)) * DataDepth));
5134 {Discard the unwanted pixels}
5135 ByteData:= ByteData and ($FF shr (8 - DataDepth));
5136
5137 {For palette mode map the palette entry and for grayscale convert and
5138 returns the intensity}
5139 case ColorType of
5140 COLOR_PALETTE:
5141 with TChunkPLTE(png.Chunks.ItemFromClass(TChunkPLTE)).Item[ByteData] do
5142 Result := rgb(GammaTable[rgbRed], GammaTable[rgbGreen],
5143 GammaTable[rgbBlue]);
5144 COLOR_GRAYSCALE:
5145 begin
5146 if BitDepth = 1
5147 then ByteData := GammaTable[Byte(ByteData * 255)]
5148 else ByteData := GammaTable[Byte(ByteData * ((1 shl DataDepth) + 1))];
5149 Result := rgb(ByteData, ByteData, ByteData);
5150 end;
5151 else Result := 0;
5152 end {case};
5153 end {with}
5154end;
5155
5156{In case vcl units are not being used}
5157{$IFNDEF UseDelphi}
5158function ColorToRGB(const Color: TColor): COLORREF;
5159begin
5160 Result := Color
5161end;
5162{$ENDIF}
5163
5164{Sets a pixel for grayscale and palette pngs}
5165procedure SetByteArrayPixel(const png: TPngObject; const X, Y: Integer;
5166 const Value: TColor);
5167const
5168 ClearFlag: Array[1..8] of Integer = (1, 3, 0, 15, 0, 0, 0, $FF);
5169var
5170 ByteData: pByte;
5171 DataDepth: Byte;
5172 ValEntry: Byte;
5173begin
5174 with png.Header do
5175 begin
5176 {Map into a palette entry}
5177 ValEntry := GetNearestPaletteIndex(Png.Palette, ColorToRGB(Value));
5178
5179 {16 bits grayscale extra bits are discarted}
5180 DataDepth := BitDepth;
5181 if DataDepth > 8 then DataDepth := 8;
5182 {Gets a pointer to the byte we intend to change}
5183 ByteData := @pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)];
5184 {Clears the old pixel data}
5185 ByteData^ := ByteData^ and not (ClearFlag[DataDepth] shl ((8 - DataDepth) -
5186 (X mod (8 div DataDepth)) * DataDepth));
5187
5188 {Setting the new pixel}
5189 ByteData^ := ByteData^ or (ValEntry shl ((8 - DataDepth) -
5190 (X mod (8 div DataDepth)) * DataDepth));
5191 end {with png.Header}
5192end;
5193
5194{Returns pixel when png uses RGB}
5195function GetRGBLinePixel(const png: TPngObject;
5196 const X, Y: Integer): TColor;
5197begin
5198 with pRGBLine(png.Scanline[Y])^[X] do
5199 Result := RGB(rgbtRed, rgbtGreen, rgbtBlue)
5200end;
5201
5202{Sets pixel when png uses RGB}
5203procedure SetRGBLinePixel(const png: TPngObject;
5204 const X, Y: Integer; Value: TColor);
5205begin
5206 with pRGBLine(png.Scanline[Y])^[X] do
5207 begin
5208 rgbtRed := GetRValue(Value);
5209 rgbtGreen := GetGValue(Value);
5210 rgbtBlue := GetBValue(Value)
5211 end
5212end;
5213
5214{Sets a pixel}
5215procedure TPngObject.SetPixels(const X, Y: Integer; const Value: TColor);
5216begin
5217 if ((X >= 0) and (X <= Width - 1)) and
5218 ((Y >= 0) and (Y <= Height - 1)) then
5219 with Header do
5220 begin
5221 if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then
5222 SetByteArrayPixel(Self, X, Y, Value)
5223 else
5224 SetRGBLinePixel(Self, X, Y, Value)
5225 end {with}
5226end;
5227
5228
5229{Returns a pixel}
5230function TPngObject.GetPixels(const X, Y: Integer): TColor;
5231begin
5232 if ((X >= 0) and (X <= Width - 1)) and
5233 ((Y >= 0) and (Y <= Height - 1)) then
5234 with Header do
5235 begin
5236 if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then
5237 Result := GetByteArrayPixel(Self, X, Y)
5238 else
5239 Result := GetRGBLinePixel(Self, X, Y)
5240 end {with}
5241 else Result := 0
5242end;
5243
5244{Returns the image palette}
5245function TPngObject.GetPalette: HPALETTE;
5246var
5247 LogPalette: TMaxLogPalette;
5248 i: Integer;
5249begin
5250 {Palette is avaliable for COLOR_PALETTE and COLOR_GRAYSCALE modes}
5251 if (Header.ColorType in [COLOR_PALETTE, COLOR_GRAYSCALE]) then
5252 begin
5253 {In case the pal}
5254 if TempPalette = 0 then
5255 with LogPalette do
5256 begin
5257 {Prepares the new palette}
5258 palVersion := $300;
5259 palNumEntries := 256;
5260 {Copy entries}
5261 for i := 0 to LogPalette.palNumEntries - 1 do
5262 begin
5263 palPalEntry[i].peRed := Header.BitmapInfo.bmiColors[i].rgbRed;
5264 palPalEntry[i].peGreen := Header.BitmapInfo.bmiColors[i].rgbGreen;
5265 palPalEntry[i].peBlue := Header.BitmapInfo.bmiColors[i].rgbBlue;
5266 palPalEntry[i].peFlags := 0;
5267 end {for i};
5268 {Creates the palette}
5269 TempPalette := CreatePalette(pLogPalette(@LogPalette)^);
5270 end {with LogPalette, if Temppalette = 0}
5271 end {if Header.ColorType in ...};
5272 Result := TempPalette;
5273end;
5274
5275initialization
5276 {Initialize}
5277 ChunkClasses := nil;
5278 {crc table has not being computed yet}
5279 crc_table_computed := FALSE;
5280 {Register the necessary chunks for png}
5281 RegisterCommonChunks;
5282 {Registers TPNGObject to use with TPicture}
5283 {$IFDEF UseDelphi}{$IFDEF RegisterGraphic}
5284 TPicture.RegisterFileFormat('PNG', 'Portable Network Graphics', TPNGObject);
5285 {$ENDIF}{$ENDIF}
5286finalization
5287 {$IFDEF UseDelphi}{$IFDEF RegisterGraphic}
5288 TPicture.UnregisterGraphicClass(TPNGObject);
5289 {$ENDIF}{$ENDIF}
5290 {Free chunk classes}
5291 FreeChunkClassList;
5292end.
5293
5294
Note: See TracBrowser for help on using the repository browser.