paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-06 21:18:01 +02:00
Code Issues Packages Projects Releases Wiki Activity

added uninstall popupmenuitem to package graph explorer

Browse Source 
git-svn-id: trunk@5212 -
This commit is contained in:
mattias 2004-02-21 01:01:04 +00:00
parent 6a9c435997
commit f1c507bc10
10 changed files with 1453 additions and 1361 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2575
components/codetools/memcheck.pas
View File

File diff suppressed because it is too large Load Diff

7
lcl/extctrls.pp
View File

@ -495,9 +495,9 @@ type
public
Property Align;
property AutoSize;
property Center : Boolean read FCenter write SetCenter;
property Center: Boolean read FCenter write SetCenter;
property Constraints;
property Picture : TPicture read FPicture write SetPicture;
property Picture: TPicture read FPicture write SetPicture;
property Visible;
property OnClick;
property OnMouseDown;
@ -925,6 +925,9 @@ end.
{
$Log$
Revision 1.97 2004/02/21 01:01:03 mattias
added uninstall popupmenuitem to package graph explorer
Revision 1.96 2004/02/10 10:13:08 mattias
added diamonds to TShape

5
lcl/graphics.pp
View File

@ -982,7 +982,7 @@ type
procedure HandleNeeded;
procedure MaskHandleNeeded;
procedure PaletteNeeded;
procedure UnshareImage;
procedure UnshareImage(CopyContent: boolean);
procedure FreeSaveStream;
procedure ReadData(Stream: TStream); override;
procedure SetWidthHeight(NewWidth, NewHeight: integer); virtual;
@ -1449,6 +1449,9 @@ end.
{ =============================================================================
$Log$
Revision 1.116 2004/02/21 01:01:03 mattias
added uninstall popupmenuitem to package graph explorer
Revision 1.115 2004/02/19 05:07:16 mattias
CreateBitmapFromRawImage now creates mask only if needed

27
lcl/graphtype.pp
View File

@ -200,8 +200,12 @@ begin
// quick test
if (RawImage^.Mask=nil) or (RawImage^.MaskSize=0)
or (RawImage^.Description.Width=0) or (RawImage^.Description.Height=0)
or (RawImage^.Description.AlphaPrec=0) then
or (RawImage^.Description.AlphaPrec=0) then begin
{$IFDEF VerboseRawImage}
writeln('RawImageMaskIsEmpty Quicktest: empty');
{$ENDIF}
exit;
end;
Result:=false;
// slow test
@ -225,7 +229,9 @@ begin
for x:=0 to UsedBytesPerLine-1 do begin
if p^<>$ff then begin
// not all bits set -> transparent pixels found -> Mask needed
//writeln('RawImageMaskIsEmpty y=',y,' x=',x,' ',HexStr(Cardinal(p^),2));
{$IFDEF VerboseRawImage}
writeln('RawImageMaskIsEmpty FullByte y=',y,' x=',x,' Byte=',HexStr(Cardinal(p^),2));
{$ENDIF}
exit;
end;
inc(p);
@ -234,7 +240,9 @@ begin
if UnusedBitsAtEnd>0 then begin
if (p^ or UnusedByteMask)<>$ff then begin
// not all bits set -> transparent pixels found -> Mask needed
//writeln('RawImageMaskIsEmpty y=',y,' x=',x,' ',HexStr(Cardinal(p^),2),' ',HexStr(Cardinal(UnusedByteMask),8));
{$IFDEF VerboseRawImage}
writeln('RawImageMaskIsEmpty EdgeByte y=',y,' x=',x,' Byte=',HexStr(Cardinal(p^),2),' UnusedByteMask=',HexStr(Cardinal(UnusedByteMask),8));
{$ENDIF}
exit;
end;
inc(p);
@ -242,15 +250,23 @@ begin
end;
end else begin
// ToDo: AlphaSeparate and rileTight
{$IFDEF VerboseRawImage}
writeln('RawImageMaskIsEmpty TODO');
{$ENDIF}
exit;
end;
end else begin
// ToDo: Alpha not Separate
{$IFDEF VerboseRawImage}
writeln('RawImageMaskIsEmpty TODO');
{$ENDIF}
exit;
end;
// no pixel is transparent
Result:=true;
end;
{$IFDEF VerboseRawImage}
writeln('RawImageMaskIsEmpty Empty=',Result);
{$ENDIF}
end;
function RawImageDescriptionAsString(Desc: PRawImageDescription): string;
@ -513,6 +529,9 @@ end.
{ =============================================================================
$Log$
Revision 1.26 2004/02/21 01:01:03 mattias
added uninstall popupmenuitem to package graph explorer
Revision 1.25 2004/02/19 05:07:16 mattias
CreateBitmapFromRawImage now creates mask only if needed

33
lcl/include/bitmap.inc
View File

@ -73,7 +73,10 @@ begin
SrcFPImage:=TFPCustomImage(Source);
IntfImage:=TLazIntfImage.Create(0,0);
try
IntfImage.GetDescriptionFromBitmap(Handle);
if HandleAllocated then
IntfImage.GetDescriptionFromBitmap(Handle)
else
IntfImage.GetDescriptionFromDevice(0);
IntfImage.Assign(SrcFPImage);
IntfImage.CreateBitmap(ImgHandle,ImgMaskHandle,false);
Handle:=ImgHandle;
@ -229,7 +232,7 @@ procedure TBitmap.Changing(Sender: TObject);
// -> make sure the handle is unshared (otherwise the modifications will also
// modify all copies)
begin
UnshareImage;
UnshareImage(true);
FImage.FDIB.dsbmih.biClrUsed := 0;
FImage.FDIB.dsbmih.biClrImportant := 0;
FreeSaveStream;
@ -366,7 +369,7 @@ begin
// ToDo
end;
procedure TBitmap.UnshareImage;
procedure TBitmap.UnshareImage(CopyContent: boolean);
var
NewImage: TBitmapImage;
OldImage: TBitmapImage;
@ -380,7 +383,8 @@ begin
NewImage:=TBitmapImage.Create;
try
NewImage.Reference;
if FImage.HandleAllocated and (Width>0) and (Height>0) then begin
if CopyContent and FImage.HandleAllocated
and (Width>0) and (Height>0) then begin
// copy content
{$IFNDEF DisableFPImage}
IntfImage:=TLazIntfImage.Create(0,0);
@ -569,7 +573,7 @@ var
end;
begin
UnshareImage;
UnshareImage(false);
if Size = 0 then begin
CreateEmptyBitmap;
@ -807,7 +811,7 @@ var
ImgHandle, ImgMaskHandle: HBitmap;
NewSaveStream: TMemoryStream;
begin
UnshareImage;
UnshareImage(false);
if Size = 0 then begin
Width:=0;
Height:=0;
@ -927,14 +931,12 @@ end;
procedure TBitmap.SetHandle(Value: HBITMAP);
begin
if FImage.FHandle = Value then exit;
if FImage.FHandle<>0 then begin
// free old handles
FreeCanvasContext;
UnshareImage;
end;
// TODO: get the properties from new bitmap
// free old handles
FreeCanvasContext;
UnshareImage(false);
with FImage do begin
FreeHandle;
// get the properties from new bitmap
FHandle:=Value;
FillChar(FDIB, SizeOf(FDIB), 0);
if FHandle <> 0 then
@ -956,10 +958,10 @@ begin
end;
end;
// creates handle and remove all references to give up ownership
// release handles without freeing them
Function TBitmap.ReleaseHandle: HBITMAP;
Begin
HandleNeeded;
//HandleNeeded; Delphi creates a handle. Why?
FreeCanvasContext;
Result := FImage.ReleaseHandle;
end;
@ -1064,6 +1066,9 @@ end;
{ =============================================================================
$Log$
Revision 1.69 2004/02/21 01:01:03 mattias
added uninstall popupmenuitem to package graph explorer
Revision 1.68 2004/02/19 05:07:16 mattias
CreateBitmapFromRawImage now creates mask only if needed

2
lcl/include/sharedimage.inc
View File

@ -25,6 +25,8 @@ procedure TSharedImage.Release;
begin
if Pointer(Self) <> nil then begin
Dec(FRefCount);
if FRefCount<0 then
RaiseGDBException('');
if FRefCount = 0 then begin
FreeHandle;
Free;

52
lcl/interfaces/gtk/gtkobject.inc
View File

@ -2009,7 +2009,7 @@ var
begin
Result := false;
if Desc=nil then begin
RaiseGDBException('TgtkObject.GetWindowDeviceRawImageDescription');
RaiseGDBException('TgtkObject.GetWindowRawImageDescription');
exit;
end;
@ -2037,7 +2037,7 @@ begin
GDK_VISUAL_TRUE_COLOR: Desc^.Format:=ricfRGBA;
GDK_VISUAL_DIRECT_COLOR: Desc^.Format:=ricfRGBA;
else
writeln('TgtkObject.GetDeviceRawImageDescription unknown Visual type ',
writeln('TgtkObject.GetWindowRawImageDescription unknown Visual type ',
integer(Visual^.thetype));
exit;
end;
@ -2097,7 +2097,7 @@ begin
Desc^.AlphaByteOrder:=riboLSBFirst;
{$IFDEF VerboseRawImage}
writeln('TgtkObject.GetDeviceRawImageDescription A ',RawImageDescriptionAsString(Desc));
writeln('TgtkObject.GetWindowRawImageDescription A ',RawImageDescriptionAsString(Desc));
{$ENDIF}
Result:=true;
@ -2110,10 +2110,6 @@ var
MaxRect: TRect;
SourceRect: TRect;
AnImage: PGdkImage;
{y: Integer;
x: Integer;
AColor: guint;
i: Integer;}
begin
Result:=false;
FillChar(NewRawImage,SizeOf(NewRawImage),0);
@ -2148,11 +2144,9 @@ begin
then exit;
// get gdk_image
BeginGDKErrorTrap;
AnImage:=gdk_image_get(GDKWindow,SourceRect.Left,SourceRect.Top,
NewRawImage.Description.Width,
NewRawImage.Description.Height);
EndGDKErrorTrap;
if AnImage=nil then begin
writeln('WARNING: TgtkObject.GetRawImageFromGdkWindow gdk_image_get failed');
exit;
@ -2165,21 +2159,18 @@ begin
RaiseGDBException('NewRawImage.Description.BitsPerPixel<>AnImage^.bpp');
NewRawImage.DataSize:=(NewRawImage.Description.BitsPerPixel shr 3)
*AnImage^.Width*AnImage^.Height;
* AnImage^.Width * AnImage^.Height;
{$IFDEF VerboseRawImage}
writeln('TgtkObject.GetRawImageFromGdkWindow G Width=',AnImage^.Width,' Height=',AnImage^.Height,' BitsPerPixel=',NewRawImage.Description.BitsPerPixel,' bpl=',AnImage^.bpl);
{$ENDIF}
if NewRawImage.DataSize<>cardinal(AnImage^.bpl)*AnImage^.Height then
if NewRawImage.DataSize<>cardinal(AnImage^.bpl) * AnImage^.Height then
RaiseGDBException('NewRawImage.DataSize<>AnImage^.bpl*AnImage^.Height');
// copy data
NewRawImage.Description.Width:=AnImage^.Width;
NewRawImage.Description.Height:=AnImage^.Height;
{NewRawImage.Description.BitsPerPixel:=SizeOf(GUInt)*8;
NewRawImage.DataSize:=AnImage^.Width*AnImage^.Height*SizeOf(GUInt);
ReAllocMem(NewRawImage.Data,NewRawImage.DataSize);
i:=0;
{ i:=0;
for y:=0 to AnImage^.Height-1 do begin
for x:=0 to AnImage^.Width-1 do begin
AColor:=gdk_image_get_pixel(AnImage,x,y);
@ -2201,11 +2192,7 @@ begin
' DataSize=',NewRawImage.DataSize);
{$ENDIF}
finally
begin
BeginGDKErrorTrap;
gdk_image_destroy(AnImage);
EndGDKErrorTrap;
end;
gdk_image_destroy(AnImage);
end;
Result:=true;
@ -2225,20 +2212,21 @@ end;
Returns: True if succesful
The StretchBlt function copies a bitmap from a source rectangle into a
destination rectangle using the specified raster operation. If needed it
destination rectangle using the specified raster operation. If needed, it
resizes the bitmap to fit the dimensions of the destination rectangle.
Sizing is done according to the stretching mode currently set in the
destination device context.
If SrcDC contains a mask the pixmap will be copied with this transparency.
ToDo: Mirroring, extended NonDrawable support (Image, Bitmap, etc)
ToDo:
Mirroring
Extended NonDrawable support (Image, Bitmap, etc)
Scale mask
------------------------------------------------------------------------------}
function TgtkObject.StretchCopyArea(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer;
Mask: HBITMAP; XMask, YMask: Integer;
Rop: Cardinal): Boolean;
//type
// TBltFunction = function: Boolean;
var
fGC: PGDKGC;
SrcDevContext, DestDevContext: TDeviceContext;
@ -7447,10 +7435,11 @@ var
Y: Integer;
DCOrigin: TPoint;
MaxX, MaxY: integer;
Pixel: LongWord;
begin
TLMSetGetPixel(data^).PixColor := clNone;
aDC := TDeviceContext(TCanvas(Sender).Handle);
aDC := TDeviceContext((Sender as TCanvas).Handle);
if (aDC = nil) or (aDC.Drawable = nil) then exit;
X:=TLMSetGetPixel(data^).X;
@ -7459,7 +7448,6 @@ begin
inc(X,DCOrigin.X);
inc(Y,DCOrigin.Y);
BeginGDKErrorTrap;
gdk_drawable_get_size(aDC.Drawable, @MaxX, @MaxY);
if (X<0) or (Y<0) or (X>=MaxX) or (Y>=MaxY) then exit;
@ -7474,12 +7462,13 @@ begin
if colormap = nil then
colormap := gdk_colormap_get_system;
gdk_colormap_query_color(colormap, gdk_image_get_pixel(Image,0,0), @GDKColor);
Pixel:=gdk_image_get_pixel(Image,0,0);
FillChar(GDKColor,SizeOf(GDKColor),0);
// does not work with TBitmap.Canvas
gdk_colormap_query_color(colormap, Pixel, @GDKColor);
gdk_image_unref(Image);
EndGDKErrorTrap;
TLMSetGetPixel(data^).PixColor := TGDKColorToTColor(GDKColor);
end;
@ -9201,6 +9190,9 @@ end;
{ =============================================================================
$Log$
Revision 1.469 2004/02/21 01:01:03 mattias
added uninstall popupmenuitem to package graph explorer
Revision 1.468 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing

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

@ -4726,7 +4726,7 @@ begin
exit;
end;
{$IFDEF VerboseRawImage}
writeln('WARNING: [TgtkObject.GetRawImageFromBitmap] A GdkPixmap=',HexStr(Cardinal(GdkPixmap),8));
writeln('TgtkObject.GetRawImageFromBitmap A GdkPixmap=',HexStr(Cardinal(GdkPixmap),8),' SrcMaskBitmap=',HexStr(Cardinal(SrcMaskBitmap),8));
{$ENDIF}
if not GetRawImageFromGdkWindow(PGdkWindow(GdkPixmap),SrcRect,NewRawImage)
then exit;
@ -4746,32 +4746,37 @@ begin
writeln('WARNING: [TgtkObject.GetRawImageFromBitmap] invalid MaskBitmap');
exit;
end;
if not GetRawImageFromGdkWindow(PGdkWindow(GdkMaskBitmap),SrcRect,
MaskRawImage)
then exit;
{$IFDEF VerboseRawImage}
writeln('TgtkObject.GetRawImageFromBitmap GdkMaskBitmap=',HexStr(Cardinal(GdkMaskBitmap),8));
{$ENDIF}
if GdkMaskBitmap<>nil then begin
if not GetRawImageFromGdkWindow(PGdkWindow(GdkMaskBitmap),SrcRect,
MaskRawImage)
then exit;
// check if mask is compatible
if (MaskRawImage.Description.Width<>NewRawImage.Description.Width)
or (MaskRawImage.Description.Height<>NewRawImage.Description.Height) then begin
writeln('WARNING: [TgtkObject.GetRawImageFromBitmap] MaskBitmap has different Size than Bitmap');
exit;
end;
if (MaskRawImage.Description.Depth<>1) then begin
writeln('WARNING: [TgtkObject.GetRawImageFromBitmap] MaskBitmap Depth<>1');
exit;
end;
if (MaskRawImage.Description.HasPalette) then begin
writeln('WARNING: [TgtkObject.GetRawImageFromBitmap] MaskBitmap HasPalette');
exit;
end;
// check if mask is compatible
if (MaskRawImage.Description.Width<>NewRawImage.Description.Width)
or (MaskRawImage.Description.Height<>NewRawImage.Description.Height) then begin
writeln('WARNING: [TgtkObject.GetRawImageFromBitmap] MaskBitmap has different Size than Bitmap');
exit;
end;
if (MaskRawImage.Description.Depth<>1) then begin
writeln('WARNING: [TgtkObject.GetRawImageFromBitmap] MaskBitmap Depth<>1');
exit;
end;
if (MaskRawImage.Description.HasPalette) then begin
writeln('WARNING: [TgtkObject.GetRawImageFromBitmap] MaskBitmap HasPalette');
exit;
end;
// merge mask
if NewRawImage.Mask<>nil then FreeMem(NewRawImage.Mask);
NewRawImage.Mask:=MaskRawImage.Data;
NewRawImage.MaskSize:=MaskRawImage.DataSize;
NewRawImage.Description.AlphaSeparate:=true;
NewRawImage.Description.AlphaPrec:=MaskRawImage.Description.Depth;
NewRawImage.Description.AlphaShift:=0;
// merge mask
if NewRawImage.Mask<>nil then FreeMem(NewRawImage.Mask);
NewRawImage.Mask:=MaskRawImage.Data;
NewRawImage.MaskSize:=MaskRawImage.DataSize;
NewRawImage.Description.AlphaSeparate:=true;
NewRawImage.Description.AlphaPrec:=MaskRawImage.Description.Depth;
NewRawImage.Description.AlphaShift:=0;
end;
Result:=true;
finally
@ -8740,6 +8745,9 @@ end;
{ =============================================================================
$Log$
Revision 1.332 2004/02/21 01:01:03 mattias
added uninstall popupmenuitem to package graph explorer
Revision 1.331 2004/02/19 05:07:17 mattias
CreateBitmapFromRawImage now creates mask only if needed

46
packager/pkggraphexplorer.pas
View File

@ -51,14 +51,19 @@ type
PkgListLabel: TLabel;
PkgListBox: TListBox;
InfoMemo: TMemo;
PkgPopupMenu: TPopupMenu;
UninstallMenuItem: TMenuItem;
procedure PkgGraphExplorerResize(Sender: TObject);
procedure PkgGraphExplorerShow(Sender: TObject);
procedure PkgListBoxClick(Sender: TObject);
procedure PkgPopupMenuPopup(Sender: TObject);
procedure PkgTreeViewDblClick(Sender: TObject);
procedure PkgTreeViewExpanding(Sender: TObject; Node: TTreeNode;
var AllowExpansion: Boolean);
procedure PkgTreeViewSelectionChanged(Sender: TObject);
procedure UninstallMenuItemClick(Sender: TObject);
private
FOnUninstallPackage: TOnUninstallPackage;
ImgIndexPackage: integer;
ImgIndexInstallPackage: integer;
ImgIndexInstalledPackage: integer;
@ -94,6 +99,8 @@ type
procedure ShowPath(PathList: TList);
public
property OnOpenPackage: TOnOpenPackage read FOnOpenPackage write FOnOpenPackage;
property OnUninstallPackage: TOnUninstallPackage read FOnUninstallPackage
write FOnUninstallPackage;
end;
var
@ -155,6 +162,18 @@ begin
end;
end;
procedure TPkgGraphExplorer.PkgPopupMenuPopup(Sender: TObject);
var
Pkg: TLazPackage;
Dependency: TPkgDependency;
begin
GetDependency(PkgTreeView.Selected,Pkg,Dependency);
UninstallMenuItem.Visible:=(Pkg<>nil) and (Pkg.AutoInstall<>pitNope);
writeln('TPkgGraphExplorer.PkgPopupMenuPopup ',UninstallMenuItem.Visible);
if UninstallMenuItem.Visible then
UninstallMenuItem.Caption:='Uninstall package '+Pkg.IDAsString;
end;
procedure TPkgGraphExplorer.PkgTreeViewDblClick(Sender: TObject);
var
Pkg: TLazPackage;
@ -231,6 +250,17 @@ begin
UpdateList;
end;
procedure TPkgGraphExplorer.UninstallMenuItemClick(Sender: TObject);
var
Pkg: TLazPackage;
Dependency: TPkgDependency;
begin
GetDependency(PkgTreeView.Selected,Pkg,Dependency);
if Pkg<>nil then begin
if Assigned(OnUninstallPackage) then OnUninstallPackage(Self,Pkg);
end;
end;
procedure TPkgGraphExplorer.SetupComponents;
procedure AddResImg(const ResName: string);
@ -261,6 +291,21 @@ begin
ImgIndexMissingPackage:=Count;
AddResImg('pkg_conflict');
end;
// popupmenu
PkgPopupMenu:=TPopupMenu.Create(Self);
with PkgPopupMenu do begin
Name:='PkgPopupMenu';
OnPopup:=@PkgPopupMenuPopup;
end;
UninstallMenuItem:=TMenuItem.Create(Self);
with UninstallMenuItem do begin
Name:='UninstallMenuItem';
OnClick:=@UninstallMenuItemClick;
end;
PkgPopupMenu.Items.Add(UninstallMenuItem);
PkgTreeLabel:=TLabel.Create(Self);
with PkgTreeLabel do begin
@ -275,6 +320,7 @@ begin
Parent:=Self;
Options:=Options+[tvoRightClickSelect];
Images:=Self.ImageList;
PopupMenu:=PkgPopupMenu;
OnExpanding:=@PkgTreeViewExpanding;
OnSelectionChanged:=@PkgTreeViewSelectionChanged;
OnDblClick:=@PkgTreeViewDblClick;

9
packager/pkgmanager.pas
View File

@ -87,6 +87,8 @@ type
// package graph
function PackageGraphExplorerOpenPackage(Sender: TObject;
APackage: TLazPackage): TModalResult;
function PackageGraphExplorerUninstallPackage(Sender: TObject;
APackage: TLazPackage): TModalResult;
procedure PackageGraphAddPackage(Pkg: TLazPackage);
procedure PackageGraphBeginUpdate(Sender: TObject);
procedure PackageGraphChangePackageName(APackage: TLazPackage;
@ -497,6 +499,12 @@ begin
Filename:=CodeToolBoss.DefineTree.FindUnitInUnitLinks(UnitName,Directory,true);
end;
function TPkgManager.PackageGraphExplorerUninstallPackage(Sender: TObject;
APackage: TLazPackage): TModalResult;
begin
Result:=DoUninstallPackage(APackage);
end;
procedure TPkgManager.mnuConfigCustomCompsClicked(Sender: TObject);
begin
ShowConfigureCustomComponents;
@ -1927,6 +1935,7 @@ begin
if PackageGraphExplorer=nil then begin
PackageGraphExplorer:=TPkgGraphExplorer.Create(Application);
PackageGraphExplorer.OnOpenPackage:=@PackageGraphExplorerOpenPackage;
PackageGraphExplorer.OnUninstallPackage:=@PackageGraphExplorerUninstallPackage;
end;
PackageGraphExplorer.ShowOnTop;
Result:=mrOk;