paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-05 19:32:43 +02:00
Code Issues Packages Projects Releases Wiki Activity
aa0082f22c
lazarus/components/exampleswindow/ulaz_examples.pas

570 lines
20 KiB
ObjectPascal
Raw Blame History

unit uLaz_Examples;
{
**********************************************************************
This file is part of a Lazarus Package, Examples Window.
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
**********************************************************************
This unit displays all the examples that it can find metadata for. At present it
looks in the LazarusDir and then the LazConfigDir (but can be made to look online).
It scans the examples and makes Catagory Checkboxes for all the Categories it finds.
In OnLine mode, will look for a master meta file in LazConfigDir/examples
If its not there, it will try to download one from Remote.
In either case will scan the LazConfigDir (excluding Examples ???) looking for
potential 'other' example projects, recognisable by a valid json file with an
extension of ex-meta.
David Bannon, Dec 2022
}
{$mode objfpc}{$H+}
{X$define EXTESTMODE}
{X$define ONLINE_EXAMPLES}
interface
uses
Classes, SysUtils,
LazFileUtils, fileutil, LazLoggerBase,
LCLType, LCLIntf, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls,
ExtCtrls, Buttons,
{$ifndef EXTESTMODE}
IDEImagesIntf,
IDEWindowIntf,
{$endif}
uexampledata, uConst;
type
{ TFormLazExam }
TFormLazExam = class(TForm)
ButtonView: TButton;
ButtonDownload: TButton;
ButtonClose: TButton;
ButtonOpen: TButton;
CheckGroupCategory: TCheckGroup;
EditSearch: TEdit;
ListView1: TListView;
Memo1: TMemo;
ClearSearchButton: TSpeedButton;
Splitter2: TSplitter;
StatusBar1: TStatusBar;
procedure ButtonCloseClick(Sender: TObject);
procedure ButtonDownloadClick(Sender: TObject);
procedure ButtonOpenClick(Sender: TObject);
procedure ButtonViewClick(Sender: TObject);
procedure CheckGroupCategoryDblClick(Sender: TObject);
procedure CheckGroupCategoryItemClick(Sender: TObject; {%H-}Index: integer);
procedure ClearSearchButtonClick(Sender: TObject);
procedure EditSearchChange(Sender: TObject);
procedure EditSearchEnter(Sender: TObject);
procedure EditSearchKeyDown(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormShow(Sender: TObject);
procedure ListView1Click(Sender: TObject);
procedure ListView1DblClick(Sender: TObject);
procedure ListView1Enter(Sender: TObject);
procedure ListView1Exit(Sender: TObject);
procedure ListView1KeyDown(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState);
procedure ListView1KeyPress(Sender: TObject; var Key: char);
procedure ListView1SelectItem(Sender: TObject; {%H-}Item: TListItem; {%H-}Selected: Boolean);
private
MoveFocusKey : char;
LastListViewIndex : integer; // If 0 or greater, its an index to ListView
procedure BuildSearchList(SL: TStringList; const Term: AnsiString);
// Copies the passed ex dir to a dir named for the Proj.
// SrcDir includes name of actual dir, DestDir does not.
function CopyFiles(const Proj, SrcDir, DestDir: string): boolean;
// Checks for existance of passed path, the last element of which is case Insensitive.
// Returns with the actual name of the full path if successful.
function DirExistsCaseInSense(const APath: string; out ActualFullDir: string) : boolean;
// Passed the Full Path (with or without trailing delim) to a Project Dir, rets F if not
// present, T if Dir exists. If it finds an lpi file, rets with FFilename, else empty string.
// WriteProjectToOpen will cause a download / copy of the files.
// Sets the Regional Var, ProjectToOpen if WriteProjectToOpen is true.
// Thats triggers a Lazarus Open when this window closes.
function GetProjectFile(const APath: string; WriteProjectToOpen: boolean = false): boolean;
procedure KeyWordSearch;
procedure NewLVItem(const Proj, Path, KeyWords, Cat: string);
// Displays the current content of Examples List in the listview and
// populates the Category checkboxes.
procedure LoadUpListView();
procedure PrimeCatFilter;
public
GitDir : string; // Not needed in Lazarus Package, used in dev's tool emt
LazConfigDir : string; // We will look for Laz config here.
ExamplesHome : string; // Defaults to LazConfig but user settable
RemoteRepo : string; // This is the full gitlab URL
ProjectToOpen : string; // If not empty after close, open the project named.
end;
var
FormLazExam: TFormLazExam;
Ex : TExampleData;
implementation
{$R *.lfm}
{ TFormLazExam }
// ------------------------ L I S T V I E W ----------------------------------
procedure TFormLazExam.NewLVItem(const Proj, Path, KeyWords, Cat : string);
var
TheItem : TListItem;
begin
TheItem := ListView1.Items.Add;
TheItem.Caption := Proj;
TheItem.SubItems.Add(KeyWords);
TheItem.SubItems.Add(Path);
TheItem.SubItems.Add(Cat);
end;
procedure TFormLazExam.ListView1SelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
begin
ListView1Click(Sender);
end;
procedure TFormLazExam.LoadUpListView();
var
Proj, Cat, Path, KeyW : string;
Cnt : integer = 0;
KeyList : TStringList = nil;
begin
Screen.Cursor := crHourGlass;
KeyList := TStringList.Create;
ListView1.BeginUpdate;
try
BuildSearchList(KeyList, EditSearch.Text);
if Ex.GetListData(Proj, Cat, Path, KeyW, True, KeyList) then begin
NewLVItem(Proj, Path, KeyW, Cat);
inc(Cnt);
end;
while Ex.GetListData(Proj, Cat, Path, KeyW, False, KeyList) do begin
NewLVItem(Proj, Path, KeyW, Cat);
inc(Cnt);
end;
finally
KeyList.Free;
Screen.Cursor := crDefault;
ListView1.EndUpdate;
end;
ButtonOpen.Enabled := false;
ButtonDownLoad.enabled := false;
ButtonView.enabled := false;
Memo1.append(format(rsFoundExampleProjects, [Cnt]));
StatusBar1.SimpleText := format(rsFoundExampleProjects, [Cnt]);
LastListViewIndex := -1; // start afresh
end;
procedure TFormLazExam.ListView1Click(Sender: TObject);
begin
if ListView1.Selected = nil then exit; // White space below entries ....
Memo1.Clear;
Memo1.append(ListView1.Selected.SubItems[1]);
Memo1.append('');
Memo1.Append(Ex.GetDesc(ListView1.Selected.SubItems[1] + ListView1.Selected.Caption));
// ListView1.Selected.Caption may be CamelCase from JSON.Name rather than path where we found it.
ButtonDownLoad.enabled := true;
ButtonView.enabled := true;
//ButtonOpen.Enabled := GetProjectFile(ListView1.Selected.SubItems[1]);
ButtonOpen.Enabled := GetProjectFile(Ex.ExampleWorkingDir() + ListView1.Selected.Caption);
end;
procedure TFormLazExam.ListView1DblClick(Sender: TObject);
// A doubleclick will select that row, but it happens after OnEnter.
begin
if ListView1.Selected = Nil then exit
else
LastListViewIndex := ListView1.ItemIndex; // So other methods can find user choice
ButtonDownloadClick(self);
ButtonOpenClick(self);
end;
procedure TFormLazExam.ListView1Enter(Sender: TObject);
begin
ListView1.ItemIndex := LastListViewIndex; // possibly -1, half highlight item 0
end;
procedure TFormLazExam.ListView1Exit(Sender: TObject);
begin
LastListViewIndex := ListView1.ItemIndex; // save it before we leave, we'll be back
ListView1.ClearSelection;
ListView1.ItemIndex := -1;
end;
procedure TFormLazExam.ListView1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_RETURN then begin
Key := 0;
// Its possible we tabbed into ListView without "selecting" a row.
if ListView1.ItemIndex < 0 then // I don't think this can happen anymore ?
if ListView1.Items.count > 0 then
ListView1.ItemIndex := 0 // Force select first item, its half highlite ??
else
Exit;
ListView1DblClick(Sender);
end;
end;
procedure TFormLazExam.ListView1KeyPress(Sender: TObject; var Key: char);
begin
MoveFocusKey := Key;
Key := char(0);
EditSearch.SetFocus;
end;
// --------------------- B U T T O N S -----------------------------------------
procedure TFormLazExam.ButtonOpenClick(Sender: TObject);
begin
if LastListViewIndex < 0 then exit;
ListView1.ItemIndex:= LastListViewIndex;
if GetProjectFile(Ex.ExampleWorkingDir() + ListView1.Selected.Caption, True) // Sets ProjectToOpen on success
and ProjectToOpen.IsEmpty then
showmessage(rsExNoProjectFile)
else
close;
end;
procedure TFormLazExam.ButtonDownloadClick(Sender: TObject);
begin
if LastListViewIndex < 0 then exit; // Can that happen ?
ListView1.ItemIndex:= LastListViewIndex;
if GetProjectFile(Ex.ExampleWorkingDir() + ListView1.Selected.Caption) then begin
if Application.MessageBox(pchar(rsRefreshExistingExample)
, pchar(ListView1.Selected.Caption)
, MB_ICONQUESTION + MB_YESNO) <> IDYES then exit;
// OK - we overwrite. Any other files user has added are not removed
end;
Screen.Cursor := crHourGlass;
try
if Ex <> nil then begin
{$ifdef ONLINE_EXAMPLES}
StatusBar1.SimpleText := rsExDownloadingProject;
Application.ProcessMessages;
EX.DownLoadDir(ListView1.Selected.SubItems[1]);
StatusBar1.SimpleText := rsExProjectDownloadedTo + ' ' + Ex.MasterMeta(True)
+ ListView1.Selected.Caption;
{$else}
StatusBar1.SimpleText := rsExCopyingProject;
Application.ProcessMessages;
if copyFiles( ListView1.Selected.Caption,
ListView1.Selected.SubItems[1], Ex.ExampleWorkingDir()) then
StatusBar1.SimpleText := rsExProjectCopiedTo + ' ' + Ex.ExampleWorkingDir()
+ ListView1.Selected.Caption
else StatusBar1.SimpleText := rsFailedToCopyFilesTo + ' ' + Ex.ExampleWorkingDir();
{$endif}
end;
finally
Screen.Cursor := crDefault;
end;
ButtonOpen.Enabled := GetProjectFile(Ex.ExampleWorkingDir() + ListView1.Selected.Caption);
ListView1.ItemIndex := -1; // Unselect again for the Tabbers of this world.
end;
procedure TFormLazExam.ButtonViewClick(Sender: TObject);
begin
// When we get here, we will have left the ListView and therefore triggered its onExit
// Must restore its selected before we access it !
if LastListViewIndex < 0 then exit; // lets not be silly
ListView1.ItemIndex:= LastListViewIndex;
OpenURL(BaseURL + ListView1.Selected.SubItems[2] + '/' + ListView1.Selected.Caption);
ListView1.ItemIndex := -1;
end;
procedure TFormLazExam.ButtonCloseClick(Sender: TObject);
begin
Close;
end;
function TFormLazExam.CopyFiles(const Proj, SrcDir, DestDir : string) : boolean;
var
STL : TStringList;
St : string;
ChopOff : integer;
begin
ChopOff := length(AppendPathDelim(SrcDir));
if not ForceDirectoriesUTF8(DestDir + Proj) then exit(False);
STL := FindAllDirectories(SrcDir, True);
for St in STL do
// note the copy process leaves a leading Pathdelim, good, I think...
if not ForceDirectoriesUTF8(DestDir + Proj + copy(St, ChopOff, 1000)) then exit(False);
STL.Free;
STL := FindAllFiles(SrcDir, AllFilesMask, True, faAnyFile);
for St in STL do begin
if not copyfile(St, DestDir + Proj + copy(St, ChopOff, 1000)) then exit(False);
//debugln('TFormLazExam.CopyFiles Copy ' + ST + #10 + ' to ' + DestDir + Proj + copy(St, ChopOff, 1000)); // DRB
end;
STL.Free;
end;
// ----------------------- Check Boxes -----------------------------------------
procedure TFormLazExam.CheckGroupCategoryDblClick(Sender: TObject);
var
i : integer;
begin
for i := 0 to CheckGroupCategory.Items.Count -1 do
CheckGroupCategory.Checked[i] := not CheckGroupCategory.Checked[i];
CheckGroupCategoryItemClick(Sender, 0);
end;
procedure TFormLazExam.CheckGroupCategoryItemClick(Sender: TObject; Index: integer);
begin
if Ex = Nil then exit;
Memo1.clear;
ListView1.Clear;
PrimeCatFilter();
LoadUpListView();
end;
// ---------------------- Setting Project to Open ------------------------------
function TFormLazExam.GetProjectFile(const APath : string; WriteProjectToOpen : boolean = false) : boolean;
var
Info : TSearchRec;
RealDir : string;
// The project dir name may not be a case match for the Project Name.
// We are looking here at dir under example_work_area so some match is expected
begin
Result := DirExistsCaseInSense(APath, RealDir);
if not (Result and WriteProjectToOpen) then exit;
if FindFirst(RealDir + '*.lpi', faAnyFile, Info) = 0 then
ProjectToOpen := RealDir + Info.Name
else ProjectToOpen := '';
FindClose(Info);
end;
function TFormLazExam.DirExistsCaseInSense(const APath : string; out ActualFullDir : string) : boolean;
var
Info : TSearchRec;
FName : string;
begin
FName := lowercase(extractFileName(ChompPathDelim(APath)));
if FindFirst(extractFileDir(ChompPathDelim(APath))+PathDelim + '*',faDirectory, Info) = 0 then begin
try
repeat
if (Info.Attr and faDirectory) = faDirectory then
if lowercase(Info.Name) = FName then begin
ActualFullDir := extractFileDir(ChompPathDelim(APath))
+PathDelim + Info.Name + PathDelim;
exit(True);
end;
until FindNext(Info) <> 0;
finally
FindClose(Info);
end;
end;
Result := False;
end;
// ---------------------- S E A R C H R E L A T E D --------------------------
// Build a StringList of the terms user has typed in, words or "groups of words"
procedure TFormLazExam.BuildSearchList(SL : TStringList; const Term : AnsiString);
var
I : integer = 1;
AWord : string = '';
InCommas : boolean = false;
begin
while I <= length(trim(Term)) do begin
if Term[i] = '"' then begin
if InCommas then begin
SL.add(AWord);
AWord := '';
InCommas := False;
end else begin
InCommas := true;
end;
inc(I);
continue;
end;
if Term[i] = ' ' then begin
if InCommas then
AWord := AWord + Term[i]
else begin
if AWord <> '' then begin
SL.Add(AWord);
AWord := '';
end;
end;
inc(I);
continue;
end;
AWord := AWord + Term[i];
inc(i);
continue;
end;
if AWord <> '' then
SL.Add(AWord);
end;
procedure TFormLazExam.KeyWordSearch();
begin
Memo1.Clear;
ListView1.Clear;
Ex.KeyFilter := EditSearch.Text;
LoadUpListView();
end;
procedure TFormLazExam.EditSearchChange(Sender: TObject);
begin
ClearSearchButton.Enabled := EditSearch.Text <> '' ;
if visible then
KeyWordSearch();
end;
procedure TFormLazExam.EditSearchEnter(Sender: TObject); // check to see if a char has been forwarded on from ListView
begin
if MoveFocusKey <> char(0) then begin // not all of this is needed for each widgetset, but does no harm
EditSearch.Caption := EditSearch.Caption + MoveFocusKey;
EditSearch.SelStart := length(EditSearch.Caption);
EditSearch.SelLength := 0;
MoveFocusKey := char(0);
end;
end;
procedure TFormLazExam.EditSearchKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key in [VK_RETURN, VK_DOWN] then begin
Key := 0;
if ListView1.items.Count > 0 then begin
ListView1.SetFocus;
if Key = VK_DOWN then begin // Is this logic for VK_DOWN good?
ListView1.Selected := ListView1.Items[0];
ListView1.ItemFocused := ListView1.Items[0];
end;
end;
end;
end;
procedure TFormLazExam.ClearSearchButtonClick(Sender: TObject);
begin
if EditSearch.Text = '' then Exit;
EditSearch.Text := '';
KeyWordSearch();
end;
procedure TFormLazExam.PrimeCatFilter();
var
i : integer;
St : string = '';
begin
for i := 0 to CheckGroupCategory.Items.Count -1 do begin
if CheckGroupCategory.Checked[i] then
St := St + CheckGroupCategory.Items[i] + ' ';
end;
Ex.CatFilter := St;
end;
// -------------------- H O U S E K E E P I N G ------------------------------
procedure TFormLazExam.FormCreate(Sender: TObject);
begin
MoveFocusKey := char(0);
Caption := rsExampleProjects;
ListView1.Column[0].Caption := rsExampleName;
ListView1.Column[1].Caption := rsExampleKeyWords;
ListView1.Column[2].Caption := rsExamplePath;
ListView1.AutoSortIndicator := True;
ListView1.Column[0].SortIndicator := siDescending;
ListView1.AutoSort := True;
ListView1.SortDirection:= sdDescending;
ListView1.AutoWidthLastColumn:= True;
ListView1.ViewStyle:= vsReport;
ListView1.Column[0].AutoSize := true;
ListView1.Column[1].AutoSize := true;
ListView1.Column[2].Visible := false;
ListView1.ReadOnly := True;
LastListViewIndex := -1; // Used to record ListView1.ItemIndex before Tabbing away
EditSearch.TextHint := rsExSearchPrompt;
{$ifndef EXTESTMODE}
ClearSearchButton.Images := IDEImages.Images_16;
ClearSearchButton.ImageIndex := IDEImages.GetImageIndex('btnfiltercancel');
{$endif}
ClearSearchButton.Enabled := False;
CheckGroupCategory.Hint := rsGroupHint;
Ex := nil;
// These are ObjectInspector set but I believe I cannot get OI literals set in a Package ??
ButtonClose.Caption := rsExampleClose;
{$ifdef ONLINE_EXAMPLES}
ButtonDownload.Caption := rsExampleDownLoad;
{$else}
ButtonDownload.Caption := rsExampleCopy;
{$endif}
ButtonView.Caption := rsExampleView;
ButtonOpen.Caption := rsExampleOpen;
CheckGroupCategory.Caption := rsExampleCategory;
{$ifndef EXTESTMODE}
IDEDialogLayoutList.ApplyLayout(Self);
{$endif}
end;
procedure TFormLazExam.FormDestroy(Sender: TObject);
begin
Ex.Free;
end;
procedure TFormLazExam.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_ESCAPE then
ModalResult := mrClose;
end;
procedure TFormLazExam.FormShow(Sender: TObject);
var
i : integer;
begin
Memo1.clear;
EditSearch.text := ''; // or should we resume previous search ?
Top := Screen.Height div 10;
Height := Screen.Height * 7 div 10;
ListView1.Height:= Screen.Height * 3 div 10;
Ex.Free;
StatusBar1.SimpleText := rsExSearchingForExamples;
Ex := TExampleData.Create();
Ex.GitDir := GitDir;
Ex.ExamplesHome := ExamplesHome;
Ex.RemoteRepo := RemoteRepo;
EX.LazConfigDir := LazConfigDir;
{$ifdef ONLINE_EXAMPLES}
Ex.LoadExData(FromCacheFile);
{$else}
Ex.LoadExData(FromLazSrcTree);
{$endif}
if Ex.ErrorMsg <> '' then
Showmessage(Ex.ErrorMsg); // Note : previously, we treated this as fatal ?
ex.getCategoryData(CheckGroupCategory.Items); // This sets the name of all categories in the CheckGroup
for i := 0 to CheckGroupCategory.items.Count-1 do // check all the categories we found.
CheckGroupCategory.Checked[i] := true;
ListView1.Clear;
PrimeCatFilter();
LoadUpListView();
ListView1.SetFocus;
end;
{ Must add a FormClose event
IDEDialogLayoutList.SaveLayout(Self);
}
end.
Reference in New Issue View Git Blame Copy Permalink