paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-03 13:59:35 +01:00
Code Issues Packages Projects Releases Wiki Activity

gtk2 intf: fixed codetools include paths, fixed double painting

Browse Source 
git-svn-id: trunk@10870 -
This commit is contained in:
mattias 2007-04-04 18:08:37 +00:00
parent bf9399bd9d
commit 05fa424bb7
15 changed files with 633 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -2594,6 +2594,8 @@ lcl/interfaces/gtk2/gtk2wsspin.pp svneol=native#text/pascal
lcl/interfaces/gtk2/gtk2wsstdctrls.pp svneol=native#text/pascal
lcl/interfaces/gtk2/gtk2wstoolwin.pp svneol=native#text/pascal
lcl/interfaces/gtk2/interfaces.pas svneol=native#text/pascal
lcl/interfaces/gtk2/tests/checkbuttononfixed.lpi svneol=native#text/plain
lcl/interfaces/gtk2/tests/checkbuttononfixed.lpr svneol=native#text/plain
lcl/interfaces/qt/README.txt svneol=native#text/plain
lcl/interfaces/qt/interfaces.pp svneol=native#text/pascal
lcl/interfaces/qt/qt4.pas svneol=native#text/plain
@ -2766,6 +2768,8 @@ lcl/tests/test1_4edit.lpi svneol=native#text/plain
lcl/tests/test1_4edit.lpr svneol=native#text/pascal
lcl/tests/test1_5checkbox.lpi svneol=native#text/plain
lcl/tests/test1_5checkbox.lpr svneol=native#text/pascal
lcl/tests/test1_6checkgroup.lpi svneol=native#text/plain
lcl/tests/test1_6checkgroup.lpr svneol=native#text/plain
lcl/tests/test2_1buttonnavigation.lpi svneol=native#text/plain
lcl/tests/test2_1buttonnavigation.lpr svneol=native#text/pascal
lcl/tests/test2_2labelattributes.lpi svneol=native#text/plain

1
components/codetools/codetoolsstrconsts.pas
View File

@ -191,6 +191,7 @@ ResourceString
ctsInstallerDirectories = 'Installer directories';
ctsDefsForLazarusSources = 'Definitions for the Lazarus Sources';
ctsAddsDirToSourcePath = 'adds %s to SrcPath';
ctsAddsDirToIncludePath = 'adds %s to IncPath';
ctsSetsIncPathTo = 'sets IncPath to %s';
ctsSetsSrcPathTo = 'sets SrcPath to %s';
ctsNamedDirectory = '%s Directory';

33
components/codetools/definetemplates.pas
View File

@ -3791,7 +3791,7 @@ var
MainDir, DirTempl, SubDirTempl, IntfDirTemplate, IfTemplate,
LCLUnitsDir, LCLUnitsCPUOSDir, LCLUnitsCPUOSWidgetSetDir,
SubTempl: TDefineTemplate;
TargetOS, SrcOS, SrcPath: string;
TargetOS, SrcOS, SrcPath, IncPath: string;
i: Integer;
CurCPU, CurOS, CurWidgetSet, ExtraSrcPath: string;
ElseTemplate: TDefineTemplate;
@ -3810,6 +3810,7 @@ begin
TargetOS:='$('+ExternalMacroStart+'TargetOS)';
SrcOS:='$('+ExternalMacroStart+'SrcOS)';
SrcPath:='$('+ExternalMacroStart+'SrcPath)';
IncPath:='$('+ExternalMacroStart+'IncPath)';
// <LazarusSrcDir>
MainDir:=TDefineTemplate.Create(
@ -4110,7 +4111,7 @@ begin
MainDir.AddChild(DirTempl);
// <LazarusSrcDir>/lcl/forms
LCLWidgetSetDir:=TDefineTemplate.Create('Forms',Format(ctsNamedDirectory,['WidgetSet']),
LCLWidgetSetDir:=TDefineTemplate.Create('forms',Format(ctsNamedDirectory,['WidgetSet']),
'','forms',da_Directory);
LCLWidgetSetDir.AddChild(TDefineTemplate.Create('LCL path addition',
Format(ctsAddsDirToSourcePath,['..']),
@ -4118,7 +4119,7 @@ begin
DirTempl.AddChild(LCLWidgetSetDir);
// <LazarusSrcDir>/lcl/widgetset
LCLWidgetSetDir:=TDefineTemplate.Create('WidgetSet',Format(ctsNamedDirectory,['WidgetSet']),
LCLWidgetSetDir:=TDefineTemplate.Create('widgetset',Format(ctsNamedDirectory,['WidgetSet']),
'','widgetset',da_Directory);
LCLWidgetSetDir.AddChild(TDefineTemplate.Create('LCL path addition',
Format(ctsAddsDirToSourcePath,['..']),
@ -4126,7 +4127,7 @@ begin
DirTempl.AddChild(LCLWidgetSetDir);
// <LazarusSrcDir>/lcl/units
LCLUnitsDir:=TDefineTemplate.Create('Units',Format(ctsNamedDirectory,['Units']),
LCLUnitsDir:=TDefineTemplate.Create('units',Format(ctsNamedDirectory,['Units']),
'','units',da_Directory);
DirTempl.AddChild(LCLUnitsDir);
for i:=Low(Lazarus_CPU_OS_Widget_Combinations)
@ -4170,17 +4171,19 @@ begin
end;
// <LazarusSrcDir>/lcl/interfaces
SubDirTempl:=TDefineTemplate.Create('WidgetDirectory',
SubDirTempl:=TDefineTemplate.Create('interfaces',
ctsWidgetDirectory,'','interfaces',da_Directory);
// add lcl to the source path of all widget set directories
SubDirTempl.AddChild(TDefineTemplate.Create('LCL Path',
Format(ctsAddsDirToSourcePath,['lcl']),ExternalMacroStart+'SrcPath',
LazarusSrcDir+d('/lcl;')+LazarusSrcDir+d('/lcl/widgetset;')+SrcPath,
LazarusSrcDir+d('/lcl;')
+LazarusSrcDir+d('/lcl/widgetset;')
+SrcPath,
da_DefineRecurse));
DirTempl.AddChild(SubDirTempl);
// <LazarusSrcDir>/lcl/interfaces/gtk
IntfDirTemplate:=TDefineTemplate.Create('gtkIntfDirectory',
IntfDirTemplate:=TDefineTemplate.Create('gtk',
ctsIntfDirectory,'','gtk',da_Directory);
// if LCLWidgetType=gtk2
IfTemplate:=TDefineTemplate.Create('IF '''+WidgetType+'''=''gtk2''',
@ -4188,6 +4191,12 @@ begin
// then define gtk2
IfTemplate.AddChild(TDefineTemplate.Create('Define gtk2',
ctsDefineMacroGTK2,'gtk2','',da_Define));
IfTemplate.AddChild(TDefineTemplate.Create('add gtk2 to unit path',
Format(ctsAddsDirToSourcePath,[d('../gtk2')]),ExternalMacroStart+'SrcPath',
d('../gtk2;')+SrcPath,da_Define));
IfTemplate.AddChild(TDefineTemplate.Create('adds gtk2 as include path',
Format(ctsAddsDirToIncludePath,[d('../gtk2')]),ExternalMacroStart+'IncPath',
d('../gtk2;')+IncPath,da_Define));
IntfDirTemplate.AddChild(IfTemplate);
// else LCLWidgetType=gtk2
ElseTemplate:=TDefineTemplate.Create('ELSE',
@ -4199,7 +4208,7 @@ begin
SubDirTempl.AddChild(IntfDirTemplate);
// <LazarusSrcDir>/lcl/interfaces/gtk2
IntfDirTemplate:=TDefineTemplate.Create('gtk2IntfDirectory',
IntfDirTemplate:=TDefineTemplate.Create('gtk2',
ctsGtk2IntfDirectory,'','gtk2',da_Directory);
// add '../gtk' to the SrcPath
IntfDirTemplate.AddChild(TDefineTemplate.Create('SrcPath',
@ -4208,7 +4217,7 @@ begin
SubDirTempl.AddChild(IntfDirTemplate);
// <LazarusSrcDir>/lcl/interfaces/gnome
IntfDirTemplate:=TDefineTemplate.Create('gnomeIntfDirectory',
IntfDirTemplate:=TDefineTemplate.Create('gnome',
ctsGnomeIntfDirectory,'','gnome',da_Directory);
// add '../gtk' to the SrcPath
IntfDirTemplate.AddChild(TDefineTemplate.Create('SrcPath',
@ -4227,7 +4236,7 @@ begin
// no special
// <LazarusSrcDir>/lcl/interfaces/wince
IntfDirTemplate:=TDefineTemplate.Create('winceIntfDirectory',
IntfDirTemplate:=TDefineTemplate.Create('wince',
ctsIntfDirectory,'','wince',da_Directory);
// then define wince1
IntfDirTemplate.AddChild(TDefineTemplate.Create('Define wince1',
@ -4235,7 +4244,7 @@ begin
SubDirTempl.AddChild(IntfDirTemplate);
// <LazarusSrcDir>/lcl/interfaces/carbon
IntfDirTemplate:=TDefineTemplate.Create('carbonIntfDirectory',
IntfDirTemplate:=TDefineTemplate.Create('carbon',
ctsIntfDirectory,'','carbon',da_Directory);
// then define carbon1
IntfDirTemplate.AddChild(TDefineTemplate.Create('Define carbon1',
@ -4243,7 +4252,7 @@ begin
SubDirTempl.AddChild(IntfDirTemplate);
// <LazarusSrcDir>/lcl/interfaces/qt
IntfDirTemplate:=TDefineTemplate.Create('qtIntfDirectory',
IntfDirTemplate:=TDefineTemplate.Create('qt',
ctsIntfDirectory,'','qt',da_Directory);
// then define qt1
IntfDirTemplate.AddChild(TDefineTemplate.Create('Define qt1',

5
components/codetools/expreval.pas
View File

@ -294,7 +294,7 @@ begin
end else if (CompAtom('NOT')) then begin
Result:=EvalAtPos();
if ErrorPos>=0 then exit;
// Note: for Delphi compatibility: "IF not NotDefined" is valid
// Note: for Delphi compatibility: "IF not UndefinedVariable" is valid
if (Result='0') then Result:='1'
else Result:='0';
exit;
@ -309,8 +309,7 @@ begin
ErrorPos:=CurPos;
exit;
end;
Result:=Variables[copy(Expr,AtomStart,AtomEnd-AtomStart)];
if Result<>'' then
if IsDefined(copy(Expr,AtomStart,AtomEnd-AtomStart)) then
Result:='1'
else
Result:='0';

16
lcl/interfaces/gtk/gtkcallback.inc
View File

@ -78,6 +78,7 @@ var
{$ENDIF}
begin
if (not RepaintAll) and ((Area^.Width<1) or (Area^.Width<1)) then exit;
MSG.Msg := LM_GtkPAINT;
MSG.Data:=TLMGtkPaintData.Create;
MSG.Data.Widget := Widget;
@ -462,7 +463,7 @@ function gtkExposeEventAfter(Widget: PGtkWidget; Event : PGDKEventExpose;
var
DesignOnlySignal: boolean;
{$IFDEF GTK2}
children: PGList;
//children: PGList;
{$ENDIF}
begin
Result := CallBackDefaultReturn;
@ -485,13 +486,16 @@ begin
end;
//DebugLn(['gtkExposeEventAfter ',GetWidgetDebugReport(Widget),' ',dbgGRect(@Event^.Area)]);
// the expose area is ok, but some gtk widgets repaints everything on expose
// -> maximize the area
DeliverGtkPaintMessage(Data,Widget,@Event^.Area,true);
{$IFDEF GTK2}
// Some widgets in gtk2 don't have their own exclusive "windows" so a synthetic event must be sent
if GTK_IS_FIXED(Widget) then begin
// MG: That is already done by the gtk2. For which widgets does this not work?
// Enabling this results in double painting, which is slower and
// wrong for anitaliased text.
{if GTK_IS_FIXED(Widget) then begin
children := gtk_container_get_children(PGtkContainer(Widget));
while children <> nil do begin
if (children^.data <> nil) then begin
@ -502,7 +506,7 @@ begin
end;
end;
g_list_free(children);
end;
end;}
{$ENDIF}
end;
@ -1067,7 +1071,7 @@ begin
if TObject(Data) is TCustomForm then begin
TheForm := TCustomForm(Data);
DebugLn(['GTKWindowStateEventCB ',DbgSName(TheForm),' new_window_state=',state^.new_window_state,' changed_mask=',state^.changed_mask]);
//DebugLn(['GTKWindowStateEventCB ',DbgSName(TheForm),' new_window_state=',state^.new_window_state,' changed_mask=',state^.changed_mask]);
if TheForm.Parent = nil then begin (* toplevel window, just as a sanity check *)
if GTK_WIDGET_REALIZED(Widget) then begin
// send a WMSize Message (see TCustomForm.WMSize)
@ -1075,7 +1079,7 @@ begin
if GtkWidth<0 then GtkWidth:=0;
GtkHeight:=Widget^.Allocation.Height;
if GtkHeight<0 then GtkHeight:=0;
debugln('GTKWindowStateEventCB ',DbgSName(TObject(Data)),' ',dbgs(state^.new_window_state),' ',WidgetFlagsToString(Widget));
//debugln('GTKWindowStateEventCB ',DbgSName(TObject(Data)),' ',dbgs(state^.new_window_state),' ',WidgetFlagsToString(Widget));
if ((GDK_WINDOW_STATE_ICONIFIED and state^.new_window_state)>0) then begin
{$IFDEF HasX}
NetAtom := gdk_atom_intern('_NET_WM_DESKTOP', True);

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

@ -611,6 +611,16 @@ begin
Result:=Result+'St';
if GTK_WIDGET_PARENT_SENSITIVE(Widget) then
Result:=Result+'Pr';
{$IFDEF Gtk2}
if GTK_WIDGET_NO_WINDOW(Widget) then
Result:=Result+'Nw';
if GTK_WIDGET_COMPOSITE_CHILD(Widget) then
Result:=Result+'Cc';
if GTK_WIDGET_APP_PAINTABLE(Widget) then
Result:=Result+'Ap';
if GTK_WIDGET_DOUBLE_BUFFERED(Widget) then
Result:=Result+'Db';
{$ENDIF}
end;
Result:=Result+']';
end;

5
lcl/interfaces/gtk2/gtk2object.inc
View File

@ -284,11 +284,8 @@ function TGtk2WidgetSet.CreateComponent(Sender : TObject): THandle;
var
p: PGtkWidget; // ptr to the newly created GtkWidget
CompStyle: integer; // componentstyle (type) of GtkWidget which will be created
SetupProps : boolean;
begin
p := nil;
SetupProps:= false;
CompStyle := GetCompStyle(Sender);
case CompStyle of
@ -303,7 +300,7 @@ begin
Exit;
end;
end; //end case
FinishComponentCreate(Sender, P, SetupProps);
FinishComponentCreate(Sender, P);
Result := THandle(P);
end;

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

@ -68,8 +68,8 @@ function TGtk2WidgetSet.CreateCursor(ACursorInfo: PIconInfo): hCursor;
var
pixmap: PGdkPixmap;
bitmap: PGdkBitmap;
w, h: integer;
max_w, max_h: guint;
Width, Height: integer;
MaxWidth, MaxHeight: guint;
pixbuf, masked_pixbuf: PGdkPixbuf;
begin
Result := 0;
@ -78,20 +78,21 @@ begin
pixmap := PGDIObject(ACursorInfo^.hbmColor)^.GDIBitmapObject;
bitmap := PGDIObject(ACursorInfo^.hbmColor)^.GDIBitmapMaskObject;
gdk_drawable_get_size(pixmap, @w, @h);
gdk_display_get_maximal_cursor_size(gdk_display_get_default, @max_w, @max_h);
gdk_drawable_get_size(pixmap, @Width, @Height);
gdk_display_get_maximal_cursor_size(gdk_display_get_default,
@MaxWidth, @MaxHeight);
if (w > max_w) or (h > max_h) then
if (Width > integer(MaxWidth)) or (Height > integer(MaxHeight)) then
exit;
{
max_w := gdk_display_get_default_cursor_size(gdk_display_get_default);
if (w > max_w) or (h > max_w) then
DebugLn(['CreateCursor cursor size:',w,'x',h,' > default size:', max_w]);
MaxWidth := gdk_display_get_default_cursor_size(gdk_display_get_default);
if (Width > MaxWidth) or (Height > MaxWidth) then
DebugLn(['CreateCursor cursor size:',Width,'x',Height,' > default size:', MaxWidth]);
}
// create alpha pixbuf
pixbuf := gdk_pixbuf_new(GDK_COLORSPACE_RGB, True, 8, w, h);
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);

10
lcl/interfaces/gtk2/gtk2wsstdctrls.pp
View File

@ -415,7 +415,6 @@ class procedure TGtk2WSCustomListBox.SetFont(const AWinControl: TWinControl;
const AFont: TFont);
var
Widget: PGtkWidget;
Selection: PGtkTreeSelection;
begin
Widget:=GetWidgetInfo(Pointer(AWinControl.Handle),True)^.CoreWidget;
@ -599,21 +598,14 @@ end;
class function TGtk2WSCustomEdit.CreateHandle(const AWinControl: TWinControl;
const AParams: TCreateParams): TLCLIntfHandle;
var
p: PGtkWidget; // ptr to the newly created GtkWidget
SetupProps : boolean;
begin
SetupProps := false;
p := gtk_entry_new();
gtk_editable_set_editable (PGtkEditable(P), not TCustomEdit(AWinControl).ReadOnly);
gtk_widget_show_all(P);
Result := TLCLIntfHandle(P);
if result = 0 then exit;
gtk2WidgetSet.FinishComponentCreate(AWinControl, P, SetupProps);
gtk2WidgetSet.FinishComponentCreate(AWinControl, P);
end;

44
lcl/interfaces/gtk2/tests/checkbuttononfixed.lpi Normal file
View File

@ -0,0 +1,44 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<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>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="checkbuttononfixed.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="CheckButtonOnFixed"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

60
lcl/interfaces/gtk2/tests/checkbuttononfixed.lpr Normal file
View File

@ -0,0 +1,60 @@
program CheckButtonOnFixed;
{$mode objfpc}{$H+}
uses
Classes, Gtk2, Gdk2, Glib2;
function gtkExposeEventAfter(Widget: PGtkWidget; Event : PGDKEventExpose;
Data: gPointer): GBoolean; cdecl;
var
children: PGList;
begin
Result:=false;
writeln('gtkExposeEventAfter ',PChar(Data));
// Some widgets in gtk2 don't have their own exclusive "windows" so a synthetic event must be sent
// MG: That is already done by the gtk2. For which widgets does this not work?
// Enabling this results in double painting, which is slower and
// wrong for anitaliased text.
if GTK_IS_FIXED(Widget) then begin
children := gtk_container_get_children(PGtkContainer(Widget));
while children <> nil do begin
if (children^.data <> nil) then begin
if GTK_WIDGET_NO_WINDOW(PGtkWidget(children^.data)) then
gtk_container_propagate_expose(PGtkContainer(Widget), PGtkWidget(children^.data), Event);
if children^.next = nil then break;
children := children^.next;
end;
end;
g_list_free(children);
end;
end;
var
GtkWindow: PGtkWidget;
GtkFixed: PGtkWidget;
GtkCheckButton: PGtkWidget;
FixedName: String;
CheckButtonName: String;
begin
gtk_init(@ARGC,@ARGV);
GtkWindow:=gtk_window_new(GTK_WINDOW_TOPLEVEL);
GtkFixed := gtk_fixed_new ();
gtk_fixed_set_has_window(PGtkFixed(GtkFixed), True);
FixedName:='GtkFixed';
g_signal_connect_after(PGtkObject(GtkFixed), 'expose-event',
TGTKSignalFunc(@gtkExposeEventAfter), PChar(FixedName));
gtk_container_add (PGtkContainer(GtkWindow), GtkFixed);
GtkCheckButton:=gtk_check_button_new_with_label('Second');
CheckButtonName:='GtkCheckButton';
g_signal_connect_after(PGtkObject(GtkCheckButton), 'expose-event',
TGTKSignalFunc(@gtkExposeEventAfter), PChar(CheckButtonName));
gtk_fixed_put(PGtkFixed(GtkFixed),GtkCheckButton,10,10);
gtk_widget_show_all(GtkWindow);
gtk_main;
end.

3
lcl/tests/test1_5checkbox.lpi
View File

@ -36,9 +36,6 @@
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<SearchPaths>
<LCLWidgetType Value="gtk2"/>
</SearchPaths>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>

52
lcl/tests/test1_6checkgroup.lpi Normal file
View File

@ -0,0 +1,52 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
<Title Value="test1_6checkgroup"/>
</General>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="1">
<Unit0>
<Filename Value="test1_6checkgroup.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="test1_6checkgroup"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

416
lcl/tests/test1_6checkgroup.lpr Normal file
View File

@ -0,0 +1,416 @@
{
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
LCL Test 1_6
Showing a form at 0,0,320,240 with a single TCheckGroup at 5,10,175x125
}
program test1_6checkgroup;
{$mode objfpc}{$H+}
uses
Interfaces, FPCAdds, LCLProc, LCLType, Classes, Controls, Forms, TypInfo,
LMessages, StdCtrls, ExtCtrls, Buttons;
type
{ TForm1 }
TForm1 = class(TForm)
CheckGroup1: TCheckGroup;
procedure CheckGroup1ChangeBounds(Sender: TObject);
procedure CheckGroup1Click(Sender: TObject);
procedure CheckGroup1DblClick(Sender: TObject);
procedure CheckGroup1Enter(Sender: TObject);
procedure CheckGroup1Exit(Sender: TObject);
procedure CheckGroup1ItemClick(Sender: TObject; Index: integer);
procedure CheckGroup1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState
);
procedure CheckGroup1KeyPress(Sender: TObject; var Key: char);
procedure CheckGroup1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure CheckGroup1MouseDown(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure CheckGroup1MouseEnter(Sender: TObject);
procedure CheckGroup1MouseLeave(Sender: TObject);
procedure CheckGroup1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure CheckGroup1MouseUp(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure CheckGroup1Resize(Sender: TObject);
procedure Form1Activate(Sender: TObject);
procedure Form1ChangeBounds(Sender: TObject);
procedure Form1Click(Sender: TObject);
procedure Form1Close(Sender: TObject; var CloseAction: TCloseAction);
procedure Form1CloseQuery(Sender: TObject; var CanClose: boolean);
procedure Form1Create(Sender: TObject);
procedure Form1Deactivate(Sender: TObject);
procedure Form1Enter(Sender: TObject);
procedure Form1Exit(Sender: TObject);
function Form1Help(Command: Word; Data: Longint; var CallHelp: Boolean
): Boolean;
procedure Form1Hide(Sender: TObject);
procedure Form1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure Form1KeyPress(Sender: TObject; var Key: char);
procedure Form1MouseDown(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Form1MouseEnter(Sender: TObject);
procedure Form1MouseLeave(Sender: TObject);
procedure Form1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer
);
procedure Form1MouseUp(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Form1MouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
procedure Form1MouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure Form1MouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure Form1Paint(Sender: TObject);
procedure Form1Resize(Sender: TObject);
procedure Form1Shortcut(var Msg: TLMKey; var Handled: Boolean);
procedure Form1Show(Sender: TObject);
procedure Form1UTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char);
public
constructor Create(TheOwner: TComponent); override;
function GetChecks(ACheckGroup: TCheckGroup): string;
end;
{ TForm1 }
procedure TForm1.CheckGroup1ChangeBounds(Sender: TObject);
begin
debugln('TForm1.CheckGroup1ChangeBounds ',DbgSName(Sender),' Bounds=',dbgs(TControl(Sender).BoundsRect));
end;
procedure TForm1.CheckGroup1Click(Sender: TObject);
begin
debugln('TForm1.CheckGroup1Click ',DbgSName(Sender),' '+GetChecks(Sender as TCheckGroup));
end;
procedure TForm1.CheckGroup1DblClick(Sender: TObject);
begin
DebugLn(['TForm1.CheckGroup1DblClick ',DbgSName(Sender)]);
end;
procedure TForm1.CheckGroup1Enter(Sender: TObject);
begin
debugln('TForm1.CheckGroup1Enter ',DbgSName(Sender));
end;
procedure TForm1.CheckGroup1Exit(Sender: TObject);
begin
debugln('TForm1.CheckGroup1Exit ',DbgSName(Sender));
end;
procedure TForm1.CheckGroup1ItemClick(Sender: TObject; Index: integer);
begin
DebugLn(['TForm1.CheckGroup1ItemClick ',DbgSName(Sender),' Index=',Index]);
end;
procedure TForm1.CheckGroup1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
Debugln('TForm1.CheckGroup1KeyDown ',DbgSName(Sender),' Key=',dbgs(Key),
' Shift=',dbgs(Shift),' '+GetChecks(Sender as TCheckGroup));
end;
procedure TForm1.CheckGroup1KeyPress(Sender: TObject; var Key: char);
begin
debugln('TForm1.CheckGroup1KeyPress ',DbgSName(Sender),' Key=',DbgStr(Key),
' ',GetChecks(Sender as TCheckGroup));
end;
procedure TForm1.CheckGroup1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState
);
begin
Debugln('TForm1.CheckGroup1KeyUp ',DbgSName(Sender),' Key=',dbgs(Key),
' Shift=',dbgs(Shift),' ',GetChecks(Sender as TCheckGroup));
end;
procedure TForm1.CheckGroup1MouseDown(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
debugln('TForm1.CheckGroup1MouseDown ',DbgSName(Sender),
' Button=',GetEnumName(TypeInfo(TMouseButton),ord(Button)),
' X=',dbgs(X),' Y=',dbgs(Y),' Shift=',dbgs(Shift),' ',
GetChecks(Sender as TCheckGroup));
end;
procedure TForm1.CheckGroup1MouseEnter(Sender: TObject);
begin
debugln('TForm1.CheckGroup1MouseEnter ',DbgSName(Sender),' ',GetChecks(Sender as TCheckGroup));
end;
procedure TForm1.CheckGroup1MouseLeave(Sender: TObject);
begin
debugln('TForm1.CheckGroup1MouseLeave ',DbgSName(Sender));
end;
procedure TForm1.CheckGroup1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
debugln('TForm1.CheckGroup1MouseMove ',DbgSName(Sender),
' X=',dbgs(X),' Y=',dbgs(Y),' Shift=',dbgs(Shift));
end;
procedure TForm1.CheckGroup1MouseUp(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
debugln('TForm1.CheckGroup1MouseUp ',DbgSName(Sender),
' Button=',GetEnumName(TypeInfo(TMouseButton),ord(Button)),
' X=',dbgs(X),' Y=',dbgs(Y),' Shift=',dbgs(Shift),' ',
GetChecks(Sender as TCheckGroup));
end;
procedure TForm1.CheckGroup1Resize(Sender: TObject);
begin ;
debugln('TForm1.CheckGroup1Resize ',DbgSName(Sender),' Bounds=',dbgs(TControl(Sender).BoundsRect));
end;
procedure TForm1.Form1Activate(Sender: TObject);
begin
debugln('TForm1.Form1Activate ',DbgSName(Sender));
end;
procedure TForm1.Form1ChangeBounds(Sender: TObject);
begin
debugln('TForm1.Form1ChangeBounds ',DbgSName(Sender),' Bounds=',dbgs(BoundsRect));
end;
procedure TForm1.Form1Click(Sender: TObject);
begin
debugln('TForm1.Form1Click ',DbgSName(Sender));
end;
procedure TForm1.Form1Close(Sender: TObject; var CloseAction: TCloseAction);
begin
debugln('TForm1.Form1Close ',DbgSName(Sender),' CloseAction=',
GetEnumName(TypeInfo(TCloseAction),ord(CloseAction)));
end;
procedure TForm1.Form1CloseQuery(Sender: TObject; var CanClose: boolean);
begin
debugln('TForm1.Form1CloseQuery ',DbgSName(Sender),' CanClose',dbgs(CanClose));
end;
procedure TForm1.Form1Create(Sender: TObject);
begin
debugln('TForm1.Form1Create ',DbgSName(Sender));
end;
procedure TForm1.Form1Deactivate(Sender: TObject);
begin
debugln('TForm1.Form1Deactivate ',DbgSName(Sender));
end;
procedure TForm1.Form1Enter(Sender: TObject);
begin
debugln('TForm1.Form1Enter ',DbgSName(Sender));
end;
procedure TForm1.Form1Exit(Sender: TObject);
begin
debugln('TForm1.Form1Exit ',DbgSName(Sender));
end;
function TForm1.Form1Help(Command: Word; Data: Longint; var CallHelp: Boolean
): Boolean;
begin
debugln('TForm1.Form1Help Command=',dbgs(Command),' Data=',HexStr(Cardinal(Data),8),' CallHelp=',dbgs(CallHelp));
Result:=false;
end;
procedure TForm1.Form1Hide(Sender: TObject);
begin
debugln('TForm1.Form1Hide ',DbgSName(Sender));
end;
procedure TForm1.Form1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState
);
begin
Debugln('TForm1.Form1KeyDown ',DbgSName(Sender),' Key=',dbgs(Key),
' Shift=',dbgs(Shift));
end;
procedure TForm1.Form1KeyPress(Sender: TObject; var Key: char);
begin
debugln('TForm1.Form1KeyPress ',DbgSName(Sender),' Key=',DbgStr(Key));
end;
procedure TForm1.Form1MouseDown(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
debugln('TForm1.Form1MouseDown ',DbgSName(Sender),
' Button=',GetEnumName(TypeInfo(TMouseButton),ord(Button)),
' X=',dbgs(X),' Y=',dbgs(Y),' Shift=',dbgs(Shift));
end;
procedure TForm1.Form1MouseEnter(Sender: TObject);
begin
debugln('TForm1.Form1MouseEnter ',DbgSName(Sender));
end;
procedure TForm1.Form1MouseLeave(Sender: TObject);
begin
debugln('TForm1.Form1MouseLeave ',DbgSName(Sender));
end;
procedure TForm1.Form1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
debugln('TForm1.Form1MouseMove ',DbgSName(Sender),
' X=',dbgs(X),' Y=',dbgs(Y),' Shift=',dbgs(Shift));
end;
procedure TForm1.Form1MouseUp(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
debugln('TForm1.Form1MouseUp ',DbgSName(Sender),
' Button=',GetEnumName(TypeInfo(TMouseButton),ord(Button)),
' X=',dbgs(X),' Y=',dbgs(Y),' Shift=',dbgs(Shift));
end;
procedure TForm1.Form1MouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
debugln('TForm1.Form1MouseWheel ',DbgSName(Sender),
' WheelDelta=',dbgs(WheelDelta),' MousePos=',dbgs(MousePos),
' Handled=',dbgs(Handled),' Shift=',dbgs(Shift));
end;
procedure TForm1.Form1MouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
debugln('TForm1.Form1MouseWheelDown ',DbgSName(Sender),
' MousePos=',dbgs(MousePos),
' Handled=',dbgs(Handled),' Shift=',dbgs(Shift));
end;
procedure TForm1.Form1MouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
debugln('TForm1.Form1MouseWheelUp ',DbgSName(Sender),
' MousePos=',dbgs(MousePos),
' Handled=',dbgs(Handled),' Shift=',dbgs(Shift));
end;
procedure TForm1.Form1Paint(Sender: TObject);
begin
debugln('TForm1.Form1Paint ',DbgSName(Sender));
end;
procedure TForm1.Form1Resize(Sender: TObject);
begin
debugln('TForm1.Form1Resize ',DbgSName(Sender),' Bounds=',dbgs(TControl(Sender).BoundsRect));
end;
procedure TForm1.Form1Shortcut(var Msg: TLMKey; var Handled: Boolean);
begin
debugln('TForm1.Form1Shortcut Msg.CharCode=',dbgs(Msg.CharCode),
' Handled=',dbgs(Handled));
end;
procedure TForm1.Form1Show(Sender: TObject);
begin
debugln('TForm1.Form1Show ',DbgSName(Sender));
end;
procedure TForm1.Form1UTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char);
begin
debugln('TForm1.Form1UTF8KeyPress ',DbgSName(Sender),' UTF8Key="',DbgStr(UTF8Key),'"');
end;
constructor TForm1.Create(TheOwner: TComponent);
begin
OnActivate:=@Form1Activate;
OnChangeBounds:=@Form1ChangeBounds;
OnClick:=@Form1Click;
OnClose:=@Form1Close;
OnCloseQuery:=@Form1CloseQuery;
OnCreate:=@Form1Create;
OnDeactivate:=@Form1Deactivate;
OnEnter:=@Form1Enter;
OnExit:=@Form1Exit;
OnHelp:=@Form1Help;
OnHide:=@Form1Hide;
OnKeyDown:=@Form1KeyDown;
OnKeyDown:=@Form1KeyDown;
OnKeyPress:=@Form1KeyPress;
OnMouseDown:=@Form1MouseDown;
OnMouseEnter:=@Form1MouseEnter;
OnMouseLeave:=@Form1MouseLeave;
OnMouseMove:=@Form1MouseMove;
OnMouseUp:=@Form1MouseUp;
OnMouseWheel:=@Form1MouseWheel;
OnMouseWheelDown:=@Form1MouseWheelDown;
OnMouseWheelUp:=@Form1MouseWheelUp;
OnPaint:=@Form1Paint;
OnResize:=@Form1Resize;
OnShortcut:=@Form1Shortcut;
OnShow:=@Form1Show;
OnUTF8KeyPress:=@Form1UTF8KeyPress;
inherited Create(TheOwner);
CheckGroup1:=TCheckGroup.Create(Self);
with CheckGroup1 do begin
Name:='CheckGroup1';
SetBounds(5,10,175,125);
Parent:=Self;
OnChangeBounds:=@CheckGroup1ChangeBounds;
OnClick:=@CheckGroup1Click;
OnDblClick:=@CheckGroup1DblClick;
OnEnter:=@CheckGroup1Enter;
OnExit:=@CheckGroup1Exit;
OnItemClick:=@CheckGroup1ItemClick;
OnKeyDown:=@CheckGroup1KeyDown;
OnKeyPress:=@CheckGroup1KeyPress;
OnKeyUp:=@CheckGroup1KeyUp;
OnMouseDown:=@CheckGroup1MouseDown;
OnMouseMove:=@CheckGroup1MouseMove;
OnMouseUp:=@CheckGroup1MouseUp;
OnResize:=@CheckGroup1Resize;
Items.Text:='First, Second'; //#10'Second'#10'Third'#10'Fourth';
end;
end;
function TForm1.GetChecks(ACheckGroup: TCheckGroup): string;
var
i: Integer;
begin
Result:='';
for i:=0 to ACheckGroup.Items.Count-1 do begin
if i>0 then
Result:=Result+' ';
Result:=Result+ACheckGroup.Items[i]+'=';
if ACheckGroup.Checked[i] then
Result:=Result+'+'
else
Result:=Result+'-';
if ACheckGroup.CheckEnabled[i] then
Result:=Result+'§'
else
Result:=Result+' ';
end;
Result:='['+Result+']';
end;
var
Form1: TForm1 = nil;
begin
Application.Initialize;
Application.CreateForm(TForm1,Form1);
Application.Run;
end.

2
lcl/widgetset/wscontrols.pp
View File

@ -139,7 +139,7 @@ begin
end;
class function TWSWinControl.CreateHandle(const AWinControl: TWinControl;
const AParams: TCreateParams): HWND;
const AParams: TCreateParams): TLCLIntfHandle;
begin
// For now default to the old creation routines
Result := WidgetSet.CreateComponent(AWinControl);