← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to ide/idehelpmanager.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
ide/idehelpmanager.pas
 
1
{
 
2
 /***************************************************************************
 
3
                            helpmanager.pas
 
4
                            ---------------
 
5
 
 
6
 
 
7
 ***************************************************************************/
 
8
 
 
9
 ***************************************************************************
 
10
 *                                                                         *
 
11
 *   This source is free software; you can redistribute it and/or modify   *
 
12
 *   it under the terms of the GNU General Public License as published by  *
 
13
 *   the Free Software Foundation; either version 2 of the License, or     *
 
14
 *   (at your option) any later version.                                   *
 
15
 *                                                                         *
 
16
 *   This code is distributed in the hope that it will be useful, but      *
 
17
 *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
 
18
 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
 
19
 *   General Public License for more details.                              *
 
20
 *                                                                         *
 
21
 *   A copy of the GNU General Public License is available on the World    *
 
22
 *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
 
23
 *   obtain it by writing to the Free Software Foundation,                 *
 
24
 *   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
 
25
 *                                                                         *
 
26
 ***************************************************************************
 
27
}
 
28
unit IDEHelpManager;
 
29
 
 
30
{$mode objfpc}{$H+}
 
31
 
 
32
interface
 
33
 
 
34
uses
 
35
  // FCL+LCL
 
36
  Classes, SysUtils, AVL_Tree, LCLProc, LCLIntf, LCLType, Forms, Controls,
 
37
  Buttons, StdCtrls, Dialogs, ExtCtrls, FileProcs, Graphics, ButtonPanel,
 
38
  LConvEncoding, lazutf8classes,
 
39
  // CodeTools
 
40
  BasicCodeTools, CodeToolManager, CodeAtom, CodeCache, CustomCodeTool, CodeTree,
 
41
  PascalParserTool, FindDeclarationTool,
 
42
  // IDEIntf
 
43
  PropEdits, ObjectInspector, FormEditingIntf, ProjectIntf, TextTools,
 
44
  IDEDialogs, LazHelpIntf, LazHelpHTML, HelpFPDoc, MacroIntf, IDEWindowIntf,
 
45
  IDEMsgIntf, PackageIntf, LazIDEIntf, HelpIntfs, IDEHelpIntf,
 
46
  // IDE
 
47
  LazarusIDEStrConsts, TransferMacros, DialogProcs, IDEOptionDefs,
 
48
  ObjInspExt, EnvironmentOpts, AboutFrm, MsgView, Project, MainBar, OutputFilter,
 
49
  IDEFPDocFileSearch, PackageDefs, PackageSystem,
 
50
  HelpOptions, MainIntf, LazConf, HelpFPCMessages, CodeHelp,
 
51
  IDEContextHelpEdit, IDEWindowHelp;
 
52
 
 
53
type
 
54
 
 
55
  { TSimpleFPCKeywordHelpDatabase }
 
56
 
 
57
  TSimpleFPCKeywordHelpDatabase = class(THTMLHelpDatabase)
 
58
  private
 
59
    FKeywordPrefixNode: THelpNode;
 
60
  public
 
61
    function GetNodesForKeyword(const HelpKeyword: string;
 
62
                        var ListOfNodes: THelpNodeQueryList; var ErrMsg: string
 
63
                        ): TShowHelpResult; override;
 
64
    function ShowHelp(Query: THelpQuery; BaseNode, NewNode: THelpNode;
 
65
                      QueryItem: THelpQueryItem;
 
66
                      var ErrMsg: string): TShowHelpResult; override;
 
67
  end;
 
68
 
 
69
  TLIHProviders = class;
 
70
 
 
71
  { TLazIDEHTMLProvider }
 
72
 
 
73
  TLazIDEHTMLProvider = class(TAbstractIDEHTMLProvider)
 
74
  private
 
75
    fWaitingForAsync: boolean;
 
76
    FProviders: TLIHProviders;
 
77
    procedure SetProviders(const AValue: TLIHProviders);
 
78
    procedure OpenNextURL(Data: PtrInt); // called via Application.QueueAsyncCall
 
79
    procedure OpenFPDoc(Path: string);
 
80
  public
 
81
    NextURL: string;
 
82
    destructor Destroy; override;
 
83
    function URLHasStream(const URL: string): boolean; override;
 
84
    procedure OpenURLAsync(const URL: string); override;
 
85
    function GetStream(const URL: string; Shared: Boolean): TStream; override;
 
86
    procedure ReleaseStream(const URL: string); override;
 
87
    property Providers: TLIHProviders read FProviders write SetProviders;
 
88
  end;
 
89
 
 
90
  { TLIHProviderStream }
 
91
 
 
92
  TLIHProviderStream = class
 
93
  private
 
94
    FRefCount: integer;
 
95
  public
 
96
    Stream: TStream;
 
97
    URL: string;
 
98
    destructor Destroy; override;
 
99
    procedure IncreaseRefCount;
 
100
    procedure DecreaseRefCount;
 
101
    property RefCount: integer read FRefCount;
 
102
  end;
 
103
 
 
104
  { TLIHProviders
 
105
    manages all TLazIDEHTMLProvider }
 
106
 
 
107
  TLIHProviders = class
 
108
  private
 
109
    FStreams: TAVLTree;// tree of TLIHProviderStream sorted for URL
 
110
  public
 
111
    constructor Create;
 
112
    destructor Destroy; override;
 
113
    function FindStream(const URL: string; CreateIfNotExists: Boolean): TLIHProviderStream;
 
114
    function GetStream(const URL: string; Shared: boolean): TStream;
 
115
    procedure ReleaseStream(const URL: string);
 
116
  end;
 
117
 
 
118
  { TSimpleHTMLControl
 
119
    At the moment it is a TLabel that simply strips all tags }
 
120
 
 
121
  TSimpleHTMLControl = class(TLabel,TIDEHTMLControlIntf)
 
122
  private
 
123
    FMaxLineCount: integer;
 
124
    FProvider: TAbstractIDEHTMLProvider;
 
125
    FURL: string;
 
126
    procedure SetProvider(const AValue: TAbstractIDEHTMLProvider);
 
127
  public
 
128
    constructor Create(AOwner: TComponent); override;
 
129
    function GetURL: string;
 
130
    procedure SetURL(const AValue: string);
 
131
    property Provider: TAbstractIDEHTMLProvider read FProvider write SetProvider;
 
132
    procedure SetHTMLContent(Stream: TStream; const NewURL: string);
 
133
    procedure GetPreferredControlSize(out AWidth, AHeight: integer);
 
134
    property MaxLineCount: integer read FMaxLineCount write FMaxLineCount;
 
135
  end;
 
136
 
 
137
  { TScrollableHTMLControl
 
138
    At the moment it is a TMemo that simply strips all tags }
 
139
 
 
140
  TScrollableHTMLControl = class(TMemo,TIDEHTMLControlIntf)
 
141
  private
 
142
    FProvider: TAbstractIDEHTMLProvider;
 
143
    FURL: string;
 
144
    procedure SetProvider(const AValue: TAbstractIDEHTMLProvider);
 
145
  public
 
146
    constructor Create(AOwner: TComponent); override;
 
147
    function GetURL: string;
 
148
    procedure SetURL(const AValue: string);
 
149
    property Provider: TAbstractIDEHTMLProvider read FProvider write SetProvider;
 
150
    procedure SetHTMLContent(Stream: TStream; const NewURL: string);
 
151
    procedure GetPreferredControlSize(out AWidth, AHeight: integer);
 
152
  end;
 
153
 
 
154
  { TIDEHelpDatabases }
 
155
 
 
156
  TIDEHelpDatabases = class(THelpDatabases)
 
157
  public
 
158
    function ShowHelpSelector(Query: THelpQuery; Nodes: THelpNodeQueryList;
 
159
                              var ErrMsg: string;
 
160
                              var Selection: THelpNodeQuery
 
161
                              ): TShowHelpResult; override;
 
162
    function GetBaseDirectoryForBasePathObject(BasePathObject: TObject): string; override;
 
163
    function ShowHelpForSourcePosition(Query: THelpQuerySourcePosition;
 
164
                                       var ErrMsg: string): TShowHelpResult; override;
 
165
    function SubstituteMacros(var s: string): boolean; override;
 
166
  end;
 
167
  
 
168
  
 
169
  { TIDEHelpManager }
 
170
 
 
171
  TIDEHelpManager = class(TBaseHelpManager)
 
172
    // help menu of the IDE menu bar
 
173
    procedure mnuHelpAboutLazarusClicked(Sender: TObject);
 
174
    procedure mnuHelpOnlineHelpClicked(Sender: TObject);
 
175
    procedure mnuHelpReportBugClicked(Sender: TObject);
 
176
    // fpdoc
 
177
    procedure mnuSearchInFPDocFilesClick(Sender: TObject);
 
178
    // messages
 
179
    procedure mnuEditMessageHelpClick(Sender: TObject);
 
180
  private
 
181
    FFCLHelpDB: THelpDatabase;
 
182
    FFCLHelpDBPath: THelpBaseURLObject;
 
183
    FHTMLProviders: TLIHProviders;
 
184
    FLCLHelpDB: THelpDatabase;
 
185
    FLCLHelpDBPath: THelpBaseURLObject;
 
186
    FMainHelpDB: THelpDatabase;
 
187
    FMainHelpDBPath: THelpBasePathObject;
 
188
    FRTLHelpDB: THelpDatabase;
 
189
    FRTLHelpDBPath: THelpBaseURLObject;
 
190
    procedure RegisterIDEHelpDatabases;
 
191
    procedure RegisterDefaultIDEHelpViewers;
 
192
    procedure FindDefaultBrowser(var DefaultBrowser, Params: string);
 
193
  public
 
194
    constructor Create(TheOwner: TComponent); override;
 
195
    destructor Destroy; override;
 
196
 
 
197
    procedure ConnectMainBarEvents; override;
 
198
    procedure LoadHelpOptions; override;
 
199
    procedure SaveHelpOptions; override;
 
200
 
 
201
    procedure ShowLazarusHelpStartPage;
 
202
    procedure ShowIDEHelpForContext(HelpContext: THelpContext);
 
203
    procedure ShowIDEHelpForKeyword(const Keyword: string); // an arbitrary keyword, not a fpc keyword
 
204
 
 
205
    function ShowHelpForSourcePosition(const Filename: string;
 
206
                                       const CodePos: TPoint;
 
207
                                       var ErrMsg: string): TShowHelpResult; override;
 
208
    procedure ShowHelpForMessage(Line: integer); override;
 
209
    procedure ShowHelpForObjectInspector(Sender: TObject); override;
 
210
    procedure ShowHelpForIDEControl(Sender: TControl); override;
 
211
 
 
212
    function CreateHint(aHintWindow: THintWindow; ScreenPos: TPoint;
 
213
                    const BaseURL: string; var TheHint: string;
 
214
                    out HintWinRect: TRect): boolean; override;
 
215
    function GetHintForSourcePosition(const ExpandedFilename: string;
 
216
                  const CodePos: TPoint;
 
217
                  out BaseURL, HTMLHint: string;
 
218
                  Flags: TIDEHelpManagerCreateHintFlags = []): TShowHelpResult; override;
 
219
 
 
220
    function ConvertSourcePosToPascalHelpContext(const CaretPos: TPoint;
 
221
               const Filename: string): TPascalHelpContextList; override;
 
222
    function ConvertCodePosToPascalHelpContext(
 
223
               ACodePos: PCodeXYPosition): TPascalHelpContextList;
 
224
    function GetFPDocFilenameForSource(SrcFilename: string;
 
225
      ResolveIncludeFiles: Boolean; out AnOwner: TObject): string; override;
 
226
  public
 
227
    property FCLHelpDB: THelpDatabase read FFCLHelpDB;
 
228
    property FCLHelpDBPath: THelpBaseURLObject read FFCLHelpDBPath;
 
229
    property MainHelpDB: THelpDatabase read FMainHelpDB;
 
230
    property MainHelpDBPath: THelpBasePathObject read FMainHelpDBPath;
 
231
    property LCLHelpDB: THelpDatabase read FLCLHelpDB;
 
232
    property LCLHelpDBPath: THelpBaseURLObject read FLCLHelpDBPath;
 
233
    property RTLHelpDB: THelpDatabase read FRTLHelpDB;
 
234
    property RTLHelpDBPath: THelpBaseURLObject read FRTLHelpDBPath;
 
235
  end;
 
236
 
 
237
  { THelpSelectorDialog }
 
238
  
 
239
  THelpSelectorDialog = class(TForm)
 
240
    BtnPanel: TButtonPanel;
 
241
    NodesGroupBox: TGroupBox;
 
242
    NodesListBox: TListBox;
 
243
    procedure HelpSelectorDialogClose(Sender: TObject;
 
244
      var CloseAction: TCloseAction);
 
245
    procedure NodesListBoxDblClick(Sender: TObject);
 
246
  private
 
247
    FNodes: THelpNodeQueryList;
 
248
    procedure SetNodes(const AValue: THelpNodeQueryList);
 
249
    procedure FillNodesListBox;
 
250
  public
 
251
    constructor Create(TheOwner: TComponent); override;
 
252
    property Nodes: THelpNodeQueryList read FNodes write SetNodes;
 
253
  end;
 
254
 
 
255
  { Help Contexts for IDE help }
 
256
const
 
257
  lihcStartPage = 'StartPage';
 
258
  lihcRTLUnits = 'RTLUnits';
 
259
  lihcFCLUnits = 'FCLUnits';
 
260
  lihcLCLUnits = 'LCLUnits';
 
261
  
 
262
  lihBaseUrl = 'http://lazarus-ccr.sourceforge.net/docs/';
 
263
 
 
264
  lihRTLURL = lihBaseUrl+'rtl/';
 
265
  lihFCLURL = lihBaseUrl+'fcl/';
 
266
  lihLCLURL = lihBaseUrl+'lcl/';
 
267
 
 
268
var
 
269
  HelpBoss: TBaseHelpManager = nil;
 
270
  
 
271
implementation
 
272
 
 
273
{$R *.lfm}
 
274
 
 
275
function LazCreateIDEHTMLControl(Owner: TComponent;
 
276
  var Provider: TAbstractIDEHTMLProvider;
 
277
  Flags: TIDEHTMLControlFlags): TControl;
 
278
begin
 
279
  if ihcScrollable in Flags then
 
280
    Result:=TScrollableHTMLControl.Create(Owner)
 
281
  else
 
282
    Result:=TSimpleHTMLControl.Create(Owner);
 
283
  if Provider=nil then
 
284
    Provider:=CreateIDEHTMLProvider(Result);
 
285
  if ihcScrollable in Flags then
 
286
  begin
 
287
    Provider.ControlIntf:=TScrollableHTMLControl(Result);
 
288
    TScrollableHTMLControl(Result).Provider:=Provider;
 
289
  end
 
290
  else
 
291
  begin
 
292
    Provider.ControlIntf:=TSimpleHTMLControl(Result);
 
293
    TSimpleHTMLControl(Result).Provider:=Provider;
 
294
  end;
 
295
end;
 
296
 
 
297
function LazCreateIDEHTMLProvider(Owner: TComponent): TAbstractIDEHTMLProvider;
 
298
begin
 
299
  Result:=TLazIDEHTMLProvider.Create(Owner);
 
300
  TLazIDEHTMLProvider(Result).Providers:=TIDEHelpManager(HelpBoss).FHTMLProviders;
 
301
end;
 
302
 
 
303
function CompareLIHProviderStream(Data1, Data2: Pointer): integer;
 
304
begin
 
305
  Result:=CompareStr(TLIHProviderStream(Data1).URL,TLIHProviderStream(Data2).URL);
 
306
end;
 
307
 
 
308
function CompareURLWithLIHProviderStream(URL, Stream: Pointer): integer;
 
309
begin
 
310
  Result:=CompareStr(AnsiString(URL),TLIHProviderStream(Stream).URL);
 
311
end;
 
312
 
 
313
{ TSimpleFPCKeywordHelpDatabase }
 
314
 
 
315
function TSimpleFPCKeywordHelpDatabase.GetNodesForKeyword(
 
316
  const HelpKeyword: string; var ListOfNodes: THelpNodeQueryList;
 
317
  var ErrMsg: string): TShowHelpResult;
 
318
var
 
319
  KeyWord: String;
 
320
begin
 
321
  Result:=shrHelpNotFound;
 
322
  if (csDesigning in ComponentState) then exit;
 
323
  if (FPCKeyWordHelpPrefix<>'')
 
324
  and (LeftStr(HelpKeyword,length(FPCKeyWordHelpPrefix))=FPCKeyWordHelpPrefix) then begin
 
325
    // HelpKeyword starts with KeywordPrefix
 
326
    KeyWord:=copy(HelpKeyword,length(FPCKeyWordHelpPrefix)+1,length(HelpKeyword));
 
327
    // test: testfcpkeyword
 
328
    if KeyWord='testfcpkeyword' then begin
 
329
      // this help database knows this keyword
 
330
      // => add a node, so that if there are several possibilities the IDE can
 
331
      //    show the user a dialog to choose
 
332
      if FKeywordPrefixNode=nil then
 
333
        FKeywordPrefixNode:=THelpNode.CreateURL(Self,'','');
 
334
      FKeywordPrefixNode.Title:='Pascal keyword '+KeyWord;
 
335
      CreateNodeQueryListAndAdd(FKeywordPrefixNode,nil,ListOfNodes,true);
 
336
      Result:=shrSuccess;
 
337
    end;
 
338
  end;
 
339
end;
 
340
 
 
341
function TSimpleFPCKeywordHelpDatabase.ShowHelp(Query: THelpQuery; BaseNode,
 
342
  NewNode: THelpNode; QueryItem: THelpQueryItem; var ErrMsg: string
 
343
  ): TShowHelpResult;
 
344
var
 
345
  KeywordQuery: THelpQueryKeyword;
 
346
  KeyWord: String;
 
347
begin
 
348
  Result:=shrHelpNotFound;
 
349
  if not (Query is THelpQueryKeyword) then exit;
 
350
  KeywordQuery:=THelpQueryKeyword(Query);
 
351
  KeyWord:=copy(KeywordQuery.Keyword,length(FPCKeyWordHelpPrefix)+1,length(KeywordQuery.Keyword));
 
352
  debugln(['TSimpleFPCKeywordHelpDatabase.ShowHelp Keyword=',Keyword]);
 
353
end;
 
354
 
 
355
function HTMLToCaption(const s: string; MaxLines: integer): string;
 
356
var
 
357
  p: Integer;
 
358
  EndPos: Integer;
 
359
  NewTag: String;
 
360
  Line: Integer;
 
361
  sp: LongInt;
 
362
  InHeader: Boolean;
 
363
  CurTagName: String;
 
364
begin
 
365
  Result:=s;
 
366
  //debugln(['HTMLToCaption HTML="',Result,'"']);
 
367
  Line:=1;
 
368
  p:=1;
 
369
  // remove UTF8 BOM
 
370
  if copy(Result,1,3)=UTF8BOM then
 
371
    Result:=copy(s,4,length(Result));
 
372
  InHeader:=false; // it could be a snippet
 
373
  while p<=length(Result) do begin
 
374
    if Result[p]='<' then begin
 
375
      // removes html tags
 
376
      EndPos:=p+1;
 
377
      if (EndPos<=length(Result)) and (Result[EndPos]='/') then inc(EndPos);
 
378
      while (EndPos<=length(Result))
 
379
      and (not (Result[EndPos] in [' ','>','"','/',#9,#10,#13])) do
 
380
        inc(EndPos);
 
381
      CurTagName:=UpperCase(copy(Result,p+1,EndPos-p-1));
 
382
      while (EndPos<=length(Result)) do begin
 
383
        if Result[EndPos]='"' then begin
 
384
          // skip " tag
 
385
          inc(EndPos);
 
386
          while (EndPos<=length(Result)) and (Result[EndPos]<>'"') do
 
387
            inc(EndPos);
 
388
          if EndPos>length(Result) then break;
 
389
        end;
 
390
        if (Result[EndPos]='>') then begin
 
391
          inc(EndPos);
 
392
          break;
 
393
        end;
 
394
        inc(EndPos);
 
395
      end;
 
396
      //debugln(['HTMLToCaption CurTagName=',CurTagName,' Tag="',copy(Result,p,EndPos-p),'"']);
 
397
 
 
398
      if CurTagName='HTML' then
 
399
      begin
 
400
        // it's a whole page
 
401
        InHeader:=true;
 
402
      end;
 
403
      if CurTagName='BODY' then
 
404
      begin
 
405
        // start of body => ignore header
 
406
        InHeader:=false;
 
407
        Result:=copy(Result,EndPos,length(Result));
 
408
        p:=1;
 
409
        EndPos:=1;
 
410
        Line:=1;
 
411
      end;
 
412
      if CurTagName='/BODY' then
 
413
      begin
 
414
        // end of body
 
415
        Result:=copy(Result,1,p-1);
 
416
        break;
 
417
      end;
 
418
 
 
419
      if (CurTagName='P') or (CurTagName='/P') then begin
 
420
        // add a line break if there is not already one
 
421
        sp:=p;
 
422
        while (sp>1) and (Result[sp-1] in [' ',#9]) do dec(sp);
 
423
        if (sp>1) and (not (Result[sp-1] in [#10,#13])) then
 
424
          CurTagName:='BR';
 
425
      end;
 
426
      if (CurTagName='DIV') or (CurTagName='/DIV')
 
427
      then begin
 
428
        // add a line break if not in first line
 
429
        if Line>1 then
 
430
          CurTagName:='BR';
 
431
      end;
 
432
 
 
433
      if CurTagName='BR' then
 
434
      begin
 
435
        NewTag:=LineEnding;
 
436
        if not InHeader then
 
437
          inc(Line);
 
438
        if Line>MaxLines then begin
 
439
          Result:=copy(Result,1,p)+LineEnding+'...';
 
440
          break;
 
441
        end;
 
442
      end
 
443
      else
 
444
        NewTag:='';
 
445
      if NewTag='' then begin
 
446
        //debugln(['HTMLToCaption deleting tag ',copy(Result,p,EndPos-p)]);
 
447
        System.Delete(Result,p,EndPos-p);
 
448
      end
 
449
      else begin
 
450
        Result:=copy(Result,1,p-1)+NewTag+copy(Result,EndPos,length(Result));
 
451
        inc(p,length(NewTag));
 
452
      end;
 
453
    end else if Result[p] in [' ',#9,#10,#13] then begin
 
454
      // replace spaces and newline characters with a single space
 
455
      EndPos:=p+1;
 
456
      while (EndPos<=length(Result)) and (Result[EndPos] in [' ',#9,#10,#13]) do
 
457
        inc(EndPos);
 
458
      if (p > 1) and not (Result[p-1] in [' ',#9,#10,#13]) then
 
459
      begin
 
460
        Result:=copy(Result,1,p-1)+' '+copy(Result,EndPos,length(Result));
 
461
        inc(p);
 
462
      end
 
463
      else
 
464
        Result:=copy(Result,1,p-1)+copy(Result,EndPos,length(Result));
 
465
    end else if Result[p]='&' then begin
 
466
      // special chars: &lt; &gt; &amp;
 
467
        if (p+2<Length(Result)) and (Result[p+1]='l') and (Result[p+2]='t') and (Result[p+3]=';') then begin
 
468
          EndPos:=p+4;
 
469
          Result:=copy(Result,1,p-1)+'<'+copy(Result,EndPos,length(Result));
 
470
        end else
 
471
        if (p+2<Length(Result)) and (Result[p+1]='g') and (Result[p+2]='t') and (Result[p+3]=';') then begin
 
472
          EndPos:=p+4;
 
473
          Result:=copy(Result,1,p-1)+'>'+copy(Result,EndPos,length(Result));
 
474
        end else
 
475
        if (p+3<Length(Result)) and (Result[p+1]='a') and (Result[p+2]='m') and (Result[p+3]='p') and (Result[p+4]=';') then begin
 
476
          EndPos:=p+5;
 
477
        Result:=copy(Result,1,p-1)+'&'+copy(Result,EndPos,length(Result));
 
478
      end;
 
479
      inc(p);
 
480
    end else
 
481
      inc(p);
 
482
  end;
 
483
  // trim space at end
 
484
  p:=length(Result);
 
485
  while (p>0) and (Result[p] in [' ',#9,#10,#13]) do dec(p);
 
486
  SetLength(Result,p);
 
487
 
 
488
  //DebugLn(['HTMLToCaption Caption="',dbgstr(Result),'"']);
 
489
end;
 
490
 
 
491
function HTMLToCaption(Stream: TStream; MaxLines: integer): string;
 
492
var
 
493
  s: string;
 
494
begin
 
495
  SetLength(s,Stream.Size);
 
496
  if s<>'' then
 
497
    Stream.Read(s[1],length(s));
 
498
  Result:=HTMLToCaption(s,MaxLines);
 
499
end;
 
500
 
 
501
{ TSimpleHTMLControl }
 
502
 
 
503
procedure TSimpleHTMLControl.SetProvider(const AValue: TAbstractIDEHTMLProvider);
 
504
begin
 
505
  if FProvider=AValue then exit;
 
506
  FProvider:=AValue;
 
507
end;
 
508
 
 
509
constructor TSimpleHTMLControl.Create(AOwner: TComponent);
 
510
begin
 
511
  inherited Create(AOwner);
 
512
  MaxLineCount:=30;
 
513
  WordWrap := True;
 
514
  Layout := tlCenter;
 
515
  Alignment := taLeftJustify;
 
516
  Font.Color := clInfoText;
 
517
  BorderSpacing.Around := 4;
 
518
  ShowAccelChar := False;  //don't underline after &
 
519
end;
 
520
 
 
521
function TSimpleHTMLControl.GetURL: string;
 
522
begin
 
523
  Result:=FURL;
 
524
end;
 
525
 
 
526
procedure TSimpleHTMLControl.SetURL(const AValue: string);
 
527
var
 
528
  Stream: TStream;
 
529
  NewURL: String;
 
530
begin
 
531
  if Provider=nil then raise Exception.Create('TSimpleHTMLControl.SetURL missing Provider');
 
532
  if FURL=AValue then exit;
 
533
  NewURL:=Provider.MakeURLAbsolute(Provider.BaseURL,AValue);
 
534
  if FURL=NewURL then exit;
 
535
  FURL:=NewURL;
 
536
  try
 
537
    Stream:=Provider.GetStream(FURL,true);
 
538
    try
 
539
      Caption:=HTMLToCaption(Stream, MaxLineCount);
 
540
    finally
 
541
      Provider.ReleaseStream(FURL);
 
542
    end;
 
543
  except
 
544
    on E: Exception do begin
 
545
      Caption:=E.Message;
 
546
    end;
 
547
  end;
 
548
end;
 
549
 
 
550
procedure TSimpleHTMLControl.SetHTMLContent(Stream: TStream;
 
551
  const NewURL: string);
 
552
begin
 
553
  FURL:=NewURL;
 
554
  Caption:=HTMLToCaption(Stream,MaxLineCount);
 
555
  //debugln(['TSimpleHTMLControl.SetHTMLContent ',Caption]);
 
556
end;
 
557
 
 
558
procedure TSimpleHTMLControl.GetPreferredControlSize(out AWidth, AHeight: integer);
 
559
var
 
560
  DC: HDC;
 
561
  R: TRect;
 
562
  OldFont: HGDIOBJ;
 
563
  Flags: Cardinal;
 
564
  LabelText: String;
 
565
begin
 
566
  AWidth:=0;
 
567
  AHeight:=0;
 
568
  DC := GetDC(Parent.Handle);
 
569
  try
 
570
    R := Rect(0, 0, 600, 200);
 
571
    OldFont := SelectObject(DC, HGDIOBJ(Font.Reference.Handle));
 
572
    Flags := DT_CALCRECT or DT_EXPANDTABS;
 
573
    inc(Flags, DT_WordBreak);
 
574
    LabelText := GetLabelText;
 
575
    DrawText(DC, PChar(LabelText), Length(LabelText), R, Flags);
 
576
    SelectObject(DC, OldFont);
 
577
    AWidth := R.Right - R.Left + 8; // border
 
578
    AHeight := R.Bottom - R.Top + 8; // border
 
579
  finally
 
580
    ReleaseDC(Parent.Handle, DC);
 
581
  end;
 
582
  //DebugLn(['TSimpleHTMLControl.GetPreferredControlSize Caption="',Caption,'" ',AWidth,'x',AHeight]);
 
583
end;
 
584
 
 
585
{ TScrollableHTMLControl }
 
586
 
 
587
procedure TScrollableHTMLControl.SetProvider(const AValue: TAbstractIDEHTMLProvider);
 
588
begin
 
589
  if FProvider=AValue then exit;
 
590
  FProvider:=AValue;
 
591
end;
 
592
 
 
593
constructor TScrollableHTMLControl.Create(AOwner: TComponent);
 
594
begin
 
595
  inherited Create(AOwner);
 
596
  BorderSpacing.Around := 4;
 
597
  BorderStyle := bsNone;
 
598
  ReadOnly := True;
 
599
  ScrollBars := ssAutoVertical;
 
600
end;
 
601
 
 
602
function TScrollableHTMLControl.GetURL: string;
 
603
begin
 
604
  Result:=FURL;
 
605
end;
 
606
 
 
607
procedure TScrollableHTMLControl.SetURL(const AValue: string);
 
608
var
 
609
  Stream: TStream;
 
610
  NewURL: String;
 
611
begin
 
612
  if Provider=nil then raise Exception.Create('TScrollableHTMLControl.SetURL missing Provider');
 
613
  if FURL=AValue then exit;
 
614
  NewURL:=Provider.MakeURLAbsolute(Provider.BaseURL,AValue);
 
615
  if FURL=NewURL then exit;
 
616
  FURL:=NewURL;
 
617
  try
 
618
    Stream:=Provider.GetStream(FURL,true);
 
619
    try
 
620
      Caption:=HTMLToCaption(Stream, MaxInt);
 
621
    finally
 
622
      Provider.ReleaseStream(FURL);
 
623
    end;
 
624
  except
 
625
    on E: Exception do begin
 
626
      Caption:=E.Message;
 
627
    end;
 
628
  end;
 
629
end;
 
630
 
 
631
procedure TScrollableHTMLControl.SetHTMLContent(Stream: TStream;
 
632
  const NewURL: string);
 
633
begin
 
634
  FURL:=NewURL;
 
635
  Caption:=HTMLToCaption(Stream,MaxInt);
 
636
  //debugln(['TScrollableHTMLControl.SetHTMLContent ',Caption]);
 
637
end;
 
638
 
 
639
procedure TScrollableHTMLControl.GetPreferredControlSize(out AWidth, AHeight: integer);
 
640
begin
 
641
  AWidth:=0;
 
642
  AHeight:=0;
 
643
  GetPreferredSize(AWidth, AHeight);
 
644
end;
 
645
 
 
646
{ TLazIDEHTMLProvider }
 
647
 
 
648
procedure TLazIDEHTMLProvider.SetProviders(const AValue: TLIHProviders);
 
649
begin
 
650
  if FProviders=AValue then exit;
 
651
  FProviders:=AValue;
 
652
end;
 
653
 
 
654
procedure TLazIDEHTMLProvider.OpenNextURL(Data: PtrInt);
 
655
var
 
656
  URLScheme: string;
 
657
  URLPath: string;
 
658
  URLParams: string;
 
659
  AFilename: String;
 
660
  p: TPoint;
 
661
begin
 
662
  fWaitingForAsync:=false;
 
663
  SplitURL(NextURL,URLScheme,URLPath,URLParams);
 
664
  debugln(['TLazIDEHTMLProvider.OpenNextURL "',URLScheme,'" :// "',URLPath,'" & "',URLParams,'"']);
 
665
  if URLScheme='source' then begin
 
666
    p:=Point(1,1);
 
667
    if REMatches(URLPath,'(.*)\((.*),(.*)\)') then begin
 
668
      AFilename:=REVar(1);
 
669
      p.Y:=StrToIntDef(REVar(2),p.x);
 
670
      p.X:=StrToIntDef(REVar(3),p.y);
 
671
    end else begin
 
672
      AFilename:=URLPath;
 
673
    end;
 
674
    AFilename:=SetDirSeparators(AFilename);
 
675
    LazarusIDE.DoOpenFileAndJumpToPos(AFilename,p,-1,-1,-1,[]);
 
676
  end else if (URLScheme='openpackage') and (URLPath<>'')
 
677
  and IsValidIdent(URLPath) then begin
 
678
    PackageEditingInterface.DoOpenPackageWithName(URLPath,[],false);
 
679
  end else if (URLScheme='fpdoc') and (URLParams<>'') then begin
 
680
    OpenFPDoc(URLParams);
 
681
  end;
 
682
end;
 
683
 
 
684
procedure TLazIDEHTMLProvider.OpenFPDoc(Path: string);
 
685
var
 
686
  RestPath: string;
 
687
 
 
688
  function ExtractSubPath: string;
 
689
  var
 
690
    p: SizeInt;
 
691
  begin
 
692
    p:=System.Pos('.',RestPath);
 
693
    if p<1 then p:=length(RestPath)+1;
 
694
    Result:=copy(RestPath,1,p-1);
 
695
    RestPath:=copy(RestPath,p+1,length(RestPath));
 
696
  end;
 
697
 
 
698
  procedure InvalidPathError(Msg: string);
 
699
  begin
 
700
    debugln(['InvalidPathError Path="',Path,'" Msg="',Msg,'"']);
 
701
    IDEMessageDialog('Unable to open fpdoc help',
 
702
      'The fpdoc path "'+Path+'" is invalid.'#13+Msg,mtError,[mbCancel]);
 
703
  end;
 
704
 
 
705
var
 
706
  PkgName: String;
 
707
  Pkg: TLazPackage;
 
708
  AnUnitName: String;
 
709
  PkgFile: TPkgFile;
 
710
  ContextList: TPascalHelpContextList;
 
711
  ElementName: String;
 
712
  Filename: String;
 
713
  ErrMsg: string;
 
714
  PascalHelpContextLists: TList;
 
715
  i: Integer;
 
716
  PkgList: TFPList;
 
717
  SubPkg: TLazPackage;
 
718
begin
 
719
  RestPath:=Path;
 
720
  PkgName:=ExtractSubPath;
 
721
  if (PkgName='') or (PkgName[1]<>'#') then begin
 
722
    InvalidPathError('It does not start with a package name, for example #rtl.');
 
723
    exit;
 
724
  end;
 
725
  PkgName:=copy(PkgName,2,length(PkgName));
 
726
  if (PkgName='') or not IsValidIdent(PkgName) then begin
 
727
    InvalidPathError('It does not start with a package name, for example #rtl.');
 
728
    exit;
 
729
  end;
 
730
  if SysUtils.CompareText(PkgName,'rtl')=0 then PkgName:='fcl';
 
731
  Pkg:=TLazPackage(PackageEditingInterface.FindPackageWithName(PkgName));
 
732
  if Pkg=nil then begin
 
733
    InvalidPathError('Package "'+PkgName+'" not found.');
 
734
    exit;
 
735
  end;
 
736
  if Pkg.IsVirtual then begin
 
737
    InvalidPathError('Package "'+PkgName+'" has no help.');
 
738
    exit;
 
739
  end;
 
740
 
 
741
  AnUnitName:=ExtractSubPath;
 
742
  if (AnUnitName='') or (not IsValidIdent(AnUnitName)) then begin
 
743
    InvalidPathError('Unit name "'+AnUnitName+'" is invalid.');
 
744
    exit;
 
745
  end;
 
746
 
 
747
  Filename:='';
 
748
  PkgFile:=Pkg.FindUnit(AnUnitName);
 
749
  if PkgFile=nil then begin
 
750
    // search in all sub packages
 
751
    PkgList:=nil;
 
752
    try
 
753
      PackageGraph.GetAllRequiredPackages(Pkg.FirstRequiredDependency,PkgList);
 
754
      if PkgList<>nil then begin
 
755
        for i:=0 to PkgList.Count-1 do begin
 
756
          SubPkg:=TLazPackage(PkgList[i]);
 
757
          PkgFile:=SubPkg.FindUnit(AnUnitName);
 
758
          if PkgFile<>nil then begin
 
759
            Pkg:=SubPkg;
 
760
            break;
 
761
          end;
 
762
        end;
 
763
      end;
 
764
    finally
 
765
      PkgList.Free;
 
766
    end;
 
767
  end;
 
768
  if (PkgFile<>nil) and (PkgFile.FileType in PkgFileRealUnitTypes) then begin
 
769
    // normal unit in lpk
 
770
    Filename:=PkgFile.GetFullFilename;
 
771
  end else if SysUtils.CompareText(PkgName,'fcl')=0 then begin
 
772
    // search in FPC sources
 
773
    Filename:=CodeToolBoss.DirectoryCachePool.FindUnitInUnitSet('',AnUnitName);
 
774
  end;
 
775
  if Filename='' then begin
 
776
    InvalidPathError('Unit "'+AnUnitName+'" was not found in package '+Pkg.Name+'.');
 
777
    exit;
 
778
  end;
 
779
 
 
780
  PascalHelpContextLists:=TList.Create;
 
781
  try
 
782
    // create a context list (and add it as sole element to the PascalHelpContextLists)
 
783
    ContextList:=TPascalHelpContextList.Create;
 
784
    PascalHelpContextLists.Add(ContextList);
 
785
    ContextList.Add(pihcFilename,Filename);
 
786
    ContextList.Add(pihcSourceName,AnUnitName);
 
787
    repeat
 
788
      ElementName:=ExtractSubPath;
 
789
      if ElementName='' then break;
 
790
      ContextList.Add(pihcType,ElementName);
 
791
    until false;
 
792
    ShowHelpForPascalContexts(Filename,Point(1,1),PascalHelpContextLists,ErrMsg);
 
793
  finally
 
794
    if PascalHelpContextLists<>nil then begin
 
795
      for i:=0 to PascalHelpContextLists.Count-1 do
 
796
        TObject(PascalHelpContextLists[i]).Free;
 
797
      PascalHelpContextLists.Free;
 
798
    end;
 
799
  end;
 
800
end;
 
801
 
 
802
destructor TLazIDEHTMLProvider.Destroy;
 
803
begin
 
804
  if (Application<>nil) and fWaitingForAsync then
 
805
    Application.RemoveAsyncCalls(Self);
 
806
  inherited Destroy;
 
807
end;
 
808
 
 
809
function TLazIDEHTMLProvider.URLHasStream(const URL: string): boolean;
 
810
var
 
811
  URLScheme: string;
 
812
  URLPath: string;
 
813
  URLParams: string;
 
814
begin
 
815
  Result:=false;
 
816
  SplitURL(NextURL,URLScheme,URLPath,URLParams);
 
817
  if (URLScheme='file') or (URLScheme='lazdoc') or (URLScheme='fpdoc') then
 
818
    Result:=true;
 
819
end;
 
820
 
 
821
procedure TLazIDEHTMLProvider.OpenURLAsync(const URL: string);
 
822
begin
 
823
  NextURL:=URL;
 
824
  //debugln(['TLazIDEHTMLProvider.OpenURLAsync URL=',URL]);
 
825
  if not fWaitingForAsync then begin
 
826
    Application.QueueAsyncCall(@OpenNextURL,0);
 
827
    fWaitingForAsync:=true;
 
828
  end;
 
829
end;
 
830
 
 
831
function TLazIDEHTMLProvider.GetStream(const URL: string; Shared: Boolean
 
832
  ): TStream;
 
833
begin
 
834
  Result:=FProviders.GetStream(URL,Shared);
 
835
end;
 
836
 
 
837
procedure TLazIDEHTMLProvider.ReleaseStream(const URL: string);
 
838
begin
 
839
  FProviders.ReleaseStream(URL);
 
840
end;
 
841
 
 
842
{ TLIHProviders }
 
843
 
 
844
constructor TLIHProviders.Create;
 
845
begin
 
846
  FStreams:=TAVLTree.Create(@CompareLIHProviderStream);
 
847
end;
 
848
 
 
849
destructor TLIHProviders.Destroy;
 
850
begin
 
851
  FStreams.FreeAndClear;
 
852
  FreeAndNil(FStreams);
 
853
  inherited Destroy;
 
854
end;
 
855
 
 
856
function TLIHProviders.FindStream(const URL: string; CreateIfNotExists: Boolean
 
857
  ): TLIHProviderStream;
 
858
var
 
859
  Node: TAVLTreeNode;
 
860
begin
 
861
  if URL='' then
 
862
    exit(nil);
 
863
  Node:=FStreams.FindKey(Pointer(URL),@CompareURLWithLIHProviderStream);
 
864
  if Node<>nil then begin
 
865
    Result:=TLIHProviderStream(Node.Data);
 
866
  end else if CreateIfNotExists then begin
 
867
    Result:=TLIHProviderStream.Create;
 
868
    Result.URL:=URL;
 
869
    FStreams.Add(Result);
 
870
  end else
 
871
    Result:=nil;
 
872
end;
 
873
 
 
874
function TLIHProviders.GetStream(const URL: string; Shared: boolean): TStream;
 
875
 
 
876
  procedure OpenFile(out Stream: TStream; const Filename: string;
 
877
    UseCTCache: boolean);
 
878
  var
 
879
    fs: TFileStreamUTF8;
 
880
    ok: Boolean;
 
881
    Buf: TCodeBuffer;
 
882
    ms: TMemoryStream;
 
883
  begin
 
884
    if UseCTCache then begin
 
885
      Buf:=CodeToolBoss.LoadFile(Filename,true,false);
 
886
      if Buf=nil then
 
887
        raise Exception.Create('TLIHProviders.GetStream: unable to open file '+Filename);
 
888
      ms:=TMemoryStream.Create;
 
889
      Buf.SaveToStream(ms);
 
890
      ms.Position:=0;
 
891
      Result:=ms;
 
892
    end else begin
 
893
      fs:=nil;
 
894
      ok:=false;
 
895
      try
 
896
        DebugLn(['TLIHProviders.GetStream.OpenFile ',Filename]);
 
897
        fs:=TFileStreamUTF8.Create(Filename,fmOpenRead);
 
898
        Stream:=fs;
 
899
        ok:=true;
 
900
      finally
 
901
        if not ok then
 
902
          fs.Free;
 
903
      end;
 
904
    end;
 
905
  end;
 
906
 
 
907
 
 
908
{const
 
909
  HTML =
 
910
     '<HTML>'+#10
 
911
    +'<BODY>'+#10
 
912
    +'Test'+#10
 
913
    +'</BODY>'+#10
 
914
    +'</HTML>';}
 
915
var
 
916
  Stream: TLIHProviderStream;
 
917
  URLType: string;
 
918
  URLPath: string;
 
919
  URLParams: string;
 
920
begin
 
921
  if URL='' then raise Exception.Create('TLIHProviders.GetStream no URL');
 
922
  if Shared then begin
 
923
    Stream:=FindStream(URL,true);
 
924
    Stream.IncreaseRefCount;
 
925
    Result:=Stream.Stream;
 
926
  end else begin
 
927
    Stream:=nil;
 
928
    Result:=nil;
 
929
  end;
 
930
  try
 
931
    if Result=nil then begin
 
932
      SplitURL(URL,URLType,URLPath,URLParams);
 
933
      {$ifdef VerboseLazDoc}
 
934
      DebugLn(['TLIHProviders.GetStream URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams]);
 
935
      {$endif}
 
936
      if URLType='lazdoc' then begin
 
937
        if copy(URLPath,1,8)='lazarus/' then begin
 
938
          URLPath:=copy(URLPath,9,length(URLPath));
 
939
          if (URLPath='index.html')
 
940
          or (URLPath='images/laztitle.jpg')
 
941
          or (URLPath='images/cheetah1.png')
 
942
          or (URLPath='lazdoc.css')
 
943
          then begin
 
944
            OpenFile(Result,
 
945
              EnvironmentOptions.GetParsedLazarusDirectory+SetDirSeparators('/docs/'+URLPath),
 
946
              true);
 
947
          end;
 
948
        end;
 
949
      end else if URLType='file' then begin
 
950
        OpenFile(Result,SetDirSeparators(URLPath),true);
 
951
      end;
 
952
      {Result:=TMemoryStream.Create;
 
953
      Stream.Stream:=Result;
 
954
      Result.Write(HTML[1],length(HTML));
 
955
      Result.Position:=0;}
 
956
      if Result=nil then
 
957
        raise Exception.Create('TLIHProviders.GetStream: URL not found "'+dbgstr(URL)+'"');
 
958
      if Stream<>nil then
 
959
        Stream.Stream:=Result;
 
960
    end;
 
961
  finally
 
962
    if (Result=nil) and (Stream<>nil) then
 
963
      ReleaseStream(URL);
 
964
  end;
 
965
end;
 
966
 
 
967
procedure TLIHProviders.ReleaseStream(const URL: string);
 
968
var
 
969
  Stream: TLIHProviderStream;
 
970
begin
 
971
  Stream:=FindStream(URL,false);
 
972
  if Stream=nil then
 
973
    raise Exception.Create('TLIHProviders.ReleaseStream "'+URL+'"');
 
974
  Stream.DecreaseRefCount;
 
975
  if Stream.RefCount=0 then begin
 
976
    FStreams.Remove(Stream);
 
977
    Stream.Free;
 
978
  end;
 
979
end;
 
980
 
 
981
{ TLIHProviderStream }
 
982
 
 
983
destructor TLIHProviderStream.Destroy;
 
984
begin
 
985
  FreeAndNil(Stream);
 
986
  inherited Destroy;
 
987
end;
 
988
 
 
989
procedure TLIHProviderStream.IncreaseRefCount;
 
990
begin
 
991
  inc(FRefCount);
 
992
end;
 
993
 
 
994
procedure TLIHProviderStream.DecreaseRefCount;
 
995
begin
 
996
  if FRefCount<=0 then
 
997
    raise Exception.Create('TLIHProviderStream.DecreaseRefCount');
 
998
  dec(FRefCount);
 
999
end;
 
1000
 
 
1001
{ THelpSelectorDialog }
 
1002
 
 
1003
procedure THelpSelectorDialog.HelpSelectorDialogClose(Sender: TObject;
 
1004
  var CloseAction: TCloseAction);
 
1005
begin
 
1006
  IDEDialogLayoutList.SaveLayout(Self);
 
1007
end;
 
1008
 
 
1009
procedure THelpSelectorDialog.NodesListBoxDblClick(Sender: TObject);
 
1010
begin
 
1011
  ModalResult := mrOK;
 
1012
end;
 
1013
 
 
1014
procedure THelpSelectorDialog.SetNodes(const AValue: THelpNodeQueryList);
 
1015
begin
 
1016
  if FNodes=AValue then exit;
 
1017
  FNodes:=AValue;
 
1018
  FillNodesListBox;
 
1019
end;
 
1020
 
 
1021
procedure THelpSelectorDialog.FillNodesListBox;
 
1022
var
 
1023
  List: TStringList;
 
1024
  i: Integer;
 
1025
  NodeQuery: THelpNodeQuery;
 
1026
begin
 
1027
  List:=TStringList.Create;
 
1028
  if (Nodes<>nil) then begin
 
1029
    for i:=0 to Nodes.Count-1 do begin
 
1030
      NodeQuery:=Nodes[i];
 
1031
      List.Add(NodeQuery.AsString);
 
1032
    end;
 
1033
  end;
 
1034
  NodesListBox.Items.Assign(List);
 
1035
  List.Free;
 
1036
  if NodesListBox.Count > 0 then NodesListBox.ItemIndex := 0;
 
1037
end;
 
1038
 
 
1039
constructor THelpSelectorDialog.Create(TheOwner: TComponent);
 
1040
begin
 
1041
  inherited Create(TheOwner);
 
1042
  IDEDialogLayoutList.ApplyLayout(Self,500,300);
 
1043
 
 
1044
  Caption := lisHelpSelectorDialog;
 
1045
  NodesGroupBox.Caption:=lisSelectAHelpItem;
 
1046
  BtnPanel.OKButton.Caption:=lisMenuOk;
 
1047
end;
 
1048
 
 
1049
{ TIDEHelpDatabases }
 
1050
 
 
1051
function TIDEHelpDatabases.ShowHelpSelector(Query: THelpQuery;
 
1052
  Nodes: THelpNodeQueryList;
 
1053
  var ErrMsg: string;
 
1054
  var Selection: THelpNodeQuery
 
1055
  ): TShowHelpResult;
 
1056
var
 
1057
  Dialog: THelpSelectorDialog;
 
1058
  i: LongInt;
 
1059
begin
 
1060
  Selection:=nil;
 
1061
  Result:=shrNone;
 
1062
  Dialog:=THelpSelectorDialog.Create(nil);
 
1063
  try
 
1064
    Dialog.Nodes:=Nodes;
 
1065
    if Dialog.ShowModal=mrOk then begin
 
1066
      i:=Dialog.NodesListBox.ItemIndex;
 
1067
      if i>=0 then begin
 
1068
        Selection:=Nodes[i];
 
1069
        Result:=shrSuccess;
 
1070
      end;
 
1071
    end else begin
 
1072
      Result:=shrCancel;
 
1073
    end;
 
1074
  finally
 
1075
    Dialog.Free;
 
1076
  end;
 
1077
end;
 
1078
 
 
1079
function TIDEHelpDatabases.GetBaseDirectoryForBasePathObject(
 
1080
  BasePathObject: TObject): string;
 
1081
begin
 
1082
  Result:='';
 
1083
  DebugLn('TIDEHelpDatabases.GetBaseDirectoryForBasePathObject BasePathObject=',dbgsName(BasePathObject));
 
1084
  if (BasePathObject is THelpBasePathObject) then
 
1085
    Result:=THelpBasePathObject(BasePathObject).BasePath
 
1086
  else if (BasePathObject=HelpBoss) or (BasePathObject=MainIDEInterface) then
 
1087
    Result:=EnvironmentOptions.GetParsedLazarusDirectory
 
1088
  else if BasePathObject is TProject then
 
1089
    Result:=TProject(BasePathObject).ProjectDirectory
 
1090
  else if BasePathObject is TLazPackage then
 
1091
    Result:=TLazPackage(BasePathObject).Directory;
 
1092
  if Result<>'' then
 
1093
    IDEMacros.SubstituteMacros(Result);
 
1094
  Result:=AppendPathDelim(Result);
 
1095
end;
 
1096
 
 
1097
function TIDEHelpDatabases.ShowHelpForSourcePosition(
 
1098
  Query: THelpQuerySourcePosition; var ErrMsg: string): TShowHelpResult;
 
1099
begin
 
1100
  Result:=HelpBoss.ShowHelpForSourcePosition(Query.Filename,
 
1101
                                             Query.SourcePosition,ErrMsg);
 
1102
end;
 
1103
 
 
1104
function TIDEHelpDatabases.SubstituteMacros(var s: string): boolean;
 
1105
begin
 
1106
  Result:=IDEMacros.SubstituteMacros(s);
 
1107
end;
 
1108
 
 
1109
{ TIDEHelpManager }
 
1110
 
 
1111
procedure TIDEHelpManager.mnuSearchInFPDocFilesClick(Sender: TObject);
 
1112
begin
 
1113
  ShowFPDocFileSearch;
 
1114
end;
 
1115
 
 
1116
procedure TIDEHelpManager.mnuEditMessageHelpClick(Sender: TObject);
 
1117
begin
 
1118
 
 
1119
end;
 
1120
 
 
1121
procedure TIDEHelpManager.mnuHelpAboutLazarusClicked(Sender: TObject);
 
1122
begin
 
1123
  ShowAboutForm;
 
1124
end;
 
1125
 
 
1126
procedure TIDEHelpManager.mnuHelpOnlineHelpClicked(Sender: TObject);
 
1127
begin
 
1128
  ShowLazarusHelpStartPage;
 
1129
end;
 
1130
 
 
1131
procedure TIDEHelpManager.mnuHelpReportBugClicked(Sender: TObject);
 
1132
begin
 
1133
  OpenURL(lisReportingBugURL);
 
1134
end;
 
1135
 
 
1136
procedure TIDEHelpManager.RegisterIDEHelpDatabases;
 
1137
 
 
1138
  procedure CreateMainIDEHelpDB;
 
1139
  var
 
1140
    StartNode: THelpNode;
 
1141
    HTMLHelp: THTMLHelpDatabase;
 
1142
  begin
 
1143
    FMainHelpDB:=HelpDatabases.CreateHelpDatabase(lihcStartPage,
 
1144
                                                  THTMLHelpDatabase,true);
 
1145
    HTMLHelp:=FMainHelpDB as THTMLHelpDatabase;
 
1146
    FMainHelpDBPath:=THelpBasePathObject.Create('$(LazarusDir)/docs');
 
1147
    HTMLHelp.BasePathObject:=FMainHelpDBPath;
 
1148
 
 
1149
    // HTML nodes for the IDE
 
1150
    StartNode:=THelpNode.CreateURLID(HTMLHelp,'Lazarus',
 
1151
                                     'file://index.html',lihcStartPage);
 
1152
    HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,StartNode);// once as TOC
 
1153
    HTMLHelp.RegisterItemWithNode(StartNode);// and once as normal page
 
1154
  end;
 
1155
  
 
1156
  procedure CreateRTLHelpDB;
 
1157
  var
 
1158
    HTMLHelp: TFPDocHTMLHelpDatabase;
 
1159
    FPDocNode: THelpNode;
 
1160
    DirItem: THelpDBISourceDirectory;
 
1161
  begin
 
1162
    FRTLHelpDB:=HelpDatabases.CreateHelpDatabase(lihcRTLUnits,
 
1163
                                                 TFPDocHTMLHelpDatabase,true);
 
1164
    HTMLHelp:=FRTLHelpDB as TFPDocHTMLHelpDatabase;
 
1165
    HTMLHelp.DefaultBaseURL:=lihRTLURL;
 
1166
    FRTLHelpDBPath:=THelpBaseURLObject.Create;
 
1167
    HTMLHelp.BasePathObject:=FRTLHelpDBPath;
 
1168
 
 
1169
    // FPDoc nodes for units in the RTL
 
1170
    FPDocNode:=THelpNode.CreateURL(HTMLHelp,
 
1171
                   'RTL - Free Pascal Run Time Library Units',
 
1172
                   'file://index.html');
 
1173
    HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,FPDocNode);// once as TOC
 
1174
    DirItem:=THelpDBISourceDirectory.Create(FPDocNode,'$(FPCSrcDir)/rtl',
 
1175
                                   '*.pp;*.pas',true);// and once as normal page
 
1176
    HTMLHelp.RegisterItem(DirItem);
 
1177
  end;
 
1178
 
 
1179
  procedure CreateFCLHelpDB;
 
1180
  var
 
1181
    HTMLHelp: TFPDocHTMLHelpDatabase;
 
1182
    FPDocNode: THelpNode;
 
1183
    DirItem: THelpDBISourceDirectory;
 
1184
  begin
 
1185
    FFCLHelpDB:=HelpDatabases.CreateHelpDatabase(lihcFCLUnits,
 
1186
                                                 TFPDocHTMLHelpDatabase,true);
 
1187
    HTMLHelp:=FFCLHelpDB as TFPDocHTMLHelpDatabase;
 
1188
    HTMLHelp.DefaultBaseURL:=lihFCLURL;
 
1189
    FFCLHelpDBPath:=THelpBaseURLObject.Create;
 
1190
    HTMLHelp.BasePathObject:=FFCLHelpDBPath;
 
1191
 
 
1192
    // FPDoc nodes for units in the FCL
 
1193
    // create TOC
 
1194
    HTMLHelp.TOCNode:=THelpNode.CreateURL(HTMLHelp,
 
1195
                   'FCL - Free Pascal Component Library Units',
 
1196
                   'file://index.html');
 
1197
                   
 
1198
    // fpc 2.0.x FCL source directory
 
1199
    FPDocNode:=THelpNode.CreateURL(HTMLHelp,
 
1200
                   'FCL - Free Pascal Component Library Units (2.0.x)',
 
1201
                   'file://index.html');
 
1202
    DirItem:=THelpDBISourceDirectory.Create(FPDocNode,
 
1203
                                     '$(FPCSrcDir)/fcl/inc','*.pp;*.pas',false);
 
1204
    HTMLHelp.RegisterItem(DirItem);
 
1205
    
 
1206
    // fpc 2.2.x FCL source directory
 
1207
    FPDocNode:=THelpNode.CreateURL(HTMLHelp,
 
1208
                   'FCL - Free Pascal Component Library Units',
 
1209
                   'file://index.html');
 
1210
    DirItem:=THelpDBISourceDirectory.Create(FPDocNode,
 
1211
                   '$(FPCSrcDir)/packages/fcl-base/src','*.pp;*.pas',true);
 
1212
    HTMLHelp.RegisterItem(DirItem);
 
1213
 
 
1214
    // fpc 2.4.4+ FCL source directory
 
1215
    FPDocNode:=THelpNode.CreateURL(HTMLHelp,
 
1216
                   'FCL - Free Pascal Component Library Units',
 
1217
                   'file://index.html');
 
1218
    DirItem:=THelpDBISourceDirectories.Create(FPDocNode,'$(FPCSrcDir)/packages',
 
1219
      'fcl-base/src;fcl-db/src;fcl-extra/src;fcl-process/src;fcl-web/src;paszlib/src',
 
1220
      '*.pp;*.pas',true);
 
1221
    HTMLHelp.RegisterItem(DirItem);
 
1222
  end;
 
1223
 
 
1224
  procedure CreateLCLHelpDB;
 
1225
  var
 
1226
    HTMLHelp: TFPDocHTMLHelpDatabase;
 
1227
    FPDocNode: THelpNode;
 
1228
    DirItem: THelpDBISourceDirectory;
 
1229
  begin
 
1230
    FLCLHelpDB:=HelpDatabases.CreateHelpDatabase(lihcLCLUnits,
 
1231
                                                 TFPDocHTMLHelpDatabase,true);
 
1232
    HTMLHelp:=FLCLHelpDB as TFPDocHTMLHelpDatabase;
 
1233
    HTMLHelp.DefaultBaseURL:=lihLCLURL;
 
1234
    FLCLHelpDBPath:=THelpBaseURLObject.Create;
 
1235
    HTMLHelp.BasePathObject:=FLCLHelpDBPath;
 
1236
 
 
1237
    // FPDoc nodes for units in the RTL
 
1238
    FPDocNode:=THelpNode.CreateURL(HTMLHelp,
 
1239
                   'LCL - Lazarus Component Library Units',
 
1240
                   'file://index.html');
 
1241
    HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,FPDocNode);// once as TOC
 
1242
    DirItem:=THelpDBISourceDirectory.Create(FPDocNode,'$(LazarusDir)/lcl',
 
1243
                                   '*.pp;*.pas',true);// and once as normal page
 
1244
    HTMLHelp.RegisterItem(DirItem);
 
1245
  end;
 
1246
 
 
1247
  procedure CreateFPCKeywordsHelpDB;
 
1248
  begin
 
1249
    {$IFDEF EnableSimpleFPCKeyWordHelpDB}
 
1250
    HelpDatabases.CreateHelpDatabase('SimpleDemoForFPCKeyWordHelpDB',
 
1251
                                            TSimpleFPCKeywordHelpDatabase,true);
 
1252
    {$ENDIF}
 
1253
  end;
 
1254
 
 
1255
begin
 
1256
  CreateMainIDEHelpDB;
 
1257
  CreateRTLHelpDB;
 
1258
  CreateFCLHelpDB;
 
1259
  CreateLCLHelpDB;
 
1260
  CreateFPCMessagesHelpDB;
 
1261
  CreateFPCKeywordsHelpDB;
 
1262
end;
 
1263
 
 
1264
procedure TIDEHelpManager.RegisterDefaultIDEHelpViewers;
 
1265
var
 
1266
  HelpViewer: THTMLBrowserHelpViewer;
 
1267
begin
 
1268
  HelpViewer:= THTMLBrowserHelpViewer.Create(nil);
 
1269
  HelpViewer.OnFindDefaultBrowser := @FindDefaultBrowser;
 
1270
  HelpViewers.RegisterViewer(HelpViewer);
 
1271
end;
 
1272
 
 
1273
procedure TIDEHelpManager.FindDefaultBrowser(var DefaultBrowser, Params: string);
 
1274
begin
 
1275
  GetDefaultBrowser(DefaultBrowser, Params);
 
1276
end;
 
1277
 
 
1278
constructor TIDEHelpManager.Create(TheOwner: TComponent);
 
1279
begin
 
1280
  inherited Create(TheOwner);
 
1281
  HelpBoss:=Self;
 
1282
  LazarusHelp:=Self;
 
1283
  HelpOpts:=THelpOptions.Create;
 
1284
  HelpOpts.SetDefaultFilename;
 
1285
  HelpDatabases:=TIDEHelpDatabases.Create;
 
1286
  HelpIntfs.HelpManager:=HelpDatabases;
 
1287
  HelpViewers:=THelpViewers.Create;
 
1288
  RegisterIDEHelpDatabases;
 
1289
  RegisterDefaultIDEHelpViewers;
 
1290
  
 
1291
  CodeHelpBoss:=TCodeHelpManager.Create(Self);
 
1292
 
 
1293
  // register property editors for URL handling
 
1294
  RegisterPropertyEditor(TypeInfo(AnsiString),
 
1295
                       THTMLHelpDatabase,'BaseURL',TURLDirectoryPropertyEditor);
 
1296
 
 
1297
  FHTMLProviders:=TLIHProviders.Create;
 
1298
 
 
1299
  if CreateIDEHTMLControl=nil then
 
1300
    CreateIDEHTMLControl:=@LazCreateIDEHTMLControl;
 
1301
  if CreateIDEHTMLProvider=nil then
 
1302
    CreateIDEHTMLProvider:=@LazCreateIDEHTMLProvider;
 
1303
end;
 
1304
 
 
1305
destructor TIDEHelpManager.Destroy;
 
1306
begin
 
1307
  FreeThenNil(FHTMLProviders);
 
1308
  FreeThenNil(CodeHelpBoss);
 
1309
  FPCMessagesHelpDB:=nil;
 
1310
  FreeLCLHelpSystem;
 
1311
  FreeThenNil(HelpOpts);
 
1312
  FreeThenNil(FMainHelpDBPath);
 
1313
  FreeThenNil(FRTLHelpDBPath);
 
1314
  FreeThenNil(FFCLHelpDBPath);
 
1315
  FreeThenNil(FLCLHelpDBPath);
 
1316
  HelpBoss:=nil;
 
1317
  LazarusHelp:=nil;
 
1318
  inherited Destroy;
 
1319
end;
 
1320
 
 
1321
procedure TIDEHelpManager.ConnectMainBarEvents;
 
1322
begin
 
1323
  with MainIDEBar do
 
1324
  begin
 
1325
    itmHelpAboutLazarus.OnClick := @mnuHelpAboutLazarusClicked;
 
1326
    itmHelpOnlineHelp.OnClick := @mnuHelpOnlineHelpClicked;
 
1327
    itmHelpReportingBug.OnClick := @mnuHelpReportBugClicked;
 
1328
 
 
1329
    {$IFDEF EnableFPDocSearch}
 
1330
    itmSearchInFPDocFiles.OnClick:=@mnuSearchInFPDocFilesClick;
 
1331
    {$ENDIF}
 
1332
 
 
1333
 
 
1334
  end;
 
1335
end;
 
1336
 
 
1337
procedure TIDEHelpManager.LoadHelpOptions;
 
1338
begin
 
1339
  HelpOpts.Load;
 
1340
end;
 
1341
 
 
1342
procedure TIDEHelpManager.SaveHelpOptions;
 
1343
begin
 
1344
  HelpOpts.Save;
 
1345
end;
 
1346
 
 
1347
procedure TIDEHelpManager.ShowLazarusHelpStartPage;
 
1348
begin
 
1349
  ShowIDEHelpForKeyword(lihcStartPage);
 
1350
end;
 
1351
 
 
1352
procedure TIDEHelpManager.ShowIDEHelpForContext(HelpContext: THelpContext);
 
1353
begin
 
1354
  ShowHelpOrErrorForContext(MainHelpDB.ID,HelpContext);
 
1355
end;
 
1356
 
 
1357
procedure TIDEHelpManager.ShowIDEHelpForKeyword(const Keyword: string);
 
1358
begin
 
1359
  ShowHelpOrErrorForKeyword(MainHelpDB.ID,Keyword);
 
1360
end;
 
1361
 
 
1362
function TIDEHelpManager.ShowHelpForSourcePosition(const Filename: string;
 
1363
  const CodePos: TPoint; var ErrMsg: string): TShowHelpResult;
 
1364
  
 
1365
  function CollectKeyWords(CodeBuffer: TCodeBuffer): TShowHelpResult;
 
1366
  var
 
1367
    p: Integer;
 
1368
    IdentStart, IdentEnd: integer;
 
1369
    KeyWord: String;
 
1370
    ErrorMsg: String;
 
1371
  begin
 
1372
    Result:=shrHelpNotFound;
 
1373
    p:=0;
 
1374
    CodeBuffer.LineColToPosition(CodePos.Y,CodePos.X,p);
 
1375
    if p<1 then exit;
 
1376
    GetIdentStartEndAtPosition(CodeBuffer.Source,p,IdentStart,IdentEnd);
 
1377
    if IdentEnd<=IdentStart then exit;
 
1378
    if (IdentStart > 1) and (CodeBuffer.Source[IdentStart - 1] in ['$','%']) then
 
1379
      Dec(IdentStart);
 
1380
    KeyWord:=copy(CodeBuffer.Source,IdentStart,IdentEnd-IdentStart);
 
1381
    ErrorMsg:='';
 
1382
    if KeyWord[1] = '$' then
 
1383
      Result:=ShowHelpForDirective('',FPCDirectiveHelpPrefix+Keyword,ErrorMsg)
 
1384
    else if KeyWord[1] = '%' then
 
1385
      Result:=ShowHelpForDirective('',IDEDirectiveHelpPrefix+Keyword,ErrorMsg)
 
1386
    else
 
1387
      Result:=ShowHelpForKeyword('',FPCKeyWordHelpPrefix+Keyword,ErrorMsg);
 
1388
    if Result=shrHelpNotFound then exit;
 
1389
    HelpManager.ShowError(Result,ErrorMsg);
 
1390
  end;
 
1391
 
 
1392
  function CollectDeclarations(CodeBuffer: TCodeBuffer;
 
1393
    out Complete: boolean): TShowHelpResult;
 
1394
  var
 
1395
    NewList: TPascalHelpContextList;
 
1396
    PascalHelpContextLists: TList;
 
1397
    ListOfPCodeXYPosition: TFPList;
 
1398
    CurCodePos: PCodeXYPosition;
 
1399
    i: Integer;
 
1400
  begin
 
1401
    Complete:=false;
 
1402
    Result:=shrHelpNotFound;
 
1403
    ListOfPCodeXYPosition:=nil;
 
1404
    PascalHelpContextLists:=nil;
 
1405
    try
 
1406
      // get all possible declarations of this identifier
 
1407
      if CodeToolBoss.FindDeclarationAndOverload(CodeBuffer,CodePos.X,CodePos.Y,
 
1408
        ListOfPCodeXYPosition,[fdlfWithoutEmptyProperties,fdlfWithoutForwards])
 
1409
      then begin
 
1410
        if ListOfPCodeXYPosition=nil then exit;
 
1411
        debugln('TIDEHelpManager.ShowHelpForSourcePosition B Success ',dbgs(ListOfPCodeXYPosition.Count));
 
1412
        // convert the source positions in pascal help context list
 
1413
        for i:=0 to ListOfPCodeXYPosition.Count-1 do begin
 
1414
          CurCodePos:=PCodeXYPosition(ListOfPCodeXYPosition[i]);
 
1415
          debugln('TIDEHelpManager.ShowHelpForSourcePosition C ',CurCodePos^.Code.Filename,' X=',dbgs(CurCodePos^.X),' Y=',dbgs(CurCodePos^.Y));
 
1416
          NewList:=ConvertCodePosToPascalHelpContext(CurCodePos);
 
1417
          if NewList<>nil then begin
 
1418
            if PascalHelpContextLists=nil then
 
1419
              PascalHelpContextLists:=TList.Create;
 
1420
            PascalHelpContextLists.Add(NewList);
 
1421
          end;
 
1422
        end;
 
1423
        if PascalHelpContextLists=nil then exit;
 
1424
 
 
1425
        // invoke help system
 
1426
        Complete:=true;
 
1427
        debugln('TIDEHelpManager.ShowHelpForSourcePosition D PascalHelpContextLists.Count=',dbgs(PascalHelpContextLists.Count));
 
1428
        Result:=ShowHelpForPascalContexts(Filename,CodePos,PascalHelpContextLists,ErrMsg);
 
1429
      end else if CodeToolBoss.ErrorCode<>nil then begin
 
1430
        MainIDEInterface.DoJumpToCodeToolBossError;
 
1431
        Complete:=True;
 
1432
      end;
 
1433
    finally
 
1434
      FreeListOfPCodeXYPosition(ListOfPCodeXYPosition);
 
1435
      if PascalHelpContextLists<>nil then begin
 
1436
        for i:=0 to PascalHelpContextLists.Count-1 do
 
1437
          TObject(PascalHelpContextLists[i]).Free;
 
1438
        PascalHelpContextLists.Free;
 
1439
      end;
 
1440
    end;
 
1441
  end;
 
1442
 
 
1443
var
 
1444
  CodeBuffer: TCodeBuffer;
 
1445
  Complete: boolean;
 
1446
begin
 
1447
  debugln('TIDEHelpManager.ShowHelpForSourcePosition A Filename=',Filename,' ',dbgs(CodePos));
 
1448
  Result:=shrHelpNotFound;
 
1449
  ErrMsg:='No help found for "'+Filename+'"'
 
1450
         +' at ('+IntToStr(CodePos.Y)+','+IntToStr(CodePos.X)+')';
 
1451
  // commit editor changes
 
1452
  if not CodeToolBoss.GatherExternalChanges then exit;
 
1453
  // get code buffer for Filename
 
1454
  if mrOk<>LoadCodeBuffer(CodeBuffer,FileName,[lbfCheckIfText],false) then
 
1455
    exit;
 
1456
 
 
1457
  Result:=CollectDeclarations(CodeBuffer,Complete);
 
1458
  if Complete then exit;
 
1459
  Result:=CollectKeyWords(CodeBuffer);
 
1460
end;
 
1461
 
 
1462
function TIDEHelpManager.ConvertCodePosToPascalHelpContext(
 
1463
  ACodePos: PCodeXYPosition): TPascalHelpContextList;
 
1464
 
 
1465
  procedure AddContext(Descriptor: TPascalHelpContextType;
 
1466
    const Context: string);
 
1467
  begin
 
1468
    Result.Add(Descriptor,Context);
 
1469
    //debugln('  AddContext Descriptor=',dbgs(ord(Descriptor)),' Context="',Context,'"');
 
1470
  end;
 
1471
 
 
1472
  procedure AddContextsBackwards(Tool: TCodeTool;
 
1473
    Node: TCodeTreeNode);
 
1474
  begin
 
1475
    if Node=nil then exit;
 
1476
    AddContextsBackwards(Tool,Node.Parent);
 
1477
    case Node.Desc of
 
1478
    ctnUnit, ctnPackage, ctnProgram, ctnLibrary:
 
1479
      AddContext(pihcSourceName,Tool.GetSourceName);
 
1480
    ctnVarDefinition:
 
1481
      AddContext(pihcVariable,Tool.ExtractDefinitionName(Node));
 
1482
    ctnTypeDefinition:
 
1483
      AddContext(pihcType,Tool.ExtractDefinitionName(Node));
 
1484
    ctnConstDefinition:
 
1485
      AddContext(pihcConst,Tool.ExtractDefinitionName(Node));
 
1486
    ctnProperty:
 
1487
      AddContext(pihcProperty,Tool.ExtractPropName(Node,false));
 
1488
    ctnProcedure:
 
1489
      AddContext(pihcProcedure,Tool.ExtractProcName(Node,
 
1490
                                                    [phpWithoutClassName]));
 
1491
    ctnProcedureHead:
 
1492
      AddContext(pihcParameterList,Tool.ExtractProcHead(Node,
 
1493
                [phpWithoutClassKeyword,phpWithoutClassName,phpWithoutName,
 
1494
                 phpWithoutSemicolon]));
 
1495
    end;
 
1496
  end;
 
1497
 
 
1498
var
 
1499
  MainCodeBuffer: TCodeBuffer;
 
1500
  Tool: TCustomCodeTool;
 
1501
  CleanPos: integer;
 
1502
  i: Integer;
 
1503
  Node: TCodeTreeNode;
 
1504
  IncludeChain: TFPList;
 
1505
  ConversionResult: LongInt;
 
1506
begin
 
1507
  Result:=nil;
 
1508
  // find code buffer
 
1509
  if ACodePos^.Code=nil then begin
 
1510
    debugln('WARNING: ConvertCodePosToPascalHelpContext ACodePos.Code=nil');
 
1511
    exit;
 
1512
  end;
 
1513
  Result:=TPascalHelpContextList.Create;
 
1514
  // add filename and all filenames of the include chain
 
1515
  IncludeChain:=nil;
 
1516
  try
 
1517
    CodeToolBoss.GetIncludeCodeChain(ACodePos^.Code,true,IncludeChain);
 
1518
    if IncludeChain=nil then begin
 
1519
      debugln('WARNING: ConvertCodePosToPascalHelpContext IncludeChain=nil');
 
1520
      exit;
 
1521
    end;
 
1522
    for i:=0 to IncludeChain.Count-1 do
 
1523
      AddContext(pihcFilename,TCodeBuffer(IncludeChain[i]).Filename);
 
1524
    MainCodeBuffer:=TCodeBuffer(IncludeChain[0]);
 
1525
  finally
 
1526
    IncludeChain.Free;
 
1527
  end;
 
1528
  // find code tool
 
1529
  Tool:=CodeToolBoss.FindCodeToolForSource(MainCodeBuffer);
 
1530
  if not (Tool is TCodeTool) then begin
 
1531
    debugln('WARNING: ConvertCodePosToPascalHelpContext not (Tool is TCodeTool) MainCodeBuffer=',MainCodeBuffer.Filename);
 
1532
    exit;
 
1533
  end;
 
1534
  // convert cursor position to clean position
 
1535
  ConversionResult:=Tool.CaretToCleanPos(ACodePos^,CleanPos);
 
1536
  if ConversionResult<>0 then begin
 
1537
    // position not in clean code, maybe a comment, maybe behind last line
 
1538
    // => ignore
 
1539
    exit;
 
1540
  end;
 
1541
  // find node
 
1542
  Node:=Tool.FindDeepestNodeAtPos(CleanPos,false);
 
1543
  if Node=nil then begin
 
1544
    // position not in a scanned pascal node, maybe in between
 
1545
    // => ignore
 
1546
    exit;
 
1547
  end;
 
1548
  AddContextsBackwards(TCodeTool(Tool),Node);
 
1549
end;
 
1550
 
 
1551
function TIDEHelpManager.GetFPDocFilenameForSource(SrcFilename: string;
 
1552
  ResolveIncludeFiles: Boolean; out AnOwner: TObject): string;
 
1553
var
 
1554
  CacheWasUsed: boolean;
 
1555
begin
 
1556
  Result:=CodeHelpBoss.GetFPDocFilenameForSource(SrcFilename,ResolveIncludeFiles,
 
1557
    CacheWasUsed,AnOwner);
 
1558
end;
 
1559
 
 
1560
procedure TIDEHelpManager.ShowHelpForMessage(Line: integer);
 
1561
 
 
1562
  function ParseMessage(MsgItem: TIDEMessageLine): TStringList;
 
1563
  begin
 
1564
    Result:=TStringList.Create;
 
1565
    Result.Values['Message']:=MsgItem.Msg;
 
1566
    if MsgItem.Parts<>nil then
 
1567
      Result.Assign(MsgItem.Parts);
 
1568
  end;
 
1569
 
 
1570
var
 
1571
  MsgItem: TIDEMessageLine;
 
1572
  MessageParts: TStringList;
 
1573
begin
 
1574
  //debugln('TIDEHelpManager.ShowHelpForMessage A Line=',dbgs(Line));
 
1575
  if MessagesView=nil then exit;
 
1576
  if Line<0 then
 
1577
    Line:=MessagesView.SelectedMessageIndex;
 
1578
  //DebugLn('TIDEHelpManager.ShowHelpForMessage B Line=',dbgs(Line),' ',dbgs(MessagesView.VisibleItemCount));
 
1579
  if (Line<0) or (Line>=MessagesView.VisibleItemCount) then exit;
 
1580
  MsgItem:=MessagesView.VisibleItems[Line];
 
1581
  if MsgItem=nil then exit;
 
1582
  if MsgItem.Msg<>'' then begin
 
1583
    MessageParts:=ParseMessage(MsgItem);
 
1584
    ShowHelpOrErrorForMessageLine(MsgItem.Msg,MessageParts);
 
1585
  end;
 
1586
end;
 
1587
 
 
1588
procedure TIDEHelpManager.ShowHelpForObjectInspector(Sender: TObject);
 
1589
var
 
1590
  AnInspector: TObjectInspectorDlg;
 
1591
  Code: TCodeBuffer;
 
1592
  Caret: TPoint;
 
1593
  ErrMsg: string;
 
1594
  NewTopLine: integer;
 
1595
begin
 
1596
  //DebugLn('TIDEHelpManager.ShowHelpForObjectInspector ',dbgsName(Sender));
 
1597
  if Sender=nil then Sender:=ObjectInspector1;
 
1598
  if Sender is TObjectInspectorDlg then begin
 
1599
    AnInspector:=TObjectInspectorDlg(Sender);
 
1600
    if AnInspector.GetActivePropertyRow<>nil then begin
 
1601
      if FindDeclarationOfOIProperty(AnInspector,nil,Code,Caret,NewTopLine) then
 
1602
      begin
 
1603
        if NewTopLine=0 then ;
 
1604
        ShowHelpForSourcePosition(Code.Filename,Caret,ErrMsg);
 
1605
      end;
 
1606
    end else begin
 
1607
      DebugLn('TIDEHelpManager.ShowHelpForObjectInspector show default help for OI');
 
1608
      ShowHelpForIDEControl(AnInspector);
 
1609
    end;
 
1610
  end;
 
1611
end;
 
1612
 
 
1613
procedure TIDEHelpManager.ShowHelpForIDEControl(Sender: TControl);
 
1614
begin
 
1615
  LoadIDEWindowHelp;
 
1616
  IDEWindowHelpNodes.InvokeHelp(Sender);
 
1617
end;
 
1618
 
 
1619
function TIDEHelpManager.CreateHint(aHintWindow: THintWindow; ScreenPos: TPoint;
 
1620
  const BaseURL: string; var TheHint: string; out HintWinRect: TRect): boolean;
 
1621
var
 
1622
  IsHTML: Boolean;
 
1623
  Provider: TAbstractIDEHTMLProvider;
 
1624
  HTMLControl: TControl;
 
1625
  ms: TMemoryStream;
 
1626
  NewWidth, NewHeight: integer;
 
1627
begin
 
1628
  IsHTML:=SysUtils.CompareText(copy(TheHint,1,6),'<HTML>')=0;
 
1629
 
 
1630
  if aHintWindow.ControlCount>0 then begin
 
1631
    aHintWindow.Controls[0].Free;
 
1632
  end;
 
1633
  if IsHTML then begin
 
1634
    Provider:=nil;
 
1635
    HTMLControl:=CreateIDEHTMLControl(aHintWindow,Provider, [ihcWithClipboardMenu]);
 
1636
    Provider.BaseURL:=BaseURL;
 
1637
    HTMLControl.Parent:=aHintWindow;
 
1638
    HTMLControl.Align:=alClient;
 
1639
    ms:=TMemoryStream.Create;
 
1640
    try
 
1641
      if TheHint<>'' then
 
1642
        ms.Write(TheHint[1],length(TheHint));
 
1643
      ms.Position:=0;
 
1644
      Provider.ControlIntf.SetHTMLContent(ms,'');
 
1645
    finally
 
1646
      ms.Free;
 
1647
    end;
 
1648
    Provider.ControlIntf.GetPreferredControlSize(NewWidth,NewHeight);
 
1649
 
 
1650
    if NewWidth <= 0 then
 
1651
      NewWidth := 500
 
1652
    else
 
1653
      inc(NewWidth, 8); // border
 
1654
 
 
1655
    if NewHeight <= 0 then
 
1656
      NewHeight := 200
 
1657
    else
 
1658
      inc(NewHeight, 8); // border
 
1659
 
 
1660
    HintWinRect := Rect(0, 0, NewWidth, NewHeight);
 
1661
    TheHint:='';
 
1662
  end else begin
 
1663
    HintWinRect := aHintWindow.CalcHintRect(Screen.Width, TheHint, nil);
 
1664
  end;
 
1665
  OffsetRect(HintWinRect, ScreenPos.X, ScreenPos.Y+30);
 
1666
 
 
1667
  Result:=true;
 
1668
end;
 
1669
 
 
1670
function TIDEHelpManager.GetHintForSourcePosition(
 
1671
  const ExpandedFilename: string; const CodePos: TPoint; out BaseURL,
 
1672
  HTMLHint: string; Flags: TIDEHelpManagerCreateHintFlags): TShowHelpResult;
 
1673
var
 
1674
  Code: TCodeBuffer;
 
1675
  CacheWasUsed: boolean;
 
1676
  HintFlags: TCodeHelpHintOptions;
 
1677
begin
 
1678
  BaseURL:='';
 
1679
  HTMLHint:='';
 
1680
  Code:=CodeToolBoss.LoadFile(ExpandedFilename,true,false);
 
1681
  if (Code=nil) or Code.LineColIsSpace(CodePos.Y,CodePos.X) then
 
1682
    exit(shrHelpNotFound);
 
1683
  HintFlags:=[chhoDeclarationHeader];
 
1684
  if ihmchAddFocusHint in Flags then
 
1685
    Include(HintFlags,chhoShowFocusHint);
 
1686
  if CodeHelpBoss.GetHTMLHint(Code,CodePos.X,CodePos.Y,
 
1687
    HintFlags,BaseURL,HTMLHint,CacheWasUsed)=chprSuccess
 
1688
  then
 
1689
    exit(shrSuccess);
 
1690
  Result:=shrHelpNotFound;
 
1691
end;
 
1692
 
 
1693
function TIDEHelpManager.ConvertSourcePosToPascalHelpContext(
 
1694
  const CaretPos: TPoint; const Filename: string): TPascalHelpContextList;
 
1695
var
 
1696
  CodePos: TCodeXYPosition;
 
1697
  Code: TCodeBuffer;
 
1698
  ACodeTool: TCodeTool;
 
1699
begin
 
1700
  Result:=nil;
 
1701
  Code:=CodeToolBoss.FindFile(Filename);
 
1702
  if Code=nil then exit;
 
1703
  CodePos.Code:=Code;
 
1704
  CodePos.X:=CaretPos.X;
 
1705
  CodePos.Y:=CaretPos.Y;
 
1706
  if not CodeToolBoss.Explore(Code,ACodeTool,false) then exit;
 
1707
  if ACodeTool=nil then ;
 
1708
  Result:=ConvertCodePosToPascalHelpContext(@CodePos);
 
1709
end;
 
1710
 
 
1711
end.
 
1712