added basic TIcon reading from Colin

git-svn-id: trunk@5390 -

lcl/graphics.pp

@@ -903,7 +903,8 @@ type
   TBitmapNativeType = (
     bnNone,
     bnWinBitmap,
-    bnXPixmap
+    bnXPixmap,
+    bnIcon
     );
   TBitmapNativeTypes = set of TBitmapNativeType;
 
@@ -1109,9 +1110,11 @@ type
   { TIcon }
   {
     TIcon reads and writes .ICO file format.
-    ! Currently it is only a TBitmap !
+    ! Currently it is almost a TBitmap !
   }
   TIcon = class(TBitmap)
+  protected
+    procedure ReadData(Stream: TStream); override;
   end;
 
 
@@ -1175,6 +1178,7 @@ var
 function TestStreamBitmapNativeType(const AStream: TStream): TBitmapNativeType;
 function TestStreamIsBMP(const AStream: TStream): boolean;
 function TestStreamIsXPM(const AStream: TStream): boolean;
+function TestStreamIsIcon(const AStream: TStream): boolean;
 
 function XPMToPPChar(const XPM: string): PPChar;
 function LazResourceXPMToPPChar(const ResourceName: string): PPChar;
@@ -1213,7 +1217,6 @@ const
  ***************************************************************************)
 implementation
 
-
 function SendIntfMessage(LM_Message : integer; Sender : TObject;
   Data : pointer) : integer;
 begin
@@ -1583,6 +1586,35 @@ begin
   Result:='image/'+DefaultFileExt;
 end;
 
+{ TIcon }
+
+function TestStreamIsIcon(const AStream: TStream): boolean;
+var
+  Signature: array[0..3] of char;
+  ReadSize: Integer;
+  OldPosition: TStreamSeekType;
+begin
+  OldPosition:=AStream.Position;
+  ReadSize:=AStream.Read(Signature, SizeOf(Signature));
+  Result:=(ReadSize=SizeOf(Signature)) and (Signature=#0#0#1#0);
+  AStream.Position:=OldPosition;
+end;
+
+procedure TIcon.ReadData(Stream: TStream);
+var
+  Size: longint;
+  Position: TStreamSeekType;
+begin
+  Position := Stream.Position;
+  Stream.Read(Size, SizeOf(Size));
+  if Size = $10000 then begin // Icon starts 00 00 01 00
+    // Assume Icon - stream without explicit size
+    Stream.Position := Position;
+    ReadStream(Stream, false, Size);
+  end else
+    ReadStream(Stream, true, Size);
+end;
+
 initialization
   PicClipboardFormats:=nil;
   PicFileFormats:=nil;
@@ -1604,6 +1636,9 @@ end.
 { =============================================================================
 
   $Log$
+  Revision 1.132  2004/04/10 00:11:16  mattias
+  added basic TIcon reading  from Colin
+
   Revision 1.131  2004/04/03 16:47:46  mattias
   implemented converting gdkbitmap to RawImage mask
 

lcl/include/bitmap.inc

@@ -24,6 +24,8 @@ begin
     Result:=bnWinBitmap
   else if TestStreamIsXPM(AStream) then
     Result:=bnXPixmap
+  else if TestStreamIsIcon(AStream) then
+    Result := bnIcon
   else
     Result:=bnNone;
 end;
@@ -497,6 +499,7 @@ begin
     case StreamType of
     bnWinBitmap:  ReaderClass:=TLazReaderBMP;
     bnXPixmap:    ReaderClass:=TLazReaderXPM;
+    bnIcon:       ReaderClass:=TLazReaderIcon;
     else
       RaiseInvalidBitmapHeader;
     end;
@@ -1193,6 +1196,9 @@ end;
 { =============================================================================
 
   $Log$
+  Revision 1.84  2004/04/10 00:11:16  mattias
+  added basic TIcon reading  from Colin
+
   Revision 1.83  2004/04/05 11:41:05  mattias
   fixed retrieving gdkbitmaps  LineEnding=rileDWordBoundary
 

lcl/intfgraphics.pas

@@ -330,17 +330,30 @@ type
       LineBuf: PByte;          // Buffer for 1 scanline. Can be Byte, Word, TColorRGB or TColorRGBA
 
       // SetupRead will allocate the needed buffers, and read the colormap if needed.
-      procedure SetupRead(nPalette, nRowBits: Integer; Stream: TStream); virtual;
+      procedure SetupRead(nPalette, nRowBits: Integer; Stream: TStream;
+        ReadPalette: Boolean); virtual;
       procedure ReadScanLine(Row: Integer; Stream: TStream); virtual;
       procedure WriteScanLine(Row: Integer; Img: TFPCustomImage); virtual;
       // required by TFPCustomImageReader
       procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
+      procedure InternalReadBody(Stream: TStream; Img: TFPCustomImage);
       function  InternalCheck(Stream: TStream) : boolean; override;
     public
       constructor Create; override;
       destructor Destroy; override;
   end;
 
+  { TLazReaderIcon }
+  { This is a FPImage writer for icon images. }
+  TLazReaderIcon = class (TLazReaderBMP)
+    private
+      FnIcons: Integer;
+      FnStartPos: TStreamSeekType;
+    protected
+      // required by TFPCustomImageReader
+      procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
+      function  InternalCheck(Stream: TStream) : boolean; override;
+  end;
 
 function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
 procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
@@ -2924,7 +2937,8 @@ begin
     end;
 end;
 
-procedure TLazReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream: TStream);
+procedure TLazReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream: TStream;
+  ReadPalette: Boolean);
 {$ifdef VER1_0}
 type
   tcolinfo = ARRAY [0..0] OF TColorBmpRGBA;
@@ -2942,20 +2956,24 @@ begin
     GetMem(FPalette, nPalette*SizeOf(TFPColor));
     {$ifdef VER1_0}
     GetMem(ColInfo, nPalette*Sizeof(TColorBmpRGBA));
-    if BFI.biClrUsed>0 then
+    if ReadPalette then begin
-      Stream.Read(ColInfo^[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
+      if BFI.biClrUsed>0 then
-    else // Seems to me that this is dangerous.
+        Stream.Read(ColInfo^[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
-      Stream.Read(ColInfo^[0],nPalette*SizeOf(TColorBmpRGBA));
+      else // Seems to me that this is dangerous.
-    for i := 0 to nPalette-1 do
+        Stream.Read(ColInfo^[0],nPalette*SizeOf(TColorBmpRGBA));
-      FPalette[i] := BmpRGBAToFPColor(ColInfo^[i]);
+      for i := 0 to nPalette-1 do
+        FPalette[i] := BmpRGBAToFPColor(ColInfo^[i]);
+    end;
     {$else}
     SetLength(ColInfo, nPalette);
-    if BFI.biClrUsed>0 then
+    if ReadPalette then begin
-      Stream.Read(ColInfo[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
+      if BFI.biClrUsed>0 then
-    else // Seems to me that this is dangerous.
+        Stream.Read(ColInfo[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
-      Stream.Read(ColInfo[0],nPalette*SizeOf(TColorBmpRGBA));
+      else // Seems to me that this is dangerous.
-    for i := 0 to High(ColInfo) do
+        Stream.Read(ColInfo[0],nPalette*SizeOf(TColorBmpRGBA));
-      FPalette[i] := BmpRGBAToFPColor(ColInfo[i]);
+      for i := 0 to High(ColInfo) do
+        FPalette[i] := BmpRGBAToFPColor(ColInfo[i]);
+    end;
     {$endif}
     end
   else if BFI.biClrUsed>0 then { Skip palette }
@@ -3006,10 +3024,15 @@ begin
 end;
 
 procedure TLazReaderBMP.InternalRead(Stream: TStream; Img: TFPCustomImage);
+begin
+  Stream.Read(BFI,SizeOf(BFI));
+  InternalReadBody(Stream, Img);
+end;
+
+procedure TLazReaderBMP.InternalReadBody(Stream: TStream; Img: TFPCustomImage);
 Var
   Row : Integer;
 begin
-  Stream.Read(BFI,SizeOf(BFI));
   { This will move past any junk after the BFI header }
   Stream.Position:=Stream.Position-TStreamSeekType(SizeOf(BFI)-BFI.biSize);
   with BFI do
@@ -3021,17 +3044,17 @@ begin
     end;
   Case BFI.biBitCount of
     1 : { Monochrome }
-      SetupRead(2,Img.Width,Stream);
+      SetupRead(2,Img.Width,Stream,true);
     4 :
-      SetupRead(16,Img.Width*4,Stream);
+      SetupRead(16,Img.Width*4,Stream,true);
     8 :
-      SetupRead(256,Img.Width*8,Stream);
+      SetupRead(256,Img.Width*8,Stream,true);
     16 :
-      SetupRead(0,Img.Width*8*2,Stream);
+      SetupRead(0,Img.Width*8*2,Stream,true);
     24:
-      SetupRead(0,Img.Width*8*3,Stream);
+      SetupRead(0,Img.Width*8*3,Stream,true);
     32:
-      SetupRead(0,Img.Width*8*4,Stream);
+      SetupRead(0,Img.Width*8*4,Stream,true);
   end;
   Try
     for Row:=Img.Height-1 downto 0 do
@@ -3115,6 +3138,78 @@ begin
   end;
 end;
 
+{ TLazReaderIcon }
+
+type
+  TIconHeader = packed record
+    idReserved: Word; {0}
+    idType: Word;     {1}
+    idCount: Word;    {number of icons in file}
+  end;
+  
+  TIconDirEntry = packed record
+    bWidth: Byte;          {ie: 16 or 32}
+    bHeight: Byte;         {ie: 16 or 32}
+    bColorCount: Byte;     {number of entires in pallette table below}
+    bReserved: Byte;       { not used  = 0}
+    wPlanes: Word;         { not used  = 0}
+    wBitCount: Word;       { not used  = 0}
+    dwBytesInRes: Longint;  {total number bytes in images including pallette data
+                             XOR, AND     and bitmap info header}
+    dwImageOffset: Longint;  {pos of image as offset from the beginning of file}
+  end;
+
+procedure TLazReaderIcon.InternalRead(Stream: TStream; Img: TFPCustomImage);
+var
+  CurrentDirEntry, BestDirEntry: TIconDirEntry;
+  Row, Column, i: Integer;
+begin
+  { For the time being, read the largest and/or most colourful icon }
+  Stream.Read(BestDirEntry, Sizeof(BestDirEntry));
+  CurrentDirEntry := BestDirEntry;
+  for i := 2 to FnIcons do begin
+    Stream.Read(CurrentDirEntry, Sizeof(CurrentDirEntry));
+    if ((CurrentDirEntry.bWidth > BestDirEntry.bWidth)
+         and (CurrentDirEntry.bHeight > BestDirEntry.bHeight))
+       or ((CurrentDirEntry.bWidth = BestDirEntry.bWidth)
+           and (CurrentDirEntry.bHeight = BestDirEntry.bHeight)
+           and (CurrentDirEntry.dwBytesInRes > BestDirEntry.dwBytesInRes)) then
+      BestDirEntry := CurrentDirEntry;
+  end;
+  Stream.Position := FnStartPos + BestDirEntry.dwImageOffset;
+  Stream.Read(BFI,SizeOf(BFI));
+  BFI.biHeight := BFI.biHeight div 2; { Height field is doubled, to (sort of) accomodate mask }
+  InternalReadBody(Stream, Img); { Now read standard bitmap }
+  { Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header }
+  if BFI.biBitCount < 32 then begin
+    ReadSize:=((Img.Width + 31) div 32) shl 2;
+    SetupRead(2,Img.Width,Stream,False);
+    try
+      for Row:=Img.Height-1 downto 0 do begin
+        ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
+        for Column:=0 to Img.Width-1 do
+          if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
+            img.colors[Column,Row]:=colTransparent
+      end;
+    finally
+      FreeBufs;
+    end;
+  end;
+  { Finally skip remaining icons }
+  Stream.Position := FnStartPos + BestDirEntry.dwImageOffset + BestDirEntry.dwBytesInRes;
+end;
+
+function TLazReaderIcon.InternalCheck(Stream: TStream): boolean;
+var
+  IconHeader: TIconHeader;
+begin
+  FnStartPos := Stream.Position;
+  Stream.Read(IconHeader,SizeOf(IconHeader));
+  With IconHeader do
+    Result := (idReserved=0) and (idType=1);
+  FnIcons := IconHeader.idCount;
+end;
+
 initialization
   InternalInit;