paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-22 13:39:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

Fixes to the new Examples Window package, View Button, relax Proj Dir name rule, minor things.

Browse Source
This commit is contained in:
dbannon 2022-04-09 11:05:36 +00:00 committed by Juha Manninen
parent 745d9ca108
commit 6e75bb3141
8 changed files with 215 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
components/exampleswindow/exampleprojects.lpk
View File

@ -17,7 +17,7 @@
</CompilerOptions> </CompilerOptions>
<Description Value="Example Projects."/> <Description Value="Example Projects."/>
<License Value="GPL"/> <License Value="GPL"/>
<Version Minor="7"/> <Version Minor="8"/>
<Files> <Files>
<Item> <Item>
<Filename Value="uintf.pas"/> <Filename Value="uintf.pas"/>

8
components/exampleswindow/languages/uconst.pot
View File

@ -13,6 +13,10 @@ msgstr ""
msgid "Close" msgid "Close"
msgstr "" msgstr ""
#: uconst.rsexamplecopy
msgid "Copy to work area"
msgstr ""
#: uconst.rsexampledownload #: uconst.rsexampledownload
msgid "Download" msgid "Download"
msgstr "" msgstr ""
@ -37,6 +41,10 @@ msgstr ""
msgid "Example Projects" msgid "Example Projects"
msgstr "" msgstr ""
#: uconst.rsexampleview
msgid "View in Browser"
msgstr ""
#: uconst.rsexcopyingproject #: uconst.rsexcopyingproject
msgid "Copying Project ..." msgid "Copying Project ..."
msgstr "" msgstr ""

8
components/exampleswindow/languages/uconst.ru.po
View File

@ -23,6 +23,10 @@ msgstr "Категория"
msgid "Close" msgid "Close"
msgstr "Закрыть" msgstr "Закрыть"
#: uconst.rsexamplecopy
msgid "Copy to work area"
msgstr ""
#: uconst.rsexampledownload #: uconst.rsexampledownload
msgid "Download" msgid "Download"
msgstr "Загрузить" msgstr "Загрузить"
@ -47,6 +51,10 @@ msgstr "Путь"
msgid "Example Projects" msgid "Example Projects"
msgstr "Примеры проектов" msgstr "Примеры проектов"
#: uconst.rsexampleview
msgid "View in Browser"
msgstr ""
#: uconst.rsexcopyingproject #: uconst.rsexcopyingproject
msgid "Copying Project ..." msgid "Copying Project ..."
msgstr "Копирование проекта ..." msgstr "Копирование проекта ..."

4
components/exampleswindow/uconst.pas
View File

@ -24,6 +24,8 @@ const
// Immediate Local dir name under which we copy or // Immediate Local dir name under which we copy or
cExamplesDir = 'examples_work_dir'; // download examples to. Carefull about simplifying it cExamplesDir = 'examples_work_dir'; // download examples to. Carefull about simplifying it
cConfigFileName = 'exampleprojectscfg.xml'; cConfigFileName = 'exampleprojectscfg.xml';
BaseURL = 'https://gitlab.com/dbannon/laz_examples/-/tree/main/'; // Online Examples, there for testing for now...
resourcestring resourcestring
@ -50,6 +52,8 @@ resourcestring
rsExampleDownload = 'Download'; // " rsExampleDownload = 'Download'; // "
rsExampleClose = 'Close'; // " rsExampleClose = 'Close'; // "
rsExampleCategory = 'Category'; // " rsExampleCategory = 'Category'; // "
rsExampleCopy = 'Copy to work area'; // "
rsExampleView = 'View in Browser'; // "
// Settings Frame // Settings Frame
rsDirWhereExamplesGo = 'Directory where Examples go'; rsDirWhereExamplesGo = 'Directory where Examples go';

185
components/exampleswindow/uexampledata.pas
View File

@ -38,6 +38,10 @@ This unit does not interact directly with user but it does (hopefully not often)
generate some error messages that may need i18n. Only network errors have been done. generate some error messages that may need i18n. Only network errors have been done.
WARNING - This unit includes code to download (and even upload) from a gitlab
repo. At present its not being used and should get stripped out during linking.
If it appears, long term, we are never to use the online approach, remove it !
Code would be greatly simplified if we were not trying to also support OnLine.
} }
{$mode ObjFPC}{$H+} {$mode ObjFPC}{$H+}
@ -46,8 +50,8 @@ interface
uses Classes, SysUtils, fpjson, jsonparser ; uses Classes, SysUtils, fpjson, jsonparser ;
const MetaFileExt = '.ex-meta'; const
MetaFileExt = '.ex-meta'; // Extension of meta files.
type TExampleDataSource = ( FromGitlabTree, // Read all remote project meta files type TExampleDataSource = ( FromGitlabTree, // Read all remote project meta files
FromLocalTree, // Read all local Git project meta files FromLocalTree, // Read all local Git project meta files
@ -57,10 +61,10 @@ type TExampleDataSource = ( FromGitlabTree, // Read all remote project meta f
type type
PExRec=^TExRec; PExRec=^TExRec;
TExRec = record TExRec = record
EName : string; // CamelCase version of last part of FFName EName : string; // CamelCase version of the example name, filenameonly of metadata file.
Category : string; // eg Beginner, NoDesign (read from remote data) Category : string; // eg Beginner, NoDesign (read from remote data)
Keywords : TStringList; // a list of (possibly multi-word) words Keywords : TStringList; // a list of (possibly multi-word) words, nil acceptable
FFName : string; // Path and filename of meta file. Maybe absolute or relative FFName : string; // Path and filename of meta file. Maybe absolute or relative, no extension
Desc : string; // 1..many lines of description Desc : string; // 1..many lines of description
end; end;
@ -102,13 +106,13 @@ type
ErrorString : String; ErrorString : String;
ExList : TExampleList; ExList : TExampleList;
GetListDataIndex : integer; GetListDataIndex : integer;
LazConfigDir : string; // dir (eg OPM) under which we might find more Examples
// Gets a Full URL and returns with St containing content, usually as JSON // Gets a Full URL and returns with St containing content, usually as JSON
function Downloader(URL: string; out SomeString: String): boolean; function Downloader(URL: string; out SomeString: String): boolean;
// Does a binary safe download of a file, URL will get repositary info prepended // Does a binary safe download of a file, URL will get repositary info prepended
// and file ends up in FullDest which should be a full path and filename. // and file ends up in FullDest which should be a full path and filename.
function DownLoadFile(const URL, FullDest: string): boolean; function DownLoadFile(const URL, FullDest: string): boolean;
//function EscJSON(InStr: string): string; //function EscJSON(InStr: string): string;
function ExtractArrayFromJSON(const Field: string; jItem: TJSONData; STL: TStringList): boolean; function ExtractArrayFromJSON(const Field: string; jItem: TJSONData; STL: TStringList): boolean;
// Passed a json block, returns the indicated field, cannot handle arrays. // Passed a json block, returns the indicated field, cannot handle arrays.
// Don't rely on its base64 decoding a binary file, see DownLoadFile() instead. // Don't rely on its base64 decoding a binary file, see DownLoadFile() instead.
@ -117,14 +121,10 @@ type
Res: string; Base64: boolean = false): boolean; Res: string; Base64: boolean = false): boolean;
function GetLazDir: string; function GetLazDir: string;
// The returned date string down to seconds includes time zone in ISO8601
// eg 2022-01-09T11:56:51+11:00
function GetLocalTime: ANSIstring;
// Receives a pretested JSON (not just a field) containing metadata of an Example // Receives a pretested JSON (not just a field) containing metadata of an Example
// Returns false if data missing, drops msg to console about bad field. // Returns false if data missing, drops msg to console about bad field.
// Path may be relative or absolute (ie starting with '/' or '\'). Ones without // Path may be relative or absolute (ie starting with '/' or '\'). Ones without
// a leading slash are remote, ie gitlab. Ones with a slash should be resolable // a leading slash are remote, ie gitlab. Ones with a slash should be resolvable
// locally. Note when indexing a local git tree, relative must be used, ie top of // locally. Note when indexing a local git tree, relative must be used, ie top of
// git tree. In this mode of course, the entry will not be resolvable locally. // git tree. In this mode of course, the entry will not be resolvable locally.
function InsertJSONData(jItem: TJSONData; FFName: string; AName: string = '' ): boolean; function InsertJSONData(jItem: TJSONData; FFName: string; AName: string = '' ): boolean;
@ -142,12 +142,11 @@ type
function ScanOneTree(Path: string; out St: string): boolean; function ScanOneTree(Path: string; out St: string): boolean;
procedure fSetErrorString(Er : string); procedure fSetErrorString(Er : string);
function WriteMasterMeta(FFileName: string): boolean;
public public
LazConfigDir : string; // Where Lazarus keeps it config.
RemoteRepo : string; // eg https://gitlab.com/api/v4/projects/32480729/repository/ RemoteRepo : string; // eg https://gitlab.com/api/v4/projects/32480729/repository/
ExamplesHome : string; // dir where we will save a working copy of examples too, usually LazConfigDir ExamplesHome : string; // dir above examples_working_dir where we copy examples to, set by uintf.pas, usually <lazConf>/
LazSrcDir : string; // Laz dir where, eg ~/examples lives LazSrcDir : string; // Laz dir where, eg ~/examples lives
GitDir : string; // where we look for a local git repo containg examples GitDir : string; // where we look for a local git repo containg examples
KeyFilter : string; // A list of words, possibly grouped by " to filter Keywords KeyFilter : string; // A list of words, possibly grouped by " to filter Keywords
@ -155,25 +154,31 @@ type
// A service function, tests passed St to ensure its // A service function, tests passed St to ensure its
// a valid lump of Example Meta Data. // a valid lump of Example Meta Data.
function TestJSON(const J: string; out Error, Cat: string): boolean; function TestJSON(const J: string; out Error, Cat: string): boolean;
// Public, returns with next set of data, false if no more available. // Returns a path (with trailing delim) to where we will putting our downloaded
// Filters using CatFilter if CatFilter is not empty. // or copied Example Projects. It includes the working dir. Usually something
// If passed KeyList is not nil, filters keywords against KeyList. // like <lazConfig>/examples_work_dir/ but is user configurable via Laz Settings.
function ExampleWorkingDir: string;
// Public, returns with next set of data, false if no more available.
// Filters using CatFilter if CatFilter is not empty.
// If passed KeyList is not nil, filters keywords against KeyList.
function GetListData(out Proj, Cat, Path, Keys: string; GetFirst: boolean; function GetListData(out Proj, Cat, Path, Keys: string; GetFirst: boolean;
KeyList: TStringList = nil): boolean; KeyList: TStringList = nil): boolean;
// Passed a created TStrings that it clears and fills in with all know categories // Passed a created TStrings that it clears and fills in with all know categories
function getCategoryData(const CatList : TStrings) : boolean; function getCategoryData(const CatList : TStrings) : boolean;
// Pass the relative path and fileNameOnly of metafile, no extension (?)
function GetDesc(const FFname: string): string; function GetDesc(const FFname: string): string;
constructor Create; constructor Create;
procedure LoadExData(DataSource: TExampleDataSource); procedure LoadExData(DataSource: TExampleDataSource);
destructor Destroy; override; destructor Destroy; override;
procedure DumpExData(); procedure DumpExData();
// A service method, called by the GUI to download a project/ // A service method, called by the GUI to download a project/
// Pass it a full example remote dir (eg Beginner/Laz_Hello/). // Pass it a full example remote dir (eg Beginner/Laz_Hello/).
function DownLoadDir(const FExampDir: string): boolean; function DownLoadDir(const FExampDir: string): boolean;
function Count : integer; function Count : integer;
function MasterMeta(DirOnly: boolean = false): string; // returns the full Master Metafile name
function ExtractFieldsFromJSON(const JStr: string; out EName, Cat, Keys, Desc, function ExtractFieldsFromJSON(const JStr: string; out EName, Cat, Keys, Desc,
Error: string): boolean; Error: string): boolean;
// Rets T if passed name is already in list as a project name
function DoesNameExist(AName : string) : boolean;
property ErrorMsg : string read ErrorString write FSetErrorString; property ErrorMsg : string read ErrorString write FSetErrorString;
class function EscJSON(InStr: string): string; class function EscJSON(InStr: string): string;
end; end;
@ -190,13 +195,13 @@ uses LCLProc,
ssockets, fpopenssl, ssockets, fpopenssl,
lazfileutils, fileutil, lazfileutils, fileutil,
jsonscanner, // these are the FPC JSON tools jsonscanner, // these are the FPC JSON tools
base64 base64,
, laz2_DOM, laz2_XMLRead // just to get LazarusDirectory, remove if we find a better way ! laz2_DOM, laz2_XMLRead // just to get LazarusDirectory, remove if we find a better way !
{$ifdef LINUX},Unix {$endif} // We call a ReReadLocalTime(); {, IDEOptionsIntf} ;
{, IDEOptionsIntf}, LazIDEIntf;
const const
LastUpDate = 'LastUpDate'; // Name of JSON item were we store last update LastUpDate = 'LastUpDate'; // Name of JSON item were we store last update date
{ A URL starts with eg 'https://gitlab.com/api/v4/projects/32480729/repository/' { A URL starts with eg 'https://gitlab.com/api/v4/projects/32480729/repository/'
It contains a multidigit number that identifies the gitlab project. The number is a It contains a multidigit number that identifies the gitlab project. The number is a
@ -311,17 +316,13 @@ begin
Debugln(ErrorString); Debugln(ErrorString);
end; end;
// Rets a path to where we will putting our downloaded or copied ex projects. function TExampleData.ExampleWorkingDir() : string;
// At present, this is the <lazconfig>/downloaded_examples/
// if not true, returns the FFName of the master meta file, same place.
function TExampleData.MasterMeta(DirOnly : boolean = false) : string;
begin begin
//result := LazConfigDir + cExamplesDir + pathdelim; result := AppendPathDelim(ExamplesHome) + cExamplesDir + PathDelim ;
result := AppendPathDelim(ExamplesHome);
if not DirOnly then
result := Result + 'master' + MetaFileExt;
end; end;
function TExampleData.ExtractFieldsFromJSON(const JStr: string; out EName, Cat, function TExampleData.ExtractFieldsFromJSON(const JStr: string; out EName, Cat,
Keys, Desc, Error: string): boolean; Keys, Desc, Error: string): boolean;
var var
@ -355,6 +356,16 @@ begin
end; end;
end; end;
function TExampleData.DoesNameExist(AName: string): boolean;
var
P : PExRec;
begin
for P in ExList do
if lowercase(AName) = lowercase(P^.EName) then
exit(True);
result := False;
end;
function TExampleData.TestJSON(const J : string; out Error, Cat : string) : boolean; function TExampleData.TestJSON(const J : string; out Error, Cat : string) : boolean;
var var
jData, jItem : TJSONData; jData, jItem : TJSONData;
@ -402,6 +413,7 @@ var
// index : integer; // index : integer;
KeyWords : TStringList; KeyWords : TStringList;
begin begin
Result := False;
ExtractFromJSON('Category', jItem, Cat); // An empty Cat is acceptable but undesirable. ExtractFromJSON('Category', jItem, Cat); // An empty Cat is acceptable but undesirable.
if not ExtractFromJSON('Description', jItem, Desc) then exit(False); if not ExtractFromJSON('Description', jItem, Desc) then exit(False);
KeyWords := TStringList.Create; KeyWords := TStringList.Create;
@ -411,7 +423,11 @@ begin
else else
if not ExtractFromJSON('Name', jItem, AnotherName) then if not ExtractFromJSON('Name', jItem, AnotherName) then
AnotherName := ''; AnotherName := '';
Result := ExList.InsertData(Cat, Desc, FFName, AnotherName, KeyWords); if DoesNameExist(AnotherName) then begin
debugln('TExampleData.InsertJSONData - WARNING duplicate Example Name found = '
+ AnotherName + ' ' + FFName);
end
else Result := ExList.InsertData(Cat, Desc, FFName, AnotherName, KeyWords);
if not Result then KeyWords.Free; // false means its not gone into list so our responsibility go free if not Result then KeyWords.Free; // false means its not gone into list so our responsibility go free
end; end;
@ -427,7 +443,6 @@ begin
STL := FindAllFiles(Path, '*' + MetaFileExt, True); STL := FindAllFiles(Path, '*' + MetaFileExt, True);
try try
for St in STL do begin for St in STL do begin
//debugln('TExampleData.ScanLocalTree 1 Looking at ' + St);
if pos('master' + MetaFileExt, St) > 0 then continue; // don't do master if you stumble across one if pos('master' + MetaFileExt, St) > 0 then continue; // don't do master if you stumble across one
if pos(cExamplesDir, St) > 0 then continue; // thats our downloaded location if pos(cExamplesDir, St) > 0 then continue; // thats our downloaded location
FileContent := TStringList.Create; FileContent := TStringList.Create;
@ -498,41 +513,39 @@ end;
constructor TExampleData.Create(); constructor TExampleData.Create();
begin begin
ExList := TExampleList.Create; ExList := TExampleList.Create;
LazConfigDir := appendPathDelim(LazarusIDE.GetPrimaryConfigPath);
end; end;
procedure TExampleData.LoadExData(DataSource: TExampleDataSource); procedure TExampleData.LoadExData(DataSource: TExampleDataSource);
begin begin
// If we are loading the data from either the remote gitlab tree or a local // If we are loading the data from either the remote gitlab tree or a local
// git tree, we save the master file. // git tree, we save the master file.
if not DirectoryExists(MasterMeta(True)) then if not DirectoryExists(ExampleWorkingDir()) then
if not ForceDirectory(MasterMeta(True)) then exit; if not ForceDirectory(ExampleWorkingDir()) then exit;
case DataSource of case DataSource of
FromGitLabTree : begin // too slow to be useful FromGitLabTree : begin // too slow to be useful
ScanRemoteTree(''); ScanRemoteTree('');
WriteMasterMeta('master' + MetaFileExt); // save in working dir
end; end;
FromLocalTree : begin // not used in Lazarus Package FromLocalTree : begin // not used in Lazarus Package
if ScanLocalTree(GitDir, False) then // This should leave relative paths, suitable to upload to gitlab if ScanLocalTree(GitDir, False) then // This should leave relative paths, suitable to upload to gitlab
WriteMasterMeta(GitDir + 'master' + MetaFileExt); // save in git tree ready to upload.
end; end;
FromLazSrcTree : begin FromLazSrcTree : begin
ScanLocalTree(GetLazDir(), True); // Scan the Lazarus SRC tree ScanLocalTree(GetLazDir(), True); // Scan the Lazarus SRC tree
ScanLocalTree(LazConfigDir, True); // Get, eg, any OPM Examples ScanLocalTree(ExamplesHome, True); // Get, eg, any OPM Examples
// in the above line, we assume if user has moved Examples, then they will have OPM there too.
end; end;
FromCacheFile : begin FromCacheFile : begin
if not LoadCacheFile(MasterMeta()) then begin if not LoadCacheFile(ExampleWorkingDir()+ 'master' + MetaFileExt) then begin
DownLoadFile('master' + MetaFileExt, MasterMeta()); DownLoadFile('master' + MetaFileExt, ExampleWorkingDir()+ 'master' + MetaFileExt);
LoadCacheFile(MasterMeta()); // ToDo : Test that worked LoadCacheFile(ExampleWorkingDir()+ 'master' + MetaFileExt); // ToDo : Test that worked
end; end;
ScanLocalTree(LazConfigDir, True); // Get, eg, any OPM Examples ScanLocalTree(ExamplesHome, True); // Get, eg, any OPM Examples
end; end;
end; end;
// if ExList.Count = 0 then begin // if ExList.Count = 0 then begin
debugln('TExampleData.LoadExData - found examples = ' + inttostr(ExList.Count)); // debugln('TExampleData.LoadExData - found examples = ' + inttostr(ExList.Count));
debugln('Lazarus Dir (ie source tree) = ' + GetLazDir()); // debugln('Lazarus Dir (ie source tree) = ' + GetLazDir());
debugln('Lazarus Config Dir = ' + LazConfigDir); // debugln('Lazarus Config Dir = ' + LazConfigDir);
debugln('Examples Home Dir = ' + ExamplesHome); // debugln('Examples Home Dir = ' + ExamplesHome);
// end; // end;
end; end;
@ -605,7 +618,7 @@ var
Node, Node1 : TDOMNode; Node, Node1 : TDOMNode;
begin begin
Result := ''; Result := '';
ReadXMLFile(Doc, LazConfigDir + 'environmentoptions.xml'); ReadXMLFile(Doc, LazConfigDir + 'environmentoptions.xml'); // even in EXTESTMODE LazConfigDir should be valid
Node1 := Doc.DocumentElement.FindNode('EnvironmentOptions'); Node1 := Doc.DocumentElement.FindNode('EnvironmentOptions');
if Node1 <> nil then begin if Node1 <> nil then begin
Node := Node1.FindNode('LazarusDirectory'); Node := Node1.FindNode('LazarusDirectory');
@ -616,30 +629,7 @@ begin
// will be wrong anyway. Further research is indicated. // will be wrong anyway. Further research is indicated.
end; end;
Doc.free; Doc.free;
debugln('TExampleData.GetLazDir = ' + Result); // debugln('TExampleData.GetLazDir = ' + Result);
end;
function TExampleData.GetLocalTime: ANSIstring;
var
ThisMoment : TDateTime;
Res : ANSIString;
Off : longint;
begin
{$ifdef LINUX}
ReReadLocalTime(); // in case we are near daylight saving time changeover
{$endif}
ThisMoment:=Now;
Result := FormatDateTime('YYYY-MM-DD',ThisMoment) + 'T'
+ FormatDateTime('hh:mm:ss',ThisMoment);
Off := GetLocalTimeOffset();
if (Off div -60) >= 0 then Res := '+'
else Res := '-';
if abs(Off div -60) < 10 then Res := Res + '0';
Res := Res + inttostr(abs(Off div -60)) + ':';
if (Off mod 60) = 0 then
Res := res + '00'
else Res := Res + inttostr(abs(Off mod 60));
Result := Result + res;
end; end;
class function TExampleData.EscJSON(InStr : string) : string; class function TExampleData.EscJSON(InStr : string) : string;
@ -651,38 +641,6 @@ begin
Result := Result.Replace(#09, '', [rfReplaceAll] ); // tab Result := Result.Replace(#09, '', [rfReplaceAll] ); // tab
end; end;
function TExampleData.WriteMasterMeta(FFileName : string) : boolean;
var
i : integer;
STL : TStringList;
St, StIndexed : string;
begin
STL := TStringList.Create;
StL.Add('{'#10'"' + LastUpDate + '":"' + GetLocalTime() +'",');
for i := 0 to ExList.Count-1 do begin
StL.Add('"' + EscJSON(ExList.Items[i]^.FFname) + '" : {'); // Must be unique
StL.Add(' "Name" : "' + EscJSON(ExList.Items[i]^.EName) + '",');
StL.Add(' "Category" : "' + EscJSON(ExList.Items[i]^.Category) + '",');
St := '';
for StIndexed in ExList.Items[i]^.Keywords do
St := St + '"' + StIndexed + '",';
if St.Length > 0 then delete(St, St.Length, 1); // Remove trailing comma
StL.Add(' "Keywords" : [' + St + '],');
StL.Add(' "Description" : "' + EscJSON(ExList.Items[i]^.Desc) + '"},');
end;
if STL.Count > 1 then begin
St := STL[STL.Count-1];
delete(St, St.Length, 1);
STL[STL.Count-1] := St;
end;
Stl.Add('}');
deletefile(FFileName); // ToDo : test its there first and then test delete worked
STL.SaveToFile(FFileName);
STL.Free;
Result := fileexists(FFileName);
end;
// ******************** Methods relating to using the data ******************* // ******************** Methods relating to using the data *******************
@ -749,15 +707,14 @@ function TExampleData.GetDesc(const FFname: string): string;
var var
P : PExRec; P : PExRec;
begin begin
Result := '';
for P in ExList do begin for P in ExList do begin
if (lowercase(P^.FFname) = lowercase(FFname)+MetaFileExt) then begin // extension must remain lower case if (lowercase(P^.FFname) = lowercase(FFname)+MetaFileExt) then begin // extension must remain lower case
exit(P^.Desc); exit(P^.Desc);
end; end;
end; end;
Result := ''; debugln('TExampleData.GetDesc - ERROR did not find Desc for ' + FFname);
debugln('TExampleData.GetDesc - did not find Desc for ' + FFname); //ExList.DumpList('TExampleData.GetDesc', True);
debugln('Spelling of Name must match directory name (case insensitive)');
ExList.DumpList('TExampleData.GetDesc', True);
end; end;
@ -772,9 +729,9 @@ begin
try try
result := ScanRemoteTree(FExampDir, STL); result := ScanRemoteTree(FExampDir, STL);
for St in STL do begin for St in STL do begin
if not DirectoryExistsUTF8(MasterMeta(True) + ExtractFileDir(St)) then if not DirectoryExistsUTF8(ExampleWorkingDir() + ExtractFileDir(St)) then
ForceDirectory(MasterMeta(True) + ExtractFileDir(St)); // ToDo : but that might fail ForceDirectory(ExampleWorkingDir() + ExtractFileDir(St)); // ToDo : but that might fail
DownLoadFile(St, MasterMeta(True) + St); DownLoadFile(St, ExampleWorkingDir() + St);
end; end;
finally finally
STL.Free; STL.Free;

5
components/exampleswindow/uintf.pas
View File

@ -41,8 +41,8 @@ begin
Config := GetIDEConfigStorage(cConfigFileName, true); Config := GetIDEConfigStorage(cConfigFileName, true);
try try
Result := Config.GetValue('Examples/Directory', Result := Config.GetValue('Examples/Directory',
AppendPathDelim(LazarusIDE.GetPrimaryConfigPath) + AppendPathDelim(LazarusIDE.GetPrimaryConfigPath));
AppendPathDelim(cExamplesDir)); // + AppendPathDelim(cExamplesDir));
finally finally
Config.Free; Config.Free;
@ -64,6 +64,7 @@ begin
try try
FormLazExam.ExamplesHome := GetExamplesHomeDir(); FormLazExam.ExamplesHome := GetExamplesHomeDir();
FormLazExam.RemoteRepo := cRemoteRepository; FormLazExam.RemoteRepo := cRemoteRepository;
FormLazExam.LazConfigDir := AppendPathDelim(LazarusIDE.GetPrimaryConfigPath);
FormLazExam.ShowModal; FormLazExam.ShowModal;
ProjectFFile := FormLazExam.ProjectToOpen; ProjectFFile := FormLazExam.ProjectToOpen;
finally finally

40
components/exampleswindow/ulaz_examples.lfm
View File

@ -1,7 +1,7 @@
object FormLazExam: TFormLazExam object FormLazExam: TFormLazExam
Left = 562 Left = 55
Height = 574 Height = 574
Top = 168 Top = 143
Width = 781 Width = 781
Caption = 'Prototype Lazarus Examples Window' Caption = 'Prototype Lazarus Examples Window'
ClientHeight = 574 ClientHeight = 574
@ -18,7 +18,7 @@ object FormLazExam: TFormLazExam
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = CheckGroupCategory AnchorSideBottom.Control = CheckGroupCategory
Left = 5 Left = 5
Height = 216 Height = 209
Top = 225 Top = 225
Width = 771 Width = 771
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
@ -71,8 +71,8 @@ object FormLazExam: TFormLazExam
AnchorSideRight.Control = ButtonClose AnchorSideRight.Control = ButtonClose
AnchorSideBottom.Control = StatusBar1 AnchorSideBottom.Control = StatusBar1
Left = 10 Left = 10
Height = 105 Height = 112
Top = 446 Top = 439
Width = 577 Width = 577
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
AutoFill = True AutoFill = True
@ -88,6 +88,7 @@ object FormLazExam: TFormLazExam
ChildSizing.Layout = cclLeftToRightThenTopToBottom ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2 ChildSizing.ControlsPerLine = 2
Columns = 2 Columns = 2
OnDblClick = CheckGroupCategoryDblClick
OnItemClick = CheckGroupCategoryItemClick OnItemClick = CheckGroupCategoryItemClick
TabOrder = 3 TabOrder = 3
end end
@ -151,10 +152,10 @@ object FormLazExam: TFormLazExam
AnchorSideLeft.Control = ButtonClose AnchorSideLeft.Control = ButtonClose
AnchorSideRight.Control = Owner AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = ButtonClose AnchorSideBottom.Control = ButtonView
Left = 597 Left = 597
Height = 35 Height = 28
Top = 481 Top = 467
Width = 179 Width = 179
Anchors = [akLeft, akRight, akBottom] Anchors = [akLeft, akRight, akBottom]
BorderSpacing.Right = 5 BorderSpacing.Right = 5
@ -167,8 +168,8 @@ object FormLazExam: TFormLazExam
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = StatusBar1 AnchorSideBottom.Control = StatusBar1
Left = 597 Left = 597
Height = 35 Height = 28
Top = 516 Top = 523
Width = 179 Width = 179
Anchors = [akRight, akBottom] Anchors = [akRight, akBottom]
BorderSpacing.Right = 5 BorderSpacing.Right = 5
@ -182,8 +183,8 @@ object FormLazExam: TFormLazExam
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = ButtonDownload AnchorSideBottom.Control = ButtonDownload
Left = 597 Left = 597
Height = 35 Height = 28
Top = 446 Top = 439
Width = 179 Width = 179
Anchors = [akLeft, akRight, akBottom] Anchors = [akLeft, akRight, akBottom]
BorderSpacing.Right = 5 BorderSpacing.Right = 5
@ -191,4 +192,19 @@ object FormLazExam: TFormLazExam
OnClick = ButtonOpenClick OnClick = ButtonOpenClick
TabOrder = 8 TabOrder = 8
end end
object ButtonView: TButton
AnchorSideLeft.Control = ButtonClose
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = ButtonClose
Left = 597
Height = 28
Top = 495
Width = 179
Anchors = [akLeft, akRight, akBottom]
BorderSpacing.Right = 5
Caption = 'ButtonView'
OnClick = ButtonViewClick
TabOrder = 9
end
end end

166
components/exampleswindow/ulaz_examples.pas
View File

@ -25,8 +25,9 @@ Notes -
David Bannon, Feb 2022 David Bannon, Feb 2022
} }
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{x$define EXTESTMODE}
{x$define ONLINE_EXAMPLES} {X$define ONLINE_EXAMPLES}
interface interface
@ -44,6 +45,7 @@ type
{ TFormLazExam } { TFormLazExam }
TFormLazExam = class(TForm) TFormLazExam = class(TForm)
ButtonView: TButton;
ButtonDownload: TButton; ButtonDownload: TButton;
ButtonClose: TButton; ButtonClose: TButton;
ButtonOpen: TButton; ButtonOpen: TButton;
@ -57,6 +59,8 @@ type
procedure ButtonCloseClick(Sender: TObject); procedure ButtonCloseClick(Sender: TObject);
procedure ButtonDownloadClick(Sender: TObject); procedure ButtonDownloadClick(Sender: TObject);
procedure ButtonOpenClick(Sender: TObject); procedure ButtonOpenClick(Sender: TObject);
procedure ButtonViewClick(Sender: TObject);
procedure CheckGroupCategoryDblClick(Sender: TObject);
procedure CheckGroupCategoryItemClick(Sender: TObject; Index: integer); procedure CheckGroupCategoryItemClick(Sender: TObject; Index: integer);
procedure EditSearchExit(Sender: TObject); procedure EditSearchExit(Sender: TObject);
procedure EditSearchKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); procedure EditSearchKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
@ -68,8 +72,11 @@ type
procedure ListView1SelectItem(Sender: TObject; Item: TListItem; Selected: Boolean); procedure ListView1SelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
private private
procedure BuildSearchList(SL: TStringList; const Term: AnsiString); 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. // SrcDir includes name of actual dir, DestDir does not.
function CopyFiles(const Proj, SrcDir, DestDir: string): boolean; 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; 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 // 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. // present, T if Dir exists. If it finds an lpi file, rets with FFilename, else empty string.
@ -78,14 +85,15 @@ type
// Thats triggers a Lazarus Open when this window closes. // Thats triggers a Lazarus Open when this window closes.
function GetProjectFile(const APath: string; WriteProjectToOpen: boolean = false): boolean; function GetProjectFile(const APath: string; WriteProjectToOpen: boolean = false): boolean;
procedure KeyWordSearch; procedure KeyWordSearch;
function NewLVItem(const LView : TListView; const Proj, Path, KeyWords : string): TListItem; function NewLVItem(const LView: TListView; const Proj, Path, KeyWords,
Cat: string): TListItem;
// Displays the current content of Examples List in the listview and // Displays the current content of Examples List in the listview and
// populates the Category checkboxes. // populates the Category checkboxes.
procedure LoadUpListView(); procedure LoadUpListView();
procedure PrimeCatFilter; procedure PrimeCatFilter;
public public
GitDir : string; // Not needed in Lazarus Package, used in dev's tool emt GitDir : string; // Not needed in Lazarus Package, used in dev's tool emt
//LazConfigDir : string; // We will download examples to here. LazConfigDir : string; // We will look for Laz config here.
ExamplesHome : string; // Defaults to LazConfig but user settable ExamplesHome : string; // Defaults to LazConfig but user settable
RemoteRepo : string; // This is the full gitlab URL RemoteRepo : string; // This is the full gitlab URL
ProjectToOpen : string; // If not empty after close, open the project named. ProjectToOpen : string; // If not empty after close, open the project named.
@ -97,7 +105,7 @@ var
implementation implementation
uses LazFileUtils, LCLType, fileutil, LazLogger; uses LazFileUtils, LCLType, fileutil, LazLogger, LCLIntf;
{$R *.lfm} {$R *.lfm}
@ -106,7 +114,7 @@ uses LazFileUtils, LCLType, fileutil, LazLogger;
// ------------------------ L I S T V I E W ---------------------------------- // ------------------------ L I S T V I E W ----------------------------------
function TFormLazExam.NewLVItem(const LView : TListView; const Proj, Path, KeyWords : string): TListItem; function TFormLazExam.NewLVItem(const LView : TListView; const Proj, Path, KeyWords, Cat : string): TListItem;
var var
TheItem : TListItem; TheItem : TListItem;
begin begin
@ -114,6 +122,7 @@ begin
TheItem.Caption := Proj; TheItem.Caption := Proj;
TheItem.SubItems.Add(KeyWords); TheItem.SubItems.Add(KeyWords);
TheItem.SubItems.Add(Path); TheItem.SubItems.Add(Path);
TheItem.SubItems.Add(Cat);
Result := TheItem; Result := TheItem;
end; end;
@ -135,11 +144,11 @@ begin
end; end;
try try
if Ex.GetListData(Proj, Cat, Path, KeyW, True, KeyList) then begin if Ex.GetListData(Proj, Cat, Path, KeyW, True, KeyList) then begin
NewLVItem(ListView1, Proj, Path, KeyW); NewLVItem(ListView1, Proj, Path, KeyW, Cat);
inc(Cnt); inc(Cnt);
end; end;
while Ex.GetListData(Proj, Cat, Path, KeyW, False, KeyList) do begin while Ex.GetListData(Proj, Cat, Path, KeyW, False, KeyList) do begin
NewLVItem(ListView1, Proj, Path, KeyW); NewLVItem(ListView1, Proj, Path, KeyW, Cat);
inc(Cnt); inc(Cnt);
end; end;
finally finally
@ -148,6 +157,7 @@ begin
end; end;
ButtonOpen.Enabled := false; ButtonOpen.Enabled := false;
ButtonDownLoad.enabled := false; ButtonDownLoad.enabled := false;
ButtonView.enabled := false;
Memo1.append(format(rsFoundExampleProjects, [Cnt])); Memo1.append(format(rsFoundExampleProjects, [Cnt]));
StatusBar1.SimpleText := format(rsFoundExampleProjects, [Cnt]); StatusBar1.SimpleText := format(rsFoundExampleProjects, [Cnt]);
end; end;
@ -157,58 +167,37 @@ begin
if ListView1.Selected = nil then exit; // White space below entries .... if ListView1.Selected = nil then exit; // White space below entries ....
Memo1.Clear; Memo1.Clear;
Memo1.append(ListView1.Selected.SubItems[1]); Memo1.append(ListView1.Selected.SubItems[1]);
Memo1.append('');
Memo1.Append(Ex.GetDesc(ListView1.Selected.SubItems[1] + ListView1.Selected.Caption)); 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. // ListView1.Selected.Caption may be CamelCase from JSON.Name rather than path where we found it.
ButtonDownLoad.enabled := true; ButtonDownLoad.enabled := true;
ButtonView.enabled := true;
//ButtonOpen.Enabled := GetProjectFile(ListView1.Selected.SubItems[1]); //ButtonOpen.Enabled := GetProjectFile(ListView1.Selected.SubItems[1]);
ButtonOpen.Enabled := GetProjectFile(Ex.MasterMeta(True) + ListView1.Selected.Caption); ButtonOpen.Enabled := GetProjectFile(Ex.ExampleWorkingDir() + ListView1.Selected.Caption);
end; end;
function TFormLazExam.CopyFiles(const Proj, SrcDir, DestDir : string) : boolean;
var
STL : TStringList;
St, FFname : string;
// The Right part of St starting with Proj
function RightSide : string;
var
i : integer;
begin
result := '';
i := St.Length;
while i > 0 do begin
if (PathDelim + lowercase(Proj) + PathDelim) = lowercase(copy(St, i, Proj.length+2)) then
exit(copy(St, i, 1000));
dec(i);
end;
debugln('TFormLazExam.CopyFiles - failed to find [' + Proj + '] in ' + St);
end;
begin
Result := False;
STL := FindAllFiles(SrcDir, '*', True);
try
for St in STL do begin
FFName := appendPathDelim(DestDir) + RightSide();
if not ForceDirectoriesUTF8(extractFileDir(FFName)) then begin
debugln('TFormLazExam.CopyFiles - Failed to force ' + extractFileDir(FFName));
exit;
end;
if not copyfile(St, FFname, [cffOverwriteFile]) then begin
debugln('TFormLazExam.CopyFiles - Failed to copy ' + St + ' to ' + FFName);
exit;
end;
end;
finally
STL.Free;
end;
result := true;
end;
procedure TFormLazExam.ListView1DblClick(Sender: TObject); procedure TFormLazExam.ListView1DblClick(Sender: TObject);
begin
ButtonDownloadClick(self);
ButtonOpenClick(self);
end;
// --------------------- B U T T O N S -----------------------------------------
procedure TFormLazExam.ButtonOpenClick(Sender: TObject);
begin
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 begin
if ListView1.Selected = nil then exit; // White space below entries .... if ListView1.Selected = nil then exit; // White space below entries ....
if GetProjectFile(Ex.MasterMeta(True) + ListView1.Selected.Caption) then begin if GetProjectFile(Ex.ExampleWorkingDir() + ListView1.Selected.Caption) then begin
if Application.MessageBox(pchar(rsRefreshExistingExample) if Application.MessageBox(pchar(rsRefreshExistingExample)
, pchar(ListView1.Selected.Caption) , pchar(ListView1.Selected.Caption)
, MB_ICONQUESTION + MB_YESNO) <> IDYES then exit; , MB_ICONQUESTION + MB_YESNO) <> IDYES then exit;
@ -227,26 +216,22 @@ begin
StatusBar1.SimpleText := rsExCopyingProject; StatusBar1.SimpleText := rsExCopyingProject;
Application.ProcessMessages; Application.ProcessMessages;
if copyFiles( ListView1.Selected.Caption, if copyFiles( ListView1.Selected.Caption,
ListView1.Selected.SubItems[1], Ex.MasterMeta(True)) then ListView1.Selected.SubItems[1], Ex.ExampleWorkingDir()) then
StatusBar1.SimpleText := rsExProjectCopiedTo + ' ' + Ex.MasterMeta(True) StatusBar1.SimpleText := rsExProjectCopiedTo + ' ' + Ex.ExampleWorkingDir()
else StatusBar1.SimpleText := rsFailedToCopyFilesTo + ' ' + Ex.MasterMeta(True); + ListView1.Selected.Caption
else StatusBar1.SimpleText := rsFailedToCopyFilesTo + ' ' + Ex.ExampleWorkingDir();
{$endif} {$endif}
end; end;
finally finally
Screen.Cursor := crDefault; Screen.Cursor := crDefault;
end; end;
ButtonOpen.Enabled := GetProjectFile(Ex.MasterMeta(True) + ListView1.Selected.Caption); ButtonOpen.Enabled := GetProjectFile(Ex.ExampleWorkingDir() + ListView1.Selected.Caption);
end; end;
// --------------------- B U T T O N S ----------------------------------------- procedure TFormLazExam.ButtonViewClick(Sender: TObject);
procedure TFormLazExam.ButtonOpenClick(Sender: TObject);
begin begin
if GetProjectFile(Ex.MasterMeta(True) + ListView1.Selected.Caption, True) // Sets ProjectToOpen on success OpenURL(BaseURL + ListView1.Selected.SubItems[2] + '/' + ListView1.Selected.Caption);
and ProjectToOpen.IsEmpty then
showmessage(rsExNoProjectFile)
else
close;
end; end;
procedure TFormLazExam.ButtonCloseClick(Sender: TObject); procedure TFormLazExam.ButtonCloseClick(Sender: TObject);
@ -254,16 +239,54 @@ begin
Close; Close;
end; end;
procedure TFormLazExam.ButtonDownloadClick(Sender: TObject); function TFormLazExam.CopyFiles(const Proj, SrcDir, DestDir : string) : boolean;
var
STL : TStringList;
St : string;
ChopOff : integer;
begin begin
ListView1DblClick(Sender); 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; 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];
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; function TFormLazExam.GetProjectFile(const APath : string; WriteProjectToOpen : boolean = false) : boolean;
var var
Info : TSearchRec; Info : TSearchRec;
RealDir : string; RealDir : string;
// The project dir name may not be a case match for the Project Name. // 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 begin
Result := DirExistsCaseInSense(APath, RealDir); Result := DirExistsCaseInSense(APath, RealDir);
if not (Result and WriteProjectToOpen) then exit; if not (Result and WriteProjectToOpen) then exit;
@ -273,8 +296,6 @@ begin
FindClose(Info); FindClose(Info);
end; end;
// 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 TFormLazExam.DirExistsCaseInSense(const APath : string; out ActualFullDir : string) : boolean; function TFormLazExam.DirExistsCaseInSense(const APath : string; out ActualFullDir : string) : boolean;
var var
Info : TSearchRec; Info : TSearchRec;
@ -298,15 +319,6 @@ begin
Result := False; Result := False;
end; end;
procedure TFormLazExam.CheckGroupCategoryItemClick(Sender: TObject; Index: integer);
begin
if Ex = Nil then exit;
Memo1.clear;
ListView1.Clear;
PrimeCatFilter();
LoadUpListView();
end;
// ---------------------- S E A R C H R E L A T E D -------------------------- // ---------------------- S E A R C H R E L A T E D --------------------------
@ -411,7 +423,12 @@ begin
Ex := nil; Ex := nil;
// These are ObjectInspector set but I believe I cannot get OI literals set in a Package ?? // These are ObjectInspector set but I believe I cannot get OI literals set in a Package ??
ButtonClose.Caption := rsExampleClose; ButtonClose.Caption := rsExampleClose;
{$ifdef ONLINE_EXAMPLES}
ButtonDownload.Caption := rsExampleDownLoad; ButtonDownload.Caption := rsExampleDownLoad;
{$else}
ButtonDownload.Caption := rsExampleCopy;
{$endif}
ButtonView.Caption := rsExampleView;
ButtonOpen.Caption := rsExampleOpen; ButtonOpen.Caption := rsExampleOpen;
CheckGroupCategory.Caption := rsExampleCategory; CheckGroupCategory.Caption := rsExampleCategory;
{$ifndef EXTESTMODE} {$ifndef EXTESTMODE}
@ -435,6 +452,7 @@ begin
Ex.GitDir := GitDir; Ex.GitDir := GitDir;
Ex.ExamplesHome := ExamplesHome; Ex.ExamplesHome := ExamplesHome;
Ex.RemoteRepo := RemoteRepo; Ex.RemoteRepo := RemoteRepo;
EX.LazConfigDir := LazConfigDir;
{$ifdef ONLINE_EXAMPLES} {$ifdef ONLINE_EXAMPLES}
Ex.LoadExData(FromCacheFile); Ex.LoadExData(FromCacheFile);
{$else} {$else}