paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-02 00:56:05 +02:00
Code Issues Packages Projects Releases Wiki Activity

lcl (from me and Marc):

Browse Source 
- create bitmaps for icon in with icon description instead of alpha bitmaps (fixes #0011514, #0011539)
- add support for gtk mono cursors
- fix gtk2 shifts on pixbufs (gtk2 bug)
- misc graphic fixes

git-svn-id: trunk@15557 -
This commit is contained in:
paul 2008-06-24 03:45:36 +00:00
parent b19ce02346
commit dabde77f8b
9 changed files with 192 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
lcl/graphtype.pp
View File

@ -898,8 +898,12 @@ begin
// The next values are only valid, if there is a precision
if (RedPrec <> 0) and (RedShift <> ADesc.RedShift ) then Exit;
if (GreenPrec <> 0) and (GreenShift <> ADesc.GreenShift) then Exit;
if (BluePrec <> 0) and (BlueShift <> ADesc.BlueShift ) then Exit;
if Format = ricfRGBA
then begin
// for mono images only red is of importance
if (GreenPrec <> 0) and (GreenShift <> ADesc.GreenShift) then Exit;
if (BluePrec <> 0) and (BlueShift <> ADesc.BlueShift ) then Exit;
end;
if (AlphaPrec <> 0) and (AlphaShift <> ADesc.AlphaShift) then Exit;
// The next values are only valid, if there is a mask (MaskBitsPerPixel > 0)

5
lcl/include/intfbaselcl.inc
View File

@ -299,11 +299,14 @@ begin
ADesc.AlphaShift := Desc.AlphaShift;
end
else begin
if Desc.Depth = 32
if (Desc.Depth = 32) and (ADesc.Format = ricfRGBA)
then begin
ADesc.Depth := 24;
//---
// maybe move this to win32 only
if Desc.AlphaShift = 24
then ADesc.BitsPerPixel := 24;
//---
end;
end;

4
lcl/include/rasterimage.inc
View File

@ -121,7 +121,9 @@ begin
H := Height;
if H < 1 then H := 1;
QueryFlags := [riqfRGB];
if ImagePtr^.Description.Depth = 1
then QueryFlags := [riqfMono]
else QueryFlags := [riqfRGB];
if ImagePtr^.Description.AlphaPrec <> 0
then Include(QueryFlags, riqfAlpha);
if ImagePtr^.Description.MaskBitsPerPixel <> 0

34
lcl/interfaces/gtk/gtkdebug.pp
View File

@ -41,11 +41,15 @@ uses
procedure DbgDumpBitmap(ABitmap: PGdkBitmap; ATitle: String = ''; AWidth: Integer = -1; AHeight: Integer = -1);
procedure DbgDumpPixmap(APixmap: PGdkPixmap; ATitle: String = ''; AWidth: Integer = -1; AHeight: Integer = -1);
procedure DbgDumpPixbuf(APixbuf: PGdkPixbuf; ATitle: String = ''; AWidth: Integer = -1; AHeight: Integer = -1);
{$ifndef gtk1}
// dont debug images on gtk1, we cannot ref, unref them and thus we cannot rely that they will not be destroyed
procedure DbgDumpImage(AImage: PGdkImage; ATitle: String = ''; AWidth: Integer = -1; AHeight: Integer = -1);
{$endif}
implementation
type
TDbgDumpType = (ddtBitmap, ddtPixmap, ddtPixbuf);
TDbgDumpType = (ddtBitmap, ddtPixmap, ddtPixbuf, ddtImage);
PDbgDumpInfo = ^TDbgDumpInfo;
TDbgDumpInfo = record
@ -54,6 +58,7 @@ type
ddtBitmap: (Bitmap: PGdkBitmap);
ddtPixmap: (Pixmap: PGdkPixmap);
ddtPixbuf: (Pixbuf: PGdkPixbuf);
ddtImage: (Image: PGdkImage);
end;
procedure OnDbgWindowDestroy(widget: PGtkWidget; Data: Pointer); cdecl;
@ -64,6 +69,7 @@ begin
ddtBitmap: if Info^.Bitmap <> nil then gdk_pixmap_unref(Info^.Bitmap);
ddtPixmap: if Info^.Pixmap <> nil then gdk_pixmap_unref(Info^.Pixmap);
ddtPixbuf: if Info^.Pixbuf <> nil then gdk_pixbuf_unref(Info^.Pixbuf);
ddtImage: if Info^.Image <> nil then {$ifndef gtk1}gdk_image_unref(Info^.Image){$endif};
end;
Dispose(Info);
end;
@ -100,6 +106,10 @@ begin
if Info^.Pixbuf <> nil
then gdk_pixbuf_render_to_drawable_alpha(Info^.Pixbuf, widget^.window, 0, 0, 0, 0, Info^.Width, Info^.Height, GDK_PIXBUF_ALPHA_BILEVEL, $80, GDK_RGB_DITHER_NORMAL, 0, 0);
end;
ddtImage: begin
if Info^.Image <> nil
then gdk_draw_image(widget^.window, gc, Info^.Image, 0, 0, 0, 0, Info^.Width, Info^.Height);
end;
end;
gdk_gc_destroy(gc);
@ -123,7 +133,6 @@ begin
gtk_widget_show_all(window);
end;
procedure DbgDumpBitmap(ABitmap: PGdkBitmap; ATitle: String = ''; AWidth: Integer = -1; AHeight: Integer = -1);
var
Info: PDbgDumpInfo;
@ -221,4 +230,25 @@ begin
DbgCreateWindow(Info, ATitle);
end;
procedure DbgDumpImage(AImage: PGdkImage; ATitle: String; AWidth: Integer;
AHeight: Integer);
var
Info: PDbgDumpInfo;
begin
New(Info);
if AWidth = -1 then AWidth := AImage^.width;
if AHeight = -1 then AHeight := AImage^.height;
Info^.Width := AWidth;
Info^.Height := AHeight;
Info^.DumpType := ddtImage;
Info^.Image := AImage;
{$ifndef gtk1}
gdk_image_ref(AImage);
{$endif}
DbgCreateWindow(Info, ATitle);
end;
end.

7
lcl/interfaces/gtk/gtklclintf.inc
View File

@ -541,7 +541,12 @@ begin
ADesc.LineEnd := Desc.MaskLineEnd;
ADesc.BitsPerPixel := Desc.MaskBitsPerPixel;
ADesc.RedPrec := 1;
ADesc.RedShift := Desc.MaskShift
ADesc.RedShift := Desc.MaskShift;
// in theory only redshift is used, but if someone reads it as color thsi works too.
ADesc.GreenPrec := 1;
ADesc.GreenShift := Desc.MaskShift;
ADesc.BluePrec := 1;
ADesc.BlueShift := Desc.MaskShift;
end
(*
//TODO

26
lcl/interfaces/gtk/gtkproc.inc
View File

@ -1190,6 +1190,7 @@ begin
Warn('Result=nil');
Exit;
end;
//DbgDumpPixbuf(Result, 'Pixbuf from Source');
// Apply mask if present
if ASrcMask <> nil
@ -1395,6 +1396,7 @@ begin
end;
if (GdiImage = nil)
or (GdiImage^.GDIBitmapType <> gbPixmap)
or (GdiImage^.GDIPixmapObject.Mask = nil)
then begin
gdk_window_get_size(GdiMask^.GDIBitmapObject, @W, @H);
@ -1404,7 +1406,7 @@ begin
gdk_draw_pixmap(Result, GC, GdiMask^.GDIBitmapObject, 0, 0, 0, 0, -1, -1);
gdk_gc_unref(GC);
// DbgDumpBitmap(Result, 'CreateGdkMaskBitmap - Mask');
//DbgDumpBitmap(Result, 'CreateGdkMaskBitmap - Mask');
Exit;
end;
@ -5650,18 +5652,26 @@ end;
function CreatePixbufFromDrawable(ASource: PGdkDrawable; AColorMap:PGdkColormap; AIncludeAplha: Boolean; ASrcX, ASrcY, ADstX, ADstY, AWidth, AHeight: longint): PGdkPixbuf;
{$ifndef HasX}
const
CanRequestAlpha = True;
CanRequestAlpha: Boolean = True;
var
{$else}
var
CanRequestAlpha: Boolean;
{$endif}
PixBuf: PGdkPixBuf;
{$ifdef Windows}
Image: PGdkImage;
{$endif}
begin
{$ifdef HasX}
CanRequestAlpha := BitmapBitOrder(gdk_display) = LSBFirst;
{$endif}
// If Source is GdkBitmap then gdk_pixbuf_get_from_drawable will get
// pixbuf with 2 colors: transparent and white, but we need only Black and White.
// If we all alpha at the end then problem is gone.
CanRequestAlpha := CanRequestAlpha and (gdk_drawable_get_depth(ASource) > 1);
if CanRequestAlpha and AIncludeAplha
then Pixbuf := gdk_pixbuf_new(GDK_COLORSPACE_RGB, True, 8, AWidth, AHeight)
else Pixbuf := nil;
@ -5679,7 +5689,19 @@ begin
and (gdk_drawable_get_colormap(ASource) = nil)
then AColorMap := gdk_colormap_get_system;
{$endif}
{$ifdef Windows}
if gdk_drawable_get_depth(ASource) = 1 then
begin
// Fix gdk error in converter. For 1 bit Byte order is not significant
Image := gdk_drawable_get_image(ASource, ASrcX, ASrcY, AWidth, AHeight);
Image^.byte_order := GDK_MSB_FIRST;
Result := gdk_pixbuf_get_from_image(Pixbuf, Image, nil, ASrcX, ASrcY, ADstX, ADstY, AWidth, AHeight);
gdk_image_unref(Image);
end
else
{$endif}
Result := gdk_pixbuf_get_from_drawable(Pixbuf, ASource, AColorMap, ASrcX, ASrcY, ADstX, ADstY, AWidth, AHeight);
//DbgDumpPixbuf(Result, '');
if CanRequestAlpha then Exit; // we're done
if not AIncludeAplha then Exit;

118
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -1801,7 +1801,7 @@ function TGTKWidgetSet.CreateIconIndirect(IconInfo: PIconInfo): HICON;
Pixel, MaskPixel: LongWord;
offset: byte;
procedure SetColorAndMask(c: TGDKColor; MaskPixel: LongWord);
procedure SetColorAndMaskPixmap(c: TGdkColor; MaskPixel: LongWord);
var
c_bit, m_bit: byte;
begin
@ -1824,41 +1824,74 @@ function TGTKWidgetSet.CreateIconIndirect(IconInfo: PIconInfo): HICON;
offset := 0;
end;
end;
procedure SetColorAndMaskBitmap(ColorPixel, MaskPixel: LongWord);
begin
AImgBits^ := AImgBits^ or (ColorPixel shl offset);
AMskBits^ := AMskBits^ or (MaskPixel shl offset);
inc(offset);
if offset > 7 then
begin
inc(AImgBits);
inc(AMskBits);
offset := 0;
end;
end;
begin
// most of this code was taken from TGtkWidgetSet.DCGetPixel
Image := gdk_drawable_get_image(AImage, 0, 0, AWidth, AHeight);
MaskImage := gdk_drawable_get_image(AMask, 0, 0, AWidth, AHeight);
{$ifdef Gtk1}
// previously gdk_image_get_colormap(image) was used, implementation
// was casting GdkImage to GdkWindow which is not valid and cause AVs
if gdk_window_get_type(PGdkWindow(AImage))= GDK_WINDOW_PIXMAP then
colormap := nil // pixmaps are created with null colormap, get system one instead
else
colormap := gdk_window_get_colormap(PGdkWindow(AImage));
{$else}
colormap := gdk_image_get_colormap(image);
{$endif}
if colormap = nil then
colormap := gdk_colormap_get_system;
if AMask = nil
then MaskImage := nil
else MaskImage := gdk_drawable_get_image(AMask, 0, 0, AWidth, AHeight);
offset := 0;
for j := 0 to AHeight - 1 do
for i := 0 to AWidth - 1 do
begin
Pixel := gdk_image_get_pixel(Image, i, j);
MaskPixel := gdk_image_get_pixel(MaskImage, i, j);
FillChar(GDKColor,SizeOf(GDKColor), 0);
// does not work with TBitmap.Canvas
gdk_colormap_query_color(colormap, Pixel, @GDKColor);
SetColorAndMask(GDKColor, MaskPixel);
end;
if gdk_drawable_get_depth(AImage) = 1 then
begin
for j := 0 to AHeight - 1 do
for i := 0 to AWidth - 1 do
begin
Pixel := gdk_image_get_pixel(Image, i, j);
if MaskImage = nil
then MaskPixel := 1
else MaskPixel := gdk_image_get_pixel(MaskImage, i, j);
SetColorAndMaskBitmap(Pixel, MaskPixel);
end;
end
else
begin
{$ifdef Gtk1}
// previously gdk_image_get_colormap(image) was used, implementation
// was casting GdkImage to GdkWindow which is not valid and cause AVs
if gdk_window_get_type(PGdkWindow(AImage))= GDK_WINDOW_PIXMAP then
colormap := nil // pixmaps are created with null colormap, get system one instead
else
colormap := gdk_window_get_colormap(PGdkWindow(AImage));
{$else}
colormap := gdk_image_get_colormap(image);
{$endif}
if colormap = nil then
colormap := gdk_colormap_get_system;
for j := 0 to AHeight - 1 do
for i := 0 to AWidth - 1 do
begin
Pixel := gdk_image_get_pixel(Image, i, j);
if MaskImage = nil
then MaskPixel := 1
else MaskPixel := gdk_image_get_pixel(MaskImage, i, j);
FillChar(GDKColor,SizeOf(GDKColor), 0);
gdk_colormap_query_color(colormap, Pixel, @GDKColor);
SetColorAndMaskPixmap(GDKColor, MaskPixel);
end;
end;
gdk_image_unref(Image);
gdk_image_unref(MaskImage);
if MaskImage <> nil
then gdk_image_unref(MaskImage);
end;
var
@ -1871,23 +1904,23 @@ begin
Result := 0;
if not IsValidGDIObject(IconInfo^.hbmColor) then Exit;
{$IFDEF VerboseGtkToDos}{$note TODO: add support for mono cursors}{$ENDIF}
Img := PGDIObject(IconInfo^.hbmColor)^.GDIBitmapObject;
if (PGDIObject(IconInfo^.hbmColor)^.GDIBitmapType = gbPixmap) and
(PGDIObject(IconInfo^.hbmColor)^.GDIPixmapObject.Mask <> nil) then
Msk := PGDIObject(IconInfo^.hbmColor)^.GDIPixmapObject.Mask
else
Msk := PGDIObject(IconInfo^.hbmMask)^.GDIBitmapObject;
gdk_drawable_get_size(Img, @W, @H);
Msk := CreateGdkMaskBitmap(IconInfo^.hbmColor, IconInfo^.hbmMask);
//DbgDumpPixmap(Img, 'Image');
//DbgDumpPixmap(Msk, 'Mask');
if IconInfo^.fIcon then
begin
// Creating PixBuf from pixmap and mask
Result := HICON(PtrUInt(CreatePixbufFromImageAndMask(Img, 0, 0, W, H, nil, Msk)));
end
else
begin
try
if IconInfo^.fIcon then
begin
// Creating PixBuf from pixmap and mask
Result := HICON(PtrUInt(CreatePixbufFromImageAndMask(Img, 0, 0, W, H, nil, Msk)));
Exit;
end;
// Create cursor
bitlen := (W * H) shr 3;
SetLength(ImgBits, bitlen);
SetLength(MskBits, bitlen);
@ -1916,6 +1949,9 @@ begin
gdk_pixmap_unref(srcbitmap);
gdk_pixmap_unref(mskbitmap);
finally
if msk <> nil
then gdk_bitmap_unref(msk);
end;
end;

56
lcl/interfaces/gtk2/gtk2winapi.inc
View File

@ -250,11 +250,11 @@ end;
function TGtk2WidgetSet.CreateIconIndirect(IconInfo: PIconInfo): HICON;
var
pixmap: PGdkPixmap;
bitmap: PGdkBitmap;
pixmap: PGdkPixmap;
pixbuf: PGdkPixbuf;
Width, Height: integer;
MaxWidth, MaxHeight: guint;
pixbuf, masked_pixbuf: PGdkPixbuf;
{$ifdef Windows}
Old80807CW: Word;
@ -274,46 +274,42 @@ begin
if not IsValidGDIObject(IconInfo^.hbmColor) then Exit;
pixmap := PGDIObject(IconInfo^.hbmColor)^.GDIPixmapObject.Image;
bitmap := PGDIObject(IconInfo^.hbmColor)^.GDIPixmapObject.Mask;
//DbgDumpPixmap(pixmap, '');
gdk_drawable_get_size(pixmap, @Width, @Height);
gdk_display_get_maximal_cursor_size(gdk_display_get_default,
@MaxWidth, @MaxHeight);
if (Width > integer(MaxWidth)) or (Height > integer(MaxHeight)) then
exit;
// create alpha pixbuf
pixbuf := gdk_pixbuf_new(GDK_COLORSPACE_RGB, True, 8, Width, Height);
// fill pixbuf from pixmap
gdk_pixbuf_get_from_drawable(pixbuf, pixmap, nil, 0, 0, 0, 0, -1, -1);
masked_pixbuf := GdkPixbufAddBitmapMask(pixbuf, bitmap, 0);
if masked_pixbuf <> nil then
begin
// masked_pixuf is a new pixbuf created from pixbuf with applying mask
gdk_pixbuf_unref(pixbuf);
pixbuf := masked_pixbuf;
end;
if IconInfo^.fIcon then
Result := HICON(PtrUInt(pixbuf))
else
begin
if (Width > integer(MaxWidth))
or (Height > integer(MaxHeight)) then Exit;
bitmap := CreateGdkMaskBitmap(IconInfo^.hbmColor, IconInfo^.hbmMask);
try
pixbuf := CreatePixbufFromImageAndMask(pixmap, 0, 0, Width, Height, nil, Bitmap);
if IconInfo^.fIcon
then begin
Result := HICON(PtrUInt(pixbuf));
Exit;
end;
// create cursor from pixbuf
{$IFDEF Windows}
try
{$IFDEF Windows}
// we'll get 'division by zero' error in CMCheckColorsInGamut in other case
SetCW;
{$ENDIF}
Result := HCURSOR(PtrUInt(gdk_cursor_new_from_pixbuf(gdk_display_get_default, pixbuf,
IconInfo^.xHotSpot, IconInfo^.yHotSpot)));
{$ENDIF}
Result := HCURSOR(PtrUInt(gdk_cursor_new_from_pixbuf(gdk_display_get_default, pixbuf,
IconInfo^.xHotSpot, IconInfo^.yHotSpot)));
{$IFDEF Windows}
finally
{$IFDEF Windows}
ResetCW;
{$ENDIF}
end;
{$ENDIF}
finally
if bitmap <> nil
then gdk_bitmap_unref(bitmap);
end;
end;

22
lcl/intfgraphics.pas
View File

@ -5022,6 +5022,7 @@ end;
procedure TLazReaderIconDIB.InternalRead(Stream: TStream; Img: TFPCustomImage);
var
Desc: TRawImageDescription;
Row, Column: Integer;
NewColor: TFPColor;
BufPtr: PByte;
@ -5030,28 +5031,33 @@ begin
FImage := TheImage as TLazIntfImage;
InternalReadHead;
// force alpha description
CheckAlphaDescription(TheImage);
// Height field is doubled, to (sort of) accomodate mask
// MWE: it shoud be safer to verify the division agains the dirinfo.height
// anyway I haven't encountered an icon in the wild which doesn't have a mask
FBFI.biHeight := FBFI.biHeight div 2;
if FUpdateDescription
then begin
DefaultReaderDescription(FBFI.biWidth, FBFI.biHeight, FBFI.biBitCount, Desc);
// if FMaskMode = lrmmNone
// then Desc.MaskBitsPerPixel := 0;
FImage.DataDescription := Desc;
end
else Desc := FImage.DataDescription;
InternalReadBody; { Now read standard bitmap }
// Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header
// MWE: Correction, it seems that even 32bit icons can have a mask following
// if BFI.biBitCount >= 32 then Exit;
FReadSize := ((Img.Width + 31) div 32) shl 2;
SetupRead(2, Img.Width, False, False);
FReadSize := ((Desc.Width + 31) div 32) shl 2;
SetupRead(2, Desc.Width, False, False);
try
for Row := Img.Height - 1 downto 0 do
for Row := Desc.Height - 1 downto 0 do
begin
ReadScanLine(Row); // Scanline in LineBuf with Size ReadSize.
BufPtr := LineBuf;
MaskBit := $80;
for Column:=0 to FImage.Width - 1 do
for Column:=0 to Desc.Width - 1 do
begin
if BufPtr^ and MaskBit = 0
then begin
@ -5062,7 +5068,7 @@ begin
// transparent
FImage.Masked[Column, Row] := True;
// add alpha when source wasn't 32bit
if FBitsPerPixel <> 32
if (Desc.AlphaPrec <> 0) and (Desc.Depth < 32)
then begin
NewColor := FImage.Colors[Column, Row];
NewColor.Alpha := alphaTransparent;