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

MG: fixed many bugs (mem leaks, canvas)

Browse Source 
git-svn-id: trunk@231 -
This commit is contained in:
lazarus 2001-03-20 16:59:15 +00:00
parent 4abca0516d
commit 3cc827e5b9
12 changed files with 203 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
designer/controlselection.pp
View File

@ -25,7 +25,7 @@ unit ControlSelection;
interface
uses
Classes, Controls, LCLLinux, Forms, Graphics;
Classes, LCLLinux, Controls, Forms, Graphics;
type
TGrabberMoveEvent = procedure(Sender: TObject; dx, dy: Integer) of object;
@ -101,6 +101,7 @@ type
FOldHeight: integer;
FCustomForm: TCustomForm;
FCanvas: TCanvas;
FGrabbers: array[TGrabIndex] of TGrabber;
FGrabberSize: integer;
FGrabberColor: TColor;
@ -260,6 +261,7 @@ begin
FGrabbers[g].Cursor:=GRAB_CURSOR[g];
end;
FCustomForm:=nil;
FCanvas:=TCanvas.Create;
FActiveGrabber:=nil;
FUpdateLock:=0;
FChangedDuringLock:=false;
@ -273,6 +275,7 @@ begin
Clear;
FControls.Free;
for g:=Low(TGrabIndex) to High(TGrabIndex) do FGrabbers[g].Free;
FCanvas.Free;
inherited Destroy;
end;
@ -430,11 +433,13 @@ end;
function TControlSelection.Add(AControl: TControl):integer;
var NewSelectedControl:TSelectedControl;
begin
BeginUpdate;
NewSelectedControl:=TSelectedControl.Create(AControl);
if GetParentForm(AControl)<>FCustomForm then Clear;
Result:=FControls.Add(NewSelectedControl);
if Count=1 then SetCustomForm;
AdjustSize;
EndUpdate;
DoChange;
end;
@ -576,7 +581,8 @@ procedure TControlSelection.DrawGrabbers(DC: HDC);
var OldBrushColor:TColor;
g:TGrabIndex;
FormOrigin, DCOrigin, Diff: TPoint;
OldFormHandle: HDC;
SaveIndex: integer;
// OldFormHandle: HDC;
begin
if (Count=0) or (FCustomForm=nil)
or (Items[0].Control is TCustomForm) then exit;
@ -590,9 +596,10 @@ writeln('[DrawGrabbers] Form=',FormOrigin.X,',',FormOrigin.Y
,' Grabber1=',FGrabbers[0].Left,',',FGrabbers[0].Top
,' Selection=',FLeft,',',FTop);
}
OldFormHandle:=FCustomForm.Canvas.Handle;
FCustomForm.Canvas.Handle:=DC;
with FCustomForm.Canvas do begin
// OldFormHandle:=FCustomForm.Canvas.Handle;
SaveIndex:=SaveDC(DC);
FCanvas.Handle:=DC;
with FCanvas do begin
OldBrushColor:=Brush.Color;
Brush.Color:=FGrabberColor;
for g:=Low(TGrabIndex) to High(TGrabIndex) do
@ -604,7 +611,9 @@ writeln('[DrawGrabbers] Form=',FormOrigin.X,',',FormOrigin.Y
));
Brush.Color:=OldbrushColor;
end;
FCustomForm.Canvas.Handle:=OldFormHandle;
FCanvas.Handle:=0;
RestoreDC(DC,SaveIndex);
// FCustomForm.Canvas.Handle:=OldFormHandle;
end;
procedure TControlSelection.DrawMarker(AControl:TControl; DC:HDC);
@ -612,7 +621,7 @@ var OldBrushColor:TColor;
ALeft,ATop:integer;
AControlOrigin,DCOrigin:TPoint;
SaveIndex:HDC;
OldFormHandle:HDC;
// OldFormHandle:HDC;
begin
if (Count<2) or (FCustomForm=nil) or (AControl is TCustomForm)
or (not IsSelected(AControl)) then exit;
@ -625,8 +634,8 @@ begin
ALeft:=AControlOrigin.X-DCOrigin.X;
ATop:=AControlOrigin.Y-DCOrigin.Y;
SaveIndex := SaveDC(DC);
OldFormHandle:=FCustomForm.Canvas.Handle;
FCustomForm.Canvas.Handle:=DC;
// OldFormHandle:=FCustomForm.Canvas.Handle;
FCanvas.Handle:=DC;
{
writeln('DrawMarker A ',FCustomForm.Name
,' Control=',AControl.Name,',',AControlOrigin.X,',',AControlOrigin.Y
@ -634,7 +643,7 @@ writeln('DrawMarker A ',FCustomForm.Name
,' DC=',Hexstr(FCustomForm.Canvas.Handle,8),' ',HexStr(Cardinal(Pointer(FCustomForm)),8)
);
}
with FCustomForm.Canvas do begin
with FCanvas do begin
OldBrushColor:=Brush.Color;
Brush.Color:=FMarkerColor;
FillRect(Rect(ALeft,ATop,ALeft+MarkerSize,ATop+MarkerSize));
@ -647,13 +656,14 @@ writeln('DrawMarker A ',FCustomForm.Name
,ALeft+AControl.Width,ATop+AControl.Height));
Brush.Color:=OldbrushColor;
end;
FCustomForm.Canvas.Handle:=OldFormHandle;
FCanvas.Handle:=0;
// FCustomForm.Canvas.Handle:=OldFormHandle;
RestoreDC(DC, SaveIndex);
end;
procedure TControlSelection.DrawRubberband(DC: HDC);
var OldFormHandle: HDC;
FormOrigin, DCOrigin, Diff: TPoint;
var FormOrigin, DCOrigin, Diff: TPoint;
SaveIndex: HDC;
procedure DrawInvertFrameRect(x1,y1,x2,y2:integer);
var i:integer;
@ -661,19 +671,19 @@ var OldFormHandle: HDC;
procedure InvertPixel(x,y:integer);
//var c:TColor;
begin
//c:=FCustomForm.Canvas.Pixels[x,y];
//c:=FCanvas.Pixels[x,y];
//c:=c xor $ffffff;
//FCustomForm.Canvas.Pixels[x,y]:=c;
FCustomForm.Canvas.MoveTo(Diff.X+x,Diff.Y+y);
FCustomForm.Canvas.LineTo(Diff.X+x+1,Diff.Y+y);
//FCanvas.Pixels[x,y]:=c;
FCanvas.MoveTo(Diff.X+x,Diff.Y+y);
FCanvas.LineTo(Diff.X+x+1,Diff.Y+y);
end;
var OldPenColor: TColor;
begin
if FCustomForm=nil then exit;
if FCanvas=nil then exit;
if x1>x2 then begin i:=x1; x1:=x2; x2:=i; end;
if y1>y2 then begin i:=y1; y1:=y2; y2:=i; end;
with FCustomForm.Canvas do begin
with FCanvas do begin
OldPenColor:=Brush.Color;
Pen.Color:=clBlack;
i:=x1+1;
@ -699,11 +709,14 @@ begin
FormOrigin:=FCustomForm.ClientOrigin;
Diff.X:=FormOrigin.X-DCOrigin.X;
Diff.Y:=FormOrigin.Y-DCOrigin.Y;
OldFormHandle:=FCustomForm.Canvas.Handle;
FCustomForm.Canvas.Handle:=DC;
// OldFormHandle:=FCustomForm.Canvas.Handle;
SaveIndex:=SaveDC(DC);
FCanvas.Handle:=DC;
with FRubberBandBounds do
DrawInvertFrameRect(Left,Top,Right,Bottom);
FCustomForm.Canvas.Handle:=OldFormHandle;
FCanvas.Handle:=0;
RestoreDC(DC,SaveIndex);
// FCustomForm.Canvas.Handle:=OldFormHandle;
end;
procedure TControlSelection.SelectWithRubberBand(ACustomForm:TCustomForm;

10
designer/designer.pp
View File

@ -53,6 +53,7 @@ type
FOnPropertiesChanged: TNotifyEvent;
FOnAddComponent: TOnAddComponent;
FHasSized: boolean;
FGridColor: TColor;
function GetIsControl: Boolean;
procedure SetIsControl(Value: Boolean);
@ -127,6 +128,7 @@ begin
FCustomForm := CustomForm;
ControlSelection:=AControlSelection;
FHasSized:=false;
FGridColor:=clGray;
end;
destructor TDesigner.Destroy;
@ -169,7 +171,9 @@ end;
function TDesigner.PaintControl(Sender: TControl; Message: TLMPaint):boolean;
begin
Result:=true;
//writeln('*** LM_PAINT A ',Sender.Name,':',Sender.ClassName,' DC=',HexStr(Message.DC,8));
Sender.Dispatch(Message);
//writeln('*** LM_PAINT B ',Sender.Name,':',Sender.ClassName,' DC=',HexStr(Message.DC,8));
if (ControlSelection.IsSelected(Sender)) then begin
// writeln('*** LM_PAINT ',Sender.Name,':',Sender.ClassName,' DC=',HexStr(Message.DC,8));
ControlSelection.DrawMarker(Sender,Message.DC);
@ -349,7 +353,9 @@ Begin
// selection mode
if not FHasSized then begin
ControlSelection.BeginUpdate;
if not (ssShift in Shift) then
if (not (ssShift in Shift))
or ((ControlSelection.Count=1)
and (ControlSelection[0].Control is TCustomForm)) then
ControlSelection.Clear;
if RubberBandWasActive then begin
ControlSelection.SelectWithRubberBand(SenderParentForm,ssShift in Shift);
@ -617,7 +623,7 @@ var
x,y : integer;
begin
with FCustomForm.Canvas do begin
Pen.Color := clGray;
Pen.Color := FGridColor;
x := 0;
while x <= FCustomForm.Width do begin
y := 0;

17
designer/jitforms.pp
View File

@ -124,10 +124,8 @@ begin
end;
destructor TJITForms.Destroy;
var a:integer;
begin
for a:=0 to FForms.Count-1 do
DestroyJITForm(a);
while FForms.Count>0 do DestroyJITForm(FForms.Count-1);
FForms.Free;
inherited Destroy;
end;
@ -161,6 +159,7 @@ begin
OldClass:=Items[Index].ClassType;
Items[Index].Free;
FreevmtCopy(OldClass);
FForms.Delete(Index);
end;
function TJITForms.FindFormByClassName(AClassName:shortstring):integer;
@ -197,22 +196,18 @@ var
begin
Result:=-1;
// create new class and an instance
writeln('[TJITForms.DoCreateJITForm] Creating new JIT class '''+NewClassName+''' ...');
//writeln('[TJITForms.DoCreateJITForm] Creating new JIT class '''+NewClassName+''' ...');
Pointer(FCurReadClass):=CreatevmtCopy(TJITForm,'TJITForm');
writeln('[TJITForms.DoCreateJITForm] Creating an instance of JIT class '''+NewClassName+''' ...');
//writeln('[TJITForms.DoCreateJITForm] Creating an instance of JIT class '''+NewClassName+''' ...');
Instance:=TComponent(FCurReadClass.NewInstance);
writeln('[TJITForms.DoCreateJITForm] Initializing new instance ...');
//writeln('[TJITForms.DoCreateJITForm] Initializing new instance ...');
TComponent(FCurReadForm):=Instance;
try
Instance.Create(nil);
Writeln('----------------------------------');
Writeln('New form name is '+NewFormName);
Writeln('----------------------------------');
Writeln('----------------------------------');
if NewFormName<>'' then
Instance.Name:=NewFormName;
DoRenameClass(FCurReadClass,NewClassName);
writeln('[TJITForms.DoCreateJITForm] Initialization was successful!');
//writeln('[TJITForms.DoCreateJITForm] Initialization was successful!');
except
TComponent(FCurReadForm):=nil;
writeln('[TJITForms.DoCreateJITForm] Error while creating instance');

9
ide/customformeditor.pp
View File

@ -24,7 +24,8 @@ unit CustomFormEditor;
interface
uses
classes, abstractformeditor, controls,propedits,Typinfo,ObjectInspector,forms,IDEComp;
Classes, AbstractFormeditor, Controls, PropEdits, TypInfo, ObjectInspector ,
Forms, IDEComp, JITForms;
Const OrdinalTypes = [tkInteger,tkChar,tkENumeration,tkbool];
@ -94,6 +95,7 @@ TCustomFormEditor
FComponentInterfaceList : TList; //used to track and find controls
FSelectedComponents : TComponentSelectionList;
FObj_Inspector : TObjectInspector;
JITFormList : TJITForms;
protected
Procedure RemoveFromComponentInterfaceList(Value :TIComponentInterface);
procedure SetSelectedComponents(TheSelectedComponents : TComponentSelectionList);
@ -123,10 +125,7 @@ TCustomFormEditor
implementation
uses
SysUtils, JITForms;
var
JITFormList : TJITForms;
SysUtils;
{TComponentInterface}

4
ide/main.pp
View File

@ -634,6 +634,7 @@ begin
Project:=nil;
end;
TheControlSelection.Free;
FormEditor1.Free;
MacroList.Free;
EnvironmentOptions.Free;
EnvironmentOptions:=nil;
@ -2889,6 +2890,9 @@ end.
{ =============================================================================
$Log$
Revision 1.76 2001/03/20 16:59:14 lazarus
MG: fixed many bugs (mem leaks, canvas)
Revision 1.75 2001/03/19 14:00:46 lazarus
MG: fixed many unreleased DC and GDIObj bugs

8
ide/splash.pp
View File

@ -329,7 +329,9 @@ end;
destructor TSplashForm.Destroy;
begin
FBitmap.Free;
FBitmap:=nil;
FTimer.Free;
FTimer:=nil;
inherited Destroy;
end;
@ -353,7 +355,8 @@ procedure TSplashForm.Paint;
begin
inherited Paint;
if FBitmap <>nil
then Canvas.Copyrect(Bounds(0, 0, Width, Height), FBitmap.Canvas, Rect(0,0, Width, Height));
then Canvas.Copyrect(Bounds(0, 0, Width, Height)
,FBitmap.Canvas, Rect(0,0, Width, Height));
end;
procedure TSplashForm.StartTimer;
@ -366,6 +369,9 @@ end.
{ =============================================================================
$Log$
Revision 1.4 2001/03/20 16:59:15 lazarus
MG: fixed many bugs (mem leaks, canvas)
Revision 1.3 2001/03/19 14:00:47 lazarus
MG: fixed many unreleased DC and GDIObj bugs

10
lcl/graphics.pp
View File

@ -413,8 +413,11 @@ type
FAutoReDraw : Boolean;
FState: TCanvasState;
FFont : TFont;
FSavedFontHandle: HFont;
FPen: TPen;
FSavedPenHandle: HPen;
FBrush: TBrush;
FSavedBrushHandle: HBrush;
FPenPos : TPoint;
FCopyMode : TCopyMode;
FHandle : HDC;
@ -425,6 +428,7 @@ type
procedure CreateBrush;
procedure CreateFont;
Procedure CreatePen;
procedure DeselectHandles;
function GetCanvasClipRect: TRect;
Function GetColor: TColor;
function GetHandle : HDC;
@ -435,6 +439,7 @@ type
Procedure SetColor(c: TColor);
Procedure SetBrush(value : TBrush);
Procedure SetFont(value : TFont);
procedure SetHandle(NewHandle: HDC);
Procedure SetPen(value : TPen);
Procedure SetPenPos(Value : TPoint);
Procedure SetPixel(X,Y : Integer; Value : TColor);
@ -464,7 +469,7 @@ type
property OnChange : TNotifyEvent read FOnChange write FOnChange;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
property Pixels[X, Y: Integer]: TCOlor read GetPixel write SetPixel;
property Handle: HDC read GetHandle write FHandle;
property Handle: HDC read GetHandle write SetHandle;
published
property AutoRedraw : Boolean read FAutoReDraw write SetAutoReDraw;
property Brush: TBrush read FBrush write SetBrush;
@ -645,6 +650,9 @@ end.
{ =============================================================================
$Log$
Revision 1.8 2001/03/20 16:59:15 lazarus
MG: fixed many bugs (mem leaks, canvas)
Revision 1.7 2001/03/19 14:00:50 lazarus
MG: fixed many unreleased DC and GDIObj bugs

80
lcl/include/canvas.inc
View File

@ -99,8 +99,11 @@ end;
procedure TCanvas.CreateBrush;
var OldHandle: HBRUSH;
begin
//writeln('[TCanvas.CreateBrush] ',Classname,' Self=',HexStr(Cardinal(Pointer(Self)),8)
// ,' Brush=',HexStr(Cardinal(Pointer(Brush)),8));
OldHandle:=SelectObject(FHandle, Brush.Handle);
if OldHandle<>Brush.Handle then LCLLinux.DeleteObject(OldHandle);
if OldHandle<>Brush.Handle then FSavedBrushHandle:=OldHandle;
Include(FState, csBrushValid);
// SetBkColor(FHandle, not ColorToRGB(Brush.Color));
// SetBkMode(FHandle, TRANSPARENT);
end;
@ -115,7 +118,8 @@ procedure TCanvas.CreatePen;
var OldHandle: HPEN;
begin
OldHandle:=SelectObject(FHandle, Pen.Handle);
if OldHandle<>Pen.Handle then LCLLinux.DeleteObject(OldHandle);
if OldHandle<>Pen.Handle then FSavedPenHandle:=OldHandle;
Include(FState, csPenValid);
// SetROP2(FHandle, PenModes[Pen.Mode]);
end;
@ -129,7 +133,8 @@ procedure TCanvas.CreateFont;
var OldHandle: HPEN;
begin
OldHandle:=SelectObject(FHandle, Font.Handle);
if OldHandle<>Font.Handle then LCLLinux.DeleteObject(OldHandle);
if OldHandle<>Font.Handle then FSavedFontHandle:=OldHandle;
Include(FState, csFontValid);
SetTextColor(FHandle, ColorToRGB(Font.Color));
end;
@ -280,7 +285,7 @@ end;
Procedure TCanvas.MoveTo(X1, Y1 : Integer);
begin
RequiredState([csHandleValid]);
if LCLLinux.MoveToEx(Handle, X1, Y1, nil) then FPenPos:= Point(X1, Y1);
if LCLLinux.MoveToEx(FHandle, X1, Y1, nil) then FPenPos:= Point(X1, Y1);
End;
{------------------------------------------------------------------------------
@ -292,7 +297,7 @@ End;
procedure TCanvas.LineTo(X1, Y1 : Integer);
begin
RequiredState([csHandleValid, csPenValid]);
if LCLLinux.LineTo(Handle, X1, Y1) then FPenPos:= Point(X1, Y1);
if LCLLinux.LineTo(FHandle, X1, Y1) then FPenPos:= Point(X1, Y1);
end;
@ -394,10 +399,13 @@ begin
inherited Create;
FFont := TFont.Create;
FFont.OnChange := @FontChanged;
FSavedFontHandle := 0;
FPen := TPen.Create;
FPen.OnChange := @PenChanged;
FSavedPenHandle := 0;
FBrush := TBrush.Create;
FBrush.OnChange := @BrushChanged;
FSavedBrushHandle := 0;
FCopyMode := cmSrcCopy;
FPenPos := Point(0, 0);
end;
@ -411,6 +419,7 @@ end;
------------------------------------------------------------------------------}
destructor TCanvas.Destroy;
begin
//writeln('[TCanvas.Destroy] ',ClassName,' Self=',HexStr(Cardinal(Pointer(Self)),8));
Handle := 0;
FFont.Free;
FPen.Free;
@ -431,6 +440,62 @@ begin
Result := FHandle;
end;
{------------------------------------------------------------------------------
Method: TCanvas.SetHandle
Params: NewHandle - the new device context
Returns: nothing
Deselect sub handles and sets the Handle
------------------------------------------------------------------------------}
procedure TCanvas.SetHandle(NewHandle: HDC);
begin
if FHandle<>NewHandle then begin
//writeln('[TCanvas.SetHandle] Old=',HexStr(FHandle,8),' New=',HexStr(NewHandle,8));
if FHandle <> 0 then
begin
DeselectHandles;
FPenPos := GetPenPos;
FHandle := 0;
Exclude(FState, csHandleValid);
end;
if NewHandle <> 0 then
begin
Include(FState, csHandleValid);
FHandle := NewHandle;
SetPenPos(FPenPos);
end;
//writeln('[TCanvas.SetHandle] END Handle=',HexStr(FHandle,8));
end;
end;
{------------------------------------------------------------------------------
Method: TCanvas.DeselectHandles
Params: none
Returns: nothing
Deselect all subhandles in the current device context
------------------------------------------------------------------------------}
procedure TCanvas.DeselectHandles;
begin
if (FHandle<>0)
and (FState - [csPenValid, csBrushValid, csFontValid] <> FState) then begin
// select default sub handles in the device context without deleting owns
if FSavedBrushHandle<>0 then begin
SelectObject(FHandle,FSavedBrushHandle);
FSavedBrushHandle:=0;
end;
if FSavedPenHandle<>0 then begin
SelectObject(FHandle,FSavedPenHandle);
FSavedPenHandle:=0;
end;
if FSavedFontHandle<>0 then begin
SelectObject(FHandle,FSavedFontHandle);
FSavedFontHandle:=0;
end;
FState := FState - [csPenValid, csBrushValid, csFontValid];
end;
end;
{------------------------------------------------------------------------------
Method: TCanvas.CreateHandle
Params: None
@ -462,6 +527,7 @@ begin
CreateHandle;
if FHandle = 0
then raise EInvalidOperation.Create('Canvas does not allow drawing');
Include(FState, csHandleValid);
end;
if csFontValid in Needed then CreateFont;
if csPenValid in Needed then
@ -471,7 +537,6 @@ begin
then Include(Needed, csBrushValid);
end;
if csBrushValid in Needed then CreateBrush;
FState := FState + Needed;
end;
end;
@ -526,6 +591,9 @@ end;
{ =============================================================================
$Log$
Revision 1.5 2001/03/20 16:59:15 lazarus
MG: fixed many bugs (mem leaks, canvas)
Revision 1.4 2001/03/19 14:00:50 lazarus
MG: fixed many unreleased DC and GDIObj bugs

50
lcl/include/customform.inc
View File

@ -66,9 +66,15 @@ end;
------------------------------------------------------------------------------}
destructor TCustomForm.Destroy;
begin
//writeln('[TCustomForm.Destroy] A ',Name,':',ClassName);
Assert(False, Format('Trace: [TCustomForm.Destroy] %s', [ClassName]));
FMenu.Free;
FMenu:=nil;
FCanvas.Free;
FCanvas:=nil;
//writeln('[TCustomForm.Destroy] B ',Name,':',ClassName);
inherited Destroy;
//writeln('[TCustomForm.Destroy] END ',Name,':',ClassName);
end;
{------------------------------------------------------------------------------
@ -164,7 +170,7 @@ end;
Params: Msg: When the form is Activated
Returns: nothing
Paint event handler.
Activate event handler.
------------------------------------------------------------------------------}
Procedure TCustomForm.WMActivate(var Message : TLMActivate);
Begin
@ -181,7 +187,8 @@ end;
Paint event handler.
------------------------------------------------------------------------------}
procedure TCustomForm.WMPaint(var Message: TLMPaint);
begin
begin
//writeln('[TCustomForm.WMPaint] ',Name,':',ClassName);
Assert(False, Format('Trace: [TCustomForm.LMPaint] %s', [ClassName]));
Include(FControlState, csCustomPaint);
@ -191,6 +198,7 @@ begin
finally
Exclude(FControlState, csCustomPaint);
end;
//writeln('[TCustomForm.WMPaint] END ',Name,':',ClassName);
end;
@ -199,7 +207,7 @@ end;
Params: Msg: The Size message
Returns: nothing
Paint event handler.
Resize event handler.
------------------------------------------------------------------------------}
procedure TCustomForm.WMSize(var Message: TLMSize);
Begin
@ -284,9 +292,11 @@ end;
------------------------------------------------------------------------------}
Function TCustomForm.GetClientRect :TRect;
Begin
SetRect(Result,0,0,0,0);
AdjustWindowRectEx(Result,GetWindowLong(Handle,GWL_STYLE),Menu <> nil,GetWIndowLong(Handle,GWL_EXSTYLE));
SetRect(Result,0,0, Width - Result.Right + Result.Left, Height - Result.Bottom + Result.Top);
SetRect(Result,0,0,0,0);
AdjustWindowRectEx(Result,GetWindowLong(Handle,GWL_STYLE),Menu <> nil
,GetWIndowLong(Handle,GWL_EXSTYLE));
SetRect(Result,0,0, Width - Result.Right + Result.Left
, Height - Result.Bottom + Result.Top);
end;
@ -312,18 +322,17 @@ end;
Procedure TCustomForm.PaintWindow(DC : Hdc);
begin
// FCanvas.Lock;
try
try
FCanvas.Handle := DC;
try
if FDesigner <> nil then FDesigner.PaintGrid else Paint;
finally
FCanvas.Handle := 0;
end;
//writeln('[TCustomForm.PaintWindow] ',ClassName,' DC=',HexStr(DC,8),' ',HexStr(FCanvas.Handle,8));
try
if FDesigner <> nil then FDesigner.PaintGrid else Paint;
finally
FCanvas.Handle := 0;
end;
finally
// FCanvas.Unlock;
end;
end;
end;
@ -470,7 +479,6 @@ riteln('[TCustomForm.WndPRoc] 1');
Integer(itemWidth), Integer(itemHeight));
finally
Handle := 0;
writeln('[TCustomForm.WndPRoc] 2');
RestoreDC(DC, SaveIndex);
end;
finally
@ -573,13 +581,11 @@ begin
begin
Include(FFormState, fsCreating);
try
// *** New
if not InitResourceComponent(Self, TForm) then begin
writeln('[TCustomForm.Create] Resource '''+ClassName+''' not found');
Writeln('This is for information purposes only. This is not critical at this time.');
end;
// ***
finally
Exclude(FFormState, fsCreating);
end;
@ -592,7 +598,7 @@ constructor TCustomForm.CreateNew(AOwner: TComponent; Num : Integer);
Begin
FBorderStyle:= bsSizeable;
inherited Create(AOwner);
fCompStyle:= csForm;
fCompStyle:= csForm;
FFormState := [];
FMenu := nil;
@ -623,7 +629,6 @@ fCompStyle:= csForm;
// FPrintScale := poProportional;
// FloatingDockSiteClass := TWinControlClass(ClassType);
Screen.AddForm(Self);
End;
{------------------------------------------------------------------------------}
@ -728,7 +733,7 @@ end;
{------------------------------------------------------------------------------}
function TCustomForm.GetCanvas: TControlCanvas;
begin
result := FCanvas;
result := FCanvas;
end;
{------------------------------------------------------------------------------}
@ -854,6 +859,9 @@ end;
{ =============================================================================
$Log$
Revision 1.16 2001/03/20 16:59:15 lazarus
MG: fixed many bugs (mem leaks, canvas)
Revision 1.15 2001/03/19 14:41:56 lazarus
MG: fixed many unreleased DC and GDIObj bugs

1
lcl/include/form.inc
View File

@ -4,7 +4,6 @@
destructor TForm.destroy;
begin
Assert(False, 'Trace:Destroying signals for TForm');
FCanvas.Free;
inherited Destroy;
end;

12
lcl/include/wincontrol.inc
View File

@ -489,7 +489,7 @@ var
DC: HDC;
PS: TPaintStruct; //defined in LCLLinux.pp
begin
//writeln('[TWinControl.PaintHandler] ',Name,':',ClassName,' DC=',HexStr(Message.DC,8));
Assert(False, Format('Trace:> [TWinControl.PaintHandler] %s --> Msg.DC: 0x%x', [ClassName, Message.DC]));
DC := Message.DC;
if DC = 0 then DC := BeginPaint(Handle, PS);
@ -515,15 +515,16 @@ begin
if Message.DC = 0 then EndPaint(Handle, PS);
end;
Assert(False, Format('Trace:< [TWinControl.PaintHandler] %s', [ClassName]));
//writeln('[TWinControl.PaintHandler] END ',Name,':',ClassName,' DC=',HexStr(Message.DC,8));
end;
procedure TWinControl.PaintControls(DC: HDC; First: TControl);
var
I, Count, SaveIndex: Integer;
FrameBrush: HBRUSH;
TempControl : TCOntrol;
begin
//writeln('[TWinControl.PaintControls] ',Name,':',ClassName,' DC=',HexStr(DC,8));
if FControls <> nil then
begin
I := 0;
@ -571,12 +572,14 @@ begin
DeleteObject(FrameBrush);
}
end;
//writeln('[TWinControl.PaintControls] END ',Name,':',ClassName,' DC=',HexStr(DC,8));
end;
procedure TWinControl.PaintWindow(DC: HDC);
var
Message: TLMessage;
begin
//writeln('[TWinControl.PaintWindow] ',Name,':',Classname,' DC=',HexStr(DC,8));
Message.Msg := LM_PAINT;
Message.WParam := DC;
Message.LParam := 0;
@ -1241,7 +1244,7 @@ var
n: Integer;
Control: TControl;
begin
//writeln('[TWinControl.Destroy] 1 ',Name,':',ClassName);
//writeln('[TWinControl.Destroy] A ',Name,':',ClassName);
DestroyHandle;
n := ControlCount;
@ -1938,6 +1941,9 @@ end;
{ =============================================================================
$Log$
Revision 1.25 2001/03/20 16:59:15 lazarus
MG: fixed many bugs (mem leaks, canvas)
Revision 1.24 2001/03/19 14:38:39 lazarus
MG: fixed many unreleased DC and GDIObj bugs

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

@ -265,7 +265,8 @@ end;
------------------------------------------------------------------------------}
function TgtkObject.CreateBitmap(Width, Height: Integer; Planes, BitCount: Longint; BitmapBits: Pointer): HBITMAP;
function TgtkObject.CreateBitmap(Width, Height: Integer;
Planes, BitCount: Longint; BitmapBits: Pointer): HBITMAP;
var
GdiObject: PGdiObject;
RawImage: PGDIRawImage;
@ -279,6 +280,7 @@ begin
Exit;
end;
//write('TgtkObject.CreateBitmap->');
GdiObject := NewGDIObject(gdiBitmap);
// if the bitcount is the system depth create a Pixmap
@ -331,6 +333,8 @@ begin
Assert(False, Format('Trace:> [TgtkObject.CreateBrushIndirect] Style: %d, Color: %8x', [LogBrush.lbStyle, LogBrush.lbColor]));
sError := '';
//write('CreateBrushIndirect->');
GObject := NewGDIObject(gdiBrush);
with LogBrush do
@ -625,6 +629,7 @@ begin
CharSetCoding := '*';
end;
//write('CreateFontIndirect->');
GDIObject := NewGDIObject(gdiFont);
LoadFont;
if GdiObject^.GDIFontObject = nil
@ -675,8 +680,7 @@ begin
if GdiObject^.GDIFontObject = nil
then begin
writeln('[TgtkObject.CreateFontIndirect] ',HexStr(Cardinal(GdiObject),8)
,' ',FGDIObjects.Count);
//writeln('[TgtkObject.CreateFontIndirect] ',HexStr(Cardinal(GdiObject),8),' ',FGDIObjects.Count);
FGDIObjects.Remove(GdiObject);
Dispose(GdiObject);
Result := 0;
@ -703,6 +707,7 @@ var
GObject: PGdiObject;
begin
Assert(False, 'trace:[TgtkObject.CreatePenIndirect]');
//write('CreatePenIndirect->');
GObject := NewGDIObject(gdiPen);
with LogPen do
@ -736,6 +741,7 @@ var
GDKColor: TGDKCOlor;
P: Pointer;
begin
//write('TgtkObject.CreatePixmapIndirect->');
GdiObject := NewGDIObject(gdiBitmap);
if TransColor >= 0
then begin
@ -1366,6 +1372,7 @@ begin
then begin
if Values.Font <> nil
then begin
//write('GetDC->');
GdiObject:=NewGDIObject(gdiFont);
GdiObject^.GDIFontObject := Values.Font;
gdk_font_ref(Values.Font);
@ -1523,7 +1530,7 @@ end;
------------------------------------------------------------------------------}
Function TgtkObject.GetProp(Handle : hwnd; Str : PChar): Pointer;
Begin
result := gtk_object_get_data(pgtkobject(Handle),Str);
result := gtk_object_get_data(pgtkobject(Handle),Str);
end;
@ -2077,7 +2084,7 @@ var
Widget: PGTKWidget;
Sender : TObject;
begin
Writeln('GetWindowRect');
//Writeln('GetWindowRect');
result := 0; //default
if Handle <> 0 then
begin
@ -2096,7 +2103,7 @@ Writeln('GetWindowRect');
sender := TObject(Gtk_Object_Get_Data(pGTKObject(widget),'Sender'));
if (sender is TControl) then
begin
writeln('****************SENDCER IS TCONTROL********************');
writeln('****************SENDER IS TCONTROL********************');
X := TControl(sender).Left;
Y := TControl(sender).Top;
W := TControl(sender).Width;
@ -2569,11 +2576,10 @@ begin
end;
// TODO copy bitmap also
Result := CopyDCData(pDC, pSavedDC);
pDC^.SavedContext := pSavedDC^.SavedContext;
pSavedDC^.SavedContext := nil;
Result := CopyDCData(pSavedDC, pDC);
//prevent deleting of copied objects;
if pSavedDC^.CurrentBitmap = pDC^.CurrentBitmap
@ -3387,6 +3393,9 @@ end;
{ =============================================================================
$Log$
Revision 1.27 2001/03/20 16:59:15 lazarus
MG: fixed many bugs (mem leaks, canvas)
Revision 1.26 2001/03/19 18:51:57 lazarus
MG: added dynhasharray and renamed tsynautocompletion