paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-02 15:39:38 +01:00
Code Issues Packages Projects Releases Wiki Activity

added TListWithEvents, fixed codetools adding a colon too much, added lcl test for TPageControl

Browse Source 
git-svn-id: trunk@9477 -
This commit is contained in:
mattias 2006-06-22 18:09:31 +00:00
parent 080df83b4c
commit 7a675dec3a
8 changed files with 303 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -2411,6 +2411,8 @@ lcl/tests/test2_2labelattributes.lpi svneol=native#text/plain
lcl/tests/test2_2labelattributes.lpr svneol=native#text/pascal
lcl/tests/test4_1synedit.lpi svneol=native#text/plain
lcl/tests/test4_1synedit.lpr svneol=native#text/plain
lcl/tests/test4_2pagecontrol.lpi svneol=native#text/plain
lcl/tests/test4_2pagecontrol.lpr svneol=native#text/plain
lcl/tests/test5_1asyncprocess.lpi svneol=native#text/plain
lcl/tests/test5_1asyncprocess.lpr svneol=native#text/plain
lcl/tests/test5_1worker.pas svneol=native#text/plain

11
components/codetools/definetemplates.pas
View File

@ -2726,6 +2726,7 @@ var CmdLine: string;
NewDefTempl: TDefineTemplate;
SrcOS: string;
SrcOS2: String;
Step: String;
begin
//DebugLn('TDefinePool.CreateFPCTemplate PPC386Path="',CompilerPath,'" PPCOptions="',CompilerOptions,'"');
Result:=nil;
@ -2738,6 +2739,7 @@ begin
// find all initial compiler macros and all unit paths
// -> ask compiler with the -vm -vt switch
SetLength(Buf,1024);
Step:='Init';
try
CmdLine:=CompilerPath+' -va ';
if FileExistsCached(EnglishErrorMsgFilename) then
@ -2752,6 +2754,7 @@ begin
TheProcess.CommandLine := CmdLine;
TheProcess.Options:= [poUsePipes, poStdErrToOutPut];
TheProcess.ShowWindow := swoHide;
Step:='Running '+CmdLine;
try
TheProcess.Execute;
OutputLine:='';
@ -2778,7 +2781,7 @@ begin
until OutLen=0;
TheProcess.WaitOnExit;
finally
//DebugLn('TDefinePool.CreateFPCTemplate OutputLine="',OutputLine,'"');
//DebugLn('TDefinePool.CreateFPCTemplate Run with -va: OutputLine="',OutputLine,'"');
TheProcess.Free;
end;
//DebugLn('TDefinePool.CreateFPCTemplate First done UnitSearchPath="',UnitSearchPath,'"');
@ -2793,6 +2796,7 @@ begin
TheProcess.CommandLine := CmdLine;
TheProcess.Options:= [poUsePipes, poStdErrToOutPut];
TheProcess.ShowWindow := swoHide;
Step:='Running '+CmdLine;
try
TheProcess.Execute;
if (TheProcess.Output<>nil) then
@ -2829,6 +2833,7 @@ begin
TheProcess.WaitOnExit;
//DebugLn('TDefinePool.CreateFPCTemplate target OS done');
finally
//DebugLn('TDefinePool.CreateFPCTemplate Run with -iTO: OutputLine="',OutputLine,'"');
TheProcess.Free;
end;
@ -2841,6 +2846,7 @@ begin
TheProcess.CommandLine := CmdLine;
TheProcess.Options:= [poUsePipes, poStdErrToOutPut];
TheProcess.ShowWindow := swoHide;
Step:='Running '+CmdLine;
try
TheProcess.Execute;
if TheProcess.Output<>nil then
@ -2863,6 +2869,7 @@ begin
TheProcess.WaitOnExit;
//DebugLn('TDefinePool.CreateFPCTemplate target CPU done');
finally
//DebugLn('TDefinePool.CreateFPCTemplate Run with -iTP: OutputLine="',OutputLine,'"');
TheProcess.Free;
end;
@ -2876,7 +2883,7 @@ begin
end;
except
on E: Exception do begin
DebugLn('ERROR: TDefinePool.CreateFPCTemplate: ',E.Message);
DebugLn('ERROR: TDefinePool.CreateFPCTemplate (',Step,'): ',E.Message);
end;
end;
if Result<>nil then

3
components/codetools/eventcodetool.pas
View File

@ -199,7 +199,8 @@ begin
SetLength(ResultType,Len);
Move(TypeData^.ParamList[Offset],ResultType[1],Len);
inc(Offset,Len);
Result:=Result+':'+ResultType;
if Result<>'' then
Result:=Result+':'+ResultType;
end;
if phpInUpperCase in Attr then Result:=UpperCaseStr(Result);
Result:=Result+';';

10
lcl/extctrls.pp
View File

@ -39,7 +39,7 @@ uses
type
{ workaround problem with fcl }
TAbstractReader = TReader;
{ TCustomPage }
TPageFlag = (
@ -90,15 +90,17 @@ type
TNBPages = class(TStrings)
private
FPageList: TList;
FPageList: TListWithEvent;
FNotebook: TCustomNotebook;
procedure PageListChange(Ptr: Pointer; AnAction: TListNotification);
protected
function Get(Index: Integer): String; override;
function GetCount: Integer; override;
function GetObject(Index: Integer): TObject; override;
procedure Put(Index: Integer; const S: String); override;
public
constructor Create(thePageList: TList; theNotebook: TCustomNotebook);
constructor Create(thePageList: TListWithEvent;
theNotebook: TCustomNotebook);
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Insert(Index: Integer; const S: String); override;
@ -134,7 +136,7 @@ type
FOptions: TNoteBookOptions;
FPageIndex: Integer;
FPageIndexOnLastChange: integer;
FPageList: TList; // List of TCustomPage
FPageList: TList; // TListWithEvent of TCustomPage
FShowTabs: Boolean;
FTabPosition: TTabPosition;
Procedure CNNotify(var Message: TLMNotify); message CN_NOTIFY;

21
lcl/include/customnotebook.inc
View File

@ -23,14 +23,27 @@
{------------------------------------------------------------------------------
TNBPages Constructor
------------------------------------------------------------------------------}
constructor TNBPages.Create(thePageList: TList; theNotebook: TCustomNotebook);
constructor TNBPages.Create(thePageList: TListWithEvent;
theNotebook: TCustomNotebook);
begin
inherited Create;
// Create the page list and a notebook
fPageList := thePageList;
fPageList.OnChange:=@PageListChange;
fNotebook := theNotebook;
end;
{------------------------------------------------------------------------------
procedure TNBPages.PageListChange(Ptr: Pointer; AnAction: TListNotification);
------------------------------------------------------------------------------}
procedure TNBPages.PageListChange(Ptr: Pointer; AnAction: TListNotification);
begin
if (AnAction=lnAdded) then begin
(TObject(Ptr) as TCustomPage).Parent:=fNotebook;
end else if (AnAction=lnDeleted) then begin
(TObject(Ptr) as TCustomPage).Parent:=nil;
end;
end;
{------------------------------------------------------------------------------
TNBPages Get
------------------------------------------------------------------------------}
@ -191,9 +204,9 @@ begin
fCompStyle := csNoteBook;
fPageList := TList.Create;
fPageList := TListWithEvent.Create;
fAccess := TNBPages.Create(fPageList, Self);
fAccess := TNBPages.Create(TListWithEvent(fPageList), Self);
fPageIndex := -1;
FLoadedPageIndex:=-1;

22
lcl/lcltype.pp
View File

@ -2122,6 +2122,20 @@ const
);
type
TListChangeEvent = procedure(Ptr: Pointer; AnAction: TListNotification) of object;
{ TListWithEvent }
TListWithEvent = class(TList)
private
FOnChange: TListChangeEvent;
protected
procedure Notify(Ptr: Pointer; AnAction: TListNotification); override;
public
property OnChange: TListChangeEvent read FOnChange write FOnChange;
end;
const
csNone = 0;
csAlignment = 1;
@ -2476,4 +2490,12 @@ begin
end;
{ TListWithEvent }
procedure TListWithEvent.Notify(Ptr: Pointer; AnAction: TListNotification);
begin
inherited Notify(Ptr, AnAction);
if Assigned(OnChange) then OnChange(Ptr,AnAction);
end;
end.

46
lcl/tests/test4_2pagecontrol.lpi Normal file
View File

@ -0,0 +1,46 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
<Title Value="test4_1synedit"/>
</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="SynEdit"/>
</Item1>
</RequiredPackages>
<Units Count="1">
<Unit0>
<Filename Value="test4_2pagecontrol.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="test4_2pagecontrol"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

199
lcl/tests/test4_2pagecontrol.lpr Normal file
View File

@ -0,0 +1,199 @@
{
*****************************************************************************
* *
* 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 4_2
Test for TPageControl.
}
program test4_2pagecontrol;
{$mode objfpc}{$H+}
uses
Interfaces, FPCAdds, LCLProc, LCLType, Classes, Controls, Forms, TypInfo,
LMessages, Buttons, ExtCtrls, ComCtrls, Graphics, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
PageControl1: TPageControl;
PagesListBox: TListBox;
ButtonsGroupBox: TGroupBox;
InsertPageLeftButton: TButton;
InsertPageRightButton: TButton;
DeletePageButton: TButton;
MovePageLeftButton: TButton;
MovePageRightButton: TButton;
PageVisibleCheckBox: TCheckBox;
procedure DeletePageButtonClick(Sender: TObject);
procedure Form1Create(Sender: TObject);
procedure InsertPageLeftButtonClick(Sender: TObject);
procedure InsertPageRightButtonClick(Sender: TObject);
procedure MovePageLeftButtonClick(Sender: TObject);
procedure MovePageRightButtonClick(Sender: TObject);
public
constructor Create(TheOwner: TComponent); override;
procedure AddNewPage(Index: integer);
end;
{ TForm1 }
procedure TForm1.Form1Create(Sender: TObject);
begin
debugln('TForm1.Form1Create ',DbgSName(Sender));
SetBounds(50,50,500,400);
PageControl1:=TPageControl.Create(Self);
with PageControl1 do begin
Name:='PageControl1';
Align:=alTop;
Height:=200;
Parent:=Self;
end;
PagesListBox:=TListBox.Create(Self);
with PagesListBox do begin
Name:='PagesListBox';
Align:=alLeft;
Parent:=Self;
end;
ButtonsGroupBox:=TGroupBox.Create(Self);
with ButtonsGroupBox do begin
Name:='ButtonsGroupBox';
Align:=alClient;
Parent:=Self;
end;
InsertPageLeftButton:=TButton.Create(Self);
with InsertPageLeftButton do begin
Name:='InsertPageLeftButton';
Caption:='Insert page left';
AutoSize:=true;
Parent:=ButtonsGroupBox;
OnClick:=@InsertPageLeftButtonClick;
end;
InsertPageRightButton:=TButton.Create(Self);
with InsertPageRightButton do begin
Name:='InsertPageRightButton';
Caption:='Insert page right';
AutoSize:=true;
Parent:=ButtonsGroupBox;
OnClick:=@InsertPageRightButtonClick;
end;
MovePageLeftButton:=TButton.Create(Self);
with MovePageLeftButton do begin
Name:='MovePageLeftButton';
Caption:='move page left';
AutoSize:=true;
Parent:=ButtonsGroupBox;
OnClick:=@MovePageLeftButtonClick;
end;
MovePageRightButton:=TButton.Create(Self);
with MovePageRightButton do begin
Name:='MovePageRightButton';
Caption:='move page right';
AutoSize:=true;
Parent:=ButtonsGroupBox;
OnClick:=@MovePageRightButtonClick;
end;
DeletePageButton:=TButton.Create(Self);
with DeletePageButton do begin
Name:='DeletePageButton';
Caption:='Delete page';
AutoSize:=true;
Parent:=ButtonsGroupBox;
OnClick:=@DeletePageButtonClick;
end;
PageVisibleCheckBox:=TCheckBox.Create(Self);
with PageVisibleCheckBox do begin
Name:='PageVisibleCheckBox';
Caption:='Visible';
AutoSize:=true;
Parent:=ButtonsGroupBox;
end;
ButtonsGroupBox.ChildSizing.ControlsPerLine:=2;
ButtonsGroupBox.ChildSizing.Layout:=cclLeftToRightThenTopToBottom;
end;
procedure TForm1.DeletePageButtonClick(Sender: TObject);
begin
if PageControl1.PageCount=0 then exit;
PageControl1.PageList.Delete(PageControl1.PageIndex);
end;
procedure TForm1.InsertPageLeftButtonClick(Sender: TObject);
begin
AddNewPage(PageControl1.PageIndex);
end;
procedure TForm1.InsertPageRightButtonClick(Sender: TObject);
begin
if PageControl1.PageCount=0 then
AddNewPage(0)
else
AddNewPage(PageControl1.PageIndex+1);
end;
procedure TForm1.MovePageLeftButtonClick(Sender: TObject);
begin
if PageControl1.PageIndex=0 then exit;
PageControl1.PageList.Move(PageControl1.PageIndex,PageControl1.PageIndex-1);
end;
procedure TForm1.MovePageRightButtonClick(Sender: TObject);
begin
if PageControl1.PageIndex<PageControl1.PageCount-1 then exit;
PageControl1.PageList.Move(PageControl1.PageIndex,PageControl1.PageIndex+1);
end;
constructor TForm1.Create(TheOwner: TComponent);
begin
OnCreate:=@Form1Create;
inherited Create(TheOwner);
AddNewPage(0);
AddNewPage(1);
AddNewPage(2);
end;
procedure TForm1.AddNewPage(Index: integer);
var
NewPage: TTabSheet;
NewName: String;
begin
NewPage:=TTabSheet.Create(Self);
NewName:='Page1';
while FindComponent(NewName)<>nil do NewName:=CreateNextIdentifier(NewName);
NewPage.Name:=NewName;
NewPage.Caption:=NewName;
PageControl1.PageList.Insert(Index,NewPage);
end;
var
Form1: TForm1 = nil;
begin
Application.Title:='test4_1synedit';
Application.Initialize;
Application.CreateForm(TForm1,Form1);
Application.Run;
end.