source: trunk/Packages/bgrabitmap/bgrareadbmp.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 33.6 KB
Line 
1{*****************************************************************************}
2{
3 This original file was part of the Free Pascal's "Free Components Library".
4 Copyright (c) 2003 by Mazen NEIFER of the Free Pascal development team
5
6 BMP reader implementation.
7
8 See the file COPYING.FPC, included in this distribution,
9 for details about the copyright.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14}
15{*****************************************************************************}
16{ 08/2005 by Giulio Bernardi:
17 - Added support for 16 and 15 bpp bitmaps.
18 - If we have bpp <= 8 make an indexed image instead of converting it to RGB
19 - Support for RLE4 and RLE8 decoding
20 - Support for top-down bitmaps
21
22 03/2014 by circular:
23 - RLE optimisation using a read buffer
24 - direct access to pixels with TBGRABitmap
25 - vertical shrink option with MinifyHeight,WantedHeight,OutputHeight (useful for thumbnails)
26 01/2017 by circular:
27 - support for OS/2 1.x format
28 - support for headerless files
29}
30
31{$mode objfpc}
32{$h+}
33
34unit BGRAReadBMP;
35
36interface
37
38uses FPImage, classes, sysutils, BMPcomn, BGRABitmapTypes;
39
40type
41 TBMPTransparencyOption = (toAuto, toTransparent, toOpaque);
42 TBitMapInfoHeader = BMPcomn.TBitMapInfoHeader;
43 TBitMapFileHeader = BMPcomn.TBitMapFileHeader;
44 TOS2BitmapHeader = packed record
45 bcSize: DWORD;
46 bcWidth: Word;
47 bcHeight: Word;
48 bcPlanes: Word;
49 bcBitCount: Word;
50 end;
51 TMinimumBitmapHeader = packed record
52 Size:longint;
53 Width:longint;
54 Height:longint;
55 Planes:word;
56 BitCount:word;
57 end;
58 TBitmapSubFormat = (bsfWithFileHeader, bsfHeaderless, bsfHeaderlessWithMask);
59 TReadScanlineProc = procedure(Row : Integer; Stream : TStream) of object;
60 TWriteScanlineProc = procedure(Row : Integer; Img : TFPCustomImage) of object;
61 TProgressProc = procedure(Percent: integer; var ShouldContinue: boolean) of object;
62
63
64 { TBGRAReaderBMP }
65
66 TBGRAReaderBMP = class (TBGRAImageReader)
67 Private
68 DeltaX, DeltaY : integer; // Used for the never-used delta option in RLE
69 TopDown : boolean; // If set, bitmap is stored top down instead of bottom up
70 Procedure FreeBufs; // Free (and nil) buffers.
71 protected
72 ReadSize : Integer; // Size (in bytes) of 1 scanline.
73 BFH: TBitMapFileHeader; // The file header
74 BFI: TBitMapInfoHeader; // The header as read from the stream.
75 FPaletteEntrySize: integer; // 4 for Windows, 3 for OS/2 1.x
76 FPalette : PFPcolor; // Buffer with Palette entries. (useless now)
77 FBGRAPalette : PBGRAPixel;
78 LineBuf : PByte; // Buffer for 1 scanline. Can be Byte, Word, TColorRGB or TColorRGBA
79 RedMask, GreenMask, BlueMask : longword; //Used if Compression=bi_bitfields
80 RedShift, GreenShift, BlueShift : shortint;
81 FOutputHeight: integer;
82 FOriginalHeight: Integer;
83 FTransparencyOption: TBMPTransparencyOption;
84 FBuffer: packed array of byte;
85 FBufferPos, FBufferSize: integer;
86 FBufferStream: TStream;
87 FHasAlphaValues: boolean;
88 FMaskData: PByte;
89 FMaskDataSize: integer;
90 // SetupRead will allocate the needed buffers, and read the colormap if needed.
91 procedure SetupRead(nPalette, nRowBits: Integer; Stream : TStream); virtual;
92 function CountBits(Value : byte) : shortint;
93 function ShiftCount(Mask : longword) : shortint;
94 function ExpandColor(value : longword) : TFPColor;
95 function ExpandColorBGRA(value : longword) : TBGRAPixel;
96 procedure ExpandRLE8ScanLine(Row : Integer; Stream : TStream);
97 procedure ExpandRLE4ScanLine(Row : Integer; Stream : TStream);
98 procedure ReadScanLine(Row : Integer; Stream : TStream); virtual;
99 procedure SkipScanLine(Row : Integer; Stream : TStream); virtual;
100 procedure WriteScanLine(Row : Integer; Img : TFPCustomImage); virtual;
101 procedure WriteScanLineBGRA(Row : Integer; Img : TFPCustomImage); virtual;
102 procedure ReadMaskLine({%H-}Row : Integer; Stream : TStream); virtual;
103 procedure SkipMaskLine({%H-}Row : Integer; Stream : TStream); virtual;
104 procedure WriteMaskLine(Row : Integer; Img : TFPCustomImage); virtual;
105 // required by TFPCustomImageReader
106 procedure InternalRead (Stream:TStream; Img:TFPCustomImage); override;
107 function InternalCheck (Stream:TStream) : boolean; override;
108 procedure InitReadBuffer(AStream: TStream; ASize: integer);
109 procedure CloseReadBuffer;
110 function GetNextBufferByte: byte;
111 procedure MakeOpaque(Img: TFPCustomImage);
112 procedure LoadMask(Stream:TStream; Img:TFPCustomImage; var ShouldContinue: boolean);
113 procedure MainProgressProc(Percent: integer; var ShouldContinue: boolean);
114 procedure ImageVerticalLoop(Stream:TStream; Img:TFPCustomImage;
115 ReadProc, SkipProc: TReadScanlineProc; WriteProc: TWriteScanlineProc;
116 ProgressProc: TProgressProc; var ShouldContinue: boolean);
117 public
118 MinifyHeight,WantedHeight: integer;
119 Hotspot: TPoint;
120 Subformat: TBitmapSubFormat;
121 constructor Create; override;
122 destructor Destroy; override;
123 property OriginalHeight: integer read FOriginalHeight;
124 property OutputHeight: integer read FOutputHeight;
125 property TransparencyOption: TBMPTransparencyOption read FTransparencyOption write FTransparencyOption;
126 function GetQuickInfo(AStream: TStream): TQuickImageInfo; override;
127 function GetBitmapDraft(AStream: TStream; {%H-}AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; override;
128 end;
129
130function MakeBitmapFileHeader(AData: TStream): TBitMapFileHeader;
131
132implementation
133
134uses math;
135
136function MakeBitmapFileHeader(AData: TStream): TBitMapFileHeader;
137var header: PBitMapInfoHeader;
138 headerSize: integer;
139 extraSize: integer;
140 os2header: TOS2BitmapHeader;
141begin
142 AData.Position := 0;
143 headerSize := LEtoN(AData.ReadDWord);
144 if headerSize = sizeof(TOS2BitmapHeader) then //OS2 1.x
145 begin
146 AData.ReadBuffer({%H-}os2header,sizeof(os2header));
147 if LEtoN(os2header.bcBitCount) in [1,2,4,8] then
148 begin
149 extraSize := 3*(1 shl LEtoN(os2header.bcBitCount));
150 end else
151 extraSize := 0;
152 result.bfType:= Word('BM');
153 result.bfSize := NtoLE(Integer(sizeof(TBitMapFileHeader) + AData.Size));
154 result.bfReserved:= 0;
155 result.bfOffset := NtoLE(Integer(sizeof(TBitMapFileHeader) + headerSize + extraSize));
156 end else
157 begin
158 if (headerSize < 16) or (headerSize > AData.Size) or (headerSize > 1024) then
159 raise exception.Create('Invalid header size');
160 getmem(header, headerSize);
161 try
162 fillchar(header^, headerSize,0);
163 header^.Size := NtoLE(headerSize);
164 AData.ReadBuffer((PByte(header)+4)^, headerSize-4);
165 if LEtoN(header^.Compression) = BI_BITFIELDS then
166 extraSize := 4*3
167 else if LEtoN(header^.BitCount) in [1,2,4,8] then
168 begin
169 if header^.ClrUsed > 0 then
170 extraSize := 4*header^.ClrUsed
171 else
172 extraSize := 4*(1 shl header^.BitCount);
173 end else
174 extraSize := 0;
175 result.bfType:= Word('BM');
176 result.bfSize := NtoLE(Integer(sizeof(TBitMapFileHeader) + AData.Size));
177 result.bfReserved:= 0;
178 result.bfOffset := NtoLE(Integer(sizeof(TBitMapFileHeader) + headerSize + extraSize));
179 finally
180 freemem(header);
181 end;
182 end;
183end;
184
185function RGBAToFPColor(Const RGBA: TColorRGBA) : TFPcolor;
186begin
187 with Result, RGBA do
188 begin
189 Red :=(R shl 8) or R;
190 Green :=(G shl 8) or G;
191 Blue :=(B shl 8) or B;
192 Alpha :=(A shl 8) or A
193 end;
194end;
195
196Function RGBToFPColor(Const RGB : TColorRGB) : TFPColor;
197
198begin
199 with Result,RGB do
200 begin {Use only the high byte to convert the color}
201 Red := (R shl 8) + R;
202 Green := (G shl 8) + G;
203 Blue := (B shl 8) + B;
204 Alpha := AlphaOpaque;
205 end;
206end;
207
208constructor TBGRAReaderBMP.Create;
209
210begin
211 inherited create;
212 FTransparencyOption := toTransparent;
213 Subformat:= bsfWithFileHeader;
214end;
215
216destructor TBGRAReaderBMP.Destroy;
217
218begin
219 FreeBufs;
220 inherited destroy;
221end;
222
223function TBGRAReaderBMP.GetQuickInfo(AStream: TStream): TQuickImageInfo;
224var headerSize: dword;
225 os2header: TOS2BitmapHeader;
226 minHeader: TMinimumBitmapHeader;
227 totalDepth: integer;
228 headerPos: int64;
229begin
230 fillchar({%H-}result, sizeof(result), 0);
231 headerPos := AStream.Position;
232 if AStream.Read({%H-}headerSize, sizeof(headerSize)) <> sizeof(headerSize) then exit;
233 headerSize := LEtoN(headerSize);
234
235 //check presence of file header
236 if (headerSize and $ffff) = BMmagic then
237 begin
238 headerPos += sizeof(TBitMapFileHeader);
239 AStream.Position := headerPos;
240 if AStream.Read(headerSize, sizeof(headerSize)) <> sizeof(headerSize) then exit;
241 headerSize := LEtoN(headerSize);
242 end;
243
244 AStream.Position := headerPos;
245
246 if headerSize = sizeof(TOS2BitmapHeader) then //OS2 1.x
247 begin
248 if AStream.Read({%H-}os2header, sizeof(os2header)) <> sizeof(os2header) then exit;
249 result.width := LEtoN(os2header.bcWidth);
250 result.height := LEtoN(os2header.bcHeight);
251 result.colorDepth := LEtoN(os2header.bcBitCount);
252 result.alphaDepth := 0;
253 end
254 else
255 if headerSize >= sizeof(minHeader) then
256 begin
257 if AStream.Read({%H-}minHeader, sizeof(minHeader)) <> sizeof(minHeader) then exit;
258 result.width := LEtoN(minHeader.Width);
259 result.height := LEtoN(minHeader.Height);
260 totalDepth := LEtoN(minHeader.BitCount);
261 if totalDepth > 24 then
262 begin
263 result.colorDepth:= 24;
264 result.alphaDepth:= 8;
265 end else
266 begin
267 result.colorDepth := totalDepth;
268 result.alphaDepth:= 0;
269 end;
270 end else
271 begin
272 result.width := 0;
273 result.height:= 0;
274 result.colorDepth:= 0;
275 result.alphaDepth:= 0;
276 end;
277end;
278
279function TBGRAReaderBMP.GetBitmapDraft(AStream: TStream; AMaxWidth,
280 AMaxHeight: integer; out AOriginalWidth, AOriginalHeight: integer): TBGRACustomBitmap;
281var
282 bmpFormat: TBGRAReaderBMP;
283 prevStreamPos: Int64;
284begin
285 bmpFormat:= TBGRAReaderBMP.Create;
286 bmpFormat.Subformat:= Subformat;
287 bmpFormat.MinifyHeight := AMaxHeight*2;
288 result := BGRABitmapFactory.Create;
289 prevStreamPos := AStream.Position;
290 try
291 result.LoadFromStream(AStream, bmpFormat);
292 AOriginalWidth:= result.Width;
293 AOriginalHeight:= bmpFormat.OriginalHeight;
294 finally
295 bmpFormat.Free;
296 AStream.Position := prevStreamPos;
297 end;
298end;
299
300procedure TBGRAReaderBMP.FreeBufs;
301begin
302 If (LineBuf<>Nil) then
303 begin
304 FreeMem(LineBuf);
305 LineBuf:=Nil;
306 end;
307 If (FPalette<>Nil) then
308 begin
309 FreeMem(FPalette);
310 FPalette:=Nil;
311 end;
312 If (FBGRAPalette<>Nil) then
313 begin
314 FreeMem(FBGRAPalette);
315 FBGRAPalette:=Nil;
316 end;
317end;
318
319{ Counts how many bits are set }
320function TBGRAReaderBMP.CountBits(Value : byte) : shortint;
321var i,bits : shortint;
322begin
323 bits:=0;
324 for i:=0 to 7 do
325 begin
326 if (value mod 2)<>0 then inc(bits);
327 value:=value shr 1;
328 end;
329 Result:=bits;
330end;
331
332{ If compression is bi_bitfields, there could be arbitrary masks for colors.
333 Although this is not compatible with windows9x it's better to know how to read these bitmaps
334 We must determine how to switch the value once masked
335 Example: 0000 0111 1110 0000, if we shr 5 we have 00XX XXXX for the color, but these bits must be the
336 highest in the color, so we must shr (5-(8-6))=3, and we have XXXX XX00.
337 A negative value means "shift left" }
338function TBGRAReaderBMP.ShiftCount(Mask : longword) : shortint;
339var tmp : shortint;
340begin
341 tmp:=0;
342 if Mask=0 then
343 begin
344 Result:=0;
345 exit;
346 end;
347
348 while (Mask mod 2)=0 do { rightmost bit is 0 }
349 begin
350 inc(tmp);
351 Mask:= Mask shr 1;
352 end;
353 tmp:=tmp-(8-CountBits(Mask and $FF));
354 Result:=tmp;
355end;
356
357function TBGRAReaderBMP.ExpandColor(value : longword) : TFPColor;
358var tmpr, tmpg, tmpb : longword;
359 col : TColorRGB;
360begin
361 {$IFDEF ENDIAN_BIG}
362 value:=swap(value);
363 {$ENDIF}
364 tmpr:=value and RedMask;
365 tmpg:=value and GreenMask;
366 tmpb:=value and BlueMask;
367 if RedShift < 0 then col.R:=byte(tmpr shl (-RedShift))
368 else col.R:=byte(tmpr shr RedShift);
369 if GreenShift < 0 then col.G:=byte(tmpg shl (-GreenShift))
370 else col.G:=byte(tmpg shr GreenShift);
371 if BlueShift < 0 then col.B:=byte(tmpb shl (-BlueShift))
372 else col.B:=byte(tmpb shr BlueShift);
373 Result:=RGBToFPColor(col);
374end;
375
376function TBGRAReaderBMP.ExpandColorBGRA(value: longword): TBGRAPixel;
377var tmpr, tmpg, tmpb : longword;
378begin
379 {$IFDEF ENDIAN_BIG}
380 value:=swap(value);
381 {$ENDIF}
382 tmpr:=value and RedMask;
383 tmpg:=value and GreenMask;
384 tmpb:=value and BlueMask;
385 if RedShift < 0 then result.red:=byte(tmpr shl (-RedShift))
386 else result.red:=byte(tmpr shr RedShift);
387 if GreenShift < 0 then result.green:=byte(tmpg shl (-GreenShift))
388 else result.green:=byte(tmpg shr GreenShift);
389 if BlueShift < 0 then result.blue:=byte(tmpb shl (-BlueShift))
390 else result.blue:=byte(tmpb shr BlueShift);
391 result.alpha:= 255;
392end;
393
394procedure TBGRAReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream : TStream);
395
396var
397 ColInfo: ARRAY OF TColorRGBA;
398 ColInfo3: packed array of TColorRGB;
399 i,colorPresent: Integer;
400
401begin
402 if ((BFI.Compression=BI_RGB) and (BFI.BitCount=16)) then { 5 bits per channel, fixed mask }
403 begin
404 RedMask:=$7C00; RedShift:=7;
405 GreenMask:=$03E0; GreenShift:=2;
406 BlueMask:=$001F; BlueShift:=-3;
407 end
408 else if ((BFI.Compression=BI_BITFIELDS) and (BFI.BitCount in [16,32])) then { arbitrary mask }
409 begin
410 Stream.Read(RedMask,4);
411 Stream.Read(GreenMask,4);
412 Stream.Read(BlueMask,4);
413 {$IFDEF ENDIAN_BIG}
414 RedMask:=swap(RedMask);
415 GreenMask:=swap(GreenMask);
416 BlueMask:=swap(BlueMask);
417 {$ENDIF}
418 RedShift:=ShiftCount(RedMask);
419 GreenShift:=ShiftCount(GreenMask);
420 BlueShift:=ShiftCount(BlueMask);
421 end
422 else if nPalette>0 then
423 begin
424 GetMem(FPalette, nPalette*SizeOf(TFPColor));
425 GetMem(FBGRAPalette, nPalette*SizeOf(TBGRAPixel));
426 SetLength(ColInfo, nPalette);
427 if BFI.ClrUsed>0 then
428 colorPresent:= min(BFI.ClrUsed,nPalette)
429 else
430 colorPresent:= nPalette;
431 if FPaletteEntrySize = 3 then
432 begin
433 setlength(ColInfo3, nPalette);
434 Stream.Read(ColInfo3[0],colorPresent*SizeOf(TColorRGB));
435 for i := 0 to colorPresent-1 do
436 ColInfo[i].RGB := ColInfo3[i];
437 end
438 else
439 begin
440 Stream.Read(ColInfo[0],colorPresent*SizeOf(TColorRGBA));
441 end;
442 for i := 0 to High(ColInfo) do
443 begin
444 FPalette[i] := RGBToFPColor(ColInfo[i].RGB);
445 FBGRAPalette[i]:= FPColorToBGRA(FPalette[i]);
446 end
447 end
448 else if BFI.ClrUsed>0 then { Skip palette }
449 {$PUSH}{$HINTS OFF}
450 Stream.Position := Stream.Position + BFI.ClrUsed*SizeOf(TColorRGBA);
451 {$POP}
452 ReadSize:=((nRowBits + 31) div 32) shl 2;
453 GetMem(LineBuf,ReadSize);
454end;
455
456procedure TBGRAReaderBMP.InternalRead(Stream:TStream; Img:TFPCustomImage);
457
458Var
459 i, pallen : Integer;
460 BadCompression : boolean;
461 WriteScanlineProc: TWriteScanlineProc;
462 headerSize: longword;
463 os2header: TOS2BitmapHeader;
464 shouldContinue: boolean;
465
466begin
467 shouldContinue:=true;
468 Progress(psStarting,0,false,EmptyRect,'',shouldContinue);
469 if not shouldContinue then exit;
470
471 headerSize := LEtoN(Stream.ReadDWord);
472 fillchar({%H-}BFI,SizeOf(BFI),0);
473 if headerSize = sizeof(TOS2BitmapHeader) then
474 begin
475 fillchar({%H-}os2header,SizeOf(os2header),0);
476 Stream.Read(os2header.bcWidth,min(SizeOf(os2header),headerSize)-sizeof(DWord));
477 BFI.Size := 16;
478 BFI.Width := LEtoN(os2header.bcWidth);
479 BFI.Height := LEtoN(os2header.bcHeight);
480 BFI.Planes := LEtoN(os2header.bcPlanes);
481 BFI.BitCount := LEtoN(os2header.bcBitCount);
482 FPaletteEntrySize:= 3;
483 end else
484 begin
485 Stream.Read(BFI.Width,min(SizeOf(BFI),headerSize)-sizeof(DWord));
486 {$IFDEF ENDIAN_BIG}
487 SwapBMPInfoHeader(BFI);
488 {$ENDIF}
489 BFI.Size := headerSize;
490 FPaletteEntrySize:= 4;
491 end;
492 { This will move past any junk after the BFI header }
493 Stream.Position:=Stream.Position-SizeOf(BFI)+BFI.Size;
494 with BFI do
495 begin
496 BadCompression:=false;
497 if ((Compression=BI_RLE4) and (BitCount<>4)) then BadCompression:=true;
498 if ((Compression=BI_RLE8) and (BitCount<>8)) then BadCompression:=true;
499 if ((Compression=BI_BITFIELDS) and (not (BitCount in [16,32]))) then BadCompression:=true;
500 if not (Compression in [BI_RGB..BI_BITFIELDS]) then BadCompression:=true;
501 if BadCompression then
502 raise FPImageException.Create('Bad BMP compression mode');
503 TopDown:=(Height<0);
504 Height:=abs(Height);
505 FOriginalHeight := Height;
506 if (TopDown and (not (Compression in [BI_RGB,BI_BITFIELDS]))) then
507 raise FPImageException.Create('Top-down bitmaps cannot be compressed');
508 Img.SetSize(0,0);
509 if BitCount<=8 then
510 begin
511 Img.UsePalette:=true;
512 Img.Palette.Clear;
513 end
514 else Img.UsePalette:=false;
515 Case BFI.BitCount of
516 1 : { Monochrome }
517 SetupRead(2,Width,Stream);
518 4 :
519 SetupRead(16,Width*4,Stream);
520 8 :
521 SetupRead(256,Width*8,Stream);
522 16 :
523 SetupRead(0,Width*8*2,Stream);
524 24:
525 SetupRead(0,Width*8*3,Stream);
526 32:
527 SetupRead(0,Width*8*4,Stream);
528 else raise exception.Create('Invalid bit depth ('+inttostr(BFI.BitCount)+')');
529 end;
530 end;
531 if Subformat = bsfHeaderlessWithMask then BFI.Height := BFI.Height div 2;
532 Try
533 { Note: it would be better to Fill the image palette in setupread instead of creating FPalette.
534 FPalette is indeed useless but we cannot remove it since it's not private :\ }
535 pallen:=0;
536 if BFI.BitCount<=8 then
537 if BFI.ClrUsed>0 then pallen:=BFI.ClrUsed
538 else pallen:=(1 shl BFI.BitCount);
539 if pallen>0 then
540 begin
541 if FPalette = nil then raise exception.Create('Internal error: palette object not initialized');
542 Img.Palette.Count:=pallen;
543 for i:=0 to pallen-1 do
544 Img.Palette.Color[i]:=FPalette[i];
545 end;
546 if (MinifyHeight > 0) and (MinifyHeight < BFI.Height) then FOutputHeight:= MinifyHeight else
547 if WantedHeight > 0 then FOutputHeight:= WantedHeight else
548 FOutputHeight:= BFI.Height;
549
550 if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then InitReadBuffer(Stream,2048);
551 FHasAlphaValues:= false;
552
553 Img.SetSize(BFI.Width,FOutputHeight);
554
555 if Img is TBGRACustomBitmap then
556 WriteScanlineProc := @WriteScanLineBGRA else
557 WriteScanlineProc := @WriteScanLine;
558
559 ImageVerticalLoop(Stream, Img, @ReadScanLine, @SkipScanLine, WriteScanlineProc,
560 @MainProgressProc, shouldContinue);
561
562 if shouldContinue then
563 begin
564 if not FHasAlphaValues and (TransparencyOption = toAuto) and (BFI.BitCount = 32) then
565 MakeOpaque(Img);
566 if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then CloseReadBuffer;
567
568 if Subformat = bsfHeaderlessWithMask then LoadMask(Stream,Img, shouldContinue);
569
570 Progress(psEnding,100,false,EmptyRect,'',shouldContinue);
571 end;
572
573 finally
574 FreeBufs;
575 end;
576end;
577
578procedure TBGRAReaderBMP.ExpandRLE8ScanLine(Row : Integer; Stream : TStream);
579var i,j,k : integer;
580 b0, b1 : byte;
581begin
582 i:=0;
583 while true do
584 begin
585 { let's see if we must skip pixels because of delta... }
586 if DeltaY<>-1 then
587 begin
588 if Row=DeltaY then j:=DeltaX { If we are on the same line, skip till DeltaX }
589 else j:=ReadSize; { else skip up to the end of this line }
590 while (i<j) do
591 begin
592 LineBuf[i]:=0;
593 inc(i);
594 end;
595
596 if Row=DeltaY then { we don't need delta anymore }
597 DeltaY:=-1
598 else break; { skipping must continue on the next line, we are finished here }
599 end;
600
601 b0 := GetNextBufferByte; b1 := GetNextBufferByte;
602 if b0<>0 then { number of repetitions }
603 begin
604 if b0+i>ReadSize then
605 raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
606 j:=i+b0;
607 while (i<j) do
608 begin
609 LineBuf[i]:=b1;
610 inc(i);
611 end;
612 end
613 else
614 case b1 of
615 0: break; { end of line }
616 1: break; { end of file }
617 2: begin { Next pixel position. Skipped pixels should be left untouched, but we set them to zero }
618 b0 := GetNextBufferByte; b1 := GetNextBufferByte;
619 DeltaX:=i+b0; DeltaY:=Row+b1;
620 end
621 else begin { absolute mode }
622 if b1+i>ReadSize then
623 raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
624 for k := b1-1 downto 0 do
625 Begin
626 LineBuf[i] := GetNextBufferByte;
627 Inc(i);
628 end;
629 { aligned on 2 bytes boundary: every group starts on a 2 bytes boundary, but absolute group
630 could end on odd address if there is a odd number of elements, so we pad it }
631 if (b1 mod 2)<>0 then GetNextBufferByte;
632 end;
633 end;
634 end;
635end;
636
637procedure TBGRAReaderBMP.ExpandRLE4ScanLine(Row : Integer; Stream : TStream);
638var i,j,tmpsize : integer;
639 b0, b1 : byte;
640 nibline : pbyte; { temporary array of nibbles }
641 even : boolean;
642begin
643 tmpsize:=ReadSize*2; { ReadSize is in bytes, while nibline is made of nibbles, so it's 2*readsize long }
644 getmem(nibline,tmpsize);
645 if nibline=nil then
646 raise FPImageException.Create('Out of memory');
647 try
648 i:=0;
649 while true do
650 begin
651 { let's see if we must skip pixels because of delta... }
652 if DeltaY<>-1 then
653 begin
654 if Row=DeltaY then j:=DeltaX { If we are on the same line, skip till DeltaX }
655 else j:=tmpsize; { else skip up to the end of this line }
656 while (i<j) do
657 begin
658 NibLine[i]:=0;
659 inc(i);
660 end;
661
662 if Row=DeltaY then { we don't need delta anymore }
663 DeltaY:=-1
664 else break; { skipping must continue on the next line, we are finished here }
665 end;
666
667 b0 := GetNextBufferByte; b1:= GetNextBufferByte;
668 if b0<>0 then { number of repetitions }
669 begin
670 if b0+i>tmpsize then
671 raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
672 even:=true;
673 j:=i+b0;
674 while (i<j) do
675 begin
676 if even then NibLine[i]:=(b1 and $F0) shr 4
677 else NibLine[i]:=b1 and $0F;
678 inc(i);
679 even:=not even;
680 end;
681 end
682 else
683 case b1 of
684 0: break; { end of line }
685 1: break; { end of file }
686 2: begin { Next pixel position. Skipped pixels should be left untouched, but we set them to zero }
687 b0 := GetNextBufferByte; b1:= GetNextBufferByte;
688 DeltaX:=i+b0; DeltaY:=Row+b1;
689 end
690 else begin { absolute mode }
691 if b1+i>tmpsize then
692 raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
693 j:=i+b1;
694 even:=true;
695 while (i<j) do
696 begin
697 if even then
698 begin
699 b0 := GetNextBufferByte;
700 NibLine[i]:=(b0 and $F0) shr 4;
701 end
702 else NibLine[i]:=b0 and $0F;
703 inc(i);
704 even:=not even;
705 end;
706 { aligned on 2 bytes boundary: see rle8 for details }
707 b1:=b1+(b1 mod 2);
708 if (b1 mod 4)<>0 then GetNextBufferByte;
709 end;
710 end;
711 end;
712 { pack the nibline into the linebuf }
713 for i:=0 to ReadSize-1 do
714 LineBuf[i]:=(NibLine[i*2] shl 4) or NibLine[i*2+1];
715 finally
716 FreeMem(nibline)
717 end;
718end;
719
720procedure TBGRAReaderBMP.ReadScanLine(Row : Integer; Stream : TStream);
721begin
722 if BFI.Compression=BI_RLE8 then ExpandRLE8ScanLine(Row,Stream)
723 else if BFI.Compression=BI_RLE4 then ExpandRLE4ScanLine(Row,Stream)
724 else Stream.Read(LineBuf[0],ReadSize);
725end;
726
727procedure TBGRAReaderBMP.SkipScanLine(Row: Integer; Stream: TStream);
728begin
729 if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then ReadScanLine(Row,Stream)
730 else Stream.Position := Stream.Position+ReadSize;
731end;
732
733procedure TBGRAReaderBMP.WriteScanLine(Row : Integer; Img : TFPCustomImage);
734
735Var
736 Column : Integer;
737 c: TFPColor;
738begin
739 Case BFI.BitCount of
740 1 :
741 for Column:=0 to Img.Width-1 do
742 if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
743 img.Pixels[Column,Row]:=1
744 else
745 img.Pixels[Column,Row]:=0;
746 4 :
747 for Column:=0 to img.Width-1 do
748 img.Pixels[Column,Row]:=(LineBuf[Column div 2] shr (((Column+1) and 1)*4)) and $0f;
749 8 :
750 for Column:=0 to img.Width-1 do
751 img.Pixels[Column,Row]:=LineBuf[Column];
752 16 :
753 for Column:=0 to img.Width-1 do
754 img.colors[Column,Row]:=ExpandColor(PWord(LineBuf)[Column]);
755 24 :
756 for Column:=0 to img.Width-1 do
757 img.colors[Column,Row]:=RGBToFPColor(PColorRGB(LineBuf)[Column]);
758 32 :
759 for Column:=0 to img.Width-1 do
760 if BFI.Compression=BI_BITFIELDS then
761 img.colors[Column,Row]:=ExpandColor(PLongWord(LineBuf)[Column])
762 else
763 begin
764 if FTransparencyOption = toOpaque then
765 img.colors[Column,Row]:=RGBToFPColor(PColorRGB(PColorRGBA(LineBuf)+Column)^)
766 else
767 begin
768 c := RGBAToFPColor(PColorRGBA(LineBuf)[Column]);
769 if c.alpha <> 0 then FHasAlphaValues:= true;
770 img.colors[Column,Row]:= c;
771 end;
772 end;
773 end;
774end;
775
776procedure TBGRAReaderBMP.WriteScanLineBGRA(Row: Integer; Img: TFPCustomImage);
777
778Var
779 Column : Integer;
780 PDest: PBGRAPixel;
781 PSrc: PByte;
782begin
783 PDest := TBGRACustomBitmap(Img).ScanLine[Row];
784 Case BFI.BitCount of
785 1 :
786 for Column:=0 to Img.Width-1 do
787 begin
788 if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
789 PDest^ := FBGRAPalette[1]
790 else
791 PDest^ := FBGRAPalette[0];
792 inc(PDest);
793 end;
794 4 :
795 for Column:=0 to img.Width-1 do
796 begin
797 PDest^ := FBGRAPalette[(LineBuf[Column div 2] shr (((Column+1) and 1)*4)) and $0f];
798 inc(PDest);
799 end;
800 8 :
801 for Column:=0 to img.Width-1 do
802 begin
803 PDest^ := FBGRAPalette[LineBuf[Column]];
804 inc(PDest);
805 end;
806 16 :
807 for Column:=0 to img.Width-1 do
808 begin
809 PDest^ :=ExpandColorBGRA(PWord(LineBuf)[Column]);
810 inc(PDest);
811 end;
812 24 : begin
813 PSrc := LineBuf;
814 for Column:=0 to img.Width-1 do
815 begin
816 PDest^ := BGRA((Psrc+2)^,(Psrc+1)^,(Psrc)^);
817 inc(PDest);
818 inc(PSrc,3);
819 end;
820 end;
821 32 :
822 if BFI.Compression=BI_BITFIELDS then
823 begin
824 for Column:=0 to img.Width-1 do
825 begin
826 PDest^:=ExpandColorBGRA(PLongWord(LineBuf)[Column]);
827 inc(PDest);
828 end;
829 end else
830 if FTransparencyOption = toOpaque then
831 begin
832 if TBGRAPixel_RGBAOrder then
833 begin
834 PSrc := LineBuf;
835 for Column:=0 to img.Width-1 do
836 begin
837 PDest^:= BGRA((PSrc)^,(PSrc+1)^,(PSrc+2)^);
838 inc(PDest);
839 Inc(PSrc,4);
840 end;
841 end
842 else
843 begin
844 PSrc := LineBuf;
845 for Column:=0 to img.Width-1 do
846 begin
847 PDest^:= BGRA((PSrc+2)^,(PSrc+1)^,(PSrc+1)^);
848 inc(PDest);
849 Inc(PSrc,4);
850 end;
851 end;
852 end else
853 begin
854 if TBGRAPixel_RGBAOrder then
855 begin
856 PSrc := LineBuf;
857 for Column:=0 to img.Width-1 do
858 begin
859 PDest^:= BGRA((PSrc+2)^,(PSrc+1)^,(PSrc)^,(PSrc+3)^);
860 if PDest^.alpha <> 0 then FHasAlphaValues:= true;
861 inc(PDest);
862 Inc(PSrc,4);
863 end;
864 end
865 else
866 begin
867 PSrc := LineBuf;
868 for Column:=0 to img.Width-1 do
869 begin
870 PDest^ := PBGRAPixel(PSrc)^;
871 if PDest^.alpha <> 0 then FHasAlphaValues:= true;
872 inc(PDest);
873 Inc(PSrc,4);
874 end;
875 end;
876 end;
877 end;
878end;
879
880procedure TBGRAReaderBMP.ReadMaskLine(Row: Integer; Stream: TStream);
881begin
882 FillChar(FMaskData^, FMaskDataSize, 0);
883 Stream.Read(FMaskData^, FMaskDataSize);
884end;
885
886procedure TBGRAReaderBMP.SkipMaskLine(Row: Integer; Stream: TStream);
887begin
888 Stream.Position := Stream.Position+FMaskDataSize;
889end;
890
891procedure TBGRAReaderBMP.WriteMaskLine(Row: Integer; Img: TFPCustomImage);
892var x, maskPos: integer;
893 bit: byte;
894 bmp: TBGRACustomBitmap;
895 pimg: PBGRAPixel;
896begin
897 if Img is TBGRACustomBitmap then
898 bmp := TBGRACustomBitmap(Img)
899 else
900 exit;
901
902 maskPos := 0;
903 bit := $80;
904 pimg := bmp.ScanLine[Row];
905 for x := 0 to bmp.Width-1 do
906 begin
907 if (FMaskData[maskPos] and bit) <> 0 then //if AND mask is non zero, value is kept
908 begin
909 if pimg^.alpha = 255 then
910 begin
911 pimg^.alpha := 0;
912 if dword(pimg^) <> 0 then
913 begin
914 bmp.NeedXorMask;
915 bmp.XorMask.SetPixel(x,Row,pimg^);
916 end;
917 end;
918 end;
919 inc(pimg);
920 bit := bit shr 1;
921 if bit = 0 then
922 begin
923 bit := $80;
924 inc(maskPos);
925 end;
926 end;
927end;
928
929function TBGRAReaderBMP.InternalCheck (Stream:TStream) : boolean;
930begin
931 fillchar(BFH, sizeof(BFH), 0);
932 if Subformat in [bsfHeaderless,bsfHeaderlessWithMask] then
933 begin
934 result := true;
935 Hotspot := Point(0,0);
936 end else
937 begin
938 if stream.Read(BFH,SizeOf(BFH)) <> sizeof(BFH) then
939 begin
940 result := false;
941 exit;
942 end;
943 Hotspot := Point(LEtoN(PWord(@BFH.bfReserved)^),LEtoN((PWord(@BFH.bfReserved)+1)^));
944 {$IFDEF ENDIAN_BIG}
945 SwapBMPFileHeader(BFH);
946 {$ENDIF}
947 With BFH do
948 Result:=(bfType=BMmagic); // Just check magic number
949 end;
950end;
951
952procedure TBGRAReaderBMP.InitReadBuffer(AStream: TStream; ASize: integer);
953begin
954 setLength(FBuffer,ASize);
955 FBufferSize := AStream.Read(FBuffer[0],ASize);
956 FBufferPos := 0;
957 FBufferStream := AStream;
958end;
959
960procedure TBGRAReaderBMP.CloseReadBuffer;
961begin
962 FBufferStream.Position:= FBufferStream.Position-FBufferSize+FBufferPos;
963end;
964
965function TBGRAReaderBMP.GetNextBufferByte: byte;
966begin
967 if FBufferPos < FBufferSize then
968 begin
969 result := FBuffer[FBufferPos];
970 inc(FBufferPos);
971 end else
972 if FBufferSize = 0 then
973 result := 0
974 else
975 begin
976 FBufferSize := FBufferStream.Read(FBuffer[0],length(FBuffer));
977 FBufferPos := 0;
978 if FBufferPos < FBufferSize then
979 begin
980 result := FBuffer[FBufferPos];
981 inc(FBufferPos);
982 end else
983 result := 0;
984 end;
985end;
986
987procedure TBGRAReaderBMP.MakeOpaque(Img: TFPCustomImage);
988var c: TFPColor;
989 x,y: NativeInt;
990begin
991 if Img is TBGRACustomBitmap then
992 TBGRACustomBitmap(Img).AlphaFill(255)
993 else
994 for y := 0 to Img.Height-1 do
995 for x := 0 to Img.Width-1 do
996 begin
997 c := Img.Colors[x,y];
998 c.alpha := alphaOpaque;
999 Img.Colors[x,y] := c;
1000 end;
1001end;
1002
1003procedure TBGRAReaderBMP.LoadMask(Stream: TStream; Img: TFPCustomImage; var ShouldContinue: boolean);
1004begin
1005 if Img is TBGRACustomBitmap then TBGRACustomBitmap(Img).DiscardXorMask;
1006 FMaskDataSize := ((Img.Width+31) div 32)*4; //padded to dword
1007 getmem(FMaskData, FMaskDataSize);
1008 try
1009 ImageVerticalLoop(Stream,Img, @ReadMaskLine, @SkipMaskLine, @WriteMaskLine, nil, ShouldContinue);
1010 finally
1011 freemem(FMaskData);
1012 FMaskData := nil;
1013 FMaskDataSize := 0;
1014 end;
1015end;
1016
1017procedure TBGRAReaderBMP.MainProgressProc(Percent: integer;
1018 var ShouldContinue: boolean);
1019begin
1020 Progress(psRunning,Percent,false,EmptyRect,'',ShouldContinue);
1021end;
1022
1023procedure TBGRAReaderBMP.ImageVerticalLoop(Stream: TStream;
1024 Img: TFPCustomImage; ReadProc, SkipProc: TReadScanlineProc;
1025 WriteProc: TWriteScanlineProc; ProgressProc: TProgressProc;
1026 var ShouldContinue: boolean);
1027var
1028 prevPercent, percent, percentAdd : byte;
1029 percentMod : longword;
1030 percentAcc, percentAccAdd : longword;
1031 PrevSourceRow,SourceRow, SourceRowDelta, SourceLastRow: integer;
1032 SourceRowAdd: integer;
1033 SourceRowAcc,SourceRowMod: integer;
1034 SourceRowAccAdd: integer;
1035 OutputLastRow, OutputRow, OutputRowDelta: integer;
1036begin
1037 if OutputHeight <= 0 then exit;
1038
1039 percent:=0;
1040 percentAdd := 100 div BFI.Height;
1041 percentAcc:=BFI.Height div 2;
1042 percentAccAdd := 100 mod BFI.Height;
1043 percentMod:=BFI.Height;
1044
1045 DeltaX:=-1; DeltaY:=-1;
1046 if TopDown then
1047 begin
1048 SourceRowDelta := 1;
1049 SourceRow := 0;
1050 SourceLastRow := BFI.Height-1;
1051 end else
1052 begin
1053 SourceRowDelta := -1;
1054 SourceRow := BFI.Height-1;
1055 SourceLastRow := 0;
1056 end;
1057 OutputRowDelta:= SourceRowDelta;
1058
1059 SourceRowAdd := (BFI.Height div OutputHeight)*SourceRowDelta;
1060 SourceRowAcc := OutputHeight div 2;
1061 SourceRowAccAdd := BFI.Height mod OutputHeight;
1062 SourceRowMod := OutputHeight;
1063 If TopDown then
1064 begin
1065 OutputRow := 0;
1066 OutputLastRow := OutputHeight-1;
1067 end
1068 else
1069 begin
1070 OutputRow := OutputHeight-1;
1071 OutputLastRow := 0;
1072 end;
1073
1074 PrevSourceRow := SourceRow-SourceRowDelta;
1075
1076 while ShouldContinue and (SourceRow <> SourceLastRow+SourceRowDelta) do
1077 begin
1078 while PrevSourceRow <> SourceRow do
1079 begin
1080 inc(PrevSourceRow, SourceRowDelta);
1081 if PrevSourceRow = SourceRow then
1082 ReadProc(PrevSourceRow,Stream)
1083 else
1084 SkipProc(PrevSourceRow,Stream);
1085 end;
1086 WriteProc(OutputRow,Img);
1087 if OutputRow = OutputLastRow then break;
1088
1089 inc(OutputRow,OutputRowDelta);
1090 inc(SourceRow,SourceRowAdd);
1091 inc(SourceRowAcc,SourceRowAccAdd);
1092 if SourceRowAcc >= SourceRowMod then
1093 begin
1094 dec(SourceRowAcc,SourceRowMod);
1095 Inc(SourceRow,SourceRowDelta);
1096 end;
1097
1098 prevPercent := percent;
1099 inc(percent,percentAdd);
1100 inc(percentAcc,percentAccAdd);
1101 if percentAcc>=percentMod then inc(percent);
1102 if (percent<>prevPercent) and Assigned(ProgressProc) then ProgressProc(percent, ShouldContinue);
1103 end;
1104end;
1105
1106initialization
1107
1108 DefaultBGRAImageReader[ifBmp] := TBGRAReaderBMP;
1109
1110end.
Note: See TracBrowser for help on using the repository browser.