ExamplesWindow: Better model to find Examples. Issue #40190, patch by dbannon.

components/exampleswindow/uexampledata.pas

@@ -8,18 +8,20 @@ unit uExampleData;
   for details about the license.
  **********************************************************************
 
-This unit is the backend that provides an List that contains details of Lazarus
+This unit is the backend that provides a List that contains details of Lazarus
 Example Projects. It might get its data from one of three different places,
 
-* The LazarusDir and the LazarusConfigDir.
+* The LazarusDir, thats the SRC dir, examples shipped with Lazarus.
-* A locally cached master meta file          Disabled as of Feb 2022
+* Any Packages installed in Lazarus, looks in <pcp>packagefiles.xml
-* A remote gitlab repository (ie, if the above is not present),  Disabled as of Feb 2022
+
+  ( 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 --
+-- PATHS (n.a. unless online mode enabled ) --
 
 This only really applies in the Out of Lazarus Package usage. David Bannon, Feb 2022
 
@@ -37,7 +39,6 @@ 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.
 
-
 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 !
@@ -45,7 +46,7 @@ Code would be greatly simplified if we were not trying to also support OnLine.
 }
 
 {$mode ObjFPC}{$H+}
-
+{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}
 interface
 
 uses
@@ -53,20 +54,20 @@ uses
     httpprotocol,  // for http encoding
     fphttpclient,  // determines a dependency on FPC 3.2.0 or later. Must for https downloads
     ssockets, fpopenssl, base64,
-    // LazUtils
+    Laz2_XMLRead, Laz2_DOM, LazFileUtils, FileUtil, LazLoggerBase
-    LazFileUtils, FileUtil, LazLoggerBase,
+    {$ifndef EXTESTMODE}
-    // BuildIntf
+    , IDEOptionsIntf
-    IDEOptionsIntf;
+    {$endif};
 
 const
     MetaFileExt = '.ex-meta';              // Extension of meta files.
 
-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
+    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
+
     PExRec=^TExRec;
     TExRec = record
           EName    : string;      // CamelCase version of the example name, filenameonly of metadata file.
@@ -76,8 +77,8 @@ type
           Desc     : string;      // 1..many lines of description
     end;
 
-type
     { TExampleList }
+
     TExampleList = class(TFPList)
         private
 
@@ -95,8 +96,7 @@ type
              function IsInKeywords(St : string; AnIndex : integer) : boolean;
              property Items[Index: integer]: PExRec read Get; default;
 
-
+    end;
-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
@@ -105,8 +105,6 @@ 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
@@ -115,6 +113,15 @@ type
             ExList : TExampleList;
             GetListDataIndex : integer;
 
+                                // Passed full file name of the packagesfiles.xml file in PCP, returns
+                                // with the list filled with paths to some directory above the package
+                                // lpk file being a suitable place to start searching for Examples.
+            procedure CollectThirdPartyPackages(PkgFilesXML: String; AList: TStrings);
+                                // Returns true if it has altered FullPkgFileName to where we can expect to find Examples
+            function GetThirdPartyDir(var FullPkgFileName: string): boolean;
+                                // Triggers a search of installed packages other than ones from LazSrcTree
+                                // It assumes such packages are listed in <PCP>/packagefiles.xml
+            procedure ScanThirdPartyPkg;
                                 // 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
@@ -127,6 +134,7 @@ type
             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;
+
                                 // 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
@@ -149,7 +157,7 @@ type
             procedure fSetErrorString(Er : string);
 
         public
-            LazConfigDir : string; // Where Lazarus keeps it config.
+            LazConfigDir : string; // Where Lazarus keeps it config. Comes from uLaz_Examples, uIntf, LazarusIDE.GetPrimaryConfigPath
             RemoteRepo : string; // eg  https://gitlab.com/api/v4/projects/32480729/repository/
 
             ExamplesHome : string; // dir above examples_working_dir where we copy examples to, set by uintf.pas, usually <lazConf>/
@@ -192,13 +200,8 @@ type
 
 implementation
 
-
 uses
-    uConst;
+    uConst {$ifdef EXTESTMODE}, Main_Examples{$endif} ;
-
-//const
-//    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/'
 It contains a multidigit number that identifies the gitlab project. The number is a
@@ -207,7 +210,6 @@ web pages as "Project ID", group id will not work. A full URL might look like th
 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
 //==============================================================================
@@ -301,6 +303,133 @@ end;
 //                     T     E X A M P L E   D A T A
 // =============================================================================
 
+// PkgFilesXML is the full path of the file "packagefiles.xml" which resides in the Lazarus primary config path.
+procedure TExampleData.CollectThirdPartyPackages(PkgFilesXML: String; AList: TStrings);
+// By WP, see https://forum.lazarus.freepascal.org/index.php/topic,62552.msg473109.html#msg473109
+var
+  doc: TXMLDocument;
+  userPkgLinks: TDOMNode;
+  pkgNode: TDOMNode;
+  filenameNode: TDOMNode;
+  filenameAttr: TDOMNode;
+  St : String;
+begin
+    if not FileExists(PkgFilesXML) then
+        exit;
+    ReadXMLFile(doc, PkgFilesXML);
+    try
+        userPkgLinks := doc.DocumentElement.FindNode('UserPkgLinks');
+        if userPkgLinks = nil then
+            exit;
+        pkgNode := userPkgLinks.FirstChild;
+        while pkgNode <> nil do begin
+            filenameNode := pkgNode.FindNode('Filename');
+            if filenameNode <> nil then begin
+                filenameAttr := filenameNode.Attributes.GetNamedItem('Value');
+                if filenameAttr <> nil then begin
+                    // wp's code delivered ffn of installed project LPK file, I need a directory above any Examples
+                    St := filenameAttr.Nodevalue;
+                    ForcePathDelims(St);            // ExtractFileDir has problems with unexpected pathdelim....
+                    if GetThirdPartyDir(St) then
+                        AList.Add(St);
+                end;
+            end;
+            pkgNode := pkgNode.NextSibling;
+        end;
+    finally
+        doc.Free;
+    end;
+end;
+
+{ First we look for a tag like <ExampleDirectory="../."/> just below <Package....
+  If we find it, good, thats authorative, exit.
+
+  Failing above, start with the full path and name to the LPK file, remove the filename.
+  We try and find Package->CompilerOptions->SearchPaths->OtherUnitFiles, if its
+  not present or empty, we assume that the LPK file is at the top of package tree.
+  Else we remove the rightmost dir item from the full path for each ..<PathSep> we
+  find in the OtherUnitFiles value.  }
+
+function TExampleData.GetThirdPartyDir(var FullPkgFileName: string): boolean;
+var
+    doc: TXMLDocument;
+    NodeA, NodeB: TDOMNode;
+    ADir : string = '';
+    DebugThis : boolean = False;     // ToDo : remove these debug statements after suitable testing
+begin
+    Result := true;
+    if DebugThis then debugln('TExampleData.GetThirdParty - looking at [' + FullPkgFileName + ']');
+    if not FileExists(FullPkgFileName) then
+        exit(false);                                        // only real error return code
+    ReadXMLFile(doc, FullPkgFileName);                      // Hmm, xml exceptions ?
+    try
+        FullPkgFileName := ExtractFileDir(FullPkgFileName); // Remove the LPK name, might be best we can do.
+        NodeB := doc.DocumentElement.FindNode('Package');
+        if NodeB = nil then exit;
+        NodeA := NodeB.FindNode('ExampleDirectory');
+        if NodeA <> nil then begin
+            if DebugThis then debugln('ExampleDir Mode');
+            NodeB := NodeA.Attributes.GetNamedItem('Value');
+            if NodeB <> nil then                            // Leave existing path in FullPkgFileName, ie assumes LPK file is level or above examples
+                ADir := NodeB.NodeValue;
+        end else begin
+            NodeA := NodeB.FindNode('CompilerOptions');     // OK, so, no ExampleDir ? we will try for OtherUnitFiles, might be OK
+            if NodeA = nil then exit;
+            NodeB := NodeA.FindNode('SearchPaths');
+            if NodeB = nil then exit;
+            NodeA := NodeB.FindNode('OtherUnitFiles');      // if we don't find OtherUnitFiles, we return with path of the LPK file and hope for the best
+            if NodeA = nil then exit;
+            NodeB := NodeA.Attributes.GetNamedItem('Value');
+            if NodeB = nil then exit;                       // Element is present but has no value ?
+            ADir := NodeB.NodeValue;
+        end;
+        if debugThis then debugln('TExampleData.GetThirdParty - ADir [' + ADir + ']');
+        while ADir.StartsWith('..') do begin                // all we are interested in is the number of leading "../"
+            ADir := ADir.Remove(0, 3);
+            FullPkgFileName := ExtractFileDir(FullPkgFileName);
+        end;
+        Result := True;
+        if DebugThis then debugln('TExampleData.GetThirdParty - Returning OtherUnitFiles [' + FullPkgFileName + ']');
+    finally
+        doc.free;
+    end;
+end;
+
+(*       An LPK file might look like this -
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <Package Version="4">
+    <PathDelim Value="\"/>
+    <Name Value="KControlsLaz"/>
+    <Type Value="RunAndDesignTime"/>
+    <Author Value="Tomas Krysl"/>
+    <ExampleDirectory Value="../.">     // Maybe not there ....
+    <CompilerOptions>
+      <Version Value="11"/>
+      <PathDelim Value="\"/>
+      <SearchPaths>
+        <IncludeFiles Value="..\..\source"/>
+        <OtherUnitFiles Value="..\..\source"/>    // Maybe not there, maybe wrong for our purpose
+*)
+
+procedure TExampleData.ScanThirdPartyPkg();
+var
+    STL : TStringList;
+    i : integer;
+begin
+    STL := TStringList.Create;
+    STL.Sorted := true;
+    STL.Duplicates := dupIgnore;
+    try
+        CollectThirdPartyPackages(LazConfigDir + 'packagefiles.xml', STL);
+        for i := 0 to Stl.Count -1 do
+            ScanLocalTree(STL[i], True);
+    finally
+        STL.Free;
+    end;
+end;
+
+
 // Address of this function is passed to a list sort call. We sort on category, Beginners at top
 function CategorySorter( Item1: Pointer;   Item2: Pointer) : Integer;
 begin
@@ -315,7 +444,7 @@ end;
 procedure TExampleData.fSetErrorString(Er : string);
 begin
     ErrorString := Er;
-    Debugln(ErrorString);
+    Debugln('Warning : [TExampleData]' + ErrorString);
 end;
 
 function TExampleData.ExampleWorkingDir() : string;
@@ -324,7 +453,6 @@ begin
 end;
 
 
-
 function TExampleData.ExtractFieldsFromJSON(const JStr: string; out EName, Cat,
                                                         Keys, Desc, Error: string): boolean;
 var
@@ -416,8 +544,10 @@ var
     KeyWords : TStringList;
 begin
     Result := False;
-    ExtractFromJSON('Category', jItem, Cat);        // An empty Cat is acceptable but undesirable.
+    if not ExtractFromJSON('Category', jItem, Cat) then        // An empty field here is acceptable but undesirable.
-    if not ExtractFromJSON('Description', jItem, Desc) then exit(False);
+        debugln('Hint: (Lazarus) [TExampleData.InsertJSONData] Metadata file has no category : ' + FFName);
+    if not ExtractFromJSON('Description', jItem, Desc) then
+        debugln('Hint: (Lazarus) [TExampleData.InsertJSONData] Metadata file has no description : ' + FFName);
     {$ifdef WINDOWS}
     Desc := Desc.Replace(#10, #13#10, [rfReplaceAll]);
     {$endif}
@@ -428,12 +558,11 @@ begin
     else
         if not ExtractFromJSON('Name', jItem, AnotherName) then
             AnotherName := '';
-    if DoesNameExist(AnotherName) then begin
+    if DoesNameExist(AnotherName) then
-        debugln('TExampleData.InsertJSONData - WARNING duplicate Example Name found = '
+        debugln('Warning: [TExampleData.InsertJSONData] duplicate Example Name found = '
-            + AnotherName + ' ' + FFName);
+            + 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 to free
 end;
 
 // Scans local tree below 'Path' looking for any likely Example Metadata files.
@@ -456,12 +585,12 @@ begin
             try
                 FileContent.LoadFromFile(St);                        // That is contents of one individual metadata file
                 if PathAbs then
-                    Result := ReadSingleJSON(FileContent, St)
+                    Result := ReadSingleJSON(FileContent, St)       // Calls InsertJSONData() if successful
-                else  Result := ReadSingleJSON(FileContent, copy(St, Path.Length+1, 1000));
+                else  Result := ReadSingleJSON(FileContent, copy(St, Path.Length+1, 1000));    // "
                 if not Result then begin
                     debugln('Offending file is ' + St);
                     debugln(ErrorMsg);
-                    //exit(False);                                   // process all the good ones anyway, hope thats good....
+                    //exit(False);                                   // process all the good ones anyway, hope thats OK....
                 end;
             finally
                 FileContent.Free;
@@ -485,13 +614,13 @@ begin
                 jItem := jData.Items[0];
             except
                 on E: EJSONParser do begin
-                    ErrorMsg := 'ERROR EJSONParser- invalid JSON in ' + PathToStore
+                    ErrorMsg := 'Error in EJSONParser- invalid JSON in ' + PathToStore
                                                  + ' ' + 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 in ' + PathToStore     // this is typically a single \
+                    ErrorMsg := 'Error in EScanner- invalid JSON in ' + PathToStore     // this is typically a single \
                                                  + ' ' + E.Message;
                     jData := Nil;                                           // Appears nothing is allocated if error  ?
                     exit(false);
@@ -538,9 +667,8 @@ begin
                             if ScanLocalTree(GitDir, False) then        // This should leave relative paths, suitable to upload to gitlab
                          end;
         FromLazSrcTree : begin
-            ScanLocalTree(IDEEnvironmentOptions.GetParsedLazarusDirectory, True); // Scan the Lazarus SRC tree
+                            ScanLocalTree(IDEEnvironmentOptions.GetParsedLazarusDirectory, True); // Scan the Lazarus SRC tree
-            ScanLocalTree(ExamplesHome, True);                // Get, eg, any OPM Examples
+                            ScanThirdPartyPkg();         // Get, eg, any OPM Examples or ones manually installed by user.
-            // in the above line, we assume if user has moved Examples, then they will have OPM there too.
             end;
         FromCacheFile  : begin
                             if not LoadCacheFile(ExampleWorkingDir()+ 'master' + MetaFileExt) then begin
@@ -551,12 +679,6 @@ begin
                          end;
     end;
     ExList.Sort(@CategorySorter);
-//    if ExList.Count = 0 then begin
-//        debugln('TExampleData.LoadExData - found examples = ' + inttostr(ExList.Count));
-//        debugln('Lazarus Dir (ie source tree) = ' + IDEEnvironmentOptions.GetParsedLazarusDirectory);
-//        debugln('Lazarus Config Dir = ' + LazConfigDir);
-//        debugln('Examples Home Dir  = ' + ExamplesHome);
-//    end;
 end;
 
 

components/exampleswindow/ulaz_examples.pas

@@ -21,7 +21,6 @@ extension of ex-meta.
     David Bannon, Dec 2022
 }
 {$mode objfpc}{$H+}
-{X$define EXTESTMODE}
 
 {X$define ONLINE_EXAMPLES}