* Start of new Icon - bitmap cleanup

git-svn-id: trunk@13624 -

lcl/graphics.pp

@@ -695,19 +695,23 @@ type
     procedure WriteData(Stream: TStream); virtual;
   public
     constructor Create; virtual;
+    function LazarusResourceTypeValid(const AResourceType: string): boolean; virtual;
     procedure LoadFromFile(const Filename: string); virtual;
-    procedure SaveToFile(const Filename: string); virtual;
     procedure LoadFromStream(Stream: TStream); virtual; abstract;
-    procedure SaveToStream(Stream: TStream); virtual; abstract;
     procedure LoadFromMimeStream(Stream: TStream; const MimeType: string); virtual;
-    procedure LoadFromLazarusResource(const ResName: String); virtual; abstract;
+    procedure LoadFromLazarusResource(const ResName: String); virtual;
+    procedure LoadFromResourceName(Instance: THandle; const ResName: String);
+    procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
     procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual;
     procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType;
       FormatID: TClipboardFormat); virtual;
+    procedure SaveToFile(const Filename: string); virtual;
+    procedure SaveToStream(Stream: TStream); virtual; abstract;
     procedure SaveToClipboardFormat(FormatID: TClipboardFormat); virtual;
     procedure SaveToClipboardFormatID(ClipboardType: TClipboardType;
       FormatID: TClipboardFormat); virtual;
     procedure GetSupportedSourceMimeTypes(List: TStrings); virtual;
+    function GetResourceType: TResourceType; virtual;
     function GetDefaultMimeType: string; virtual;
     class function GetFileExtensions: string; virtual;
     class function GetFPReaderForFileExt(
@@ -1152,6 +1156,7 @@ type
     function GetHandle: HBITMAP; virtual;
     function GetMaskHandle: HBITMAP; virtual;
     function GetTransparent: Boolean; override;
+    function GetBitmapNativeType: TBitmapNativeType; virtual;
     procedure HandleNeeded;
     procedure MaskHandleNeeded;
     procedure PaletteNeeded;
@@ -1180,22 +1185,19 @@ type
     function MaskHandleAllocated: boolean;
     function PaletteAllocated: boolean;
     procedure CreateFromBitmapHandles(ABitmap, AMask: HBitmap; const ARect: TRect);
-    function LazarusResourceTypeValid(const ResourceType: string): boolean; virtual;
+    function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
     procedure LoadFromDevice(DC: HDC); virtual;
     procedure LoadFromStream(Stream: TStream); override;
-    procedure LoadFromLazarusResource(const ResName: String); override;
-    procedure LoadFromResourceName(Instance: THandle; const ResName: String); virtual;
-    procedure LoadFromResourceID(Instance: THandle; ResID: Integer); virtual;
     procedure LoadFromMimeStream(Stream: TStream; const MimeType: string); override;
-    procedure SaveToFile(const Filename: string); override;
+    procedure LoadFromIntfImage(IntfImage: TLazIntfImage);
+    procedure LoadFromXPMFile(const Filename: String); deprecated;
+    procedure SaveToStream(Stream: TStream); override;
     procedure GetSupportedSourceMimeTypes(List: TStrings); override;
     function GetDefaultMimeType: string; override;
+    function GetResourceType: TResourceType; override;
     class function GetFileExtensions: string; override;
-    procedure LoadFromXPMFile(const Filename: String);
-    procedure LoadFromIntfImage(IntfImage: TLazIntfImage);
     procedure Mask(ATransparentColor: TColor);
     procedure SetHandles(ABitmap, AMask: HBITMAP);
-    procedure SaveToStream(Stream: TStream); override;
     procedure ReadStream(Stream: TStream; UseSize: boolean; Size: Longint); virtual;
     procedure WriteStream(Stream: TStream; WriteSize: Boolean); virtual;
     function ReleaseHandle: HBITMAP;
@@ -1236,8 +1238,9 @@ type
   { TPixmap }
 
   TPixmap = class(TBitmap)
+  protected
+    function GetBitmapNativeType: TBitmapNativeType; override;
   public
-    procedure SaveToFile(const Filename: string); override;
     function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
     procedure WriteStream(Stream: TStream; WriteSize: Boolean); override;
     class function GetDefaultFPReader: TFPCustomImageReaderClass; override;
@@ -1250,6 +1253,8 @@ type
     reader and writer }
 
   TFPImageBitmap = class(TBitmap)
+  protected
+    function GetBitmapNativeType: TBitmapNativeType; override;
   public
     class function GetFileExtensions: string; override;
     class function IsFileExtensionSupported(const FileExtension: string): boolean;
@@ -1297,10 +1302,14 @@ type
     Bitmaps property
     Writing is not (yet) implemented.
   }
+  
+  {.$define ICON_OLDSTYLE}     // Set to keep original functionality
+ 
   TIcon = class(TBitmap)
   private
     FBitmaps: TObjectList;
   protected
+    function GetBitmapNativeType: TBitmapNativeType; override;
     procedure ReadData(Stream: TStream); override;
     procedure InitFPImageReader(IntfImg: TLazIntfImage; ImgReader: TFPCustomImageReader); override;
   public
@@ -1310,6 +1319,7 @@ type
     procedure AddBitmap(Bitmap: TBitmap); { Note that Ownership passes to TIcon }
   end;
 
+
   { TCursorImage }
   TCursorImage = class(TIcon)
   private
@@ -1317,6 +1327,7 @@ type
     FCursorHandle: HCURSOR;
     FOwnHandle: Boolean;
   protected
+    function GetBitmapNativeType: TBitmapNativeType; override;
     function GetCursorHandle: HCURSOR;
     procedure CursorHandleNeeded;
   public
@@ -1938,6 +1949,11 @@ begin
     Result:=nil;
 end;
 
+function TFPImageBitmap.GetBitmapNativeType: TBitmapNativeType;
+begin
+  Result := bnNone;
+end;
+
 class function TFPImageBitmap.GetDefaultFPReader: TFPCustomImageReaderClass;
 begin
   Result:=nil;
@@ -2044,6 +2060,11 @@ begin
   FreeAndNil(FBitmaps);
 end;
 
+function TIcon.GetBitmapNativeType: TBitmapNativeType;
+begin
+  Result := bnIcon;
+end;
+
 procedure TIcon.AddBitmap(Bitmap: TBitmap);
 begin
   if not Assigned(FBitmaps) then
@@ -2051,6 +2072,8 @@ begin
   FBitmaps.Add(Bitmap);
 end;
 
+
+
 { TCursorImage }
 
 class function TCursorImage.GetFileExtensions: string;
@@ -2106,6 +2129,11 @@ begin
   inherited Destroy;
 end;
 
+function TCursorImage.GetBitmapNativeType: TBitmapNativeType;
+begin
+  Result := bnCursor;
+end;
+
 // ------------------------------------------------------------------
 // Decrease the component RGBs of a color of the quantity' passed
 //

lcl/include/bitmap.inc

@@ -270,9 +270,8 @@ end;
 
 function TBitmap.LazarusResourceTypeValid(const ResourceType: string): boolean;
 begin
-  Result:=((ClassType=TBitmap) or (ClassType=TPixmap) or (ClassType=TIcon))
+  Result := AnsiSameText(ResourceType,'XPM')
-     and ((AnsiCompareText(ResourceType,'XPM')=0)
+         or AnsiSameText(ResourceType,'BMP');
-       or (AnsiCompareText(ResourceType,'BMP')=0));
 end;
 
 procedure TBitMap.Mask(ATransparentColor: TColor);
@@ -442,51 +441,11 @@ begin
   // CreateMask;
 end;
 
-procedure TBitmap.LoadFromLazarusResource(const ResName: String);
-var
-  Stream: TLazarusResourceStream;
-begin
-  Stream := nil;
-  try
-    Stream := TLazarusResourceStream.Create(ResName, nil);
-    if LazarusResourceTypeValid(Stream.Res.ValueType) then
-      LoadFromStream(Stream);
-   finally
-     Stream.Free;
-   end;
-end;
-
 procedure TBitMap.LoadFromStream(Stream: TStream);
 begin
   ReadStream(Stream, true, Stream.Size - Stream.Position);
 end;
 
-procedure TBitMap.LoadFromResourceName(Instance: THandle; const ResName: String);
-var
-  Stream: TResourceStream;
-begin
-  Stream := nil;
-  try
-    Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);
-    LoadFromStream(Stream);
-  finally
-    Stream.Free;
-  end;
-end;
-
-procedure TBitMap.LoadFromResourceID(Instance: THandle; ResID: Integer);
-var
-  Stream: TResourceStream;
-begin
-  Stream := nil;
-  try
-    Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);
-    LoadFromStream(Stream);
-  finally
-    Stream.Free;
-  end;
-end;
-
 procedure TBitmap.GetSupportedSourceMimeTypes(List: TStrings);
 begin
   if (ClassType=TBitmap) or (ClassType=TPixmap) or (ClassType=TIcon) then
@@ -609,6 +568,11 @@ begin
   FImage.SaveStreamClass:=nil;
 end;
 
+function TBitmap.GetBitmapNativeType: TBitmapNativeType;
+begin
+  Result := bnWinBitmap;
+end;
+
 procedure TBitmap.ReadStream(Stream: TStream; UseSize: boolean; Size: Longint);
 
   procedure RaiseInvalidBitmapHeader;
@@ -703,18 +667,6 @@ begin
   inherited LoadFromMimeStream(Stream, MimeType);
 end;
 
-procedure TBitmap.SaveToFile(const Filename: string);
-begin
-  if (ClassType=TBitmap) and (FImage.SaveStreamType<>bnWinBitmap) then begin
-    // TBitmap should always save in .bmp format
-    // but the current SaveStream is not in .bmp format.
-    // -> Clear the SaveStream.
-    UnshareImage(true);
-    FreeSaveStream;
-  end;
-  inherited SaveToFile(Filename);
-end;
-
 procedure TBitmap.SetWidthHeight(NewWidth, NewHeight: integer);
 begin
   if (FImage.FDIB.dsbm.bmHeight <> NewHeight)
@@ -937,9 +889,10 @@ var
   RawImage: TRawImage;
 begin
   //DebugLn(['WriteStreamWithFPImage Self=',DbgS(Self),' ',Width,',',Height,' Using SaveStream=',(FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0)]);
-  if (FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0)
+  if  (FImage.SaveStream<>nil)
-  and ((FImage.SaveStreamType<>bnNone)
+  and (FImage.SaveStream.Size>0)
-    or CanReadGraphicStreams(FImage.SaveStreamClass))
+  and (FImage.SaveStreamType = GetBitmapNativeType)
+  and ((FImage.SaveStreamType<>bnNone) or CanReadGraphicStreams(FImage.SaveStreamClass))
   then begin
     // it's a stream format, that this graphic class can read
     // (important for restore)
@@ -1266,6 +1219,11 @@ begin
   Result := FImage.FPalette;
 end;
 
+function TBitmap.GetResourceType: TResourceType;
+begin
+  Result := RT_BITMAP;
+end;
+
 function TBitmap.GetWidth: Integer;
 begin
   Result := FImage.FDIB.dsbm.bmWidth;

lcl/include/graphic.inc

@@ -45,6 +45,11 @@ begin
   Result:=0;
 end;
 
+function TGraphic.GetResourceType: TResourceType;
+begin
+  Result := nil;
+end;
+
 procedure TGraphic.Changed(Sender: TObject);
 begin
   FModified := True;
@@ -126,7 +131,39 @@ begin
   if (DefMimeType<>'') and (MimeType=GetDefaultMimeType) then
     LoadFromStream(Stream)
   else
-    raise Exception.Create(ClassName+': Unsupported MimeType: '+MimeType);
+    raise EInvalidGraphic.Create(ClassName+': Unsupported MimeType: '+MimeType);
+end;
+
+procedure TGraphic.LoadFromResourceID(Instance: THandle; ResID: Integer);
+var
+  Stream: TResourceStream;
+  ResType: TResourceType;
+begin
+  ResType := GetResourceType;
+  if ResType = nil then Exit;
+
+  Stream := TResourceStream.CreateFromID(Instance, ResID, ResType);
+  try
+    LoadFromStream(Stream);
+  finally
+    Stream.Free;
+  end;
+end;
+
+procedure TGraphic.LoadFromResourceName(Instance: THandle; const ResName: String);
+var
+  Stream: TResourceStream;
+  ResType: TResourceType;
+begin
+  ResType := GetResourceType;
+  if ResType = nil then Exit;
+
+  Stream := TResourceStream.Create(Instance, ResName, ResType);
+  try
+    LoadFromStream(Stream);
+  finally
+    Stream.Free;
+  end;
 end;
 
 procedure TGraphic.LoadFromClipboardFormat(FormatID: TClipboardFormat);
@@ -193,6 +230,21 @@ begin
   end;
 end;
 
+procedure TGraphic.LoadFromLazarusResource(const ResName: String);
+var
+  Stream: TLazarusResourceStream;
+begin
+  Stream := nil;
+  try
+    Stream := TLazarusResourceStream.Create(ResName, nil);
+    if LazarusResourceTypeValid(Stream.Res.ValueType)
+    then LoadFromStream(Stream)
+    else raise EInvalidGraphic.Create(ClassName+': Unsupported Resourcetype: '+Stream.Res.ValueType);
+   finally
+     Stream.Free;
+   end;
+end;
+
 procedure TGraphic.WriteData(Stream: TStream);
 begin
   SaveToStream(Stream);
@@ -203,6 +255,11 @@ begin
   Result := FTransparent;
 end;
 
+function TGraphic.LazarusResourceTypeValid(const AResourceType: string): boolean;
+begin
+  Result := False;
+end;
+
 procedure TGraphic.SetModified(Value: Boolean);
 begin
   if Value then

lcl/include/pixmap.inc

@@ -277,18 +277,6 @@ end;
 
 { TPixmap }
 
-procedure TPixmap.SaveToFile(const Filename: string);
-begin
-  if (ClassType=TPixmap) and (FImage.SaveStreamType<>bnXPixmap) then begin
-    // TPixmap should always save in .xpm format
-    // but the current SaveStream is not in .xpm format.
-    // -> Clear the SaveStream.
-    UnshareImage(true);
-    FreeSaveStream;
-  end;
-  inherited SaveToFile(Filename);
-end;
-
 function TPixmap.LazarusResourceTypeValid(const ResourceType: string): boolean;
 begin
   Result:=(ResourceType='XPM');
@@ -299,6 +287,11 @@ begin
   WriteStreamWithFPImage(Stream,WriteSize,TLazWriterXPM);
 end;
 
+function TPixmap.GetBitmapNativeType: TBitmapNativeType;
+begin
+  Result := bnXPixmap;
+end;
+
 class function TPixmap.GetDefaultFPReader: TFPCustomImageReaderClass;
 begin
   Result:=TLazReaderXPM;

lcl/lcltype.pp

@@ -1868,20 +1868,21 @@ const
   CBM_INIT = 4;     { initialize bitmap  }
   
 { Predefined Resource Types }
+type
+  {$ifdef UNICODE}
+  TResourceType = PWideChar;
+  {$else}
+  TResourceType = PChar;
+  {$endif}
+const
 {$ifdef windows}
   RT_CURSOR = Windows.RT_CURSOR;
   RT_BITMAP = Windows.RT_BITMAP;
   RT_ICON   = Windows.RT_ICON;
 {$else}
-  {$ifdef UNICODE} // PI: taked this define from classesh.inc TResourceStream
+  RT_CURSOR = TResourceType(1);
-    RT_CURSOR = PWideChar(1);
+  RT_BITMAP = TResourceType(2);
-    RT_BITMAP = PWideChar(2);
+  RT_ICON   = TResourceType(3);
-    RT_ICON   = PWideChar(3);
-  {$else}
-    RT_CURSOR = PChar(1);
-    RT_BITMAP = PChar(2);
-    RT_ICON   = PChar(3);
-  {$endif}
 {$endif}