implemented help jump to FPDoc html unit

git-svn-id: trunk@5838 -

ide/helpmanager.pas

@@ -36,9 +36,9 @@ uses
   Classes, SysUtils, LCLProc, Forms, Controls, Buttons, StdCtrls, Dialogs,
   CodeToolManager, CodeAtom, CodeCache, CustomCodeTool, CodeTree,
   PascalParserTool, FindDeclarationTool,
-  HelpIntf, HelpHTML, DialogProcs,
+  HelpIntf, HelpHTML, HelpFPDoc,
-  IDEOptionDefs, EnvironmentOpts, AboutFrm, Project, PackageDefs, MainBar,
+  TransferMacros, DialogProcs, IDEOptionDefs, EnvironmentOpts, AboutFrm,
-  HelpOptions, MainIntf;
+  Project, PackageDefs, MainBar, HelpOptions, MainIntf;
 
 type
   { TBaseHelpManager }
@@ -62,13 +62,15 @@ type
 
   TIDEHelpDatabases = class(THelpDatabases)
   public
-    function ShowHelpSelector(Nodes: TList; var ErrMsg: string;
+    function ShowHelpSelector(Query: THelpQuery; Nodes: TList;
+                              var ErrMsg: string;
                               var Selection: THelpNode): TShowHelpResult; override;
     procedure ShowError(ShowResult: TShowHelpResult; const ErrMsg: string); override;
     function GetBaseDirectoryForBasePathObject(BasePathObject: TObject): string; override;
-    function ShowHelpForSourcePosition(const Filename: string;
+    function ShowHelpForSourcePosition(Query: THelpQuerySourcePosition;
-                                       const CodePos: TPoint;
                                        var ErrMsg: string): TShowHelpResult; override;
+    function StrHasMacros(const s: string): boolean; override;
+    function SubstituteMacros(var s: string): boolean; override;
   end;
   
   
@@ -81,6 +83,7 @@ type
     procedure mnuHelpOnlineHelpClicked(Sender: TObject);
   private
     FMainHelpDB: THelpDatabase;
+    FFCLHelpDB: THelpDatabase;
     procedure RegisterIDEHelpDatabases;
     procedure RegisterDefaultIDEHelpViewers;
   public
@@ -100,11 +103,14 @@ type
                                        var ErrMsg: string): TShowHelpResult; override;
   public
     property MainHelpDB: THelpDatabase read FMainHelpDB;
+    property FCLHelpDB: THelpDatabase read FFCLHelpDB;
   end;
 
   { Help Contexts for IDE help }
 const
   lihcStartPage = 'StartPage';
+  lihcFCLStartPage = 'FCLStartPage';
+  lihcFCLUnits = 'FCLUnits';
 
 var
   HelpBoss: TBaseHelpManager;
@@ -232,8 +238,8 @@ end;
 
 { TIDEHelpDatabases }
 
-function TIDEHelpDatabases.ShowHelpSelector(Nodes: TList; var ErrMsg: string;
+function TIDEHelpDatabases.ShowHelpSelector(Query: THelpQuery; Nodes: TList;
-  var Selection: THelpNode): TShowHelpResult;
+  var ErrMsg: string; var Selection: THelpNode): TShowHelpResult;
 var
   Dialog: THelpSelectorDialog;
   i: LongInt;
@@ -284,12 +290,26 @@ begin
     Result:=TProject(BasePathObject).ProjectDirectory
   else if BasePathObject is TLazPackage then
     Result:=TLazPackage(BasePathObject).Directory;
+  SubstituteMacros(Result);
 end;
 
-function TIDEHelpDatabases.ShowHelpForSourcePosition(const Filename: string;
+function TIDEHelpDatabases.ShowHelpForSourcePosition(
-  const CodePos: TPoint; var ErrMsg: string): TShowHelpResult;
+  Query: THelpQuerySourcePosition; var ErrMsg: string): TShowHelpResult;
 begin
-  Result:=HelpBoss.ShowHelpForSourcePosition(Filename,CodePos,ErrMsg);
+  Result:=HelpBoss.ShowHelpForSourcePosition(Query.Filename,
+                                                   Query.SourcePosition,ErrMsg);
+end;
+
+function TIDEHelpDatabases.StrHasMacros(const s: string): boolean;
+begin
+  Result:=MainIDEInterface.MacroList.StrHasMacros(s);
+end;
+
+function TIDEHelpDatabases.SubstituteMacros(var s: string): boolean;
+begin
+  //debugln('TIDEHelpDatabases.SubstituteMacros s="',s,'" ');
+  Result:=MainIDEInterface.MacroList.SubstituteStr(s);
+  //debugln('TIDEHelpDatabases.SubstituteMacros END s="',s,'"');
 end;
 
 { THelpManager }
@@ -311,19 +331,60 @@ begin
 end;
 
 procedure THelpManager.RegisterIDEHelpDatabases;
-var
+
-  HTMLHelp: THTMLHelpDatabase;
+  procedure CreateMainIDEHelpDB;
-  StartNode: THelpNode;
+  var
+    StartNode: THelpNode;
+    HTMLHelp: THTMLHelpDatabase;
+  begin
+    FMainHelpDB:=HelpDatabases.CreateHelpDatabase('Lazarus IDE',
+                                                  THTMLHelpDatabase,true);
+    HTMLHelp:=FMainHelpDB as THTMLHelpDatabase;
+    HTMLHelp.BasePathObject:=Self;
+    // nodes
+    StartNode:=THelpNode.CreateURLID(HTMLHelp,'Lazarus',
+                                     'file://docs/index.html',lihcStartPage);
+    HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,StartNode);
+    HTMLHelp.RegisterItemWithNode(StartNode);
+  end;
+  
+  procedure CreateFCLHelpDB;
+  var
+    HTMLHelp: TFPDocHTMLHelpDatabase;
+    StartNode: THelpNode;
+    FPDocNode: THelpNode;
+    DirItem: THelpDBSISourceDirectory;
+  begin
+    FFCLHelpDB:=HelpDatabases.CreateHelpDatabase('FCL',TFPDocHTMLHelpDatabase,
+                                                 true);
+    HTMLHelp:=FFCLHelpDB as TFPDocHTMLHelpDatabase;
+
+    // FCL
+    StartNode:=THelpNode.CreateURLID(HTMLHelp,
+                   'FCL - Free Pascal Component Library',
+                   'http://www.freepascal.org/docs-html/fcl/index.html',
+                   lihcFCLStartPage);
+    HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,StartNode);
+    HTMLHelp.RegisterItemWithNode(StartNode);
+    
+    // FPDoc: units in the FCL
+    FPDocNode:=THelpNode.CreateURL(HTMLHelp,
+                   'FCL - Free Pascal Component Library Units',
+                   'http://www.freepascal.org/docs-html/fcl/index.html');
+    DirItem:=THelpDBSISourceDirectory.Create(FPDocNode,'$(FPCSrcDir)/fcl',
+                   '*.pp;*.pas',true);
+    HTMLHelp.RegisterItem(DirItem);
+
+    // FPDoc: some RTL units are documented in the FCL
+    DirItem:=THelpDBSISourceDirectory.Create(
+                   THelpNode.Create(HTMLHelp,FPDocNode),
+                   '$(FPCSrcDir)/rtl','classes.pp;',true);
+    HTMLHelp.RegisterItem(DirItem);
+  end;
+
 begin
-  FMainHelpDB:=HelpDatabases.CreateHelpDatabase('Lazarus IDE',THTMLHelpDatabase,
+  CreateMainIDEHelpDB;
-                                                true);
+  CreateFCLHelpDB;
-  HTMLHelp:=FMainHelpDB as THTMLHelpDatabase;
-  HTMLHelp.BasePathObject:=Self;
-  // nodes
-  StartNode:=THelpNode.CreateURLID(HTMLHelp,'Lazarus',
-                                   'file://docs/index.html',lihcStartPage);
-  HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,StartNode);
-  HTMLHelp.RegisterItemWithNode(StartNode);
 end;
 
 procedure THelpManager.RegisterDefaultIDEHelpViewers;
@@ -519,7 +580,7 @@ begin
 
       // invoke help system
       debugln('THelpManager.ShowHelpForSourcePosition D PascalHelpContextLists.Count=',dbgs(PascalHelpContextLists.Count));
-      Result:=ShowHelpForPascalContexts(PascalHelpContextLists,ErrMsg);
+      ShowHelpForPascalContexts(Filename,CodePos,PascalHelpContextLists,ErrMsg);
     end else begin
       MainIDEInterface.DoJumpToCodeToolBossError;
     end;

ide/transfermacros.pp

@@ -22,7 +22,7 @@
 
   Abstract:
     This unit defines the classes TTransferMacro and TTransferMacroList. These
-    classes stores and substitutes macros in strings. Transfer macros are an
+    classes store and substitute macros in strings. Transfer macros are an
     easy way to transfer some ide variables to programs like the compiler,
     the debugger and all the other tools.
     Transfer macros have the form $(macro_name). It is also possible to define
@@ -100,13 +100,13 @@ type
     procedure Add(NewMacro: TTransferMacro);
     function FindByName(const MacroName: string): TTransferMacro; virtual;
     function SubstituteStr(var s:string): boolean; virtual;
+    function StrHasMacros(const s: string): boolean;
     property OnSubstitution: TOnSubstitution
        read fOnSubstitution write fOnSubstitution;
     property MarkUnhandledMacros: boolean read FMarkUnhandledMacros
                                           write SetMarkUnhandledMacros;
   end;
 
-
 implementation
 
 var
@@ -374,6 +374,34 @@ begin
   end;
 end;
 
+function TTransferMacroList.StrHasMacros(const s: string): boolean;
+// search for $( or $xxx(
+var
+  p: Integer;
+  Len: Integer;
+begin
+  Result:=false;
+  p:=1;
+  Len:=length(s);
+  while (p<Len) do begin
+    if s[p]='$' then begin
+      inc(p);
+      if (p<Len) and (s[p]<>'$') then begin
+        // skip macro function name
+        while (p<Len) and (s[p]<>'(') do inc(p);
+        if (p<Len) then begin
+          Result:=true;
+          exit;
+        end;
+      end else begin
+        // $$ is not a macro
+        inc(p);
+      end;
+    end else
+      inc(p);
+  end;
+end;
+
 function TTransferMacroList.FindByName(const MacroName: string): TTransferMacro;
 var
   l: Integer;

ideintf/helpfpdoc.pas

@@ -22,16 +22,75 @@ unit HelpFPDoc;
 interface
 
 uses
-  Classes, SysUtils, HelpIntf;
+  Classes, SysUtils, LCLProc, FileCtrl, HelpIntf, HelpHTML;
 
 type
-  { TFPDocHelpDatabase }
+  { TFPDocHTMLHelpDatabase }
 
-  TFPDocHelpDatabase = class(THelpDatabase)
+  TFPDocHTMLHelpDatabase = class(THTMLHelpDatabase)
+  public
+    function ShowHelp(Query: THelpQuery; BaseNode, NewNode: THelpNode;
+                      var ErrMsg: string): TShowHelpResult; override;
   end;
   
 
 implementation
 
+{ TFPDocHTMLHelpDatabase }
+
+function TFPDocHTMLHelpDatabase.ShowHelp(Query: THelpQuery; BaseNode,
+  NewNode: THelpNode; var ErrMsg: string): TShowHelpResult;
+var
+  ContextList: TPascalHelpContextList;
+  UnitName: String;
+  URL: String;
+  TheBaseURL: String;
+  Filename: String;
+begin
+  if (Query is THelpQueryPascalContexts)
+  and (NewNode.QueryItem is TPascalHelpContextList) then begin
+    // a pascal context query
+    ContextList:=TPascalHelpContextList(NewNode.QueryItem);
+    if (ContextList.Count>0) and (ContextList.List[0].Descriptor=pihcFilename)
+    then begin
+      // extract unit filename
+      UnitName:=lowercase(ExtractFileNameOnly(ContextList.List[0].Context));
+      DebugLn('TFPDocHTMLHelpDatabase.ShowHelp A Unitname=',Unitname,' NewNode.HelpType=',dbgs(ord(NewNode.HelpType)),' NewNode.Title=',NewNode.Title,' NewNode.URL=',NewNode.URL);
+      if UnitName<>'' then begin
+
+        Filename:=UnitName+'/';
+        // TODO: context in unit
+        Filename:=Filename+'index.html';
+      
+        TheBaseURL:='';
+        if NewNode.URLValid then begin
+          // the node has an URL => use only the path
+          TheBaseURL:=NewNode.URL;
+          debugln('A TheBaseURL=',TheBaseURL);
+          if (HelpDatabases<>nil) then
+            HelpDatabases.SubstituteMacros(TheBaseURL);
+          debugln('B TheBaseURL=',TheBaseURL);
+          TheBaseURL:=ExtractURLDirectory(TheBaseURL);
+          debugln('C TheBaseURL=',TheBaseURL);
+          DebugLn('TFPDocHTMLHelpDatabase.ShowHelp Node Base URL TheBaseURL=',TheBaseURL);
+        end;
+
+        if TheBaseURL='' then
+          TheBaseURL:=GetEffectiveBaseURL;
+
+        // show URL
+        if TheBaseURL<>'' then
+          URL:=TheBaseURL+Filename
+        else
+          URL:=FilenameToURL(Filename);
+        Result:=ShowURL(URL,NewNode.Title,ErrMsg);
+        exit;
+      end;
+    end;
+  end;
+  // otherwise use default
+  Result:=inherited ShowHelp(Query, BaseNode, NewNode, ErrMsg);
+end;
+
 end.
 

ideintf/helphtml.pas

@@ -34,7 +34,9 @@ type
     procedure SetBaseURL(const AValue: string);
   public
     constructor Create(TheID: THelpDatabaseID); override;
-    function ShowHelp(BaseNode, NewNode: THelpNode;
+    function ShowURL(const URL, Title: string;
+                     var ErrMsg: string): TShowHelpResult; virtual;
+    function ShowHelp(Query: THelpQuery; BaseNode, NewNode: THelpNode;
                       var ErrMsg: string): TShowHelpResult; override;
     function GetEffectiveBaseURL: string;
   public
@@ -80,54 +82,62 @@ begin
   AddSupportedMimeType('text/html');
 end;
 
-function THTMLHelpDatabase.ShowHelp(BaseNode, NewNode: THelpNode;
+function THTMLHelpDatabase.ShowURL(const URL, Title: string; var ErrMsg: string
-  var ErrMsg: string): TShowHelpResult;
+  ): TShowHelpResult;
 var
   URLType, URLPath, URLParams: string;
   BaseURLType, BaseURLPath, BaseURLParams: string;
   Viewer: THelpViewer;
   EffBaseURL: String;
   Node: THelpNode;
-  URL: String;
+  FullURL: String;
+begin
+  DebugLn('THTMLHelpDatabase.ShowURL A URL="',URL,'" Title="',Title,'"');
+
+  // find HTML viewer
+  Result:=FindViewer('text/html',ErrMsg,Viewer);
+  if Result<>shrSuccess then exit;
+
+  // make URL absolute
+  SplitURL(URL,URLType,URLPath,URLParams);
+  debugln('THTMLHelpDatabase.ShowHelp A NewNode.URL=',URL,' URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams);
+
+  if URLType='file' then begin
+    if not URLFilenameIsAbsolute(URLPath) then begin
+      EffBaseURL:=GetEffectiveBaseURL;
+      SplitURL(EffBaseURL,BaseURLType,BaseURLPath,BaseURLParams);
+      if (BaseURLType='file') and (BaseURLPath<>'') then
+        URLPath:=BaseURLPath+URLPath;
+    end;
+    if (not FileExists(URLPath)) then begin
+      Result:=shrContextNotFound;
+      ErrMsg:=Format(oisHelpTheHelpDatabaseWasUnableToFindFile, ['"', ID,
+        '"', '"', URLPath, '"']);
+      exit;
+    end;
+  end else begin
+
+  end;
+  FullURL:=CombineURL(URLType,URLPath,URLParams);
+  debugln('THTMLHelpDatabase.ShowHelp B URL=',URL,' URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams);
+
+  // call viewer
+  Node:=nil;
+  try
+    Node:=THelpNode.CreateURL(Self,Title,FullURL);
+    Result:=Viewer.ShowNode(Node,ErrMsg);
+  finally
+    Node.Free;
+  end;
+end;
+
+function THTMLHelpDatabase.ShowHelp(Query: THelpQuery;
+  BaseNode, NewNode: THelpNode; var ErrMsg: string): TShowHelpResult;
 begin
   ErrMsg:='';
   Result:=shrContextNotFound;
   if NewNode.URLValid then begin
-    // find HTML viewer
+    Result:=ShowURL(NewNode.URL,NewNode.Title,ErrMsg);
-    Result:=FindViewer('text/html',ErrMsg,Viewer);
-    if Result<>shrSuccess then exit;
-    
-    // make URL absolute
-    SplitURL(NewNode.URL,URLType,URLPath,URLParams);
-    //debugln('THTMLHelpDatabase.ShowHelp A NewNode.URL=',NewNode.URL,' URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams);
-    
-    if URLType='file' then begin
-      if not URLFilenameIsAbsolute(URLPath) then begin
-        EffBaseURL:=GetEffectiveBaseURL;
-        SplitURL(EffBaseURL,BaseURLType,BaseURLPath,BaseURLParams);
-        if (BaseURLType='file') and (BaseURLPath<>'') then
-          URLPath:=BaseURLPath+URLPath;
-      end;
-      if (not FileExists(URLPath)) then begin
-        Result:=shrContextNotFound;
-        ErrMsg:=Format(oisHelpTheHelpDatabaseWasUnableToFindFile, ['"', ID,
-          '"', '"', URLPath, '"']);
-        exit;
-      end;
-    end else begin
-
-    end;
-    URL:=CombineURL(URLType,URLPath,URLParams);
-    //debugln('THTMLHelpDatabase.ShowHelp B URL=',URL,' URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams);
-
-    // call viewer
-    Node:=THelpNode.Create(Self,NewNode);
-    try
-      Node.URL:=URL;
-      Result:=Viewer.ShowNode(Node,ErrMsg);
-    finally
-      Node.Free;
-    end;
   end else begin
     Result:=shrContextNotFound;
     ErrMsg:='THTMLHelpDatabase.ShowHelp Node.URLValid=false';
@@ -137,9 +147,11 @@ end;
 function THTMLHelpDatabase.GetEffectiveBaseURL: string;
 begin
   Result:='';
-  if BaseURL<>'' then
+  if BaseURL<>'' then begin
-    Result:=BaseURL
+    Result:=BaseURL;
-  else if (BasePathObject<>nil) and (Databases<>nil) then
+    if (HelpDatabases<>nil) then
+      HelpDatabases.SubstituteMacros(Result);
+  end else if (BasePathObject<>nil) and (Databases<>nil) then
     Result:=Databases.GetBaseURLForBasePathObject(BasePathObject);
   if (Result<>'') and (Result[length(Result)]<>'/') then
     Result:=Result+'/';

lcl/include/filectrl.inc

@@ -821,11 +821,100 @@ end;
 
 {------------------------------------------------------------------------------
   function FileInFilenameMasks(const Filename, Masks: string): boolean;
+
+  Checks if 'Filename' fits to one of the mask in 'Masks'.
+  Note: It checks the whole Filename. So, for example /somewhere/unit1.pas does
+  not fit the mask 'unit*.pas', but it will fit '*.pas'.
+  
+  Masks is delimited by semicolon.
+  Masks allows asterisk (*) for arbitrary text and question mark (?) for one
+  arbitrary character.
+  Examples:
+    '*.pas;*.pp;*.inc'
+    '*.tar.*'
+    'lazarus*.xpm'
  ------------------------------------------------------------------------------}
 function FileInFilenameMasks(const Filename, Masks: string): boolean;
+var
+  TrimmedFile: String;
+  MasksLen: Integer;
+  MaskStartPos: Integer;
+  MaskEndPos: Integer;
+  MaskPos: LongInt;
+  FilePos: Integer;
+  FileLen: Integer;
+  MaskChar: Char;
 begin
-  // TODO
   Result:=false;
+  if (Filename='') or (Masks='') then exit;
+  TrimmedFile:=TrimFilename(Filename); // do not expand
+  // try each Mask
+  MasksLen:=length(Masks);
+  FileLen:=length(TrimmedFile);
+  MaskEndPos:=1;
+  repeat
+  
+    // find next Mask
+    MaskStartPos:=MaskEndPos;
+    while (MaskStartPos<=MasksLen) and (Masks[MaskStartPos]=';') do
+      inc(MaskStartPos);
+    if MaskStartPos>MasksLen then exit; // no mask -> end
+    MaskEndPos:=MaskStartPos+1;
+    while (MaskEndPos<=MasksLen) and (Masks[MaskEndPos]<>';') do
+      inc(MaskEndPos);
+      
+    // check if mask fits to filename
+    MaskPos:=MaskStartPos;
+    FilePos:=1;
+    while MaskPos<MaskEndPos do begin
+      MaskChar:=Masks[MaskPos];
+      case MaskChar of
+      
+      '?': begin
+          // skip one character
+          inc(FilePos);
+          inc(MaskPos);
+        end;
+        
+      '*': begin
+          // Anything. Will be handled by the 'else' part below
+          inc(MaskPos);
+        end;
+        
+      else
+        {$IFDEF win32}
+        if UpperCaseTable[byte(MaskChar)]
+          =UpperCaseTable[byte(TrimmedFile[FilePos])] then
+        {$ELSE}
+        if MaskChar=TrimmedFile[FilePos] then
+        {$ENDIF}
+        begin
+          // character fits
+          inc(MaskPos);
+          inc(FilePos);
+        end else begin
+          //character does not fit
+          // -> go back to last astersik (*)
+          while (MaskPos>MaskStartPos) and (Masks[MaskPos-1]<>'*') do begin
+            dec(MaskPos);
+            dec(FilePos);
+          end;
+          if (MaskPos=MaskStartPos) then begin
+            // there was no asterisk (*) => the filename does not fit this mask
+            break;
+          end else begin
+            // there is an asterisk (*) => try the next position
+            inc(FilePos);
+          end;
+        end;
+      end;
+    end;
+    if (MaskPos=MaskEndPos) and (FilePos>FileLen) then begin
+      // found
+      Result:=true;
+      exit;
+    end;
+  until false;
 end;
 
 {------------------------------------------------------------------------------
@@ -958,6 +1047,9 @@ end;
 
 {
   $Log$
+  Revision 1.48  2004/08/23 15:05:09  mattias
+  implemented help jump to FPDoc html unit
+
   Revision 1.47  2004/08/22 22:47:43  mattias
   implemented context help for source editor
 

lcl/interfaces/gtk/gtkobject.inc

@@ -4283,7 +4283,7 @@ begin
   csPreviewFileDialog,
   csColorDialog,
   csFontDialog:
-    if GtkWidgetIsA(p,GTK_WINDOW_TYPE) then
+    if GtkWidgetIsA(p,gtk_window_get_type) then
       gtk_window_set_title(pGtkWindow(p),PLabel);
 
   csLabel:
@@ -9268,6 +9268,9 @@ end;
  { =============================================================================
 
   $Log$
+  Revision 1.531  2004/08/23 15:05:09  mattias
+  implemented help jump to FPDoc html unit
+
   Revision 1.530  2004/08/19 18:50:53  mattias
   splitted IDE component owner hierachy to reduce notification time