diff --git a/components/exampleswindow/exampleprojects.lpk b/components/exampleswindow/exampleprojects.lpk
new file mode 100644
index 0000000000..472792f94e
--- /dev/null
+++ b/components/exampleswindow/exampleprojects.lpk
@@ -0,0 +1,60 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ -
+
+
+
+
+ -
+
+
+
+ -
+
+
+
+ -
+
+
+
+ -
+
+
+
+
+
+ -
+
+
+ -
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/exampleswindow/exampleprojects.pas b/components/exampleswindow/exampleprojects.pas
new file mode 100644
index 0000000000..ab920594ea
--- /dev/null
+++ b/components/exampleswindow/exampleprojects.pas
@@ -0,0 +1,23 @@
+{ This file was automatically created by Lazarus. Do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit exampleprojects;
+
+{$warn 5023 off : no warning about unused units}
+interface
+
+uses
+ uIntf, uConst, uLaz_Examples, uexampledata, exwinsettings,
+ LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+ RegisterUnit('uIntf', @uIntf.Register);
+end;
+
+initialization
+ RegisterPackage('exampleprojects', @Register);
+end.
diff --git a/components/exampleswindow/exwinsettings.lfm b/components/exampleswindow/exwinsettings.lfm
new file mode 100644
index 0000000000..0c1e9743ad
--- /dev/null
+++ b/components/exampleswindow/exwinsettings.lfm
@@ -0,0 +1,50 @@
+object ExWinSettingsFrame: TExWinSettingsFrame
+ Left = 0
+ Height = 240
+ Top = 0
+ Width = 320
+ ClientHeight = 240
+ ClientWidth = 320
+ TabOrder = 0
+ DesignLeft = 567
+ DesignTop = 426
+ object ButtonDefault: TButton
+ AnchorSideLeft.Control = DirectoryEdit1
+ AnchorSideTop.Control = DirectoryEdit1
+ AnchorSideTop.Side = asrBottom
+ Left = 20
+ Height = 25
+ Top = 159
+ Width = 75
+ BorderSpacing.Top = 10
+ Caption = 'Default'
+ OnClick = ButtonDefaultClick
+ TabOrder = 0
+ end
+ object DirectoryEdit1: TDirectoryEdit
+ AnchorSideLeft.Control = Owner
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ Left = 20
+ Height = 29
+ Top = 120
+ Width = 280
+ Directory = 'DirectoryEdit1'
+ ShowHidden = False
+ ButtonWidth = 23
+ NumGlyphs = 1
+ Anchors = [akLeft, akRight]
+ BorderSpacing.Left = 20
+ BorderSpacing.Right = 20
+ MaxLength = 0
+ TabOrder = 1
+ Text = 'DirectoryEdit1'
+ end
+ object Label1: TLabel
+ Left = 27
+ Height = 21
+ Top = 91
+ Width = 287
+ Caption = 'Directory where examples are saved'
+ end
+end
diff --git a/components/exampleswindow/exwinsettings.pas b/components/exampleswindow/exwinsettings.pas
new file mode 100644
index 0000000000..01126313be
--- /dev/null
+++ b/components/exampleswindow/exwinsettings.pas
@@ -0,0 +1,193 @@
+unit exwinsettings;
+{
+ **********************************************************************
+ 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 makes a frame that is poked into Lazarus's Options Tree. At present
+all it gets back is the user's preference as to where the Example Projects
+working space is. Easily extended. David Bannon, Feb 2022
+
+}
+
+
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, Forms, Controls, StdCtrls, EditBtn, IDEOptionsIntf,
+ IDEOptEditorIntf;
+
+{ TExWinSettings }
+
+// -------- The Options Group ID, and, perhaps, a place in the Tree View -------
+
+type
+ TExWinSettings = class(TAbstractIDEEnvironmentOptions) // needed by options group.
+
+ private
+
+ public
+ constructor Create(const pbReadRegFile: boolean);
+ destructor Destroy; override;
+ class function GetGroupCaption: String; override;
+ class function GetInstance: TAbstractIDEOptions; override;
+ procedure DoAfterWrite({%H-}Restore: boolean); override;
+ end;
+
+
+// ------ This is the Frame displayed when user clicks the Tree View note ------
+type
+ { TExWinSettingsFrame }
+ TExWinSettingsFrame = class(TAbstractIDEOptionsEditor)
+ ButtonDefault: TButton;
+ DirectoryEdit1: TDirectoryEdit;
+ Label1: TLabel;
+ procedure ButtonDefaultClick(Sender: TObject);
+
+ private
+ DefaultExamplesHome : string;
+
+ public
+ constructor Create(TheOwner: TComponent); override;
+ destructor Destroy; override;
+ function GetTitle: String; override;
+ procedure ReadSettings({%H-}AOptions: TAbstractIDEOptions); override;
+ procedure Setup({%H-}ADialog: TAbstractOptionsEditorDialog); override;
+ class function SupportedOptionsClass: TAbstractIDEOptionsClass; override;
+ procedure WriteSettings({%H-}AOptions: TAbstractIDEOptions); override;
+ procedure RestoreSettings({%H-}AOptions: TAbstractIDEOptions); override;
+ end;
+
+
+var
+ ExWindowOptionsGroup : integer;
+ ExWinOptionsFrameID : integer;
+
+implementation
+
+uses Dialogs, LazLogger, UConst, baseIDEIntf, LazConfigStorage, LazFileUtils,
+ LazIDEIntf;
+
+{$R *.lfm}
+
+{ TExWinSettings }
+
+constructor TExWinSettings.Create(const pbReadRegFile: boolean);
+begin
+ // inherited Create;
+end;
+
+destructor TExWinSettings.Destroy;
+begin
+ inherited Destroy;
+end;
+
+class function TExWinSettings.GetGroupCaption: String;
+begin
+ Result := rsExampleProjects;
+end;
+
+class function TExWinSettings.GetInstance: TAbstractIDEOptions;
+begin
+ //result := TAbstractIDEOptions(self); // Nope, it does not like that !
+ result := nil;
+end;
+
+procedure TExWinSettings.DoAfterWrite(Restore: boolean);
+begin
+ inherited DoAfterWrite(Restore);
+end;
+
+{ TExWinSettingsFrame }
+
+
+procedure TExWinSettingsFrame.ButtonDefaultClick(Sender: TObject);
+begin
+ DirectoryEdit1.Text := DefaultExamplesHome;
+end;
+
+constructor TExWinSettingsFrame.Create(TheOwner: TComponent);
+begin
+ inherited Create(TheOwner);
+ DefaultExamplesHome := AppendPathDelim(LazarusIDE.GetPrimaryConfigPath)
+ + AppendPathDelim(cExamplesDir);
+end;
+
+destructor TExWinSettingsFrame.Destroy;
+begin
+ inherited Destroy;
+end;
+
+function TExWinSettingsFrame.GetTitle: String;
+begin
+ Result := rsExampleProjects;
+end;
+
+procedure TExWinSettingsFrame.ReadSettings(AOptions: TAbstractIDEOptions);
+var
+ Config: TConfigStorage;
+begin
+ try
+ Config := GetIDEConfigStorage(cConfigFileName, true);
+ try
+ DirectoryEdit1.Text := Config.GetValue('Examples/Directory', DefaultExamplesHome);
+
+ finally
+ Config.Free;
+ end;
+ except
+ on E: Exception do begin
+ DebugLn('TExWinSettingsFrame.ReadSettings Loading ' + cConfigFileName + ' failed: ' + E.Message);
+ end;
+ end;
+
+end;
+
+// Maybe the initial settings before we have a config file ? Labels and Captions.
+procedure TExWinSettingsFrame.Setup(ADialog: TAbstractOptionsEditorDialog);
+begin
+ Label1.Caption := rsDirWhereExamplesGo;
+end;
+
+class function TExWinSettingsFrame.SupportedOptionsClass: TAbstractIDEOptionsClass;
+begin
+ Result := nil;
+end;
+
+// Gets called whenever user opens Options tree.
+procedure TExWinSettingsFrame.WriteSettings(AOptions: TAbstractIDEOptions);
+var
+ Config: TConfigStorage;
+begin
+ try
+ Config := GetIDEConfigStorage(cConfigFileName,false);
+ try
+ Config.SetDeleteValue('Examples/Directory',DirectoryEdit1.Text, DefaultExamplesHome);
+ finally
+ Config.Free;
+ end;
+ except
+ on E: Exception do begin
+ DebugLn('TExWinSettingsFrame.ReadSettings Saving ' + cConfigFileName + ' failed: ' + E.Message);
+ end;
+ end;
+end;
+
+procedure TExWinSettingsFrame.RestoreSettings(AOptions: TAbstractIDEOptions);
+begin
+ inherited RestoreSettings(AOptions);
+end;
+
+
+initialization
+ ExWindowOptionsGroup := GetFreeIDEOptionsGroupIndex(GroupEditor);
+ RegisterIDEOptionsGroup(ExWindowOptionsGroup, TExWinSettings, False); // F cos I get Index from above line. I think.
+
+
+end.
diff --git a/components/exampleswindow/uconst.pas b/components/exampleswindow/uconst.pas
new file mode 100644
index 0000000000..2c31ccdf0c
--- /dev/null
+++ b/components/exampleswindow/uconst.pas
@@ -0,0 +1,66 @@
+unit uConst;
+{
+ **********************************************************************
+ 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 provides the Example Projects package with a few constants and
+a number of string literals that will i18n translation.
+
+}
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils;
+
+const
+ cRemoteRepository = 'https://gitlab.com/api/v4/projects/32866275/repository/';
+ // Immediate Local dir name under which we copy or
+ cExamplesDir = 'examples_work_dir'; // download examples to. Carefull about simplifying it
+ cConfigFileName = 'exampleprojectscfg.xml';
+
+resourcestring
+
+ // --------- Multiple units
+ rsExampleProjects = 'Example Projects';
+
+ // ---------- uLaz_Examples
+ rsExSearchPrompt = 'Search Here';
+ rsExNoProjectFile = 'Maybe no project file ?';
+ rsFoundExampleProjects = 'Found %d Example Projects';
+ rsRefreshExistingExample = 'Refresh Existing Example ?';
+ rsExDownloadingProject = 'Downloading Project...';
+ rsExCopyingProject = 'Copying Project...';
+ rsExProjectDownloadedTo = 'Project Downloaded to'; // followed by a full path name
+ rsExProjectCopiedTo = 'Project Copied to'; // followed by a full path name
+ rsExampleName = 'Name'; // Column title
+ rsExamplePath = 'Path'; // "
+ rsExampleKeyWords = 'Key Words'; // "
+ rsExSearchingForExamples = 'Searching for Examples';
+ rsFailedToCopyFilesTo = 'Failed to copy files to'; // Followed by a dir were we, apparently, cannot write
+
+ // These are ObjectInspector set but I believe I cannot get OI literals i18n in a Package ??
+ rsExampleOpen = 'Open'; // Button Caption
+ rsExampleDownload = 'Download'; // "
+ rsExampleClose = 'Close'; // "
+ rsExampleCategory = 'Category'; // "
+
+ // Settings Frame
+ rsDirWhereExamplesGo = 'Directory where Examples go';
+
+ // ------- rsExampleData
+ // Most literals in uExampleData are for debugging only and very unlikely to be
+ // seen by the end user. But a couple of network related ones may need i18n -
+ rsExNetWorkError = 'GitLab NetWork Error'; // Followed by system error msg
+
+
+implementation
+
+end.
+
diff --git a/components/exampleswindow/uexampledata.pas b/components/exampleswindow/uexampledata.pas
new file mode 100644
index 0000000000..5069eef132
--- /dev/null
+++ b/components/exampleswindow/uexampledata.pas
@@ -0,0 +1,1006 @@
+unit uexampledata;
+
+{
+ **********************************************************************
+ 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 is the backend that provides an List that contains details of Lazarus
+Example Projects. It might get its data from one of three different places,
+
+* The LazarusDir and the LazarusConfigDir.
+* A locally cached master meta file Disabled as of Feb 2022
+* A remote gitlab repository (ie, if the above is not present), Disabled as of Feb 2022
+
+This list can be used to populate the Lazarus Examples Window or used during the
+markup of existing Lazarus Projects. The unit is used by the Lazarus Package and
+a simple tool used to manage the meta data files.
+
+-- PATHS --
+
+This only really applies in the Out of Lazarus Package usage. David Bannon, Feb 2022
+
+Data is inserted into the list from different sources and might refer to
+content stored in different places.
+
+So, wrt FFname in the list, a path starting with a slash, / or \, is an absolute
+local path. OTOH, without a slash, its remote, eg, gitlab and relative to the
+top of the repository.
+
+Special case is when we are reading the local git repository, we are doing this
+to make a file to upload to the gilab repo that is an index of the remote repository,
+so, no leading slash and all paths are relative to the top of the local git repo.
+
+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.
+
+
+}
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses Classes, SysUtils, fpjson, jsonparser ;
+
+const MetaFileExt = '.ex-meta';
+
+
+type TExampleDataSource = ( FromGitlabTree, // Read all remote project meta files
+ FromLocalTree, // Read all local Git project meta files
+ FromCacheFile, // Load data from Local Cache File
+ FromLazSrcTree); // Searches the Lazarus Src Tree, eg ~/examples; ~/components
+
+type
+ PExRec=^TExRec;
+ TExRec = record
+ EName : string; // CamelCase version of last part of FFName
+ Category : string; // eg Beginner, NoDesign (read from remote data)
+ Keywords : TStringList; // a list of (possibly multi-word) words
+ FFName : string; // Path and filename of meta file. Maybe absolute or relative
+ Desc : string; // 1..many lines of description
+ end;
+
+type
+ { TExampleList }
+ TExampleList = class(TFPList)
+ private
+
+ procedure DumpList(wherefrom: string; ShowDesc: boolean = false);
+ function Get(Index: integer): PExRec;
+
+ public
+ constructor Create();
+ destructor Destroy; override;
+ // Public - Puts new entry in List, Keys may be Nil
+ function InsertData(Cat, Desc, FFName, AName: string; Keys: TStringList): boolean;
+ function Find(const FFname: string): PExRec;
+ function AsJSON(Index: integer): string;
+ // Ret T if St is in Keywords at AnIndex, not necessarily equal to.
+ function IsInKeywords(St : string; AnIndex : integer) : boolean;
+ property Items[Index: integer]: PExRec read Get; default;
+
+
+end;
+
+{ Note - the above list is used to generate a master.ex-meta file that might be added
+the the gitlab repo. So, dir seperators MUST be /. On Windows, they will be read
+from a local tree as \ and a local master.ex-meta file will need to be converted.
+I think we will declare they are always /, when reading local filesystems on
+Windows, must convert during the insert into list stage. }
+
+
+type
+
+ { TExampleData }
+
+ TExampleData = class
+ private
+ ErrorString : String;
+ ExList : TExampleList;
+ 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
+ function Downloader(URL: string; out SomeString: String): boolean;
+ // 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.
+ function DownLoadFile(const URL, FullDest: string): boolean;
+ //function EscJSON(InStr: string): string;
+ function ExtractArrayFromJSON(const Field: string; jItem: TJSONData; STL: TStringList): boolean;
+ // Passed a json block, returns the indicated field, cannot handle arrays.
+ // Don't rely on its base64 decoding a binary file, see DownLoadFile() instead.
+ function ExtractFromJSON(const Field, data: string; Base64: boolean=false) : string;
+ function ExtractFromJSON(const Field: string; const jItem: TJSONData; out
+ Res: string; Base64: boolean = false): boolean;
+ 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
+ // Returns false if data missing, drops msg to console about bad field.
+ // 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
+ // 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.
+ function InsertJSONData(jItem: TJSONData; FFName: string; AName: string = '' ): boolean;
+ function LoadCacheFile(FFName: string): boolean;
+ function ReadMasterJSON(FileContent: TStringList): boolean;
+ function ReadRemoteMetaFile(URL: string): boolean; // download and read meta file
+ // Gets passed a block of json, wrapped in {} containing several fields relating
+ // one example project. Path is ready to use in the List. Not suited to json
+ // With an internal Path field (ie master.ex-meta)
+ function ReadSingleJSON(FileContent: TStringList; PathToStore: string = ''): boolean;
+ function ScanLocalTree(Path: string; PathAbs: boolean): boolean;
+ // Will either scan and add what it finds to the List (if STL is nil) or it
+ // will add each full URL to the StringList if its valid and created.
+ function ScanRemoteTree(Path: string; STL: TstringList = nil): boolean;
+ function ScanOneTree(Path: string; out St: string): boolean;
+ procedure fSetErrorString(Er : string);
+
+ function WriteMasterMeta(FFileName: string): boolean;
+
+ public
+ 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
+ LazSrcDir : string; // Laz dir where, eg ~/examples lives
+ GitDir : string; // where we look for a local git repo containg examples
+ KeyFilter : string; // A list of words, possibly grouped by " to filter Keywords
+ CatFilter : string; // A string that may contain 0 to n words, each word being a category as filtered by GetListData()
+ // A service function, tests passed St to ensure its
+ // a valid lump of Example Meta Data.
+ function TestJSON(const J: string; out Error, Cat: string): boolean;
+ // 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;
+ KeyList: TStringList = nil): boolean;
+ // Passed a created TStrings that it clears and fills in with all know categories
+ function getCategoryData(const CatList : TStrings) : boolean;
+ function GetDesc(const FFname: string): string;
+ constructor Create;
+ procedure LoadExData(DataSource: TExampleDataSource);
+ destructor Destroy; override;
+ procedure DumpExData();
+ // A service method, called by the GUI to download a project/
+ // Pass it a full example remote dir (eg Beginner/Laz_Hello/).
+ function DownLoadDir(const FExampDir: string): boolean;
+ 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,
+ Error: string): boolean;
+ property ErrorMsg : string read ErrorString write FSetErrorString;
+ class function EscJSON(InStr: string): string;
+ end;
+
+
+implementation
+
+
+uses LCLProc,
+ uConst,
+ httpprotocol, // for http encoding
+ fphttpclient, // determines a dependency on FPC 3.2.0 or later. Must for https downloads
+ opensslsockets,
+ ssockets, fpopenssl,
+ lazfileutils, fileutil,
+ jsonscanner, // these are the FPC JSON tools
+ base64
+ , laz2_DOM, laz2_XMLRead // just to get LazarusDirectory, remove if we find a better way !
+ {$ifdef LINUX},Unix {$endif} // We call a ReReadLocalTime();
+ {, IDEOptionsIntf}, LazIDEIntf;
+
+const
+ LastUpDate = 'LastUpDate'; // Name of JSON item were we store last update
+
+{ 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
+combination of Owner (account, group..) and repository name. Its identified in Gitlab
+web pages as "Project ID", group id will not work. A full URL might look like this -
+https://gitlab.com/api/v4/projects/32866275/repository/files/Utility%2FExScanner%2Fproject1.ico?ref=main
+}
+
+
+// =============================================================================
+// T E X A M P L E L I S T
+//==============================================================================
+
+function TExampleList.Get(Index: integer): PExRec;
+begin
+ Result := PExRec(inherited get(Index));
+end;
+
+function TExampleList.InsertData(Cat, Desc, FFName, AName : string; Keys: TStringList): boolean;
+var
+ ExRecP : PExRec;
+begin
+ ExRecP := find(FFName);
+ new(ExRecP);
+ ExRecP^.Category := Cat;
+ ExRecP^.KeyWords := Keys; // Nil is acceptable
+ ExRecP^.Desc := Desc;
+ ExRecP^.FFName := FFName;
+ ExRecP^.EName := AName;
+ result := (inherited Add(ExRecP) > -1);
+end;
+
+ // Returns an unquoted string being one JSON Escaped record from list.
+function TExampleList.AsJSON(Index : integer) : string; // Not used, maybe remove ? Or Add in EName
+begin
+ Result := '';
+ Result := Result + 'Category : ' + Items[Index]^.Category + #10;
+ Result := Result + 'Keywords : ' + Items[Index]^.Keywords.Text + #10#10;
+ Result := Result + Items[Index]^.Desc;
+ Result := Result.Replace('\', '\\', [rfReplaceAll] );
+ Result := Result.Replace('"', '\"', [rfReplaceAll] );
+end;
+
+function TExampleList.IsInKeywords(St: string; AnIndex: integer): boolean;
+ var KeyWord : String;
+begin
+ result := false;
+ if pos(lowercase(St), lowercase(Items[AnIndex]^.EName)) > 0 then exit(true);
+ for KeyWord in Items[AnIndex]^.Keywords do begin
+ if pos(lowercase(St), lowercase(Keyword)) > 0 then exit(True);
+ end;
+end;
+
+
+procedure TExampleList.DumpList(wherefrom: string; ShowDesc : boolean = false); // ToDo : remove this, its just a debug method
+var
+ i : integer = 0;
+begin
+ DebugLn('-------- ExampleData Examples List ' + Wherefrom + '----------');
+ while i < count do begin
+ DebugLn('<<<< List - FFName=[' + Items[i]^.FFName +'] Cat=[' + Items[i]^.Category
+ + '] EName=' + Items[i]^.EName
+ + '] Key=[' + Items[i]^.Keywords.Text + ']');
+ if ShowDesc then
+ DebugLn(Items[i]^.Desc);
+ inc(i);
+ end;
+end;
+
+constructor TExampleList.Create();
+begin
+ inherited Create;
+end;
+
+destructor TExampleList.Destroy;
+var
+ i : integer;
+begin
+ for I := 0 to Count-1 do begin
+ if Items[i]^.Keywords <> nil then
+ Items[i]^.Keywords.free;
+ dispose(Items[i]);
+ end;
+ inherited Destroy;
+end;
+
+function TExampleList.Find(const FFname: string): PExRec;
+var
+ i : integer = 0;
+begin
+ while i < count do begin
+ if Items[i]^.FFname = FFname then
+ exit(Items[i]);
+ inc(i);
+ end;
+ Result := nil;
+end;
+
+// =============================================================================
+// T E X A M P L E D A T A
+// =============================================================================
+
+
+function TExampleData.Count: integer;
+begin
+ result := ExList.Count;
+end;
+
+procedure TExampleData.fSetErrorString(Er : string);
+begin
+ ErrorString := Er;
+ Debugln(ErrorString);
+end;
+
+// Rets a path to where we will putting our downloaded or copied ex projects.
+// At present, this is the /downloaded_examples/
+// if not true, returns the FFName of the master meta file, same place.
+function TExampleData.MasterMeta(DirOnly : boolean = false) : string;
+begin
+ //result := LazConfigDir + cExamplesDir + pathdelim;
+ result := AppendPathDelim(ExamplesHome);
+ if not DirOnly then
+ result := Result + 'master' + MetaFileExt;
+end;
+
+function TExampleData.ExtractFieldsFromJSON(const JStr: string; out EName, Cat,
+ Keys, Desc, Error: string): boolean;
+var
+ jData, jItem : TJSONData;
+ STL : TStringList;
+ St : string;
+begin
+ Error := '';
+ result := TestJSON(JStr, Error, Cat);
+ if Not Result then exit(False); // some basic tests done, so
+ jData := GetJSON(JStr); // we know these 2 lines are safe.
+ jItem := jData.Items[0];
+ STL := TStringList.Create;
+ Result := False;
+ try
+ if not ExtractFromJSON('Description', jItem, Desc) then begin
+ Desc := '';
+ end;
+ Keys := '';
+ if ExtractArrayFromJSON('Keywords', JItem, StL) then begin
+ for St in STL do
+ Keys := Keys + '"' + ST + '",';
+ if Keys.length > 1 then
+ delete(Keys, Keys.Length, 1);
+ end;
+ EName := TJSONObject(jData).Names[0];
+ Result := True;
+ finally
+ STL.Free;
+ JData.Free;
+ end;
+end;
+
+function TExampleData.TestJSON(const J : string; out Error, Cat : string) : boolean;
+var
+ jData, jItem : TJSONData;
+begin
+ Result := true;
+ if (J.Length = 0) or (J[1] <> '{') then begin // Ignore obvious non JSON
+ Error := 'Empty text or does not start with {';
+ exit(False)
+ end;
+ try
+ try
+ jData := GetJSON(J); // Is it valid JSON ?
+ jItem := jData.Items[0];
+ except
+ on E: EJSONParser do begin
+ Error := 'ERROR Parsing- invalid JSON ' + E.Message;
+ jData := Nil; // Appears nothing is allocated on error ?
+ exit(false);
+ end;
+ on E: EScannerError do begin
+ Error := 'ERROR Scanning- invalid JSON ' + E.Message;
+ jData := Nil; // Appears nothing is allocated on error ?
+ exit(false);
+ end;
+ end;
+
+ if TJSONObject(jItem).Count = 0 then begin
+ Error := 'WARNING - file does not contain suitable JSON : ';
+ exit(false);
+ end;
+ if not ExtractFromJSON('Category', jItem, Cat) then begin
+ Error := 'WARNING - Category Not Set ';
+ exit(false);
+ end;
+ finally
+ jData.free;
+ end;
+end;
+
+// jItem never contains Project Path, its either found in json Name (master)
+// or derived from where we found the project (individual). So, always passed here.
+function TExampleData.InsertJSONData(jItem : TJSONData; FFName : string; AName : string = ''): boolean;
+var
+ Cat, Desc, AnotherName : String;
+ // index : integer;
+ KeyWords : TStringList;
+begin
+ ExtractFromJSON('Category', jItem, Cat); // An empty Cat is acceptable but undesirable.
+ if not ExtractFromJSON('Description', jItem, Desc) then exit(False);
+ KeyWords := TStringList.Create;
+ ExtractArrayFromJSON('Keywords', jItem, Keywords);
+ if AName <> '' then
+ AnotherName := AName
+ else
+ if not ExtractFromJSON('Name', jItem, AnotherName) then
+ AnotherName := '';
+ 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
+end;
+
+// Scans local tree below 'Path' looking for any likely Example Metadata files.
+// For each, it loads content into a StringList and passes it to an Insert method.
+// If AddPath, the full path is inserted, not just the relative one, eg extra dirs
+function TExampleData.ScanLocalTree(Path : string; PathAbs : boolean) : boolean;
+var
+ STL : TStringList = nil;
+ FileContent : TStringList;
+ St : string;
+begin
+ STL := FindAllFiles(Path, '*' + MetaFileExt, True);
+ try
+ 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(cExamplesDir, St) > 0 then continue; // thats our downloaded location
+ FileContent := TStringList.Create;
+ FileContent.LoadFromFile(St); // Thats contents of one individual metadata file
+ try
+ if PathAbs then
+ Result := ReadSingleJSON(FileContent, St)
+ else Result := ReadSingleJSON(FileContent, copy(St, Path.Length+1, 1000));
+ if not Result then begin
+ debugln('Offending file is ' + St);
+ debugln(ErrorMsg);
+ exit(False);
+ end;
+ finally
+ FileContent.Free;
+ end;
+ end;
+ finally
+ STL.Free;
+ end;
+end;
+
+
+function TExampleData.ReadSingleJSON(FileContent : TStringList; PathToStore : string = '') : boolean;
+var
+ jData, jItem : TJSONData;
+begin
+ Result := true;
+ if (FileContent.Count > 0) and (FileContent[0][1] = '{') then begin // Ignore obvious non JSON
+ try
+ try
+ jData := GetJSON(FileContent.Text); // Is it valid JSON ?
+ jItem := jData.Items[0];
+ except
+ on E: EJSONParser do begin
+ ErrorMsg := 'ERROR EJSONParser- invalid JSON ' + E.Message;
+ jData := Nil; // Appears nothing is allocated if error ?
+ exit(false);
+ end;
+ on E: EScannerError do begin // Thats in jsonscanner unit, Must doc on Wiki !!!
+ ErrorMsg := 'ERROR EScanner- invalid JSON ' + E.Message; // this is typically a single \
+ jData := Nil; // Appears nothing is allocated if error ?
+ exit(false);
+ end;
+ end;
+ if TJSONObject(jItem).Count = 0 then begin
+ debugln('WARNING - file does not contain suitable JSON : ');
+ exit(false);
+ end;
+ InsertJSONData(jItem, PathToStore, TJSONObject(jData).Names[0]);
+ finally
+ jData.free;
+ end;
+ end;
+end;
+
+destructor TExampleData.Destroy;
+begin
+ ExList.free;
+ inherited Destroy;
+end;
+
+procedure TExampleData.DumpExData; // ToDo : remove this, just a debug thingo
+begin
+ ExList.DumpList('TExampleData.Dump', True);
+end;
+
+constructor TExampleData.Create();
+begin
+ ExList := TExampleList.Create;
+ LazConfigDir := appendPathDelim(LazarusIDE.GetPrimaryConfigPath);
+end;
+
+procedure TExampleData.LoadExData(DataSource: TExampleDataSource);
+begin
+ // If we are loading the data from either the remote gitlab tree or a local
+ // git tree, we save the master file.
+ if not DirectoryExists(MasterMeta(True)) then
+ if not ForceDirectory(MasterMeta(True)) then exit;
+ case DataSource of
+ FromGitLabTree : begin // too slow to be useful
+ ScanRemoteTree('');
+ WriteMasterMeta('master' + MetaFileExt); // save in working dir
+ end;
+ FromLocalTree : begin // not used in Lazarus Package
+ 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;
+ FromLazSrcTree : begin
+ ScanLocalTree(GetLazDir(), True); // Scan the Lazarus SRC tree
+ ScanLocalTree(LazConfigDir, True); // Get, eg, any OPM Examples
+ end;
+ FromCacheFile : begin
+ if not LoadCacheFile(MasterMeta()) then begin
+ DownLoadFile('master' + MetaFileExt, MasterMeta());
+ LoadCacheFile(MasterMeta()); // ToDo : Test that worked
+ end;
+ ScanLocalTree(LazConfigDir, True); // Get, eg, any OPM Examples
+ end;
+ end;
+// if ExList.Count = 0 then begin
+ debugln('TExampleData.LoadExData - found examples = ' + inttostr(ExList.Count));
+ debugln('Lazarus Dir (ie source tree) = ' + GetLazDir());
+ debugln('Lazarus Config Dir = ' + LazConfigDir);
+ debugln('Examples Home Dir = ' + ExamplesHome);
+// end;
+end;
+
+
+// ****************** Local master meta File methods ***************************
+
+function TExampleData.ReadMasterJSON(FileContent : TStringList) : boolean;
+var
+ jData, jItem : TJSONData;
+ i : integer;
+begin
+ Result := true;
+
+ if (FileContent.Count > 0) and (FileContent[0][1] = '{') then begin // Ignore obvious non JSON
+ try
+ try
+ jData := GetJSON(FileContent.Text); // Is it valid JSON ?
+ except
+ on E: EJSONParser do begin
+ ErrorMsg := 'ERROR EJSONParser - invalid JSON ' + E.Message;
+ jData := Nil; // Appears nothing is allocated if error ?
+ exit(false);
+ end;
+ on E: EScannerError do begin
+ ErrorMsg := 'ERROR EScannerError - invalid JSON ' + E.Message;
+ jData := Nil; // Appears nothing is allocated if error ?
+ exit(false);
+ end;
+ end;
+ for i := 0 to jData.Count-1 do begin // check its real JSON, not just a field.
+ jItem := jData.Items[i]; // do not free.
+ if TJSONObject(jItem).Count > 0 then begin // might be ...
+ InsertJSONData(jItem, TJSONObject(jData).Names[i]);
+ end;
+ end;
+ finally
+ freeandnil(jData);
+ end;
+ end else result := False;
+end;
+
+function TExampleData.LoadCacheFile(FFName : string) : boolean;
+var
+ FileContent : TStringList;
+begin
+ if not FileExists(FFName) then exit(False);
+ FileContent := TStringList.Create;
+ try
+ FileContent.LoadFromFile(FFname);
+ Result := ReadMasterJSON(FileContent);
+ if not Result then
+ debugln('Offending file is ' + FFName);
+ finally
+ FileContent.Free;
+ end;
+ Result := true;
+end;
+
+{ environmentoptions.xml
+
+
+
+ ...
+ .... }
+
+
+function TExampleData.GetLazDir() : string; // Todo : make direct call
+var
+ Doc : TXMLDocument;
+ Node, Node1 : TDOMNode;
+begin
+ Result := '';
+ ReadXMLFile(Doc, LazConfigDir + 'environmentoptions.xml');
+ Node1 := Doc.DocumentElement.FindNode('EnvironmentOptions');
+ if Node1 <> nil then begin
+ Node := Node1.FindNode('LazarusDirectory');
+ if Node <> nil then
+ Result := AppendPathDelim(Node.Attributes.GetNamedItem('Value').NodeValue);
+ end;
+ Doc.free;
+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;
+
+class function TExampleData.EscJSON(InStr : string) : string;
+begin
+ Result := InStr.Replace('\', '\\', [rfReplaceAll]);
+ Result := Result.Replace('"', '\"', [rfReplaceAll]);
+ Result := Result.Replace(#10, '\n', [rfReplaceAll] ); // LF
+ Result := Result.Replace(#13, '', [rfReplaceAll] ); // CR
+ Result := Result.Replace(#09, '', [rfReplaceAll] ); // tab
+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 *******************
+
+function TExampleData.GetListData(out Proj, Cat, Path, Keys : string;
+ GetFirst: boolean; KeyList : TStringList = nil): boolean;
+var
+ St : string;
+ DoContinue : boolean = false;
+begin
+ //KeyList may be Nil, if so, ignore
+ Result := True;
+ if CatFilter = '' then exit(False);
+ if GetFirst then
+ GetListDataIndex := 0;
+ while True do begin
+ if GetListDataIndex >= ExList.Count then exit(False);
+ if CatFilter <> '' then begin // Find an entry in one of the categories
+ // orig a while instead of if, needed to use DoContinue ... Why ?
+ if pos(ExList.Items[GetListDataIndex]^.Category, CatFilter) < 1 then begin
+ inc(GetListDataIndex);
+ continue;
+ end;
+ end;
+ if KeyList <> Nil then begin
+ for St in KeyList do
+ // IndexOf requires a 1:1 match, we want to know if St is in the keyword.
+ //if ExList.Items[GetListDataIndex]^.Keywords.IndexOf(St) = -1 then begin
+ if not ExList.IsInKeywords(St, GetListDataIndex) then begin
+ inc(GetListDataIndex);
+ DoContinue := True;
+ Break;
+ end;
+ if DoContinue then begin // Hmm, a GoTo would be easier ......
+ DoContinue := False;
+ Continue;
+ end;
+ end;
+ break;
+ end;
+ Proj := ExList.Items[GetListDataIndex]^.EName;
+ Cat := ExList.Items[GetListDataIndex]^.Category;
+ Path := ExtractFilePath(ExList.Items[GetListDataIndex]^.FFname);
+ Keys := '';
+ for St in ExList.Items[GetListDataIndex]^.Keywords do
+ Keys := Keys + St + ' ';
+ inc(GetListDataIndex);
+end;
+
+function TExampleData.getCategoryData(const CatList: TStrings): boolean;
+var
+ P : PExRec;
+begin
+ if CatList = nil then exit(false);
+ CatList.Clear;
+ for P in ExList do begin
+ if CatList.Indexof(P^.Category) < 0 then
+ CatList.Add(P^.Category);
+ end;
+ Result := True;
+end;
+
+// Passed the FFName, a combination of Path and Proj including '.ex-meta'.
+function TExampleData.GetDesc(const FFname: string): string;
+var
+ P : PExRec;
+begin
+ for P in ExList do begin
+ if (lowercase(P^.FFname) = lowercase(FFname)+MetaFileExt) then begin // extension must remain lower case
+ exit(P^.Desc);
+ end;
+ end;
+ Result := '';
+ debugln('TExampleData.GetDesc - did not find Desc for ' + FFname);
+ debugln('Spelling of Name must match directory name (case insensitive)');
+ ExList.DumpList('TExampleData.GetDesc', True);
+end;
+
+
+// ************* Methods relating to getting REMOTE data *******************
+
+function TExampleData.DownLoadDir(const FExampDir : string): boolean;
+var
+ St : string;
+ STL : TStringlist;
+begin
+ STL := TStringList.Create;
+ try
+ result := ScanRemoteTree(FExampDir, STL);
+ for St in STL do begin
+ if not DirectoryExistsUTF8(MasterMeta(True) + ExtractFileDir(St)) then
+ ForceDirectory(MasterMeta(True) + ExtractFileDir(St)); // ToDo : but that might fail
+ DownLoadFile(St, MasterMeta(True) + St);
+ end;
+ finally
+ STL.Free;
+ end;
+end;
+
+
+function TExampleData.DownLoadFile(const URL, FullDest : string) : boolean;
+var
+ St, S : string;
+ MemBuffer : TMemoryStream;
+ DecodedStream : TMemoryStream;
+ Decoder : TBase64DecodingStream;
+begin
+ if not Downloader(RemoteRepo + 'files/' + HTTPEncode(URL) + '?ref=main', St) then begin
+ ErrorMsg := 'TExampleData.ReadMetaFile - download FAILED ' + URL;
+ exit(false);
+ end;
+ S := ExtractFromJSON('content', St, False); // Bring it back still base64 encoded
+ MemBuffer := TMemoryStream.Create; // Speedups possible here. BuffStream ?
+ try
+ MemBuffer.Write(S[1], S.length);
+ membuffer.Position := 0;
+ DecodedStream := TMemoryStream.Create;
+ Decoder := TBase64DecodingStream.Create(MemBuffer);
+ try
+ DecodedStream.CopyFrom(Decoder, Decoder.Size);
+ DecodedStream.SaveToFile(FullDest); // Does not appear to benifit from TBufferedFileStream
+ except on E: EStreamError do
+ ErrorMsg := 'TExampleData.DownLoadFile - Error decoding ' + URL + ' ' + E.Message;
+ end;
+ finally
+ MemBuffer.Free;
+ DecodedStream.Free;
+ Decoder.Free;
+ end;
+ result := fileexists(FullDest);
+end;
+
+
+// Passed some json, returns the indicated field IFF its an arrays. The TStringList
+// must have been created before being passed.
+function TExampleData.ExtractArrayFromJSON(const Field : string; jItem : TJSONData; STL : TStringList) : boolean;
+// ToDo : better to handle this with a set or array ? Once populated, it does not change
+var
+ JObject : TJSONObject;
+ jArray : TJSONArray;
+ i : integer;
+begin
+ result := true;
+ try
+ JObject := TJSONObject(jItem); // does not require a free
+ if jObject.Find(Field, JArray) then
+ for i := 0 to JArray.count -1 do
+ STL.Add(JArray.Items[i].asstring);
+ except
+ on E:Exception do begin
+ Result := False; // Invalid JSON or content not present
+ ErrorMsg := 'Exception while decoding JSON looking for ' + Field;
+ end;
+ end;
+end;
+
+function TExampleData.ExtractFromJSON(const Field, data : string; Base64 : boolean=false) : string;
+var
+ JData : TJSONData;
+ JObject : TJSONObject;
+ jStr : TJSONString;
+begin
+ result := '';
+ try
+ try
+ JData := GetJSON(Data); // requires a free
+ JObject := TJSONObject(jData); // does not require a free
+ if jObject.Find(Field, Jstr) then begin
+ if Base64 then
+ Result := DecodeStringBase64(jStr.AsString)
+ else Result := jStr.AsString;
+ end else ErrorMsg := 'Response has no ' + Field + ' field';
+ except
+ on E:Exception do begin
+ Result := ''; // Invalid JSON or content not present
+ ErrorMsg := 'Exception while decoding JSON looking for ' + Field;
+ end;
+ end;
+ finally
+ JData.Free;
+ end;
+ if Result = '' then debugln('ERROR, we did not find content in ' + Field);
+end;
+
+// Returns false if cannot parse passed jItem, thats not necessarily an error,
+// Path will not be here if reading individual metadata files.
+// If it is an error, ErrorString is set.
+function TExampleData.ExtractFromJSON(const Field : string; const jItem : TJSONData;
+ out Res : string; Base64 : boolean=false) : boolean;
+var
+ JObject : TJSONObject;
+ jStr : TJSONString;
+begin
+ res := '';
+ try
+ JObject := TJSONObject(jItem); // does not require a free
+ if jObject.Find(Field, Jstr) then begin
+ if Base64 then
+ Res := DecodeStringBase64(jStr.AsString)
+ else Res := jStr.AsString;
+ end else if Field <> 'Path' then begin
+ ErrorMsg := 'Response has no ' + Field + ' field';
+ end;
+ except
+ on E:Exception do // Invalid JSON or content not present
+ ErrorMsg := 'Exception while decoding JSON looking for ' + Field;
+ end;
+ Result := (Res <> '');
+end;
+
+
+// Gets passed the RHS of URL of a metadata file, adds that content to list.
+// eg Beginner/Laz_Hello/Laz_Hello.ex-meta
+function TExampleData.ReadRemoteMetaFile(URL : string): boolean;
+var
+ St : string;
+ StL : TStringList;
+begin
+ if not Downloader(RemoteRepo + 'files/' + HTTPEncode(URL) + '?ref=main', St) then begin
+ ErrorMsg := 'TExampleData.ReadMetaFile - download FAILED';
+ exit(false);
+ end;
+ StL := TStringList.Create;
+ try
+ STL.Text := ExtractFromJSON('content', St, True); // get 'content' and decode base64
+ result := ReadSingleJSON(STL, URL);
+ if not Result then
+ debugln('Offending remote file is ' + URL);
+ finally
+ STL.Free;
+ end;
+end;
+
+// https://gitlab.com/api/v4/projects/32866275/repository/files/Utility/ExScanner/project1.ico?ref=main
+// curl "https://gitlab.com/api/v4/projects/32866275/repository/files/Utility%2FExScanner%2Fproject1.ico?ref=main"
+
+function TExampleData.ScanRemoteTree(Path : string; STL : TstringList = nil) : boolean;
+// warning - recursive function.
+var
+ St : string;
+ jData : TJSONData;
+ jObject : TJSONObject;
+ jArray : TJSONArray;
+ i : integer;
+begin
+ ScanOneTree(Path, St);
+ jData := GetJSON(St);
+ jArray:=TJSONArray(jData);
+ for i:=0 to jArray.Count-1 do begin
+ jObject:= TJSONObject(jArray[i]);
+ if jObject.Find('type').AsString = 'tree' then // tree and blob are gitlab defines, in the download
+ ScanRemoteTree(jObject.Find('path').AsString, STL);
+ if (jObject.Find('type').AsString = 'blob') then begin // A blob is a usable file
+ if STL <> nil then
+ STL.add(jObject.Find('path').AsString)
+ else // OK, fill in List mode.
+ if (pos(MetaFileExt, jObject.Find('path').AsString) > 0) then begin
+ if pos('master' + MetaFileExt, jObject.Find('path').AsString) < 1 then // don't do master meta file
+ if STL = Nil then
+ ReadRemoteMetaFile(jObject.Find('path').AsString );
+ end;
+ end;
+ end;
+ jArray.Free;
+ Result := true;
+end;
+
+function TExampleData.ScanOneTree(Path : string; out St : string) : boolean; // needed
+var
+ URL : string;
+begin
+ if Path <> '' then
+ URL := RemoteRepo + 'tree?path=' + Path
+ else URL := RemoteRepo + 'tree';
+ Result := Downloader(URL, St);
+end;
+
+
+function TExampleData.Downloader(URL: string; out SomeString: String): boolean;
+var
+ Client: TFPHTTPClient;
+begin
+ // This is a dumb downloader, if you need auth then maybe look at transgithub in tomboy-ng
+ // Further, gitlab API seems quite slow, up to a second for an 80K icon file ??
+ // curl "https://gitlab.com/api/v4/projects/32866275/repository/files/Utility%2FExScanner%2Fproject1.ico?ref=main"
+ // curl does the same thing in a bit over half that time. Hmm....
+ Client := TFPHttpClient.Create(nil);
+ Client.AddHeader('User-Agent','Mozilla/5.0 (compatible; fpweb)');
+ Client.AddHeader('Content-Type','application/json; charset=UTF-8');
+ Client.AllowRedirect := true;
+ SomeString := '';
+ try
+ try
+ SomeString := Client.Get(URL);
+ except
+ on E: ESocketError do begin
+ ErrorMsg := rsExNetWorkError + ' ' + E.Message;
+ exit(false);
+ end;
+ on E: EInOutError do begin
+ ErrorMsg := rsExNetWorkError + ' InOut ' + E.Message;
+ exit(False);
+ end;
+ on E: ESSL do begin
+ ErrorMsg := rsExNetWorkError + ' SSL ' + E.Message;
+ exit(False);
+ end;
+ on E: Exception do begin // Following don't need i18n, we check they are there !
+ case Client.ResponseStatusCode of
+ 401 : ErrorMsg := 'GitHub.Downloader Exception ' + E.Message
+ + ' downloading ' + URL
+ + ' 401 Maybe your Token has expired or password is invalid ??';
+ 404 : ErrorMsg := 'GitHub.Downloader Exception ' + E.Message
+ + ' downloading ' + URL + ' 404 File not found ' + URL;
+ end;
+ exit(false);
+ end;
+ end;
+ finally
+ Client.Free;
+ end;
+ result := true;
+end;
+
+end.
+
diff --git a/components/exampleswindow/uintf.pas b/components/exampleswindow/uintf.pas
new file mode 100644
index 0000000000..7e7d830ae6
--- /dev/null
+++ b/components/exampleswindow/uintf.pas
@@ -0,0 +1,106 @@
+unit uIntf;
+
+{
+ **********************************************************************
+ 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 provides the interface between Lazarus and the Package.
+
+}
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes,
+ //LCL,
+ LCLType,
+ //IDEIntf,
+ MenuIntf, IDECommands, ToolBarIntf, IDEOptEditorIntf;
+
+procedure Register;
+
+implementation
+
+uses uLaz_Examples, uConst, lazlogger,
+ LazIDEintf, LazFileUtils, BuildIntf, ExWinSettings,
+ baseIDEIntf, IDEOptionsIntf, LazConfigStorage, SysUtils;
+
+// Note : IDEEnvironmentOptions.GetParsedLazarusDirectory is the Lazarus STC tree.
+
+function GetExamplesHomeDir() : string;
+var
+ Config: TConfigStorage;
+begin
+ try
+ Config := GetIDEConfigStorage(cConfigFileName, true);
+ try
+ Result := Config.GetValue('Examples/Directory',
+ AppendPathDelim(LazarusIDE.GetPrimaryConfigPath) +
+ AppendPathDelim(cExamplesDir));
+
+ finally
+ Config.Free;
+ end;
+ except
+ on E: Exception do begin
+ DebugLn('Examples UIntf GetExamplesDirectory Loading ' + cConfigFileName + ' failed: ' + E.Message);
+ Result := IDEEnvironmentOptions.GetParsedLazarusDirectory;
+ end;
+ end;
+
+end;
+
+procedure IDEMenuSectionClicked(Sender: TObject);
+var
+ ProjectFFile : string;
+begin
+ FormLazExam := TFormLazExam.Create(nil);
+ try
+ FormLazExam.ExamplesHome := GetExamplesHomeDir();
+ FormLazExam.RemoteRepo := cRemoteRepository;
+ FormLazExam.ShowModal;
+ ProjectFFile := FormLazExam.ProjectToOpen;
+ finally
+ FormLazExam.Free;
+ FormLazExam := nil;
+ end;
+ if ProjectFFile <> '' then
+ LazarusIDE.DoOpenProjectFile(ProjectFFile, [ofProjectLoading]);
+end;
+
+procedure Register;
+var
+ IDEShortCutX: TIDEShortCut;
+ IDECommandCategory: TIDECommandCategory;
+ IDECommand: TIDECommand;
+begin
+ IDEShortCutX := IDEShortCut(VK_E, [ssCtrl, ssAlt], VK_UNKNOWN, []);
+ IDECommandCategory := IDECommandList.FindCategoryByName('ToolMenu');
+ IDECommand := nil;
+ if IDECommandCategory <> nil then
+ begin
+ IDECommand := RegisterIDECommand(IDECommandCategory, rsExampleProjects, rsExampleProjects, IDEShortCutX, nil, @IDEMenuSectionClicked);
+ if IDECommand <> nil then
+ RegisterIDEButtonCommand(IDECommand);
+ end;
+ RegisterIDEMenuCommand(itmSecondaryTools, rsExampleProjects, rsExampleProjects + ' ...', nil, @IDEMenuSectionClicked, IDECommand, 'pkg_oep');
+ RegisterIDEMenuCommand(ComponentPalettePageDropDownExtraEntries, rsExampleProjects, rsExampleProjects + ' ...', nil, @IDEMenuSectionClicked, nil, 'pkg_oep');
+
+ ExWinOptionsFrameID := RegisterIDEOptionsEditor(ExWindowOptionsGroup, TExWinSettingsFrame, 9999)^.Index; // AIndex = what ???
+
+end;
+
+initialization
+
+
+finalization
+
+
+end.
+
diff --git a/components/exampleswindow/ulaz_examples.lfm b/components/exampleswindow/ulaz_examples.lfm
new file mode 100644
index 0000000000..4b8cb9af7a
--- /dev/null
+++ b/components/exampleswindow/ulaz_examples.lfm
@@ -0,0 +1,194 @@
+object FormLazExam: TFormLazExam
+ Left = 562
+ Height = 574
+ Top = 168
+ Width = 781
+ Caption = 'Prototype Lazarus Examples Window'
+ ClientHeight = 574
+ ClientWidth = 781
+ OnCreate = FormCreate
+ OnDestroy = FormDestroy
+ OnShow = FormShow
+ LCLVersion = '2.3.0.0'
+ object Memo1: TMemo
+ AnchorSideLeft.Control = Owner
+ AnchorSideTop.Control = Splitter2
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = CheckGroupCategory
+ Left = 5
+ Height = 216
+ Top = 225
+ Width = 771
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ BorderSpacing.Left = 5
+ BorderSpacing.Right = 5
+ BorderSpacing.Bottom = 5
+ Lines.Strings = (
+ 'Memo1'
+ )
+ ParentShowHint = False
+ ReadOnly = True
+ ScrollBars = ssAutoVertical
+ TabOrder = 2
+ end
+ object ListView1: TListView
+ AnchorSideLeft.Control = Owner
+ AnchorSideTop.Control = Panel1
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = Splitter2
+ Left = 5
+ Height = 178
+ Hint = 'Click for Info, Double Click to download'
+ Top = 37
+ Width = 776
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ BorderSpacing.Left = 5
+ BorderSpacing.Top = 5
+ BorderSpacing.Bottom = 5
+ Columns = <
+ item
+ end
+ item
+ end
+ item
+ Width = 661
+ end>
+ ParentShowHint = False
+ ReadOnly = True
+ ShowHint = True
+ TabOrder = 1
+ OnClick = ListView1Click
+ OnDblClick = ListView1DblClick
+ OnSelectItem = ListView1SelectItem
+ end
+ object CheckGroupCategory: TCheckGroup
+ AnchorSideLeft.Control = Owner
+ AnchorSideTop.Control = ButtonOpen
+ AnchorSideRight.Control = ButtonClose
+ AnchorSideBottom.Control = StatusBar1
+ Left = 10
+ Height = 105
+ Top = 446
+ Width = 577
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ AutoFill = True
+ BorderSpacing.Left = 10
+ BorderSpacing.Right = 10
+ Caption = 'Category'
+ ChildSizing.LeftRightSpacing = 6
+ ChildSizing.TopBottomSpacing = 6
+ ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
+ ChildSizing.EnlargeVertical = crsHomogenousChildResize
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 2
+ Columns = 2
+ OnItemClick = CheckGroupCategoryItemClick
+ TabOrder = 3
+ end
+ object Splitter2: TSplitter
+ AnchorSideLeft.Control = Owner
+ AnchorSideTop.Control = ListView1
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = Memo1
+ Cursor = crVSplit
+ Left = 0
+ Height = 5
+ Top = 220
+ Width = 781
+ Align = alNone
+ Anchors = [akLeft, akRight]
+ ResizeAnchor = akTop
+ end
+ object Panel1: TPanel
+ AnchorSideLeft.Control = Owner
+ AnchorSideTop.Control = Owner
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ Left = 0
+ Height = 32
+ Top = 0
+ Width = 781
+ Anchors = [akTop, akLeft, akRight]
+ ClientHeight = 32
+ ClientWidth = 781
+ TabOrder = 0
+ TabStop = True
+ object EditSearch: TEdit
+ AnchorSideLeft.Control = Panel1
+ AnchorSideTop.Control = Panel1
+ Left = 10
+ Height = 29
+ Hint = 'Searches for Keywords'
+ Top = 1
+ Width = 415
+ Anchors = [akTop, akLeft, akRight]
+ BorderSpacing.Left = 9
+ BorderSpacing.Right = 25
+ OnExit = EditSearchExit
+ OnKeyUp = EditSearchKeyUp
+ ParentShowHint = False
+ ShowHint = True
+ TabOrder = 0
+ Text = 'EditSearch'
+ end
+ end
+ object StatusBar1: TStatusBar
+ Left = 0
+ Height = 23
+ Top = 551
+ Width = 781
+ Panels = <>
+ end
+ object ButtonDownload: TButton
+ AnchorSideLeft.Control = ButtonClose
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = ButtonClose
+ Left = 597
+ Height = 35
+ Top = 481
+ Width = 179
+ Anchors = [akLeft, akRight, akBottom]
+ BorderSpacing.Right = 5
+ Caption = 'Download'
+ OnClick = ButtonDownloadClick
+ TabOrder = 6
+ end
+ object ButtonClose: TButton
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = StatusBar1
+ Left = 597
+ Height = 35
+ Top = 516
+ Width = 179
+ Anchors = [akRight, akBottom]
+ BorderSpacing.Right = 5
+ Caption = 'Close'
+ OnClick = ButtonCloseClick
+ TabOrder = 7
+ end
+ object ButtonOpen: TButton
+ AnchorSideLeft.Control = ButtonClose
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = ButtonDownload
+ Left = 597
+ Height = 35
+ Top = 446
+ Width = 179
+ Anchors = [akLeft, akRight, akBottom]
+ BorderSpacing.Right = 5
+ Caption = 'Open'
+ OnClick = ButtonOpenClick
+ TabOrder = 8
+ end
+end
diff --git a/components/exampleswindow/ulaz_examples.lpi b/components/exampleswindow/ulaz_examples.lpi
new file mode 100644
index 0000000000..1984869e56
--- /dev/null
+++ b/components/exampleswindow/ulaz_examples.lpi
@@ -0,0 +1,58 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ -
+
+
+ -
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/exampleswindow/ulaz_examples.pas b/components/exampleswindow/ulaz_examples.pas
new file mode 100644
index 0000000000..e8fef2c28a
--- /dev/null
+++ b/components/exampleswindow/ulaz_examples.pas
@@ -0,0 +1,471 @@
+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.
+
+Notes -
+ We have a search field across the top, its requires user to press enter,
+ performance notwithstanding, it could be converted to update with every key press.
+
+ David Bannon, Feb 2022
+}
+{$mode objfpc}{$H+}
+
+{x$define ONLINE_EXAMPLES}
+
+interface
+
+uses
+ Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls,
+ ExtCtrls, Interfaces, uexampledata, uConst
+ {$ifndef EXTESTMODE}
+ , IDEWindowIntf
+ {$endif}
+ ;
+
+
+type
+
+ { TFormLazExam }
+
+ TFormLazExam = class(TForm)
+ ButtonDownload: TButton;
+ ButtonClose: TButton;
+ ButtonOpen: TButton;
+ CheckGroupCategory: TCheckGroup;
+ EditSearch: TEdit;
+ ListView1: TListView;
+ Memo1: TMemo;
+ Panel1: TPanel;
+ Splitter2: TSplitter;
+ StatusBar1: TStatusBar;
+ procedure ButtonCloseClick(Sender: TObject);
+ procedure ButtonDownloadClick(Sender: TObject);
+ procedure ButtonOpenClick(Sender: TObject);
+ procedure CheckGroupCategoryItemClick(Sender: TObject; Index: integer);
+ procedure EditSearchExit(Sender: TObject);
+ procedure EditSearchKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure ListView1Click(Sender: TObject);
+ procedure ListView1DblClick(Sender: TObject);
+ procedure ListView1SelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
+ private
+ procedure BuildSearchList(SL: TStringList; const Term: AnsiString);
+ // SrcDir includes name of actual dir, DestDir does not.
+ function CopyFiles(const Proj, SrcDir, DestDir: 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
+ // 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;
+ function NewLVItem(const LView : TListView; const Proj, Path, KeyWords : string): TListItem;
+ // 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 download examples to 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
+
+uses LazFileUtils, LCLType, fileutil, LazLogger;
+
+{$R *.lfm}
+
+{ TFormLazExam }
+
+
+// ------------------------ L I S T V I E W ----------------------------------
+
+function TFormLazExam.NewLVItem(const LView : TListView; const Proj, Path, KeyWords : string): TListItem;
+var
+ TheItem : TListItem;
+begin
+ TheItem := LView.Items.Add;
+ TheItem.Caption := Proj;
+ TheItem.SubItems.Add(KeyWords);
+ TheItem.SubItems.Add(Path);
+ Result := TheItem;
+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;
+ if EditSearch.text <> rsExSearchPrompt then begin
+ KeyList := TStringList.Create;
+ BuildSearchList(KeyList, EditSearch.Text);
+ end;
+ try
+ if Ex.GetListData(Proj, Cat, Path, KeyW, True, KeyList) then begin
+ NewLVItem(ListView1, Proj, Path, KeyW);
+ inc(Cnt);
+ end;
+ while Ex.GetListData(Proj, Cat, Path, KeyW, False, KeyList) do begin
+ NewLVItem(ListView1, Proj, Path, KeyW);
+ inc(Cnt);
+ end;
+ finally
+ if KeyList <> Nil then KeyList.Free;
+ Screen.Cursor := crDefault;
+ end;
+ ButtonOpen.Enabled := false;
+ ButtonDownLoad.enabled := false;
+ Memo1.append(format(rsFoundExampleProjects, [Cnt]));
+ StatusBar1.SimpleText := format(rsFoundExampleProjects, [Cnt]);
+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(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;
+ //ButtonOpen.Enabled := GetProjectFile(ListView1.Selected.SubItems[1]);
+ ButtonOpen.Enabled := GetProjectFile(Ex.MasterMeta(True) + ListView1.Selected.Caption);
+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();
+
+ debugln('TFormLazExam.CopyFiles Forcing an ExamplesHome of ' + extractFileDir(FFname));
+ debugln('TFormLazExam.CopyFiles Copying a file to ' + FFname);
+ debugln('TFormLazExam.CopyFiles DestDir = ' + DestDir);
+ debugln('TFormLazExam.CopyFiles ExamplesHome = ' + ExamplesHome);
+ 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);
+begin
+ if ListView1.Selected = nil then exit; // White space below entries ....
+ if GetProjectFile(Ex.MasterMeta(True) + 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.MasterMeta(True)) then
+ StatusBar1.SimpleText := rsExProjectCopiedTo + ' ' + Ex.MasterMeta(True)
+ else StatusBar1.SimpleText := rsFailedToCopyFilesTo + ' ' + Ex.MasterMeta(True);
+ {$endif}
+ end;
+ finally
+ Screen.Cursor := crDefault;
+ end;
+ ButtonOpen.Enabled := GetProjectFile(Ex.MasterMeta(True) + ListView1.Selected.Caption);
+end;
+
+// --------------------- B U T T O N S -----------------------------------------
+
+procedure TFormLazExam.ButtonOpenClick(Sender: TObject);
+begin
+ if GetProjectFile(Ex.MasterMeta(True) + ListView1.Selected.Caption, True) // Sets ProjectToOpen on success
+ and ProjectToOpen.IsEmpty then
+ showmessage(rsExNoProjectFile)
+ else
+ close;
+end;
+
+procedure TFormLazExam.ButtonCloseClick(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TFormLazExam.ButtonDownloadClick(Sender: TObject);
+begin
+ ListView1DblClick(Sender);
+end;
+
+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.
+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;
+
+// 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;
+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;
+
+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 --------------------------
+
+// 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.EditSearchExit(Sender: TObject);
+begin
+ if EditSearch.Text = '' then begin
+ EditSearch.Hint:= rsExSearchPrompt;
+ EditSearch.Text := rsExSearchPrompt;
+ EditSearch.SelStart := 1;
+ EditSearch.SelLength := length(EditSearch.Text);
+ end;
+end;
+
+procedure TFormLazExam.KeyWordSearch();
+begin
+ Memo1.clear;
+ ListView1.Clear;
+ Ex.KeyFilter := EditSearch.Text;
+ LoadUpListView();
+end;
+
+procedure TFormLazExam.EditSearchKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
+begin
+ // Must do this here to stop LCL from selecting the text on VK_RETURN
+ if Key = VK_RETURN then begin
+ Key := 0;
+ KeyWordSearch();
+ end;
+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
+ 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;
+ EditSearch.text := rsExSearchPrompt;
+ Ex := nil;
+ // These are ObjectInspector set but I believe I cannot get OI literals set in a Package ??
+ ButtonClose.Caption := rsExampleClose;
+ ButtonDownload.Caption := rsExampleDownLoad;
+ ButtonOpen.Caption := rsExampleOpen;
+ CheckGroupCategory.Caption := rsExampleCategory;
+ {$ifndef EXTESTMODE}
+ IDEDialogLayoutList.ApplyLayout(Self);
+ {$endif}
+end;
+
+procedure TFormLazExam.FormDestroy(Sender: TObject);
+begin
+ if Ex <> nil then Ex.Free;
+end;
+
+procedure TFormLazExam.FormShow(Sender: TObject);
+var
+ i : integer;
+begin
+ Memo1.clear;
+ if Ex <> Nil then Ex.Free;
+ StatusBar1.SimpleText := rsExSearchingForExamples;
+ Ex := TExampleData.Create();
+ Ex.GitDir := GitDir;
+ Ex.ExamplesHome := ExamplesHome;
+ Ex.RemoteRepo := RemoteRepo;
+ {$ifdef ONLINE_EXAMPLES}
+ Ex.LoadExData(FromCacheFile);
+ {$else}
+ Ex.LoadExData(FromLazSrcTree);
+ {$endif}
+ if Ex.ErrorMsg <> '' then
+ Showmessage(Ex.ErrorMsg)
+ else begin
+ 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();
+ end;
+ if EditSearch.Text <> rsExSearchPrompt then
+ KeyWordSearch()
+ else EditSearch.SetFocus;
+
+
+end;
+
+{ Must add a FormClose event
+ IDEDialogLayoutList.SaveLayout(Self);
+}
+
+
+end.
+