+ Patch from Colin Western

fcl/image/bmpcomn.pp

@@ -24,7 +24,7 @@ const
   BMmagic=19778;
 type
 
-   TBitMapFileHeader = record
+   TBitMapFileHeader = packed record
 {00+02 :File type}
       bfType:word;
 {02+04 :File size in bytes}
@@ -35,7 +35,7 @@ type
       bfOffset:longint;
    end;
 
-   TBitMapInfoHeader = record
+   TBitMapInfoHeader = packed record
 {14+04 : Size of the bitmap info header : sould be 40=$28}
       Size:longint;
 {18+04 : Image width in pixels}
@@ -64,9 +64,8 @@ type
       B,G,R:Byte;
     end;
     TColorRGBA=packed record
-      A:Byte;
       case Boolean of
-        False:(B,G,R:Byte);
+        False:(B,G,R,A:Byte);
         True:(RGB:TColorRGB);
       end;
 {54+?? : Color map : Lenght of color map is 4 bytes + the rest until the beginning of image data fixed in BFH.bfOffset}
@@ -77,7 +76,10 @@ implementation
 end.
 {
 $Log$
-Revision 1.2  2003-09-09 11:22:30  mazen
+Revision 1.3  2004-02-15 20:59:06  michael
++ Patch from Colin Western
+
+Revision 1.2  2003/09/09 11:22:30  mazen
 + adding comment for type defintion in the fpdoc style
 * fixing copyright section in the file header
 

fcl/image/fpimage.pp

@@ -109,13 +109,13 @@ type
       procedure SetPixel (x,y:integer; Value:integer);
       function GetPixel (x,y:integer) : integer;
       function GetUsePalette : boolean;
-      procedure SetUsePalette (Value:boolean);virtual;
     protected
       // Procedures to store the data. Implemented in descendants
       procedure SetInternalColor (x,y:integer; const Value:TFPColor); virtual;
       function GetInternalColor (x,y:integer) : TFPColor; virtual;
       procedure SetInternalPixel (x,y:integer; Value:integer); virtual; abstract;
       function GetInternalPixel (x,y:integer) : integer; virtual; abstract;
+      procedure SetUsePalette (Value:boolean);virtual;
       procedure Progress(Sender: TObject; Stage: TProgressStage;
                          PercentDone: Byte;  RedrawNow: Boolean; const R: TRect;
                          const Msg: AnsiString; var Continue: Boolean); Virtual;

fcl/image/fpreadbmp.pp

@@ -50,55 +50,110 @@ end;
 procedure TFPReaderBMP.InternalRead(Stream:TStream; Img:TFPCustomImage);
   var
     BFI:TBitMapInfoHeader;
-  var
-    Row,Coulumn,nBpLine,ReadSize:Integer;
+    Row,Column,nBpLine,ReadSize:Integer;
     aColor:TFPcolor;
-{$IFDEF UseDynArray}
+    palette: ARRAY OF TFPcolor;
     aLine:ARRAY OF TColorRGB;
-{$ELSE UseDynArray}
-    aLine:^TColorRGB;
-{$ENDIF UseDynArray}
+    bLine:ARRAY OF TColorRGBA;
+    mLine: array of Byte;
+    function MakeFpColor(RGBA: TColorRGBA):TFPcolor;
+    begin
+      with Result, RGBA do begin
+        Red := (R shl 8) or R;
+        Green := (G shl 8) or G;
+        Blue := (B shl 8) or B;
+        alpha := AlphaOpaque;
+      end;
+    end;
+    procedure SetupRead(nPalette, nRowBits: Integer);
+    var
+      ColInfo: ARRAY OF TColorRGBA;
+      i: Integer;
+    begin
+      if nPalette > 0 then begin
+        SetLength(palette, nPalette);
+        SetLength(ColInfo, nPalette);
+        if BFI.ClrUsed > 0 then
+          Stream.Read(ColInfo[0], BFI.ClrUsed*SizeOf(TColorRGBA))
+        else if nPalette > 0 then
+          Stream.Read(ColInfo[0], nPalette*SizeOf(TColorRGBA));
+      end else
+        if BFI.ClrUsed > 0 then { Skip palette }
+          Stream.Position := Stream.Position + BFI.ClrUsed*SizeOf(TColorRGBA);
+      for i := 0 to High(ColInfo) do
+        palette[i] := MakeFpColor(ColInfo[i]);
+      ReadSize := ((nRowBits + 31) div 32) shl 2;
+    end;
   begin
     Stream.Read(BFI,SizeOf(BFI));
+    { This will move past any junk after the BFI header }
+    Stream.Position := Stream.Position - SizeOf(BFI) + BFI.Size;
     with BFI do
       begin
         Img.Width:=Width;
         Img.Height:=Height;
-        BytesPerPixel:=BitCount SHR 3;
       end;
-    if BytesPerPixel=1
-    then
-      begin
-//        stream.read(Palet, bfh.bfOffset - 54);
-      end
+    if BFI.BitCount = 1 then begin
+      { Monochrome }
+      SetupRead(2, Img.Width);
+      SetLength(mLine, ReadSize);
+      for Row:=Img.Height-1 downto 0 do begin
+        Stream.Read(mLine[0],ReadSize);
+        for Column:=0 to Img.Width-1 do
+          if ((mLine[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
+            img.colors[Column,Row] := Palette[1]
+          else
+            img.colors[Column,Row] := Palette[0];
+       end;
+    end else if BFI.BitCount = 4 then begin
+      SetupRead(16, Img.Width*4);
+      SetLength(mLine, ReadSize);
+      for Row:=img.Height-1 downto 0 do begin
+        Stream.Read(mLine[0],ReadSize);
+        for Column:=0 to img.Width-1 do
+          img.colors[Column,Row] := Palette[(mLine[Column div 2] shr (((Column+1) and 1)*4)) and $0f];
+       end;
+    end else if BFI.BitCount = 8 then begin
+      SetupRead(256, Img.Width*8);
+      SetLength(mLine, ReadSize);
+      for Row:=img.Height-1 downto 0 do begin
+        Stream.Read(mLine[0],ReadSize);
+        for Column:=0 to img.Width-1 do
+          img.colors[Column,Row] := Palette[mLine[Column]];
+       end;
+    end else if BFI.BitCount = 16 then begin
+      raise Exception.Create('16 bpp bitmaps not supported');
 {Treating the 24bit BMP files}
-    else
+    end else if BFI.BitCount=24 then
       begin
-        nBpLine:=Img.Width*SizeOf(TColorRGB);
-        ReadSize:=(nBpLine+3)AND $FFFFFFFC;//BMP needs evry line 4Bytes aligned
-{$IFDEF UseDynArray}
-        SetLength(aLine,Img.Width+1);//3 extra byte for BMP 4Bytes alignement.
-{$ELSE UseDynArray}
-        GetMem(aLine,(Img.Width+1)*SizeOf(TColorRGB));//3 extra byte for BMP 4Bytes alignement.
-{$ENDIF UseDynArray}
+        SetupRead(0, Img.Width*8*3);
+        SetLength(aLine,ReadSize);//3 extra byte for BMP 4Bytes alignement.
         for Row:=img.Height-1 downto 0 do
           begin
-            for Coulumn:=0 to img.Width-1 do
-              with aLine[Coulumn],aColor do
+            Stream.Read(aLine[0],ReadSize);
+            for Column:=0 to img.Width-1 do
+              with aLine[Column],aColor do
                 begin
 {Use only the high byte to convert the color}
                   Red := (R shl 8) + R;
                   Green := (G shl 8) + G;
                   Blue := (B shl 8) + B;
                   alpha := AlphaOpaque;
-                  img.colors[Coulumn,Row]:=aColor;
+                  img.colors[Column,Row]:=aColor;
                 end;
-            Stream.Read(aLine{$IFNDEF UseDynArray}^{$ENDIF UseDynArray},ReadSize);
+          end;
+      end
+    else if BFI.BitCount=32 then
+      begin
+        SetupRead(0, Img.Width*8*4);
+        SetLength(bLine,ReadSize);
+        for Row:=img.Height-1 downto 0 do
+          begin
+            Stream.Read(bLine[0],ReadSize);
+            for Column:=0 to img.Width-1 do
+              img.colors[Column,Row]:=MakeFpColor(bLine[Column])
           end;
       end;
-{$IFNDEF UseDynArray}
-        FreeMem(aLine,(Img.Width+1)*SizeOf(TColorRGB));
-{$ENDIF UseDynArray}
   end;
 
 function  TFPReaderBMP.InternalCheck (Stream:TStream) : boolean;
@@ -110,10 +165,7 @@ function  TFPReaderBMP.InternalCheck (Stream:TStream) : boolean;
       if bfType<>BMmagic
       then
         InternalCheck:=False
-      else if Stream.Size<>bfSize
-      then
-        InternalCheck:=False
-      else
+      else { Do not check size to allow multiple bitmaps per stream }
         InternalCheck:=True;
 end;
 
@@ -122,7 +174,10 @@ initialization
 end.
 {
 $Log$
-Revision 1.5  2003-09-30 14:17:05  luk
+Revision 1.6  2004-02-15 20:59:06  michael
++ Patch from Colin Western
+
+Revision 1.5  2003/09/30 14:17:05  luk
 * better color conversion (White didn't stay white)
 
 Revision 1.4  2003/09/30 06:17:38  mazen

fcl/image/fpreadxpm.pp

@@ -66,18 +66,20 @@ var l : integer;
       raise exception.CreateFmt ('Wrong character (%s) in hexadecimal number', [c]);
   end;
   function convert (n : string) : word;
-  var t,r, shift : integer;
+  var t,r: integer;
   begin
-    shift := 0;
     result := 0;
     t := length(n);
     if t > 4 then
-      raise exception.CreateFmt ('To many bytes for color (%s)',[s]);
-    for r := length(n) downto 1 do
-      begin
-      result := result + (CharConv(n[r]) shl shift);
-      inc (shift,4);
-      end;
+      raise exception.CreateFmt ('Too many bytes for color (%s)',[s]);
+    for r := 1 to length(n) do
+      result := (result shl 4) or CharConv(n[r]);
+    // fill missing bits
+    case t of
+      1: result:=result or (result shl 4) or (result shl 8) or (result shl 12);
+      2: result:=result or (result shl 8);
+      3: result:=result or (result shl 12);
+    end;
   end;
 begin
   s := uppercase (s);