paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 11:24:16 +01:00
Code Issues Packages Projects Releases Wiki Activity
1ef533ffa9
fpc/ide/fpcodcmp.pas
fpc 790a4fe2d3 * log and id tags removed 
git-svn-id: trunk@42 -
2005-05-21 09:42:41 +00:00

634 lines
18 KiB
ObjectPascal
Raw Blame History

{
This file is part of the Free Pascal Integrated Development Environment
Copyright (c) 1998 by Berczi Gabor
Code Complete routines
See the file COPYING.FPC, 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.
**********************************************************************}
unit FPCodCmp; { CodeComplete }
interface
uses Objects,Drivers,Dialogs,
WEditor,WUtils,WViews;
type
PCodeCompleteWordList = ^TCodeCompleteWordList;
TCodeCompleteWordList = object(TTextCollection)
end;
PCodeCompleteDialog = ^TCodeCompleteDialog;
TCodeCompleteDialog = object(TCenterDialog)
constructor Init;
function Execute: Word; virtual;
procedure HandleEvent(var Event: TEvent); virtual;
private
CodeCompleteLB : PAdvancedListBox;
RB : PRadioButtons;
CB : PCheckBoxes;
MinInputL,InputL : PEditorInputLine;
procedure Add;
procedure Edit;
procedure Delete;
end;
function FPCompleteCodeWord(const WordS: string; var Text: string): boolean;
procedure InitCodeComplete;
function LoadCodeComplete(var S: TStream): boolean;
procedure AddStandardUnitsToCodeComplete;
procedure AddAvailableUnitsToCodeComplete(OnlyStandard : boolean);
function StoreCodeComplete(var S: TStream): boolean;
procedure DoneCodeComplete;
const CodeCompleteWords : PCodeCompleteWordList = nil;
type
TCodeCompleteCase = (ccc_unchanged, ccc_lower, ccc_upper, ccc_mixed);
const
CodeCompleteCase : TCodeCompleteCase = ccc_unchanged;
UnitsCodeCompleteWords : PCodeCompleteWordList = nil;
procedure RegisterCodeComplete;
implementation
uses App,Views,MsgBox,Validate,
FVConsts,
systems, BrowCol,
FPSwitch, FPCompil,
FPVars, FPSymbol,
FPConst,FPString,FPViews;
{$ifndef NOOBJREG}
const
RCodeCompleteWordList: TStreamRec = (
ObjType: 14401;
VmtLink: Ofs(TypeOf(TCodeCompleteWordList)^);
Load: @TCodeCompleteWordList.Load;
Store: @TCodeCompleteWordList.Store
);
{$endif}
function FPCompleteCodeWord(const WordS: string; var Text: string): boolean;
var OK: boolean;
CIndex, Index, i : sw_integer;
St, UpWordS : string;
begin
if ShowOnlyUnique then
UpWordS:=UpCaseStr(WordS);
OK:=Assigned(CodeCompleteWords);
if OK then
begin
Text:=CodeCompleteWords^.Lookup(WordS,CIndex);
OK:=(CIndex<>-1) and (length(Text)<>length(WordS));
Index:=-1;
if OK and ShowOnlyUnique and (CIndex<CodeCompleteWords^.Count-1) then
begin
St:=PString(CodeCompleteWords^.At(CIndex+1))^;
if (UpCaseStr(Copy(St,1,length(WordS)))=UpWordS) then
begin
{if UpCase(st[Length(UpWordS)+1])<>Upcase(Text[Length(UpWordS)+1]) then}
begin
Text:='';
FPCompleteCodeWord:=false;
exit;
(* end
else
{ only give the common part }
begin
i:=Length(UpWordS)+1;
while (i<=length(st)) and (i<=length(text)) and (UpCase(st[i])=Upcase(Text[i])) do
inc(i);
SetLength(Text,i-1); *)
end;
end;
end;
end;
if (ShowOnlyUnique or not OK) and Assigned(UnitsCodeCompleteWords) then
begin
Text:=UnitsCodeCompleteWords^.Lookup(WordS,Index);
OK:=(Index<>-1) and (length(Text)<>length(WordS));
if ShowOnlyUnique and (Index<UnitsCodeCompleteWords^.Count-1) then
begin
St:=PString(UnitsCodeCompleteWords^.At(Index+1))^;
if UpCaseStr(Copy(St,1,length(WordS)))=UpWordS then
begin
{if UpCase(st[Length(UpWordS)+1])<>Upcase(Text[Length(UpWordS)+1]) then}
begin
Text:='';
FPCompleteCodeWord:=false;
exit;
(* end
else
{ only give the common part }
begin
i:=Length(UpWordS)+1;
while (i<=length(st)) and (i<=length(text)) and (UpCase(st[i])=Upcase(Text[i])) do
inc(i);
SetLength(Text,i-1); *)
end;
end;
end;
end;
if ShowOnlyUnique and (Index<>-1) and (CIndex<>-1) then
begin
{St:=PString(CodeCompleteWords^.At(CIndex+1))^;
Was wrong, CIndex+1 could be above count => collection.error
generated RTE 213
if UpCase(st[Length(UpWordS)+1])<>Upcase(Text[Length(UpWordS)+1]) then}
begin
Text:='';
FPCompleteCodeWord:=false;
exit;
(* end
else
{ only give the common part }
begin
i:=Length(UpWordS)+1;
while (i<=length(st)) and (i<=length(text)) and (UpCase(st[i])=Upcase(Text[i])) do
inc(i);
SetLength(Text,i-1); *)
end;
end;
if OK=false then Text:=''
else case CodeCompleteCase of
ccc_upper : Text:=UpcaseStr(Text);
ccc_lower : Text:=LowcaseStr(Text);
ccc_mixed : Text:=UpCase(Text[1])+LowCaseStr(Copy(Text,2,High(Text)));
end;
FPCompleteCodeWord:=OK;
end;
procedure InitCodeComplete;
var I:integer;
S: string;
begin
if Assigned(CodeCompleteWords) then
Dispose(CodeCompleteWords, Done);
New(CodeCompleteWords, Init(10,10));
for I:=0 to GetReservedWordCount-1 do
begin
S:=LowCaseStr(GetReservedWord(I));
if length(S)>=CodeCompleteMinLen then
CodeCompleteWords^.Insert(NewStr(S));
end;
{
there should be also a user front-end for customizing CodeComplete !
any volunteers to implement? ;) - Gabor
}
end;
procedure AddAvailableUnitsToCodeComplete(OnlyStandard : boolean);
var
I : sw_integer;
Overflow: boolean;
Level : longint;
UpStandardUnits : string;
procedure InsertInS(P: PSymbol); {$ifndef FPC}far;{$endif}
procedure InsertItemsInS(P: PSymbolCollection);
var I: Sw_integer;
begin
for I:=0 to P^.Count-1 do
InsertInS(P^.At(I));
end;
Var
st : string;
begin
Inc(level);
if UnitsCodeCompleteWords^.Count=MaxCollectionSize then
begin Overflow:=true; Exit; end;
st:=P^.GetName;
if Length(st)>=CodeCompleteMinLen then
if not ((level=1) and OnlyStandard and (st=UpCaseStr(CodeCompleteUnitName))) then
UnitsCodeCompleteWords^.Insert(NewStr(Lowcasestr(st)));
{ this is wrong because it inserted args or locals of proc
in the globals list !! PM}
if (P^.Items<>nil) and (level=1) and
((not OnlyStandard or (Pos(P^.GetName+',',UpStandardUnits)>0) or
{ don't exclude system unit ... }
(Pos('SYS',P^.GetName)>0))) then
InsertItemsInS(P^.Items);
Dec(level);
end;
begin
if OnlyStandard then
UpStandardunits:=UpCaseStr(StandardUnits)+',';
if IsSymbolInfoAvailable then
begin
if Assigned(UnitsCodeCompleteWords) then
begin
Dispose(UnitsCodeCompleteWords,done);
UnitsCodeCompleteWords:=nil;
end;
New(UnitsCodeCompleteWords, Init(10,10));
level:=0;
Overflow:=false;
BrowCol.Modules^.ForEach(@InsertInS);
{ if Overflow then
WarningBox(msg_toomanysymbolscantdisplayall,nil); }
end;
end;
procedure AddStandardUnitsToCodeComplete;
var
HiddenSource : PSourceWindow;
R : TRect;
StoreBrowserSwitchesConfig : string;
begin
Desktop^.GetExtent(R);
New(HiddenSource,init(R,'*'));
HiddenSource^.NoNameCount:=0;
HiddenSource^.UpdateTitle;
HiddenSource^.Hide;
CompilingHiddenFile:=HiddenSource;
{ compile a dummy file to get symbol info }
with HiddenSource^.Editor^ do
begin
FileName:=CodeCompleteUnitName+'.pp';
Addline('unit '+CodeCompleteUnitName+';');
Addline('interface');
if StandardUnits<>'' then
begin
AddLine('uses');
Addline(StandardUnits);
Addline(' ;');
end;
Addline('implementation');
Addline('end.');
SetModified(true);
// SaveFile;
end;
StoreBrowserSwitchesConfig:=BrowserSwitches^.GetCurrSelParam;
BrowserSwitches^.ReadItemsCfg('+');
DoCompile(cCompile);
BrowserSwitches^.SetCurrSelParam(StoreBrowserSwitchesConfig);
AddAvailableUnitsToCodeComplete(true);
{ Now add the interface declarations to the Code Complete list }
CompilingHiddenFile:=nil;
Dispose(HiddenSource,Done);
end;
function LoadCodeComplete(var S: TStream): boolean;
var C: PCodeCompleteWordList;
OK: boolean;
NewCodeCompleteMinLen : byte;
NewUseStandardUnitsInCodeComplete,
NewUseAllUnitsInCodeComplete,
NewShowOnlyUnique : boolean;
NewCodeCompleteCase : TCodeCompleteCase;
StPtr : PString;
begin
New(C, Load(S));
OK:=Assigned(C) and (S.Status=stOk);
if OK then
begin
if Assigned(CodeCompleteWords) then Dispose(CodeCompleteWords, Done);
CodeCompleteWords:=C;
S.Read(NewCodeCompleteCase,Sizeof(TCodeCompleteCase));
OK:=(S.Status=stOk);
if OK then
CodeCompleteCase:=NewCodeCompleteCase;
{ Old version of Code complete, also OK PM }
if not OK or (S.getPos=S.getSize) then
begin
LoadCodeComplete:=OK;
exit;
end;
if S.Status=stOK then
S.Read(NewUseStandardUnitsInCodeComplete,Sizeof(UseStandardUnitsInCodeComplete));
if S.Status=stOK then
UseStandardUnitsInCodeComplete:=NewUseStandardUnitsInCodeComplete;
if S.Status=stOK then
S.Read(NewUseAllUnitsInCodeComplete,Sizeof(UseAllUnitsInCodeComplete));
if S.Status=stOK then
UseAllUnitsInCodeComplete:=NewUseAllUnitsInCodeComplete;
if S.Status=stOK then
S.Read(NewShowOnlyUnique,Sizeof(ShowOnlyUnique));
if S.Status=stOK then
ShowOnlyUnique:=NewShowOnlyUnique;
if S.Status=stOK then
S.Read(NewCodeCompleteMinLen,Sizeof(CodeCompleteMinLen));
if S.Status=stOK then
CodeCompleteMinLen:=NewCodeCompleteMinLen;
if S.Status=stOK then
StPtr:=S.ReadStr
else
StPtr:=nil;
if (S.Status=stOK) then
StandardUnits:=GetStr(StPtr);
if assigned(StPtr) then
FreeMem(StPtr,Length(StandardUnits)+1);
OK:=S.Status=stOK;
end
else
if Assigned(C) then
Dispose(C, Done);
LoadCodeComplete:=OK;
end;
function StoreCodeComplete(var S: TStream): boolean;
var OK: boolean;
begin
OK:=Assigned(CodeCompleteWords);
if OK then
begin
CodeCompleteWords^.Store(S);
S.Write(CodeCompleteCase,Sizeof(TCodeCompleteCase));
{ New fields added }
S.Write(UseStandardUnitsInCodeComplete,Sizeof(UseStandardUnitsInCodeComplete));
S.Write(UseAllUnitsInCodeComplete,Sizeof(UseAllUnitsInCodeComplete));
S.Write(ShowOnlyUnique,Sizeof(ShowOnlyUnique));
S.Write(CodeCompleteMinLen,Sizeof(CodeCompleteMinLen));
S.WriteStr(@StandardUnits);
OK:=OK and (S.Status=stOK);
end;
StoreCodeComplete:=OK;
end;
procedure DoneCodeComplete;
begin
if Assigned(CodeCompleteWords) then
begin
Dispose(CodeCompleteWords, Done);
CodeCompleteWords:=nil;
end;
if Assigned(UnitsCodeCompleteWords) then
begin
Dispose(UnitsCodeCompleteWords,done);
UnitsCodeCompleteWords:=nil;
end;
end;
constructor TCodeCompleteDialog.Init;
var R,R2,R3: TRect;
Items: PSItem;
SB: PScrollBar;
begin
R.Assign(0,0,50,22);
inherited Init(R,dialog_codecomplete);
HelpCtx:=hcCodeCompleteOptions;
{ name list dialog }
GetExtent(R); R.Grow(-3,-2); Inc(R.A.Y); R3.Copy(R); Dec(R.B.X,12);
Dec(R.B.Y,7);
R2.Copy(R); R2.Move(1,0); R2.A.X:=R2.B.X-1;
New(SB, Init(R2)); Insert(SB);
New(CodeCompleteLB, Init(R,1,SB));
Insert(CodeCompleteLB);
R2.Copy(R); R2.Move(0,-1); R2.B.Y:=R2.A.Y+1; Dec(R2.A.X);
Insert(New(PLabel, Init(R2, label_codecomplete_keywords, CodeCompleteLB)));
{ Case choice }
R.Copy(R3); Dec(R.B.Y,2); R.A.Y:=R.B.Y-4; Inc(R.A.X); R.B.X:=R.A.X+15;
Items:=NewSItem('Unc~h~anged',
NewSItem('~L~ower',
NewSItem('~U~pper',
NewSItem('~M~ixed',nil))));
RB:=New(PRadioButtons,Init(R,Items));
RB^.SetData(ord(CodeCompleteCase));
R2.Copy(R); R2.Move(0,-1); R2.B.Y:=R2.A.Y+1; Dec(R2.A.X);
Insert(New(PLabel, Init(R2, 'Case handling', RB)));
Insert(RB);
{ Mininum length inputline }
R.Copy(R3); R.A.Y:=R.B.Y-7;R.B.Y:=R.A.Y+1; Dec(R.B.X); R.A.X:=R.B.X -5;
New(MinInputL, Init(R,5));
MinInputL^.SetValidator(New(PRangeValidator, Init(1,255)));
Insert(MinInputL);
R2.Copy(R); R2.A.X:=20;Dec(R2.B.X,5);
Insert(New(PLabel, Init(R2, 'Min. length', MinInputL)));
{ Standard/all units booleans }
Items:=nil;
Items:=NewSItem('Add standard units', Items);
Items:=NewSItem('Add all units', Items);
Items:=NewSItem('Show only unique', Items);
R.Copy(R3); R.A.Y:=R.B.Y-5;R.B.Y:=R.A.Y+3; Inc(R.A.X,18); Dec(R.B.X);
New(CB, Init(R, Items));
Insert(CB);
R2.Copy(R); R2.Move(0,-1); R2.B.Y:=R2.A.Y+1; Dec(R2.A.X);
Insert(New(PLabel, Init(R2, 'Unit handling', CB)));
R2.Copy(R); R2.Move(0,-1); R2.B.Y:=R2.A.Y+1;
If ShowOnlyUnique then
CB^.Press(0);
If UseAllUnitsInCodeComplete then
CB^.Press(1);
If UseStandardUnitsInCodeComplete then
CB^.Press(2);
{ Standard unit name boolean }
R.Copy(R3); R.A.Y:=R.B.Y-1; Inc(R.A.X); Dec(R.B.X);
New(InputL,Init(R,255));
Insert(InputL);
InputL^.SetValidator(New(PFilterValidator,Init(NumberChars+AlphaChars+[','])));
R2.Copy(R); R2.Move(0,-1); R2.B.Y:=R2.A.Y+1; Dec(R2.A.X);R2.B.X:=R2.A.X+25;
Insert(New(PLabel, Init(R2, '~S~tandard unit list', InputL)));
R.Copy(R3); R.A.X:=R.B.X-10; R.B.Y:=R.A.Y+2;
Insert(New(PButton, Init(R, button_OK, cmOK, bfNormal)));
R.Move(0,2);
Insert(New(PButton, Init(R, button_Edit, cmEditItem, bfDefault)));
R.Move(0,2);
Insert(New(PButton, Init(R, button_New, cmAddItem, bfNormal)));
R.Move(0,2);
Insert(New(PButton, Init(R, button_Delete, cmDeleteItem, bfNormal)));
R.Move(0,2);
Insert(New(PButton, Init(R, button_Cancel, cmCancel, bfNormal)));
SelectNext(false);
end;
procedure TCodeCompleteDialog.HandleEvent(var Event: TEvent);
var DontClear: boolean;
begin
case Event.What of
evKeyDown :
begin
DontClear:=false;
case Event.KeyCode of
kbIns :
Message(@Self,evCommand,cmAddItem,nil);
kbDel :
Message(@Self,evCommand,cmDeleteItem,nil);
else DontClear:=true;
end;
if DontClear=false then ClearEvent(Event);
end;
evBroadcast :
case Event.Command of
cmListItemSelected :
if Event.InfoPtr=pointer(CodeCompleteLB) then
Message(@Self,evCommand,cmEditItem,nil);
end;
evCommand :
begin
DontClear:=false;
case Event.Command of
cmAddItem : Add;
cmDeleteItem : Delete;
cmEditItem : Edit;
else DontClear:=true;
end;
if DontClear=false then ClearEvent(Event);
end;
end;
inherited HandleEvent(Event);
end;
function TCodeCompleteDialog.Execute: Word;
var R: word;
C: PCodeCompleteWordList;
NewVal, I: integer;
NewValStr : string;
begin
New(C, Init(10,20));
if Assigned(CodeCompleteWords) then
for I:=0 to CodeCompleteWords^.Count-1 do
C^.Insert(NewStr(GetStr(CodeCompleteWords^.At(I))));
CodeCompleteLB^.NewList(C);
InputL^.SetData(StandardUnits);
NewValStr:=IntToStr(CodeCompleteMinLen);
MinInputL^.SetData(NewValStr);
R:=inherited Execute;
if R=cmOK then
begin
if Assigned(CodeCompleteWords) then Dispose(CodeCompleteWords, Done);
CodeCompleteWords:=C;
CodeCompleteCase:=TCodeCompleteCase(RB^.Value);
MinInputL^.GetData(NewValStr);
NewVal:=StrToInt(NewValStr);
if (NewVal>0) and (NewVal<>CodeCompleteMinLen) then
begin
CodeCompleteMinLen:=NewVal;
InitCodeComplete;
end;
ShowOnlyUnique:=CB^.Mark(0);
UseAllUnitsInCodeComplete:=CB^.Mark(1);
UseStandardUnitsInCodeComplete:=CB^.Mark(2);
if UseStandardUnitsInCodeComplete and (not UseAllUnitsInCodeComplete or not assigned(UnitsCodeCompleteWords)) and
((StandardUnits<>GetStr(InputL^.Data)) or not assigned(UnitsCodeCompleteWords)) then
begin
InputL^.GetData(StandardUnits);
AddStandardUnitsToCodeComplete;
end
else
InputL^.GetData(StandardUnits);
end
else
Dispose(C, Done);
Execute:=R;
end;
procedure TCodeCompleteDialog.Add;
var IC: boolean;
S: string;
P: PString;
Cmd: word;
CanExit: boolean;
I: sw_integer;
begin
IC:=CodeCompleteLB^.Range=0;
if IC=false then
S:=GetStr(CodeCompleteLB^.List^.At(CodeCompleteLB^.Focused))
else
S:='';
repeat
Cmd:=InputBox(dialog_codecomplete_add,label_codecomplete_add_keyword,S,255);
CanExit:=Cmd<>cmOK;
if CanExit=false then
begin
CanExit:=PCodeCompleteWordList(CodeCompleteLB^.List)^.Search(@S,I)=false;
if CanExit=false then
begin
ClearFormatParams; AddFormatParamStr(S);
ErrorBox(msg_codecomplete_alreadyinlist,@FormatParams);
end;
end;
until CanExit;
if Cmd=cmOK then
begin
P:=NewStr(S);
with CodeCompleteLB^ do
begin
List^.Insert(P);
SetRange(List^.Count);
SetFocusedItem(P);
end;
ReDraw;
end;
end;
procedure TCodeCompleteDialog.Edit;
var S: string;
I,T: sw_integer;
Cmd: word;
CanExit: boolean;
P: PString;
begin
if CodeCompleteLB^.Range=0 then Exit;
I:=CodeCompleteLB^.Focused;
S:=GetStr(CodeCompleteLB^.List^.At(I));
repeat
Cmd:=InputBox(dialog_codecomplete_edit,label_codecomplete_edit_keyword,S,255);
CanExit:=Cmd<>cmOK;
if CanExit=false then
begin
CanExit:=PCodeCompleteWordList(CodeCompleteLB^.List)^.Search(@S,T)=false;
CanExit:=CanExit or (T=I);
if CanExit=false then
begin
ClearFormatParams; AddFormatParamStr(S);
ErrorBox(msg_codecomplete_alreadyinlist,@FormatParams);
end;
end;
until CanExit;
if Cmd=cmOK then
begin
P:=NewStr(S);
with CodeCompleteLB^ do
begin
List^.AtFree(I);
List^.Insert(P);
SetFocusedItem(P);
end;
ReDraw;
end;
end;
procedure TCodeCompleteDialog.Delete;
begin
if CodeCompleteLB^.Range=0 then Exit;
CodeCompleteLB^.List^.AtFree(CodeCompleteLB^.Focused);
CodeCompleteLB^.SetRange(CodeCompleteLB^.List^.Count);
ReDraw;
end;
procedure RegisterCodeComplete;
begin
{$ifndef NOOBJREG}
RegisterType(RCodeCompleteWordList);
{$endif}
end;
END.
Reference in New Issue View Git Blame Copy Permalink