mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 12:23:24 +01:00
531 lines
12 KiB
ObjectPascal
531 lines
12 KiB
ObjectPascal
unit tabs;
|
||
interface
|
||
|
||
uses
|
||
objects,drivers,views;
|
||
|
||
type
|
||
PTabItem = ^TTabItem;
|
||
TTabItem = record
|
||
Next : PTabItem;
|
||
View : PView;
|
||
Dis : boolean;
|
||
end;
|
||
|
||
PTabDef = ^TTabDef;
|
||
TTabDef = record
|
||
Next : PTabDef;
|
||
Name : PString;
|
||
Items : PTabItem;
|
||
DefItem : PView;
|
||
ShortCut : char;
|
||
end;
|
||
|
||
PTab = ^TTab;
|
||
TTab = object(TGroup)
|
||
TabDefs : PTabDef;
|
||
ActiveDef : integer;
|
||
DefCount : word;
|
||
constructor Init(var Bounds: TRect; ATabDef: PTabDef);
|
||
function AtTab(Index: integer): PTabDef; virtual;
|
||
procedure SelectTab(Index: integer); virtual;
|
||
function TabCount: integer;
|
||
function Valid(Command: Word): Boolean; virtual;
|
||
procedure ChangeBounds(var Bounds: TRect); virtual;
|
||
procedure HandleEvent(var Event: TEvent); virtual;
|
||
function GetPalette: PPalette; virtual;
|
||
procedure Draw; virtual;
|
||
procedure SetData(var Rec);virtual;
|
||
procedure GetData(var Rec);virtual;
|
||
procedure SetState(AState: Word; Enable: Boolean); virtual;
|
||
destructor Done; virtual;
|
||
private
|
||
InDraw: boolean;
|
||
end;
|
||
|
||
function NewTabItem(AView: PView; ANext: PTabItem): PTabItem;
|
||
procedure DisposeTabItem(P: PTabItem);
|
||
function NewTabDef(AName: string; ADefItem: PView; AItems: PTabItem; ANext: PTabDef): PTabDef;
|
||
procedure DisposeTabDef(P: PTabDef);
|
||
|
||
|
||
implementation
|
||
|
||
uses
|
||
FvCommon,dialogs;
|
||
|
||
constructor TTab.Init(var Bounds: TRect; ATabDef: PTabDef);
|
||
begin
|
||
inherited Init(Bounds);
|
||
Options:=Options or ofSelectable or ofFirstClick or ofPreProcess or ofPostProcess;
|
||
GrowMode:=gfGrowHiX+gfGrowHiY+gfGrowRel;
|
||
TabDefs:=ATabDef;
|
||
ActiveDef:=-1;
|
||
SelectTab(0);
|
||
ReDraw;
|
||
end;
|
||
|
||
function TTab.TabCount: integer;
|
||
var i: integer;
|
||
P: PTabDef;
|
||
begin
|
||
I:=0; P:=TabDefs;
|
||
while (P<>nil) do
|
||
begin
|
||
Inc(I);
|
||
P:=P^.Next;
|
||
end;
|
||
TabCount:=I;
|
||
end;
|
||
|
||
|
||
function TTab.AtTab(Index: integer): PTabDef;
|
||
var i: integer;
|
||
P: PTabDef;
|
||
begin
|
||
i:=0; P:=TabDefs;
|
||
while (I<Index) do
|
||
begin
|
||
if P=nil then RunError($AA);
|
||
P:=P^.Next;
|
||
Inc(i);
|
||
end;
|
||
AtTab:=P;
|
||
end;
|
||
|
||
procedure TTab.SelectTab(Index: integer);
|
||
var P: PTabItem;
|
||
V: PView;
|
||
begin
|
||
if ActiveDef<>Index then
|
||
begin
|
||
if Owner<>nil then Owner^.Lock;
|
||
Lock;
|
||
{ --- Update --- }
|
||
if TabDefs<>nil then
|
||
begin
|
||
DefCount:=1;
|
||
while AtTab(DefCount-1)^.Next<>nil do Inc(DefCount);
|
||
end
|
||
else DefCount:=0;
|
||
if ActiveDef<>-1 then
|
||
begin
|
||
P:=AtTab(ActiveDef)^.Items;
|
||
while P<>nil do
|
||
begin
|
||
if P^.View<>nil then Delete(P^.View);
|
||
P:=P^.Next;
|
||
end;
|
||
end;
|
||
ActiveDef:=Index;
|
||
P:=AtTab(ActiveDef)^.Items;
|
||
while P<>nil do
|
||
begin
|
||
if P^.View<>nil then Insert(P^.View);
|
||
P:=P^.Next;
|
||
end;
|
||
V:=AtTab(ActiveDef)^.DefItem;
|
||
if V<>nil then V^.Select;
|
||
ReDraw;
|
||
{ --- Update --- }
|
||
UnLock;
|
||
if Owner<>nil then Owner^.UnLock;
|
||
DrawView;
|
||
end;
|
||
end;
|
||
|
||
procedure TTab.ChangeBounds(var Bounds: TRect);
|
||
var D: TPoint;
|
||
procedure DoCalcChange(P: PView); {$ifndef FPC}far;{$endif}
|
||
var
|
||
R: TRect;
|
||
begin
|
||
if P^.Owner=nil then Exit; { it think this is a bug in TV }
|
||
P^.CalcBounds(R, D);
|
||
P^.ChangeBounds(R);
|
||
end;
|
||
var
|
||
P: PTabItem;
|
||
I: integer;
|
||
begin
|
||
D.X := Bounds.B.X - Bounds.A.X - Size.X;
|
||
D.Y := Bounds.B.Y - Bounds.A.Y - Size.Y;
|
||
inherited ChangeBounds(Bounds);
|
||
for I:=0 to TabCount-1 do
|
||
if I<>ActiveDef then
|
||
begin
|
||
P:=AtTab(I)^.Items;
|
||
while P<>nil do
|
||
begin
|
||
if P^.View<>nil then DoCalcChange(P^.View);
|
||
P:=P^.Next;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TTab.HandleEvent(var Event: TEvent);
|
||
var Index : integer;
|
||
I : integer;
|
||
X : integer;
|
||
Len : byte;
|
||
P : TPoint;
|
||
V : PView;
|
||
CallOrig: boolean;
|
||
LastV : PView;
|
||
FirstV: PView;
|
||
function FirstSelectable: PView;
|
||
var
|
||
FV : PView;
|
||
begin
|
||
FV := First;
|
||
while (FV<>nil) and ((FV^.Options and ofSelectable)=0) and (FV<>Last) do
|
||
FV:=FV^.Next;
|
||
if FV<>nil then
|
||
if (FV^.Options and ofSelectable)=0 then FV:=nil;
|
||
FirstSelectable:=FV;
|
||
end;
|
||
function LastSelectable: PView;
|
||
var
|
||
LV : PView;
|
||
begin
|
||
LV := Last;
|
||
while (LV<>nil) and ((LV^.Options and ofSelectable)=0) and (LV<>First) do
|
||
LV:=LV^.Prev;
|
||
if LV<>nil then
|
||
if (LV^.Options and ofSelectable)=0 then LV:=nil;
|
||
LastSelectable:=LV;
|
||
end;
|
||
begin
|
||
if (Event.What and evMouseDown)<>0 then
|
||
begin
|
||
MakeLocal(Event.Where,P);
|
||
if P.Y<3 then
|
||
begin
|
||
Index:=-1; X:=1;
|
||
for i:=0 to DefCount-1 do
|
||
begin
|
||
Len:=CStrLen(AtTab(i)^.Name^);
|
||
if (P.X>=X) and (P.X<=X+Len+1) then Index:=i;
|
||
X:=X+Len+3;
|
||
end;
|
||
if Index<>-1 then
|
||
SelectTab(Index);
|
||
end;
|
||
end;
|
||
if Event.What=evKeyDown then
|
||
begin
|
||
Index:=-1;
|
||
case Event.KeyCode of
|
||
kbTab,kbShiftTab :
|
||
if GetState(sfSelected) then
|
||
begin
|
||
if Current<>nil then
|
||
begin
|
||
LastV:=LastSelectable; FirstV:=FirstSelectable;
|
||
if ((Current=LastV) or (Current=PLabel(LastV)^.Link)) and (Event.KeyCode=kbShiftTab) then
|
||
begin
|
||
if Owner<>nil then Owner^.SelectNext(true);
|
||
end else
|
||
if ((Current=FirstV) or (Current=PLabel(FirstV)^.Link)) and (Event.KeyCode=kbTab) then
|
||
begin
|
||
Lock;
|
||
if Owner<>nil then Owner^.SelectNext(false);
|
||
UnLock;
|
||
end else
|
||
SelectNext(Event.KeyCode=kbShiftTab);
|
||
ClearEvent(Event);
|
||
end;
|
||
end;
|
||
else
|
||
for I:=0 to DefCount-1 do
|
||
begin
|
||
if Upcase(GetAltChar(Event.KeyCode))=AtTab(I)^.ShortCut
|
||
then begin
|
||
Index:=I;
|
||
ClearEvent(Event);
|
||
Break;
|
||
end;
|
||
end;
|
||
end;
|
||
if Index<>-1 then
|
||
begin
|
||
Select;
|
||
SelectTab(Index);
|
||
V:=AtTab(ActiveDef)^.DefItem;
|
||
if V<>nil then V^.Focus;
|
||
end;
|
||
end;
|
||
CallOrig:=true;
|
||
if Event.What=evKeyDown then
|
||
begin
|
||
if ((Owner<>nil) and (Owner^.Phase=phPostProcess) and (GetAltChar(Event.KeyCode)<>#0)) or GetState(sfFocused)
|
||
then
|
||
else CallOrig:=false;
|
||
end;
|
||
if CallOrig then inherited HandleEvent(Event);
|
||
end;
|
||
|
||
function TTab.GetPalette: PPalette;
|
||
begin
|
||
GetPalette:=nil;
|
||
end;
|
||
|
||
procedure TTab.Draw;
|
||
var B : TDrawBuffer;
|
||
i : integer;
|
||
C1,C2,C3,C : word;
|
||
HeaderLen : integer;
|
||
X,X2 : integer;
|
||
Name : PString;
|
||
ActiveKPos : integer;
|
||
ActiveVPos : integer;
|
||
FC : char;
|
||
procedure SWriteBuf(X,Y,W,H: integer; var Buf);
|
||
var i: integer;
|
||
begin
|
||
if Y+H>Size.Y then H:=Size.Y-Y;
|
||
if X+W>Size.X then W:=Size.X-X;
|
||
if Buffer=nil then WriteBuf(X,Y,W,H,Buf)
|
||
else for i:=1 to H do
|
||
Move(Buf,Buffer^[X+(Y+i-1)*Size.X],W*2);
|
||
end;
|
||
procedure ClearBuf;
|
||
begin
|
||
MoveChar(B,' ',C1,Size.X);
|
||
end;
|
||
begin
|
||
if InDraw then Exit;
|
||
InDraw:=true;
|
||
{ - Start of TGroup.Draw - }
|
||
{ if Buffer = nil then
|
||
begin
|
||
GetBuffer;
|
||
end; }
|
||
{ - Start of TGroup.Draw - }
|
||
|
||
C1:=GetColor(1);
|
||
C2:=(GetColor(7) and $f0 or $08)+GetColor(9)*256;
|
||
C3:=GetColor(8)+GetColor({9}8)*256;
|
||
|
||
{ Calculate the size of the headers }
|
||
HeaderLen:=0;
|
||
for i:=0 to DefCount-1 do
|
||
HeaderLen:=HeaderLen+CStrLen(AtTab(i)^.Name^)+3;
|
||
Dec(HeaderLen);
|
||
if HeaderLen>Size.X-2 then HeaderLen:=Size.X-2;
|
||
|
||
{ --- 1. sor --- }
|
||
ClearBuf; MoveChar(B[0],'<27>',C1,1); MoveChar(B[HeaderLen+1],'<27>',C1,1);
|
||
X:=1;
|
||
for i:=0 to DefCount-1 do
|
||
begin
|
||
Name:=AtTab(i)^.Name; X2:=CStrLen(Name^);
|
||
if i=ActiveDef
|
||
then begin
|
||
ActiveKPos:=X-1;
|
||
ActiveVPos:=X+X2+2;
|
||
if GetState(sfFocused) then C:=C3 else C:=C2;
|
||
end
|
||
else C:=C2;
|
||
MoveCStr(B[X],' '+Name^+' ',C); X:=X+X2+3;
|
||
MoveChar(B[X-1],'<27>',C1,1);
|
||
end;
|
||
SWriteBuf(0,1,Size.X,1,B);
|
||
|
||
{ --- 0. sor --- }
|
||
ClearBuf; MoveChar(B[0],'<27>',C1,1);
|
||
X:=1;
|
||
for i:=0 to DefCount-1 do
|
||
begin
|
||
if I<ActiveDef then FC:='<27>'
|
||
else FC:='<27>';
|
||
X2:=CStrLen(AtTab(i)^.Name^)+2;
|
||
MoveChar(B[X+X2],{'<27>'}FC,C1,1);
|
||
if i=DefCount-1 then X2:=X2+1;
|
||
if X2>0 then
|
||
MoveChar(B[X],'<27>',C1,X2);
|
||
X:=X+X2+1;
|
||
end;
|
||
MoveChar(B[HeaderLen+1],'<27>',C1,1);
|
||
MoveChar(B[ActiveKPos],'<27>',C1,1); MoveChar(B[ActiveVPos],'<27>',C1,1);
|
||
SWriteBuf(0,0,Size.X,1,B);
|
||
|
||
{ --- 2. sor --- }
|
||
MoveChar(B[1],'<27>',C1,Max(HeaderLen,0)); MoveChar(B[HeaderLen+2],'<27>',C1,Max(Size.X-HeaderLen-3,0));
|
||
MoveChar(B[Size.X-1],'<27>',C1,1);
|
||
MoveChar(B[ActiveKPos],'<27>',C1,1);
|
||
if ActiveDef=0 then MoveChar(B[0],'<27>',C1,1)
|
||
else MoveChar(B[0],{'<27>'}'<27>',C1,1);
|
||
MoveChar(B[HeaderLen+1],'<27>'{'<27>'},C1,1); MoveChar(B[ActiveVPos],'<27>',C1,1);
|
||
MoveChar(B[ActiveKPos+1],' ',C1,Max(ActiveVPos-ActiveKPos-1,0));
|
||
SWriteBuf(0,2,Size.X,1,B);
|
||
|
||
{ --- marad<61>k sor --- }
|
||
ClearBuf; MoveChar(B[0],'<27>',C1,1); MoveChar(B[Size.X-1],'<27>',C1,1);
|
||
SWriteBuf(0,3,Size.X,Size.Y-4,B);
|
||
|
||
{ --- Size.X . sor --- }
|
||
MoveChar(B[0],'<27>',C1,1); MoveChar(B[1],'<27>',C1,Max(Size.X-2,0)); MoveChar(B[Size.X-1],'<27>',C1,1);
|
||
SWriteBuf(0,Size.Y-1,Size.X,1,B);
|
||
|
||
{ - End of TGroup.Draw - }
|
||
if Buffer <> nil then
|
||
begin
|
||
Lock;
|
||
Redraw;
|
||
UnLock;
|
||
end;
|
||
if Buffer <> nil then
|
||
WriteBuf(0, 0, Size.X, Size.Y, Buffer^)
|
||
else
|
||
Redraw;
|
||
{ - End of TGroup.Draw - }
|
||
InDraw:=false;
|
||
end;
|
||
|
||
function TTab.Valid(Command: Word): Boolean;
|
||
var PT : PTabDef;
|
||
PI : PTabItem;
|
||
OK : boolean;
|
||
begin
|
||
OK:=true;
|
||
PT:=TabDefs;
|
||
while (PT<>nil) and (OK=true) do
|
||
begin
|
||
PI:=PT^.Items;
|
||
while (PI<>nil) and (OK=true) do
|
||
begin
|
||
if PI^.View<>nil then OK:=OK and PI^.View^.Valid(Command);
|
||
PI:=PI^.Next;
|
||
end;
|
||
PT:=PT^.Next;
|
||
end;
|
||
Valid:=OK;
|
||
end;
|
||
|
||
|
||
procedure TTab.SetData(var Rec);
|
||
type
|
||
Bytes = array[0..65534] of Byte;
|
||
var
|
||
I: Sw_Word;
|
||
PT : PTabDef;
|
||
PI : PTabItem;
|
||
begin
|
||
I := 0;
|
||
PT:=TabDefs;
|
||
while (PT<>nil) do
|
||
begin
|
||
PI:=PT^.Items;
|
||
while (PI<>nil) do
|
||
begin
|
||
if PI^.View<>nil then
|
||
begin
|
||
PI^.View^.SetData(Bytes(Rec)[I]);
|
||
Inc(I, PI^.View^.DataSize);
|
||
end;
|
||
PI:=PI^.Next;
|
||
end;
|
||
PT:=PT^.Next;
|
||
end;
|
||
end;
|
||
|
||
|
||
procedure TTab.GetData(var Rec);
|
||
type
|
||
Bytes = array[0..65534] of Byte;
|
||
var
|
||
I: Sw_Word;
|
||
PT : PTabDef;
|
||
PI : PTabItem;
|
||
begin
|
||
I := 0;
|
||
PT:=TabDefs;
|
||
while (PT<>nil) do
|
||
begin
|
||
PI:=PT^.Items;
|
||
while (PI<>nil) do
|
||
begin
|
||
if PI^.View<>nil then
|
||
begin
|
||
PI^.View^.GetData(Bytes(Rec)[I]);
|
||
Inc(I, PI^.View^.DataSize);
|
||
end;
|
||
PI:=PI^.Next;
|
||
end;
|
||
PT:=PT^.Next;
|
||
end;
|
||
end;
|
||
|
||
|
||
procedure TTab.SetState(AState: Word; Enable: Boolean);
|
||
begin
|
||
inherited SetState(AState,Enable);
|
||
if (AState and sfFocused)<>0 then DrawView;
|
||
end;
|
||
|
||
destructor TTab.Done;
|
||
var P,X: PTabDef;
|
||
procedure DeleteViews(P: PView); {$ifndef FPC}far;{$endif}
|
||
begin
|
||
if P<>nil then Delete(P);
|
||
end;
|
||
begin
|
||
ForEach(@DeleteViews);
|
||
inherited Done;
|
||
P:=TabDefs;
|
||
while P<>nil do
|
||
begin
|
||
X:=P^.Next;
|
||
DisposeTabDef(P);
|
||
P:=X;
|
||
end;
|
||
end;
|
||
|
||
|
||
function NewTabItem(AView: PView; ANext: PTabItem): PTabItem;
|
||
var P: PTabItem;
|
||
begin
|
||
New(P); FillChar(P^,SizeOf(P^),0);
|
||
P^.Next:=ANext; P^.View:=AView;
|
||
NewTabItem:=P;
|
||
end;
|
||
|
||
procedure DisposeTabItem(P: PTabItem);
|
||
begin
|
||
if P<>nil then
|
||
begin
|
||
if P^.View<>nil then Dispose(P^.View, Done);
|
||
Dispose(P);
|
||
end;
|
||
end;
|
||
|
||
function NewTabDef(AName: string; ADefItem: PView; AItems: PTabItem; ANext: PTabDef): PTabDef;
|
||
var P: PTabDef;
|
||
x: byte;
|
||
begin
|
||
New(P);
|
||
P^.Next:=ANext; P^.Name:=NewStr(AName); P^.Items:=AItems;
|
||
x:=pos('~',AName);
|
||
if (x<>0) and (x<length(AName)) then P^.ShortCut:=Upcase(AName[x+1])
|
||
else P^.ShortCut:=#0;
|
||
P^.DefItem:=ADefItem;
|
||
NewTabDef:=P;
|
||
end;
|
||
|
||
procedure DisposeTabDef(P: PTabDef);
|
||
var PI,X: PTabItem;
|
||
begin
|
||
DisposeStr(P^.Name);
|
||
PI:=P^.Items;
|
||
while PI<>nil do
|
||
begin
|
||
X:=PI^.Next;
|
||
DisposeTabItem(PI);
|
||
PI:=X;
|
||
end;
|
||
Dispose(P);
|
||
end;
|
||
|
||
end.
|