paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-10 03:48:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

TButtonGlyph now uses shared bitmaps, improved debugging mem leaks

Browse Source 
git-svn-id: trunk@9629 -
This commit is contained in:
mattias 2006-07-18 17:20:34 +00:00
parent 88558ed640
commit b17384ebc1
15 changed files with 231 additions and 338 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

188
examples/multithreading/waitforexample1.lpi
View File

@ -4,13 +4,13 @@
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
@ -25,16 +25,11 @@
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="8">
<Units Count="2">
<Unit0>
<Filename Value="waitforexample1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="WaitForExample1"/>
<CursorPos X="8" Y="14"/>
<TopLine Value="1"/>
<EditorIndex Value="1"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="waitforunit1.pas"/>
@ -42,185 +37,8 @@
<IsPartOfProject Value="True"/>
<ResourceFilename Value="waitforunit1.lrs"/>
<UnitName Value="WaitForUnit1"/>
<CursorPos X="20" Y="32"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="mainunit.pas"/>
<UnitName Value="MainUnit"/>
<CursorPos X="1" Y="27"/>
<TopLine Value="1"/>
<EditorIndex Value="7"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="../../../freepascal/fpc/fcl/inc/custapp.pp"/>
<UnitName Value="CustApp"/>
<CursorPos X="14" Y="69"/>
<TopLine Value="47"/>
<EditorIndex Value="6"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="../../../freepascal/fpc/rtl/objpas/classes/classesh.inc"/>
<CursorPos X="18" Y="1220"/>
<TopLine Value="1196"/>
<EditorIndex Value="3"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="../../../freepascal/fpc/rtl/objpas/classes/classes.inc"/>
<CursorPos X="1" Y="103"/>
<TopLine Value="75"/>
<EditorIndex Value="5"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit5>
<Unit6>
<Filename Value="../../../freepascal/fpc/rtl/inc/threadh.inc"/>
<CursorPos X="59" Y="136"/>
<TopLine Value="110"/>
<EditorIndex Value="2"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit6>
<Unit7>
<Filename Value="../../../freepascal/fpc/rtl/linux/tthread.inc"/>
<CursorPos X="3" Y="292"/>
<TopLine Value="290"/>
<EditorIndex Value="4"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit7>
</Units>
<JumpHistory Count="30" HistoryIndex="29">
<Position1>
<Filename Value="waitforunit1.pas"/>
<Caret Line="158" Column="1" TopLine="122"/>
</Position1>
<Position2>
<Filename Value="waitforunit1.pas"/>
<Caret Line="112" Column="11" TopLine="90"/>
</Position2>
<Position3>
<Filename Value="waitforunit1.pas"/>
<Caret Line="102" Column="1" TopLine="90"/>
</Position3>
<Position4>
<Filename Value="waitforunit1.pas"/>
<Caret Line="145" Column="1" TopLine="109"/>
</Position4>
<Position5>
<Filename Value="waitforunit1.pas"/>
<Caret Line="45" Column="1" TopLine="45"/>
</Position5>
<Position6>
<Filename Value="waitforunit1.pas"/>
<Caret Line="145" Column="19" TopLine="109"/>
</Position6>
<Position7>
<Filename Value="waitforunit1.pas"/>
<Caret Line="72" Column="1" TopLine="50"/>
</Position7>
<Position8>
<Filename Value="waitforunit1.pas"/>
<Caret Line="144" Column="22" TopLine="108"/>
</Position8>
<Position9>
<Filename Value="waitforunit1.pas"/>
<Caret Line="110" Column="5" TopLine="56"/>
</Position9>
<Position10>
<Filename Value="waitforunit1.pas"/>
<Caret Line="105" Column="15" TopLine="102"/>
</Position10>
<Position11>
<Filename Value="waitforunit1.pas"/>
<Caret Line="76" Column="1" TopLine="54"/>
</Position11>
<Position12>
<Filename Value="waitforunit1.pas"/>
<Caret Line="114" Column="8" TopLine="96"/>
</Position12>
<Position13>
<Filename Value="waitforunit1.pas"/>
<Caret Line="115" Column="5" TopLine="93"/>
</Position13>
<Position14>
<Filename Value="waitforunit1.pas"/>
<Caret Line="53" Column="25" TopLine="26"/>
</Position14>
<Position15>
<Filename Value="waitforunit1.pas"/>
<Caret Line="45" Column="25" TopLine="23"/>
</Position15>
<Position16>
<Filename Value="waitforunit1.pas"/>
<Caret Line="118" Column="62" TopLine="96"/>
</Position16>
<Position17>
<Filename Value="waitforunit1.pas"/>
<Caret Line="133" Column="7" TopLine="111"/>
</Position17>
<Position18>
<Filename Value="waitforunit1.pas"/>
<Caret Line="40" Column="36" TopLine="18"/>
</Position18>
<Position19>
<Filename Value="waitforunit1.pas"/>
<Caret Line="66" Column="15" TopLine="35"/>
</Position19>
<Position20>
<Filename Value="waitforunit1.pas"/>
<Caret Line="133" Column="1" TopLine="101"/>
</Position20>
<Position21>
<Filename Value="waitforunit1.pas"/>
<Caret Line="21" Column="1" TopLine="1"/>
</Position21>
<Position22>
<Filename Value="waitforunit1.pas"/>
<Caret Line="149" Column="11" TopLine="116"/>
</Position22>
<Position23>
<Filename Value="waitforunit1.pas"/>
<Caret Line="71" Column="12" TopLine="49"/>
</Position23>
<Position24>
<Filename Value="waitforunit1.pas"/>
<Caret Line="103" Column="38" TopLine="81"/>
</Position24>
<Position25>
<Filename Value="waitforunit1.pas"/>
<Caret Line="102" Column="1" TopLine="81"/>
</Position25>
<Position26>
<Filename Value="waitforunit1.pas"/>
<Caret Line="148" Column="11" TopLine="115"/>
</Position26>
<Position27>
<Filename Value="waitforunit1.pas"/>
<Caret Line="129" Column="5" TopLine="114"/>
</Position27>
<Position28>
<Filename Value="waitforunit1.pas"/>
<Caret Line="150" Column="1" TopLine="114"/>
</Position28>
<Position29>
<Filename Value="waitforunit1.pas"/>
<Caret Line="147" Column="1" TopLine="116"/>
</Position29>
<Position30>
<Filename Value="waitforunit1.pas"/>
<Caret Line="152" Column="3" TopLine="118"/>
</Position30>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>

177
ide/componentpalette.pas
View File

@ -451,99 +451,104 @@ begin
exit;
end;
//writeln('TComponentPalette.UpdateNoteBookButtons A');
// lock
fUpdatingNotebook:=true;
OldActivePage:=FNoteBook.ActivePage;
// remove every page in the notebook without a visible page
for i:=FNoteBook.PageCount-1 downto 0 do begin
PageIndex:=IndexOfPageComponent(FNoteBook.Page[i]);
if (PageIndex<0) or (not Pages[PageIndex].Visible) then begin
if PageIndex>=0 then
Pages[i].PageComponent:=nil;
FNoteBook.Pages.Delete(i);
end;
end;
// insert a notebook page for every visible palette page
PageIndex:=0;
for i:=0 to Count-1 do begin
if not Pages[i].Visible then continue;
if Pages[i].PageComponent=nil then begin
// insert a new notebook page
FNoteBook.Pages.Insert(PageIndex,Pages[i].PageName);
Pages[i].PageComponent:=FNoteBook.Page[PageIndex];
end else begin
// move to the right position
CurPageIndex:=TPage(Pages[i].PageComponent).PageIndex;
if CurPageIndex<>PageIndex then
FNoteBook.Pages.Move(CurPageIndex,PageIndex);
end;
inc(PageIndex);
end;
// create a speedbutton for every visible component
for i:=0 to Count-1 do begin
CurPage:=Pages[i];
if not CurPage.Visible then continue;
CurNoteBookPage:=TPage(CurPage.PageComponent);
if not (CurNoteBookPage is TPage) then RaiseException('CurNoteBookPage');
ButtonX:=0;
// create selection button
if CurPage.SelectButton=nil then begin
CurBtn:=TSpeedButton.Create(nil);
CurPage.SelectButton:=CurBtn;
with CurBtn do begin
Name:='PaletteSelectBtn'+IntToStr(i);
Parent:=CurNoteBookPage;
OnClick := @SelectionToolClick;
Glyph.LoadFromLazarusResource('tmouse');
Flat := True;
GroupIndex:= 1;
Down := True;
Hint := lisSelectionTool;
SetBounds(ButtonX,0,ComponentPaletteBtnWidth,ComponentPaletteBtnHeight);
FNoteBook.DisableAlign;
try
OldActivePage:=FNoteBook.ActivePage;
// remove every page in the notebook without a visible page
for i:=FNoteBook.PageCount-1 downto 0 do begin
PageIndex:=IndexOfPageComponent(FNoteBook.Page[i]);
if (PageIndex<0) or (not Pages[PageIndex].Visible) then begin
if PageIndex>=0 then
Pages[i].PageComponent:=nil;
FNoteBook.Pages.Delete(i);
end;
end;
inc(ButtonX,((ComponentPaletteBtnWidth*3) div 2)+2);
// create component buttons
for j:=0 to CurPage.Count-1 do begin
CurComponent:=TPkgComponent(CurPage[j]);
if CurComponent.Visible then begin
if CurComponent.Button=nil then begin
CurBtn:=TSpeedButton.Create(nil);
CurComponent.Button:=CurBtn;
CreatePopupMenu;
with CurBtn do begin
Name:='PaletteBtnPage'+IntToStr(i)+'_'+IntToStr(j)
+'_'+CurComponent.ComponentClass.ClassName;
Parent := CurNoteBookPage;
SetBounds(ButtonX,0,ComponentPaletteBtnWidth,ComponentPaletteBtnHeight);
Glyph := CurComponent.GetIconCopy;
GroupIndex := 1;
Flat := true;
OnClick := @ComponentBtnClick;
OnDblClick := @ComponentBtnDblClick;
Hint := CurComponent.ComponentClass.ClassName;
CurBtn.PopupMenu:=Self.PopupMenu;
Visible:=true;
end;
//writeln('TComponentPalette.UpdateNoteBookButtons Created Button: ',CurComponent.ComponentClass.ClassName,' ',CurComponent.Button.Name);
// insert a notebook page for every visible palette page
PageIndex:=0;
for i:=0 to Count-1 do begin
if not Pages[i].Visible then continue;
if Pages[i].PageComponent=nil then begin
// insert a new notebook page
FNoteBook.Pages.Insert(PageIndex,Pages[i].PageName);
Pages[i].PageComponent:=FNoteBook.Page[PageIndex];
end else begin
// move to the right position
CurPageIndex:=TPage(Pages[i].PageComponent).PageIndex;
if CurPageIndex<>PageIndex then
FNoteBook.Pages.Move(CurPageIndex,PageIndex);
end;
inc(PageIndex);
end;
// create a speedbutton for every visible component
for i:=0 to Count-1 do begin
CurPage:=Pages[i];
if not CurPage.Visible then continue;
CurNoteBookPage:=TPage(CurPage.PageComponent);
if not (CurNoteBookPage is TPage) then RaiseException('CurNoteBookPage');
ButtonX:=0;
// create selection button
if CurPage.SelectButton=nil then begin
CurBtn:=TSpeedButton.Create(nil);
CurPage.SelectButton:=CurBtn;
with CurBtn do begin
Name:='PaletteSelectBtn'+IntToStr(i);
OnClick := @SelectionToolClick;
Glyph.LoadFromLazarusResource('tmouse');
Flat := True;
GroupIndex:= 1;
Down := True;
Hint := lisSelectionTool;
SetBounds(ButtonX,0,ComponentPaletteBtnWidth,ComponentPaletteBtnHeight);
Parent:=CurNoteBookPage;
end;
end else if CurComponent.Button<>nil then begin
//writeln('TComponentPalette.UpdateNoteBookButtons Destroy Button: ',CurComponent.ComponentClass.ClassName,' ',CurComponent.Button.Name);
CurComponent.Button.Free;
CurComponent.Button:=nil;
end;
inc(ButtonX,ComponentPaletteBtnWidth+2);
inc(ButtonX,((ComponentPaletteBtnWidth*3) div 2)+2);
// create component buttons
for j:=0 to CurPage.Count-1 do begin
CurComponent:=TPkgComponent(CurPage[j]);
if CurComponent.Visible then begin
if CurComponent.Button=nil then begin
CurBtn:=TSpeedButton.Create(nil);
CurComponent.Button:=CurBtn;
CreatePopupMenu;
with CurBtn do begin
Name:='PaletteBtnPage'+IntToStr(i)+'_'+IntToStr(j)
+'_'+CurComponent.ComponentClass.ClassName;
SetBounds(ButtonX,0,ComponentPaletteBtnWidth,ComponentPaletteBtnHeight);
Glyph := CurComponent.Icon;
GroupIndex := 1;
Flat := true;
OnClick := @ComponentBtnClick;
OnDblClick := @ComponentBtnDblClick;
Hint := CurComponent.ComponentClass.ClassName;
CurBtn.PopupMenu:=Self.PopupMenu;
Parent := CurNoteBookPage;
end;
//writeln('TComponentPalette.UpdateNoteBookButtons Created Button: ',CurComponent.ComponentClass.ClassName,' ',CurComponent.Button.Name);
end;
end else if CurComponent.Button<>nil then begin
//writeln('TComponentPalette.UpdateNoteBookButtons Destroy Button: ',CurComponent.ComponentClass.ClassName,' ',CurComponent.Button.Name);
CurComponent.Button.Free;
CurComponent.Button:=nil;
end;
inc(ButtonX,ComponentPaletteBtnWidth+2);
end;
end;
// restore active page
if (OldActivePage<>'') and (FNoteBook.Pages.IndexOf(OldActivePage)>=0) then
begin
FNoteBook.ActivePage:=OldActivePage;
end else if FNoteBook.PageCount>0 then begin
FNoteBook.PageIndex:=0;
end;
finally
// unlock
fUpdatingNotebook:=false;
fNoteBookNeedsUpdate:=false;
FNoteBook.EnableAlign;
end;
// restore active page
if (OldActivePage<>'') and (FNoteBook.Pages.IndexOf(OldActivePage)>=0) then
begin
FNoteBook.ActivePage:=OldActivePage;
end else if FNoteBook.PageCount>0 then begin
FNoteBook.PageIndex:=0;
end;
// unlock
fUpdatingNotebook:=false;
fNoteBookNeedsUpdate:=false;
//writeln('TComponentPalette.UpdateNoteBookButtons END');
end;

3
ide/lazarus.lpi
View File

@ -14,7 +14,6 @@
<IconPath Value="./"/>
<TargetFileExt Value=""/>
</General>
<LazDoc Paths=""/>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
@ -40,7 +39,7 @@
<Filename Value="../lazarus"/>
</Target>
<SearchPaths>
<UnitOutputDirectory Value="$(LazarusDir)/units/$(TargetCPU)-$(TargetOS)/"/>
<UnitOutputDirectory Value="$(LazarusDir)/units/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>

2
ide/main.pp
View File

@ -2742,7 +2742,7 @@ Begin
OnCloseQuery:=@OnDesignerCloseQuery;
OnPersistentDeleted:=@OnDesignerPersistentDeleted;
OnGetNonVisualCompIcon:=
@TComponentPalette(IDEComponentPalette).OnGetNonVisualCompIcon;
@TComponentPalette(IDEComponentPalette).OnGetNonVisualCompIcon;
OnGetSelectedComponentClass:=@OnDesignerGetSelectedComponentClass;
OnModified:=@OnDesignerModified;
OnPasteComponent:=@OnDesignerPasteComponent;

28
lcl/include/buttonglyph.inc
View File

@ -26,37 +26,29 @@ begin
FOriginal.OnChange := @GlyphChanged;
end;
{------------------------------------------------------------------------------}
{ TButtonGlyph destructor }
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------
TButtonGlyph destructor
------------------------------------------------------------------------------}
destructor TButtonGlyph.Destroy;
Begin
begin
FOriginal.Free;
FOriginal:=nil;
inherited Destroy;
end;
{------------------------------------------------------------------------------}
{ TButtonGlyph SetGlyph }
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------
TButtonGlyph SetGlyph
------------------------------------------------------------------------------}
procedure TButtonGlyph.SetGlyph(Value : TBitmap);
var
GlyphCount : integer;
begin
if FOriginal = Value then exit;
{$IFDEF BitmapSharingWorks}
if FOriginal=nil then begin
FOriginal:=TBitmap.Create;
end;
FOriginal.OnChange:=nil;
FOriginal.Assign(Value);
{$ELSE}
if FOriginal<>nil then begin
FOriginal.OnChange:=nil;
FOriginal.Free;
end;
FOriginal:= Value;
{$ENDIF}
FOriginal.OnChange := @GlyphChanged;
FNumGlyphs:=1;
if (FOriginal <> nil) and (FOriginal.Height > 0) then begin
@ -75,9 +67,9 @@ begin
if Assigned(FOnChange) then FOnChange(Self);
end;
{------------------------------------------------------------------------------}
{ TButtonGlyph Draw }
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------
TButtonGlyph Draw
------------------------------------------------------------------------------}
Function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; State: TButtonState; Transparent: Boolean;
BiDiFlags: Longint): TRect;

12
lcl/interfaces/gtk/gtkdef.pp
View File

@ -380,8 +380,8 @@ const
GDKX_KEY_LaunchF = $1008FF4F;
function NewPGDIObject: PGDIObject;
procedure DisposePGDIObject(GDIObject: PGdiObject);
function InternalNewPGDIObject: PGDIObject;
procedure InternalDisposePGDIObject(GDIObject: PGdiObject);
function NewDeviceContext: TDeviceContext;
procedure DisposeDeviceContext(DeviceContext: TDeviceContext);
@ -393,6 +393,9 @@ var
DebugDeviceContexts: TDebugLCLItems = nil;
{$ENDIF}
procedure GtkDefDone;
implementation
@ -411,7 +414,7 @@ type
const
GDIObjectMemManager: TGDIObjectMemManager = nil;
function NewPGDIObject: PGDIObject;
function InternalNewPGDIObject: PGDIObject;
begin
if GDIObjectMemManager=nil then begin
GDIObjectMemManager:=TGDIObjectMemManager.Create;
@ -423,7 +426,7 @@ begin
{$ENDIF}
end;
procedure DisposePGDIObject(GDIObject: PGdiObject);
procedure InternalDisposePGDIObject(GDIObject: PGdiObject);
begin
{$IFDEF DebugLCLComponents}
DebugGdiObjects.MarkDestroyed(GDIObject);
@ -605,7 +608,6 @@ begin
DCFlags:=[];
end;
procedure GtkDefInit;
begin
{$IFDEF DebugLCLComponents}

21
lcl/interfaces/gtk/gtklistsl.inc
View File

@ -437,6 +437,20 @@ var
i: integer;
begin
if not (glsItemCacheNeedsUpdate in FStates) then exit;
{$IFDEF DebugLCLComponents}
// if items were removed => mark them as destroyed
for i:=0 to FCachedCount-1 do begin
if (FGtkList=nil)
or (g_list_find(FGtkList^.children,FCachedItems[i])=nil) then begin
if DebugGtkWidgets.IsCreated(FCachedItems[i]) then begin
DebugLn(['TGtkListStringList.UpdateItemCache item vanished: ',i]);
DebugGtkWidgets.MarkDestroyed(FCachedItems[i]);
end;
end;
end;
{$ENDIF}
if (FGtkList<>nil) and (FGtkList^.children<>nil) then
FCachedCount:=g_list_length(FGtkList^.children)
else
@ -455,6 +469,13 @@ begin
i:=0;
while CurListItem<>nil do begin
FCachedItems[i]:=PGtkListItem(CurListItem^.Data);
{$IFDEF DebugLCLComponents}
if not DebugGtkWidgets.IsCreated(PGtkListItem(CurListItem^.Data)) then
begin
DebugLn(['TGtkListStringList.UpdateItemCache unknown item ',i,' ',DbgSName(Owner)]);
DumpStack;
end;
{$ENDIF}
inc(i);
CurListItem:=CurListItem^.Next;
end;

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

@ -515,6 +515,8 @@ begin
FKeyStateList_.Free;
{$ENDIF}
FTimerData.Free;
GtkDefDone;
// finally remove our loghandler
g_log_remove_handler(nil, FLogHandlerID);
@ -4230,6 +4232,7 @@ begin
FFixWidgetsResized.Remove(FixWidget);
// destroy the widget
//DebugLn(['TGtkWidgetSet.DestroyConnectedWidget ',GetWidgetDebugReport(Widget)]);
DestroyWidget(Widget);
// remove all remaining messages to this widget
@ -6103,16 +6106,8 @@ begin
if Result then
with PGdiObject(GDIObject)^ do
case GDIType of
gdiBitmap : begin
case GDIBitmapType of
gbPixmap: Result := GDIPixmapObject <> nil;
gbBitmap: Result := GDIBitmapObject <> nil;
{obsolete: gbImage: Result := GDI_RGBImageObject <> nil;}
else
Result := False;
end;
end;
gdiBrush : Result := True; //Result := GDIBrushPixmap <> nil; //GDIBrushPixmap may be nil
gdiBitmap : Result:=true;
gdiBrush : Result := True;
gdiFont : Result := GDIFontObject <> nil;// ToDo: create font on demand
gdiPen : Result := True;
gdiRegion : Result := True;
@ -6252,7 +6247,7 @@ end;
function TGtkWidgetSet.NewDC: TDeviceContext;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.NewDC]', []));
Result:=GtkDef.NewDeviceContext;
Result:=NewDeviceContext;
with Result do
begin
{$ifdef TraceGdiCalls}
@ -6488,7 +6483,7 @@ end;
function TGtkWidgetSet.NewGDIObject(const GDIType: TGDIType): PGdiObject;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.NewGDIObject]', []));
Result:=GtkDef.NewPGDIObject;
Result:=GtkDef.InternalNewPGDIObject;
{$ifdef TraceGdiCalls}
FillStackAddrs(get_caller_frame(get_frame), @Result^.StackAddrs);
{$endif}
@ -6511,7 +6506,7 @@ begin
if FGDIObjects.Contains(GDIObject) then begin
dec(GDIObject^.RefCount);
FGDIObjects.Remove(GDIObject);
GtkDef.DisposePGDIObject(GDIObject);
GtkDef.InternalDisposePGDIObject(GDIObject);
end else
RaiseGDBException('');
end;

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

@ -4990,8 +4990,10 @@ begin
then begin
Widget := Window^.focus_widget;
{$IFDEF DebugLCLComponents}
if DebugGtkWidgets.IsDestroyed(Widget) then
DebugLn('TGtkWidgetSet.GetFocus ',DebugGtkWidgets.GetInfo(Widget,true));
if DebugGtkWidgets.IsDestroyed(Widget) then begin
DebugLn(['TGtkWidgetSet.GetFocus Window^.focus_widget was laready destroyed:']);
DebugLn(DebugGtkWidgets.GetInfo(Widget,true));
end;
{$ENDIF}
if (Widget <> nil) and gtk_widget_has_focus(Widget)
@ -7901,8 +7903,20 @@ function TGtkWidgetSet.SelectObject(DC: HDC; GDIObj: HGDIOBJ): HGDIOBJ;
begin
DebugLn(['TGtkWidgetSet.SelectObject DC=',dbghex(DC),' IsValidDC(DC)=',IsValidDC(DC),' GDIObj=',dbghex(GDIObj),' IsValidGDIObject(GDIObj)=',IsValidGDIObject(GDIObj)]);
DumpStack;
{$IFDEF DebugLCLComponents}
if not IsValidDC(DC) then begin
DebugLn(['DebugInvalidGDIObject DC:']);
debugln(DebugDeviceContexts.GetInfo(Pointer(DC),true));
end;
if not IsValidGDIObject(GDIObj) then begin
DebugLn(['DebugInvalidGDIObject GDIObj:']);
debugln(DebugGdiObjects.GetInfo(Pointer(GDIObj),true));
end;
{$ENDIF}
end;
var
NewDrawable: PGdkPixmap;
begin
Result := 0;
@ -7922,28 +7936,36 @@ begin
with TDeviceContext(DC) do
begin
Assert(False, Format('trace: [TGtkWidgetSet.SelectObject] DC: 0x%x, Type: Bitmap', [DC]));
if CurrentBitmap=nil then begin
// creating HBitmap on the fly (To find mem leaks)
CurrentBitmap:=NewGDIObject(gdiBitmap);
end;
Result := HBITMAP(CurrentBitmap);
if CurrentBitmap<>PGDIObject(GDIObj) then begin
CurrentBitmap := PGDIObject(GDIObj);
if GC <> nil then begin
gdk_gc_unref(GC);
GC:=nil;
end;
with CurrentBitmap^ do
case GDIBitmapType of
gbPixmap: Drawable := GDIPixmapObject;
gbBitmap: Drawable := GDIBitmapObject;
{obsolete: gbImage: Drawable := nil;//GDI_RGBImageObject;}
gbPixmap: NewDrawable := GDIPixmapObject;
gbBitmap: NewDrawable := GDIBitmapObject;
else
Drawable := nil;
NewDrawable := nil;
end;
//DebugLn('TGtkWidgetSet.SelectObject DC=',DbgS(DC),8),' GDIBitmap=',DbgS(Cardinal(CurrentBitmap),
//' GDIBitmapType=',ord(CurrentBitmap^.GDIBitmapType),' Drawable=',DbgS(Drawable));
GC := gdk_gc_new(Drawable);
gdk_gc_set_function(GC, GDK_COPY);
SelectedColors := dcscCustom;
if NewDrawable<>nil then begin
//DebugLn('TGtkWidgetSet.SelectObject DC=',DbgS(DC),8),' GDIBitmap=',DbgS(Cardinal(CurrentBitmap),
//' GDIBitmapType=',ord(CurrentBitmap^.GDIBitmapType),' Drawable=',DbgS(Drawable));
if GC <> nil then begin
gdk_gc_unref(GC);
GC:=nil;
end;
Drawable:=NewDrawable;
GC := gdk_gc_new(Drawable);
gdk_gc_set_function(GC, GDK_COPY);
SelectedColors := dcscCustom;
end else begin
// use defaults, free dummy gdiobject
DisposeGDIObject(CurrentBitmap);
CurrentBitmap:=nil;
end;
end;
end;

3
lcl/interfaces/gtk/gtkwsbuttons.pp
View File

@ -130,6 +130,9 @@ begin
Result := TLCLIntfHandle(gtk_button_new_with_label('button'));
if Result = 0 then Exit;
{$IFDEF DebugLCLComponents}
DebugGtkWidgets.MarkCreated(Pointer(Result),'button');
{$ENDIF}
WidgetInfo := CreateWidgetInfo(Pointer(Result), Button, AParams);

28
lcl/lclproc.pas
View File

@ -91,6 +91,7 @@ type
function FindInfo(p: Pointer; CreateIfNotExists: boolean = false
): TDebugLCLItemInfo;
function IsDestroyed(p: Pointer): boolean;
function IsCreated(p: Pointer): boolean;
function MarkCreated(p: Pointer; const InfoText: string): TDebugLCLItemInfo;
procedure MarkDestroyed(p: Pointer);
function GetInfo(p: Pointer; WithStackTraces: boolean): string;
@ -2393,27 +2394,31 @@ begin
end;
end;
function UTF8CStringToUTF8String(SourceStart: PChar; SourceLen: SizeInt) : string;
function UTF8CStringToUTF8String(SourceStart: PChar; SourceLen: SizeInt) : string;
var
Source: PChar;
Dest: PChar;
SourceEnd: PChar;
CharLen: integer;
SourceCopied: PChar;
// Copies from SourceStart till Source to Dest and updates Dest
procedure CopyPart; inline;
var
CopyLength: SizeInt;
begin
CopyLength := Source - SourceStart;
CopyLength := Source - SourceCopied;
if CopyLength=0 then exit;
move(SourceStart^ , Dest^, CopyLength);
move(SourceCopied^ , Dest^, CopyLength);
SourceCopied:=Source;
inc(Dest, CopyLength);
end;
begin
Source:= SourceStart;
SetLength(Result, SourceLen);
if SourceLen=0 then exit;
SourceCopied:=SourceStart;
Source:=SourceStart;
Dest:=PChar(Result);
SourceEnd := Source + SourceLen;
while Source<SourceEnd do begin
@ -2442,7 +2447,7 @@ begin
inc(Source);
inc(Dest);
end;
SourceStart := Source;
SourceCopied := Source;
end
else
Inc(Source, CharLen);
@ -2993,6 +2998,17 @@ begin
Result:=Info.IsDestroyed;
end;
function TDebugLCLItems.IsCreated(p: Pointer): boolean;
var
Info: TDebugLCLItemInfo;
begin
Info:=FindInfo(p);
if Info=nil then
Result:=false
else
Result:=not Info.IsDestroyed;
end;
procedure TDebugLCLItems.MarkDestroyed(p: Pointer);
var
Info: TDebugLCLItemInfo;
@ -3041,7 +3057,7 @@ var
procedure RaiseDoubleCreated;
begin
debugLn('TDebugLCLItems.MarkCreated old:');
debugLn('TDebugLCLItems.MarkCreated CREATED TWICE. Old:');
debugln(Info.AsString(true));
debugln(' New=',dbgs(p),' InfoText="',InfoText,'"');
DebugLn(GetStackTrace(true));

6
packager/packagedefs.pas
View File

@ -3120,7 +3120,11 @@ end;
destructor TPkgComponent.Destroy;
begin
PkgFile:=nil;
if fIconLoaded then FIcon.Free;
if fIconLoaded then begin
FIcon.Free;
FIcon:=nil;
fIconLoaded:=false;
end;
inherited Destroy;
end;

16
tools/install/cross_unix/HowToCreate_fpc_crosswin32_rpm.txt
View File

@ -2,13 +2,17 @@ How to create the fpc_crosswin32 rpm
This rpm was only tested under linux.
First get the FPC sources.
For configuration see below.
First get the FPC sources and the binutils.
For example:
[]$ cd <lazarusdir>/tools/install/cross_unix/
[]$ ./build_linux_cross_win32_rpm.sh downloadbinutils downloadfpc buildbinutils
This will download the FPC svn to ~/freepascal/fpc.
This will download the FPC svn to ~/freepascal/fpc, its install files to
~/freepascal/install and the binutils to ~/freepascal/binutils.
Create the fpc rpm and install it:
@ -21,3 +25,11 @@ Then build the fpc_crosswin32 rpm and install it:
[]$ sudo rpm -Uvh <path_to_rpms>/RPMS/i386/fpc_crosswin32-<version>.i386.rpm
Now you can cross compile from linux to win32.
================================================================================
The following environment variables are handled:
The base directory BuildRoot. Default value is ~/freepascal
[]$ export BuildRoot=/home/user/freepascal

4
tools/install/cross_unix/build_linux_cross_win32_rpm.sh
View File

@ -7,7 +7,9 @@ set -e
#set -x
# This is the root for all download and building directories
BuildRoot=~/freepascal
if [ ! -d "$BuildRoot" ]; then
BuildRoot=~/freepascal
fi
#===============================================================================
# parse command line parameters

4
tools/install/cross_unix/update_cross_fpc.sh
View File

@ -7,7 +7,9 @@ set -e
set -x
# This is the root for all download and building directories
BuildRoot=~/freepascal
if [ ! -d "$BuildRoot" ]; then
BuildRoot=~/freepascal
fi
# the binutils version to download
BinutilsVersion=2.16