1 {
2   Graphical CHM help content provider.
3   Responsible for loading TOC, providing search etc.
4 }
5 
6 unit ChmContentProvider;
7 
8 {$mode objfpc}{$H+}
9 
10 {$Note Compiling lhelp with search support}
11 {$DEFINE CHM_SEARCH}
12 
13 {$IF FPC_FULLVERSION>=20400}
14 {$Note Compiling lhelp *with* binary index and toc support}
15 // CHMs can have both binary and text Table of Contents and index
16 {$DEFINE CHM_BINARY_INDEX_TOC}    // internal chm index else external file`s indexes
17 {$endif}
18 
19 {off $DEFINE CHM_DEBUG_TIME}
20 
21 interface
22 
23 uses
24   Classes, SysUtils, ChmReader,
25   // LCL
26   LCLIntf, Forms, StdCtrls, ExtCtrls, ComCtrls, Controls, Menus,
27   // LazUtils
28   LazFileUtils, LazStringUtils, LazUTF8, Laz2_XMLCfg, LazLoggerBase,
29   // Turbopower IPro
30   IpHtml,
31   // ChmHelp
32   BaseContentProvider, FileContentProvider, ChmDataProvider, lhelpstrconsts;
33 
34 const
35   DefaultCHMContentTitle = '[unknown]';
36 
37 type
38 
39   TAsyncIndexData = record
40     CHMReader: TChmReader;
41     isUpdate: Boolean;
42   end;
43   PTAsyncIndexData = ^TAsyncIndexData;
44 
45   TAsyncUri = record
46     CHMReader: TChmReader;
47     Uri: String;
48   end;
49   PTAsyncUri = ^TAsyncUri;
50 
51   { TChmContentProvider }
52 
53   TChmContentProvider = class(TFileContentProvider)
54   private
55     fUpdateURI: String; // last request
56     fLastURI: String;   // last showed
57     fTabsControl: TPageControl;
58       fContentsTab: TTabSheet;
59        fContentsPanel: TPanel;
60          fContentsTree: TTreeView;
61       fIndexTab: TTabSheet;
62         fIndexEdit: TLabeledEdit;
63         fIndexView: TTreeView;
64       fSearchTab: TTabSheet;
65         fKeywordLabel: TLabel;
66         fKeywordCombo: TComboBox;
67         fSearchBtn: TButton;
68         fResultsLabel: TLabel;
69         fSearchResults: TTreeView;
70     fSplitter: TSplitter;
71     fHtml: TIpHtmlPanel;
72     fPopUp: TPopUpMenu;
73     fStatusBar: TStatusBar;
74     fFillTOCStack: TFPList;
GetShowStatusbarnull75     function GetShowStatusbar: Boolean;
76     procedure SetShowStatusbar(AValue: Boolean);
77     procedure CompareIndexNodes(Sender: TObject; Node1, Node2: TTreeNode;
78                               var Compare: Integer);
79     procedure ProcTreeKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
80     procedure ProcKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
81     procedure ProcTreeKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
82   protected
83     fIsUsingHistory: Boolean;
84     fChms: TChmFileList;
85     fChmDataProvider: TIpChmDataProvider;
86     fHistory: TStringList;
87     fHistoryIndex: Integer;
88     fStopTimer: Boolean;
89     fActiveChmTitle: String;
90     FLoadingSearchURL: Boolean; // use this to try to highlight search terms
91 
MakeURInull92     function  MakeURI(Const AUrl: String; AChm: TChmReader): String;
93 
94     procedure AddHistory(Const URL: String);
95     procedure DoOpenChm(Const AFile: String; ACloseCurrent: Boolean = True);
96     procedure DoLoadContext(Context: THelpContext);
97     procedure DoLoadUri(Uri: String; AChm: TChmReader = nil);
98     procedure DoError({%H-}Error: Integer);
GetChmReadernull99     function  GetChmReader(Const AFile: String): TChmReader;
100     procedure NewChmOpened(ChmFileList: TChmFileList; Index: Integer);
101     // Set to queue LoadUri processing
102     procedure QueueLoadUriAsync(Uri: String; AChm: TChmReader = nil);
103     // Set to queue a filling TOC Index for later processing
104     procedure QueueFillToc(AChm: TChmReader);
105     // Filling TOC and index for the chm file through Async process
106     procedure ProcFillTOC(AData: PtrInt);
107     // LoadURI through Async process
108     procedure ProcLoadUri(UriData: PtrInt);
109     procedure LoadingHTMLStream(var AStream: TStream);
110     procedure IpHtmlPanelDocumentOpen(Sender: TObject);
111     procedure IpHtmlPanelHotChange(Sender: TObject);
112     // text and image resource types
113     procedure IpHtmlPanelHotClick(Sender: TObject);
114     procedure PopupCopyClick(Sender: TObject);
115     procedure PopupCopySourceClick(Sender: TObject);
116 
117     procedure ContentsTreeSelectionChanged(Sender: TObject);
118     procedure TreeViewStopCollapse(Sender: TObject; {%H-}Node: TTreeNode; var AllowCollapse: Boolean);
119     procedure TreeViewShowHint(Sender: TObject; HintInfo: PHintInfo);
120     procedure ViewMenuContentsClick(Sender: TObject);
121     procedure UpdateTitle;
122     procedure SetTitle(const AValue: String); override;
123     procedure SearchEditChange(Sender: TObject);
124     procedure TOCExpand(Sender: TObject; Node: TTreeNode);
125     procedure TOCCollapse(Sender: TObject; Node: TTreeNode);
126     procedure SelectTreeItemFromURL(Const AUrl: String);
127     procedure GetTreeNodeClass(Sender: TCustomTreeView; var NodeClass: TTreeNodeClass);
128     {$IFDEF CHM_SEARCH}
129     procedure SearchButtonClick(Sender: TObject);
130     procedure SearchComboKeyDown(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState);
131     {$ENDIF}
132   public
133     procedure ProcGlobalKeyUp(var {%H-}Key: Word; {%H-}Shift: TShiftState);overload;
134     procedure LoadPreferences(ACfg: TXMLConfig); override;
135     procedure SavePreferences(ACfg: TXMLConfig); override;
136     procedure BeginUpdate; override;
137     procedure EndUpdate; override;
138 
CanGoBacknull139     function CanGoBack: Boolean; override;
CanGoForwardnull140     function CanGoForward: Boolean; override;
GetHistorynull141     function GetHistory: TStrings; override;
LoadURLnull142     function LoadURL(const AURL: String; const AContext: THelpContext=-1): Boolean; override;
HasLoadedDatanull143     function HasLoadedData(const AUrl: String): Boolean; override;
144     procedure GoHome; override;
145     procedure GoBack; override;
146     procedure GoForward; override;
147     procedure ActivateProvider; override;
148     procedure ActivateTOCControl; override;
149     procedure ActivateIndexControl; override;
150     procedure ActivateSearchControl; override;
151     // property
152     property TabsControl: TPageControl read fTabsControl;
153     property Splitter: TSplitter read fSplitter;
154     property ShowStatusbar: Boolean read GetShowStatusbar write SetShowStatusbar;
155 
GetProperContentProvidernull156     class function GetProperContentProvider(const {%H-}AURL: String): TBaseContentProviderClass; override;
157 
158     constructor Create(AParent: TWinControl; AImageList: TImageList; AUpdateCount: Integer); override;
159     destructor Destroy; override;
160   end;
161 
162 implementation
163 
164 uses
165   clipbrd,
166   ChmSpecialParser{$IFDEF CHM_SEARCH}, chmFIftiMain{$ENDIF}, chmsitemap,
167   LCLType, SAX_HTML, Dom, DOM_HTML, HTMWrite, LConvEncoding;
168 
169 type
170 
171   { THTMLWordHighlighter }
172 
173   THTMLWordHighlighter = class
174   private
175     Doc: THTMLDocument;
176     Words: TStrings;
177     Color: String;
178     procedure ScanSubNodes(ADomNode: TDOMNode);
179     procedure CheckTextNode(var ATextNode: TDomNode);
180   public
181     constructor Create(AHTMLDoc: THTMLDocument);
182     procedure HighlightWords(AWords: TStrings; AColor: String);
183   end;
184 
185 { THTMLWordHighlighter }
186 
187 procedure THTMLWordHighlighter.ScanSubNodes(ADomNode: TDOMNode);
188 
189 var
190   CurNode: TDomNode;
191 begin
192   CurNode := ADomNode;
193   while CurNode <> nil do
194   begin
195     if CurNode.HasChildNodes then
196       ScanSubNodes(CurNode.FirstChild);
197 
198     if CurNode.NodeType = TEXT_NODE then
199       CheckTextNode(CurNode);
200 
201     CurNode := CurNode.NextSibling;
202   end;
203 end;
204 
205 procedure THTMLWordHighlighter.CheckTextNode(var ATextNode: TDomNode);
206 var
207   i, xPos: Integer;
208   WordStart, After: TDOMText;
209   Span: TDomElement;
210   aWord: DOMString;
211   Parent: TDomNode;
212 begin
213    Parent := AtextNode.ParentNode;
214    for i := 0 to Words.Count-1 do
215    begin
216      aWord := LowerCase(DOMString(Words[i]));
217      xPos := Pos(aWord, LowerCase(ATextNode.TextContent));
218      while xpos > 0 do
219      begin
220        WordStart:= TDOMText(ATextNode).SplitText(xPos-1);
221        After := WordStart.SplitText(Length(aWord));
222        Span := doc.CreateElement('span');
223        // TODO: lHtml don`t perceive background color :(
224        Span.SetAttribute('style', DOMString('color:' + Color +
225                         ';font-weight:bold;background:lightgray;padding:3px;'));
226        Parent.InsertBefore(Span, After);
227        Span.AppendChild(WordStart);
228 
229        // or we'll keep finding our new node again and again
230        ATextNode := After;
231 
232        xPos := Pos(aWord, LowerCase(ATextNode.TextContent));
233      end;
234    end;
235 end;
236 
237 constructor THTMLWordHighlighter.Create(AHTMLDoc: THTMLDocument);
238 begin
239   Doc := AHTMLDoc;
240 end;
241 
242 procedure THTMLWordHighlighter.HighlightWords(AWords: TStrings; AColor: String);
243 var
244   Elem: TDOMNode;
245 begin
246   Words := AWords;
247   Color := AColor;
248   Elem := Doc.DocumentElement.FirstChild;
249 
250   ScanSubNodes(Elem);
251 
252 end;
253 
254 function ChmURI(Const AUrl: String; Const AFileName: String): String;
255 var
256   FileNameNoPath: String;
257 begin
258   Result := AUrl;
259   if Pos('ms-its:', Result) > 0 then
260     Exit;
261   FileNameNoPath := ExtractFileName(AFileName);
262   Result := 'ms-its:'+FileNameNoPath+'::'+AUrl;
263 end;
264 
265 { TChmContentProvider }
266 
GetShowStatusbarnull267 function TChmContentProvider.GetShowStatusbar: Boolean;
268 begin
269   Result := fStatusbar.Visible;
270 end;
271 
272 procedure TChmContentProvider.SetShowStatusbar(AValue: Boolean);
273 begin
274   fStatusbar.Visible := AValue;
275 end;
276 
277 procedure TChmContentProvider.CompareIndexNodes(Sender: TObject; Node1,
278   Node2: TTreeNode; var Compare: Integer);
279 begin
280   Compare:= UTF8CompareLatinTextFast(Node1.Text, Node2.Text);
281 end;
282 
283 procedure TChmContentProvider.ProcTreeKeyDown(Sender: TObject; var Key: Word;
284   Shift: TShiftState);
285 begin
286   if  Sender is TTreeView then
287   begin
288     if (Key = VK_RETURN) and (Shift = []) then
289     begin
290       ContentsTreeSelectionChanged(Sender);
291       key:= 0;
292     end
293   end;
294   if ((Sender is TTreeView) or (Sender is TIpHtmlPanel)) and (Shift = [ssAlt]) then
295   case Key of
296     VK_Left: begin
297       GoBack; key:= 0;
298     end;
299     VK_RIGHT: begin
300       GoForward; key:= 0;
301     end;
302     VK_Home: begin
303       GoHome; key:= 0;
304     end;
305   end;
306 end;
307 
308 procedure TChmContentProvider.ProcKeyDown(Sender: TObject; var Key: Word;
309   Shift: TShiftState);
310 begin
311   if (Shift <> []) then Exit;
312   if (Sender is TLabeledEdit) and (Sender = fIndexEdit) then
313   begin
314     if ((Key = VK_DOWN) and ( fIndexView.Items.Count >0 )) then
315     begin
316       fIndexView.SetFocus();
317       if (fIndexView.Selected = nil) then
318       begin
319         fIndexView.Items.GetFirstNode().MakeVisible;
320         fIndexView.Items.GetFirstNode().Selected:=True;
321       end;
322       Key:= 0;
323     end;
324   end;
325 end;
326 
327 procedure TChmContentProvider.ProcTreeKeyUp(Sender: TObject; var Key: Word;
328   Shift: TShiftState);
329 begin
330   if Sender is TTreeView then
331   begin
332     if ((Key = VK_DOWN) or (Key = VK_UP)) and (Shift = []) then
333     begin
334       ContentsTreeSelectionChanged(Sender);
335       Key:= 0;
336     end;
337   end;
338 end;
339 
MakeURInull340 function TChmContentProvider.MakeURI ( const AUrl: String; AChm: TChmReader
341   ) : String;
342 var
343   ChmIndex: Integer;
344 begin
345   ChmIndex := fChms.IndexOfObject(AChm);
346   Result := ChmURI(AUrl, fChms.FileName[ChmIndex]);
347 end;
348 
349 procedure TChmContentProvider.BeginUpdate;
350 begin
351   if not isUpdate then
352   begin
353     fContentsTree.BeginUpdate;
354     fIndexView.BeginUpdate;
355   end;
356   inherited BeginUpdate;
357 end;
358 
359 procedure TChmContentProvider.EndUpdate;
360 begin
361   inherited EndUpdate;
362   if not isUpdate then
363   begin
364     fContentsTree.EndUpdate;
365     fIndexView.EndUpdate;
366     fContentsPanel.Caption := '';
367     fContentsTree.Visible := True;
368     UpdateTitle;
369   end;
370 end;
371 
372 procedure TChmContentProvider.AddHistory ( const URL: String ) ;
373 begin
374   if fHistoryIndex < fHistory.Count then
375   begin
376     while fHistory.Count-1 > fHistoryIndex do
377       fHistory.Delete(fHistory.Count-1);
378   end;
379 
380   fHistory.Add(URL);
381   Inc(fHistoryIndex);
382 end;
383 
384 procedure TChmContentProvider.DoOpenChm ( const AFile: String;
385   ACloseCurrent: Boolean ) ;
386 begin
387   fChmDataProvider.DoOpenChm(AFile, ACloseCurrent);
388  //DebugLn('CHP DoOpenChm() Chm file: ', AFile);
389   fHistoryIndex := -1;
390   fHistory.Clear;
391 
392   // Code here has been moved to the OpenFile handler
393 end;
394 
395 procedure TChmContentProvider.DoLoadContext(Context: THelpContext);
396 var
397  Str: String;
398 begin
399   if fChms = nil then exit;
400   Str := fChms.Chm[0].GetContextUrl(Context);
401   if Str <> '' then DoLoadUri(Str, fChms.Chm[0]);
402 end;
403 
404 procedure TChmContentProvider.QueueLoadUriAsync(Uri: String; AChm: TChmReader = nil);
405 var
406   AUriData:PTAsyncUri;
407 begin
408   // https://www.freepascal.org/docs-html/rtl/system/initialize.html
409   {$IFDEF DEBUGASYNC}
410   DebugLn('CHP QueueLoadUriAsync() URI: ', Uri);
411   {$ENDIF}
412   GetMem(AUriData,SizeOf(TAsyncUri));
413   Initialize(AUriData^);
414   AUriData^.CHMReader:= AChm;
415   AUriData^.Uri:= Uri;
416   Application.ProcessMessages;
417   Application.QueueAsyncCall(@ProcLoadUri, PtrInt(AUriData));
418 end;
419 
420 procedure TChmContentProvider.DoLoadUri(Uri: String; AChm: TChmReader = nil);
421 var
422   ChmIndex: Integer;
423   NewUrl: String;
424   FilteredURL: String;
425   xPos: Integer;
426   StartTime: TDateTime;
427   EndTime: TDateTime;
428   Time: String;
429 begin
430   if (fChms = nil) and (AChm = nil) then exit;
431   fStatusBar.SimpleText := Format(slhelp_Loading, [Uri]);
432 
433   StartTime := Now;
434 
435   xPos := Pos('#', Uri);
436   if xPos > 0 then
437     FilteredURL := Copy(Uri, 1, xPos -1)
438   else
439     FilteredURL := Uri;
440   {$IFDEF LDEBUG}
441   DebugLn('CHP DoLoadUri() LastURI: '+ fLastURI);
442   {$ENDIF}
443   if fChms.ObjectExists(FilteredURL, AChm) = 0 then
444   begin
445     fStatusBar.SimpleText := Format(slhelp_NotFound, [URI]);
446     {$IFDEF LDEBUG}
447     DebugLn('CHP ERR Chm object is not found - URI: '+ Uri);
448     {$ENDIF}
449     Exit;
450   end;
451   if (Pos('ms-its', Uri) = 0) and (AChm <> nil) then
452   begin
453     ChmIndex := fChms.IndexOfObject(AChm);
454     NewUrl := ExtractFileName(fChms.FileName[ChmIndex]);
455     NewUrl := 'ms-its:'+NewUrl+'::/'+Uri;
456     Uri := NewUrl;
457   end;
458   Application.ProcessMessages;
459   // Already showed
460 
461   if fLastURI = Uri then Exit;
462 
463   if not isUpdate then
464   begin
465 
466     fIsUsingHistory := True;
467     fChmDataProvider.CurrentPath := ExtractFileDir(URI)+'/';
468     {$IFDEF LDEBUG}
469     DebugLn('CHP OpenURL URI: '+ Uri);
470     {$ENDIF}
471     fHtml.BeginUpdateBounds;
472     fLastURI:= ''; // TODO: for check it
473     fHtml.OpenURL(Uri);
474     fUpdateURI:= '';
475     fHtml.EndUpdateBounds;
476     if Assigned(OnContentComplete) then
477       OnContentComplete(Self);
478 
479     AddHistory(Uri);
480     EndTime := Now;
481 
482     Time := INtToStr(DateTimeToTimeStamp(EndTime).Time - DateTimeToTimeStamp(StartTime).Time);
483     fStatusBar.SimpleText := Format(slhelp_LoadedInMs, [Uri, Time]);
484 
485   end
486   else if isUpdateLast then
487   begin
488     // Do nothing, save URI and use Show for execute request
489     fUpdateURI:= Uri;
490     // Used to async load URL before enable of Updating
491     // QueueLoadUriAsync(Uri, AChm);
492     {$IFDEF UPDATE_CNT}
493     DebugLn('Lastupdate URI: '+ Uri);
494     {$ENDIF}
495   end;
496 
497 end;
498 
499 procedure TChmContentProvider.ProcLoadUri(UriData: PtrInt);
500 var
501   AUriData: PTAsyncUri;
502 begin
503   AUriData:= PTAsyncUri(UriData);
504   {$IFDEF DEBUGASYNC}
505   DebugLn('CHP ProcLoadUri() URI: ', AUriData^.Uri);
506   {$ENDIF}
507   fHtml.BeginUpdateBounds;
508   fHtml.OpenURL(AUriData^.Uri);
509   fHtml.EndUpdateBounds;
510   Finalize(AUriData^);
511   FreeMem(AUriData);
512 end;
513 
514 
515 procedure TChmContentProvider.DoError(Error: Integer);
516 begin
517   //what to do with these errors?
518   //INVALID_FILE_TYPE;
519 end;
520 
GetChmReadernull521 function TChmContentProvider.GetChmReader ( const AFile: String ) : TChmReader;
522 var
523   FileIndex : Integer;
524 begin
525   Result := nil;
526   if fChms = nil then Exit;
527   FileIndex := fChms.IndexOf(AFile);
528   if (fChms <> nil) and (FileIndex >= 0) then
529     Result := fChms.Chm[fChms.IndexOf(AFile)];
530 end;
531 
532 procedure TChmContentProvider.NewChmOpened(ChmFileList: TChmFileList;
533   Index: Integer);
534 begin
535   if ChmFileList.Chm[Index].Title = '' then
536     ChmFileList.Chm[Index].Title := ExtractFileName(ChmFileList.FileName[Index]);
537 
538   // Fill the table of contents.
539   QueueFillToc(ChmFileList.Chm[Index]);
540 end;
541 
542 procedure TChmContentProvider.LoadingHTMLStream(var AStream: TStream);
543 var
544   Doc: THTMLDocument;
545   NewStream: TMemoryStream;
546   Highlighter: THTMLWordHighlighter;
547   Words: TStringList;
548   UseOrigStream: Boolean;
549 begin
550   if not FLoadingSearchURL then
551     Exit;
552   // load html and add tags to highlight words then save back to stream
553   NewStream := TMemoryStream.Create;
554 
555   Words := TStringList.Create;
556   Words.Delimiter:=' ';
557   Words.DelimitedText:=fKeywordCombo.Text;
558 
559   Doc:=nil;
560   try
561     UseOrigStream := True;
562     ReadHTMLFile(Doc, AStream);
563     Highlighter := THTMLWordHighlighter.Create(Doc);
564     Highlighter.HighlightWords(Words, 'red');
565     WriteHTMLFile(Doc, NewStream);
566     UseOrigStream := False;
567   finally
568     try
569       Doc.Free;
570       Highlighter.Free;
571     except
572       UseOrigStream := True;
573     end;
574   end;
575 
576   Words.Free;
577 
578   if not UseOrigStream then
579   begin
580     AStream.Free;
581     AStream := NewStream;
582     NewStream.Position:=0;
583   end
584   else
585     NewStream.Free;
586 
587   AStream.Position := 0;
588 end;
589 
590 procedure TChmContentProvider.QueueFillToc(AChm: TChmReader);
591 var
592   AData:PTAsyncIndexData;
593 begin
594   fContentsTree.Visible := False;
595   fContentsPanel.Caption := slhelp_TableOfContentsLoadingPleaseWait;
596   fStatusBar.SimpleText := slhelp_TableOfContentsLoading;
597 
598   AData:= New(PTAsyncIndexData);
599   AData^.CHMReader:= AChm;
600   AData^.isUpdate:= self.isUpdate; // save state for Async process
601 
602   Application.ProcessMessages;
603   Application.QueueAsyncCall(@ProcFillTOC, PtrInt(AData));
604 end;
605 
606 procedure TChmContentProvider.ProcFillTOC(AData: PtrInt);
607 var
608   CHMReader: TChmReader;
609   ParentNode: TTreeNode;
610   i: Integer;
611   StackIdx: Integer;
612   SM: TChmSiteMap;
613   HasSearchIndex: Boolean = False;
614   {$IFNDEF CHM_BINARY_INDEX_TOC}
615   Stream: TMemoryStream;
616   {$ENDIF}
617 begin
618   SM := nil;
619   CHMReader := PTAsyncIndexData(AData)^.CHMReader;
620   try
621     BeginUpdate;
622     StackIdx := fFillTOCStack.IndexOf(CHMReader);
623     if StackIdx > 0 then Exit;
624 
625     fFillTOCStack.Add(CHMReader);
626     {$IFDEF CHM_DEBUG_TIME}
627     DebugLn('CHT CHM Title: '+CHMReader.Title);
628     DebugLn('CHT Start of load: ',FormatDateTime('hh:nn:ss.zzz', Now));
629     {$ENDIF}
630     if CHMReader <> nil then
631     begin
632       ParentNode := fContentsTree.Items.AddChildObject(nil, CHMReader.Title, CHMReader);
633       ParentNode.ImageIndex := 0;
634       ParentNode.SelectedIndex := 0;
635       {$IFDEF CHM_BINARY_INDEX_TOC}
636       // GetTOCSitemap first tries binary TOC but falls back to text if needed
637       {$IFDEF CHM_DEBUG_INDEX}
638       DebugLn('CHP GetTOCSitemap: ',FormatDateTime('hh:nn:ss.zzz', Now));
639       {$ENDIF}
640       {$IFDEF CHM_DEBUG_TIME}
641       DebugLn('CHT Load of TOC start: ',FormatDateTime('hh:nn:ss.zzz', Now));
642       {$ENDIF}
643       SM := CHMReader.GetTOCSitemap;
644       {$ELSE}
645       SM := nil;
646       fFillingIndex := True;
647       Stream := TMemoryStream(fChms.GetObject(fChms.TOCFile));
648       if Stream <> nil then
649       begin
650         SM := TChmSiteMap.Create(stTOC);
651         SM.LoadFromStream(Stream);
652         Stream.Free;
653       end;
654       {$ENDIF}
655       if SM <> nil then
656       begin
657         with TContentsFiller.Create(fContentsTree, SM, @fStopTimer, CHMReader) do
658         try
659           DoFill(ParentNode, false);
660         finally
661           Free;
662         end;
663         FreeAndNil(SM);
664       end;
665       if Assigned(ParentNode) and (ParentNode.Index = 0) then ParentNode.Expanded := True;
666       {$IFDEF CHM_DEBUG_TIME}
667       DebugLn('CHT Load of TOC end: ',FormatDateTime('hh:nn:ss.zzz', Now));
668       {$ENDIF}
669 
670       // Now we fill the index for all files
671       {$IFDEF CHM_DEBUG_TIME}
672       DebugLn('CHT oad of INDEX start: ',FormatDateTime('hh:nn:ss.zzz', Now));
673       {$ENDIF}
674       {$IFDEF CHM_BINARY_INDEX_TOC}
675       SM := CHMReader.GetIndexSitemap;
676       {$ELSE}
677       SM := nil;
678       Stream := TMemoryStream(fChms.GetObject(fChms.IndexFile));
679       if Stream <> nil then
680       begin
681         SM := TChmSiteMap.Create(stTOC);
682         SM.LoadFromStream(Stream);
683         Stream.Free;
684       end;
685       {$ENDIF}
686       if SM <> nil then
687       begin
688         fStatusBar.SimpleText := slhelp_IndexLoading;
689         {$IFDEF CHM_DEBUG_TIME}
690         DebugLn('CHT Load of INDEX start: ',FormatDateTime('hh:nn:ss.zzz', Now));
691         {$ENDIF}
692         with TContentsFiller.Create(fIndexView, SM, @fStopTimer, CHMReader) do
693         try
694           DoFill(nil, false);
695           if fChms.Count > 1 then // FpDoc have to sort an INDEX
696             fIndexView.Items.SortTopLevelNodes(@fIndexView.DefaultTreeViewSort);
697         finally
698           Free;
699         end;
700         FreeAndNil(SM);
701         {$IFDEF CHM_DEBUG_TIME}
702         DebugLn('CHT Load of INDEX end: ',FormatDateTime('hh:nn:ss.zzz', Now));
703         {$ENDIF}
704         fIndexView.FullExpand;
705       end;
706       {$IFDEF CHM_DEBUG_TIME}
707       DebugLn('CHT end of load: ',FormatDateTime('hh:nn:ss.zzz', Now));
708       {$ENDIF}
709     end;
710 
711     {$IFDEF CHM_DEBUG_TIME}
712     DebugLn('CHT CHM Title: '+CHMReader.Title);
713     DebugLn('CHT End: ',FormatDateTime('hh:nn:ss.zzz', Now));
714     {$ENDIF}
715 
716     fContentsTab.TabVisible := fContentsTree.Items.Count > 0;
717     fIndexTab.TabVisible := fIndexTab.TabVisible or (fIndexView.Items.Count > 0);
718     fStatusBar.SimpleText:= '';
719 
720     {$IFDEF CHM_SEARCH}
721     i := 0;
722     while (HasSearchIndex = False) and (i < fChms.Count) do
723     begin
724       // Look for binary full text search index in CHM file
725       HasSearchIndex := fChms.Chm[i].ObjectExists('/$FIftiMain') > 0;
726       inc(i);
727     end;
728     fSearchTab.TabVisible := fSearchTab.TabVisible or HasSearchIndex;
729     {$ENDIF}
730 
731     if Title=DefaultCHMContentTitle then
732       UpdateTitle;
733     fFillTOCStack.Remove(CHMReader);
734   finally
735     Dispose(PTAsyncIndexData(AData));
736     EndUpdate;
737   end;
738 end;
739 
740 procedure TChmContentProvider.IpHtmlPanelDocumentOpen(Sender: TObject);
741 begin
742   if fIsUsingHistory = False then
743     AddHistory(fChmDataProvider.CurrentPage)
744   else
745     fIsUsingHistory := False;
746   fLastURI:= fChmDataProvider.CurrentPage;
747   SelectTreeItemFromURL(fLastURI);
748   // Debugln('CHP Ev IpHtmlPanelDocumentOpen() URL: '+fLastURI);
749 end;
750 
751 procedure TChmContentProvider.IpHtmlPanelHotChange(Sender: TObject);
752 begin
753   fStatusBar.SimpleText := fHtml.HotURL;
754 end;
755 
756 procedure TChmContentProvider.IpHtmlPanelHotClick(Sender: TObject);
757 var
758   HelpFile: String;
759   aPos: integer;
760 begin
761   // chm-links look like: mk:@MSITStore:D:\LazPortable\docs\chm\iPro.chm::/html/lh3zs3.htm
762   if LazStartsText('javascript:helppopup(''', fHtml.HotURL) or
763      LazStartsText('javascript:popuplink(''', fHtml.HotURL)
764   then begin
765     HelpFile := Copy(fHtml.HotURL, 23, Length(fHtml.HotURL) - (23-1));
766     HelpFile := Copy(HelpFile, 1, Pos('''', HelpFile)-1);
767 
768     if (Pos('/',HelpFile)=0) and (Pos('.chm:',HelpFile)=0) then begin //looks like?: 'xyz.htm'
769       aPos := LastDelimiter('/', fHtml.CurURL);
770       if aPos>0 then HelpFile := Copy(fHtml.CurURL,1,aPos) + HelpFile;
771    end
772    else if (Pos('.chm:',HelpFile)=0) then begin //looks like?: 'folder/xyz.htm' or '/folder/xyz.htm'
773      if HelpFile[1]<>'/' then HelpFile:='/'+HelpFile;
774      aPos := LastDelimiter(':', fHtml.CurURL);
775      if aPos>0 then HelpFile := Copy(fHtml.CurURL,1,aPos) + HelpFile;
776    end;
777    DoLoadUri(HelpFile); //open it in current iphtmlpanel.
778   end
779   else
780    OpenURL(fHtml.HotURL);
781 end;
782 
783 procedure TChmContentProvider.PopupCopyClick(Sender: TObject);
784 begin
785   fHtml.CopyToClipboard;
786 end;
787 
788 procedure TChmContentProvider.PopupCopySourceClick(Sender: TObject);
789 var
790   rbs: rawbytestring;
791   s: String;
792 begin
793   rbs := fChmDataProvider.GetHtmlText(fHtml.CurUrl);
794   s := ConvertEncoding(rbs, fHtml.MasterFrame.Html.DocCharset, encodingUTF8);
795   Clipboard.SetAsHtml(rbs, s);
796 end;
797 
798 procedure TChmContentProvider.ContentsTreeSelectionChanged(Sender: TObject);
799 var
800   ATreeNode: TContentTreeNode;
801   ARootNode: TTreeNode;
802   fChm: TChmReader = nil;
803   ActiveTreeView: TTreeView;
804   Uri: String;
805 begin
806   // Check Active TreeView
807   ActiveTreeView:= nil;
808   if fTabsControl.ActivePage = fContentsTab then ActiveTreeView:= fContentsTree;
809   if fTabsControl.ActivePage = fIndexTab then ActiveTreeView:= fIndexView;
810   if fTabsControl.ActivePage = fSearchTab then ActiveTreeView:= fSearchResults;
811 
812   if not (Assigned(ActiveTreeView) and Assigned(ActiveTreeView.Selected)) then Exit;
813   // Load root pagefor TOC treeView
814   if (ActiveTreeView = fContentsTree) and (ActiveTreeView.Selected.Parent = nil) then
815   begin
816     fChm := TChmReader(ActiveTreeView.Selected.Data);
817     fActiveChmTitle:= fChm.Title;
818     //UpdateTitle;
819     if fChm.DefaultPage <> '' then
820     begin
821       Uri := MakeURI(fChm.DefaultPage, fChm);
822 {$IFDEF TREE_DEBUG}
823       WriteLn('CHTR ContentTree changed1 URI: ', URI);
824 {$ENDIF}
825       if ((fHtml.MasterFrame <> nil) and (MakeURI(fHtml.CurURL, fChm)  = Uri)) = False then
826       begin
827         ActiveTreeView.Tag:=1; // status of request from treeview
828         DoLoadUri(Uri);
829         ActiveTreeView.Tag:=0;
830       end;
831     end;
832     Exit;
833   end;
834 
835   ATreeNode := TContentTreeNode(ActiveTreeView.Selected);
836 
837   ArootNode:= ATreeNode;
838   fChm := TChmReader(ARootNode.Data);
839     if ATreeNode.Url <> '' then
840     begin
841       Uri := MakeURI(ATreeNode.Url, fChm);
842 {$IFDEF TREE_DEBUG}
843       WriteLn('CHTR ContentTree changed1 URI: ', URI);
844 {$ENDIF}
845       if ((fHtml.MasterFrame <> nil) and (MakeURI(fHtml.CurURL, fChm)  = Uri)) = False then
846       begin
847         if ActiveTreeView = fSearchResults then  FLoadingSearchURL:= True;
848         ActiveTreeView.Tag:=1; // status of request from treeview
849         DoLoadUri(MakeURI(ATreeNode.Url, fChm));
850         ActiveTreeView.Tag:=0;
851         if ActiveTreeView = fSearchResults then  FLoadingSearchURL:= False;
852       end;
853     end;
854 end;
855 
856 procedure TChmContentProvider.TreeViewStopCollapse(Sender: TObject;
857   Node: TTreeNode; var AllowCollapse: Boolean);
858 begin
859   AllowCollapse:=False;
860 end;
861 
862 procedure TChmContentProvider.TreeViewShowHint ( Sender: TObject;
863   HintInfo: PHintInfo ) ;
864 var
865   Node: TContentTreeNode;
866 begin
867   if HintInfo^.HintControl is TTreeView then
868   begin
869     Node:= TContentTreeNode(TTreeView(HintInfo^.HintControl).Selected);
870     if Assigned(Node) and PtInRect(Node.DisplayRect(True), HintInfo^.CursorPos) then
871         HintInfo^.HintStr:= MakeURI(Node.Url, TChmReader(Node.Data));
872   end;
873 end;
874 
875 procedure TChmContentProvider.ViewMenuContentsClick(Sender: TObject);
876 begin
877   //TMenuItem(Sender).Checked := not TMenuItem(Sender).Checked;
878   //fSplitter.Visible := TMenuItem(Sender).Checked;
879   //TabPanel.Visible := Splitter1.Visible;
880 end;
881 
882 procedure TChmContentProvider.UpdateTitle;
883 var
884   Item: TTreeNode;
885   NewTitle: String;
886 begin
887   Item:=nil;
888   if fContentsTree.Items.Count > 0 then
889     Item := fContentsTree.Items.GetFirstNode;
890   NewTitle := '';
891   while (Item <> nil) do
892   begin
893     if Item.Text <> fActiveChmTitle then
894     begin
895       NewTitle:=NewTitle+Item.Text;
896       if (Item.GetNextSibling <> nil)
897       and ((Item.GetNextSibling.GetNextSibling <> nil) or (Item.GetNextSibling.Text <>  fActiveChmTitle))
898       then
899         NewTitle:=NewTitle+', ';
900     end;
901     Item := Item.GetNextSibling;
902   end;
903   if NewTitle <> '' then
904     NewTitle := FActiveChmTitle + ' [' + NewTitle + ']'
905   else
906     NewTitle := FActiveChmTitle;
907   if NewTitle = '' then NewTitle := DefaultCHMContentTitle;
908   Title := NewTitle;
909 end;
910 
911 procedure TChmContentProvider.SetTitle(const AValue: String);
912 begin
913   if (fHtml = nil) or (fHtml.Parent = nil) then exit;
914   TTabSheet(fHtml.Parent).Caption := AValue;
915   inherited SetTitle(AValue);
916 end;
917 
918 procedure TChmContentProvider.SearchEditChange(Sender: TObject);
919 var
920   SearchText: String;
921   Node: TTreeNode;
922 begin
923   if fIndexEdit <> Sender then
924     Exit;
925   SearchText := fIndexEdit.Text;
926   Node := fIndexView.Items.GetFirstNode;
927   while Node<>nil do
928   begin
929     if LazStartsText(SearchText, Node.Text) then
930     begin
931       fIndexView.Items.GetLastNode.MakeVisible;
932       Node.MakeVisible;
933       Node.Selected:=True;
934       //DebugLn('Search edit exit: %s', [SearchText]);
935       Exit;
936     end;
937     Node := Node.GetNextSibling;
938   end;
939 end;
940 
941 procedure TChmContentProvider.TOCExpand(Sender: TObject; Node: TTreeNode);
942 begin
943   if Node.Parent <> nil then
944   begin
945     Node.ImageIndex := 2;
946     Node.SelectedIndex := 2;
947   end;
948 end;
949 
950 procedure TChmContentProvider.TOCCollapse(Sender: TObject; Node: TTreeNode) ;
951 begin
952   if Node.Parent <> nil then
953   begin
954     Node.ImageIndex := 1;
955     Node.SelectedIndex := 1;
956   end;
957 end;
958 
959 procedure TChmContentProvider.SelectTreeItemFromURL ( const AUrl: String ) ;
960 var
961   FileName: String;
962   URL: String;
963   RootNode,
964   FoundNode,
965   Node: TTreeNode;
966   TmpHolder: TNotifyEvent;
967   i: integer;
968 begin
969   RootNode:= nil;
970   if fContentsTree.Tag = 1 then
971     Exit; // the change was a response to a click and should be ignored
972   {$IFDEF LDEBUG}
973   WriteLn('CHP >> SelectTreeItemFromURL()');
974   DebugLn('Input AUrl: '+Aurl);
975   {$ENDIF}
976   FileName := GetURIFileName(AUrl);
977   URL      := GetURIURL(AUrl);
978   {$IFDEF LDEBUG}
979   DebugLn('CHP Get Url: '+Url + ' Into filename: '+FileName);
980   {$ENDIF}
981   FoundNode := nil;
982   Node := nil;
983   for i := 0 to fChms.Count-1 do
984   begin
985     if FileName = ExtractFileName(fChms.FileName[i]) then
986     begin
987       fActiveChmTitle:= fChms.Chm[i].Title;
988       //UpdateTitle;
989 
990       RootNode := fContentsTree.Items.FindNodeWithData(fChms.Chm[i]);
991       if URL = fChms.Chm[i].DefaultPage then
992       begin
993         FoundNode := RootNode;
994         {$IFDEF LDEBUG}
995         DebugLn('CHP RootNode: '+ RootNode.text);
996         {$ENDIF}
997         Break;
998       end;
999 
1000       if RootNode <> nil then
1001       begin
1002         Node := RootNode.GetFirstChild;
1003         {$IFDEF LDEBUG}
1004         DebugLn('CHP RootNode Url : '+ TContentTreeNode(Node).Url);
1005         {$ENDIF}
1006       end;
1007       Break;
1008     end;
1009 
1010   end;
1011 
1012   if RootNode = nil then
1013     Exit;
1014 
1015   TmpHolder := fContentsTree.OnClick;
1016   fContentsTree.OnClick := nil;
1017   // Todo: clear WoContext compare FIRST
1018   while (Node<>nil) and (GetUrlWoContext(TContentTreeNode(Node).Url)<>GetUrlWoContext(Url)) do
1019   begin
1020     Node:=Node.GetNext;
1021   end;
1022   // Todo: clear WoContext compare SECOND
1023   if (Node <> nil) and (GetUrlWoContext(TContentTreeNode(Node).Url) = GetUrlWoContext(Url)) then
1024   begin
1025     FoundNode := Node;
1026   end;
1027 
1028   if FoundNode <> nil then
1029   begin
1030     {$IFDEF LDEBUG}
1031     DebugLn('CHP Found node: '+ FoundNode.Text);
1032     DebugLn('CHP Found URL: '+ TContentTreeNode(FoundNode).Url);
1033     {$ENDIF}
1034     fContentsTree.Selected := FoundNode;
1035     if not FoundNode.IsVisible then
1036       FoundNode.MakeVisible;
1037   end
1038   else
1039     fContentsTree.Selected := nil;
1040 
1041   fContentsTree.OnClick := TmpHolder;
1042   {$IFDEF LDEBUG}
1043   DebugLn('CHP << SelectTreeItemFromURL()');
1044   {$ENDIF}
1045 end;
1046 
1047 procedure TChmContentProvider.GetTreeNodeClass(Sender: TCustomTreeView;
1048   var NodeClass: TTreeNodeClass);
1049 begin
1050   NodeClass := TContentTreeNode;
1051 end;
1052 
1053 procedure TChmContentProvider.LoadPreferences(ACfg: TXMLConfig);
1054 begin
1055   inherited LoadPreferences(ACfg);
1056   fTabsControl.Width := ACfg.GetValue(ClassName+'/TabControlWidth/Value', fTabsControl.Width);
1057 end;
1058 
1059 procedure TChmContentProvider.SavePreferences(ACfg: TXMLConfig);
1060 begin
1061   inherited SavePreferences(ACfg);
1062   ACfg.SetValue(ClassName+'/TabControlWidth/Value', fTabsControl.Width);
1063 end;
1064 
1065 {$IFDEF CHM_SEARCH}
1066 
1067 procedure TChmContentProvider.SearchComboKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
1068 begin
1069   if (Shift <> []) then Exit;
1070   case key of
1071     VK_RETURN: begin
1072         SearchButtonClick(Sender);
1073         Key:=0;
1074       end;
1075     VK_DOWN:
1076       if fSearchResults.Items.Count > 0 then
1077       begin
1078         fSearchResults.SetFocus();
1079         if (fSearchResults.Selected = nil) then
1080         begin
1081           fSearchResults.Items.GetFirstNode().MakeVisible;
1082           fSearchResults.Items.GetFirstNode().Selected:=True;
1083         end;
1084         Key:= 0;
1085       end;
1086     else // hide warning
1087   end;
1088 end;
1089 
1090 procedure TChmContentProvider.ProcGlobalKeyUp(var Key: Word; Shift: TShiftState
1091   );
1092 begin
1093 
1094 end;
1095 
1096 procedure TChmContentProvider.SearchButtonClick ( Sender: TObject ) ;
1097 type
1098   TTopicEntry = record
1099     Topic:Integer;
1100     Hits: Integer;
1101     TitleHits: Integer;
1102     FoundForThisRound: Boolean;
1103   end;
1104   TFoundTopics = array of TTopicEntry;
1105 var
1106   FoundTopics: TFoundTopics;
1107 
1108   procedure DeleteTopic(ATopicIndex: Integer);
1109   var
1110     MoveSize: DWord;
1111   begin
1112     //DebugLn('Deleting Topic');
1113     if ATopicIndex < High(FoundTopics) then
1114     begin
1115       MoveSize := SizeOf(TTopicEntry) * (High(FoundTopics) - (ATopicIndex+1));
1116       Move(FoundTopics[ATopicIndex+1], FoundTopics[ATopicIndex], MoveSize);
1117     end;
1118     SetLength(FoundTopics, Length(FoundTopics) -1);
1119   end;
1120 
1121   function GetTopicIndex(ATopicID: Integer): Integer;
1122   var
1123     i: Integer;
1124   begin
1125     Result := -1;
1126     for i := 0 to High(FoundTopics) do
1127     begin
1128       if FoundTopics[i].Topic = ATopicID then
1129         Exit(i);
1130     end;
1131   end;
1132 
1133   procedure UpdateTopic(TopicID: Integer; NewHits: Integer; NewTitleHits: Integer; AddNewTopic: Boolean);
1134   var
1135     TopicIndex: Integer;
1136   begin
1137     //DebugLn('Updating topic');
1138     TopicIndex := GetTopicIndex(TopicID);
1139     if TopicIndex = -1 then
1140     begin
1141       if AddNewTopic = False then
1142         Exit;
1143       SetLength(FoundTopics, Length(FoundTopics)+1);
1144       TopicIndex := High(FoundTopics);
1145       FoundTopics[TopicIndex].Topic := TopicID;
1146     end;
1147 
1148     FoundTopics[TopicIndex].FoundForThisRound := True;
1149     if NewHits > 0 then
1150       Inc(FoundTopics[TopicIndex].Hits, NewHits);
1151     if NewTitleHits > 0 then
1152       Inc(FoundTopics[TopicIndex].TitleHits, NewTitleHits);
1153   end;
1154 
1155 var
1156   TopicResults: TChmWLCTopicArray;
1157   TitleResults: TChmWLCTopicArray;
1158   FIftiMainStream: TMemoryStream;
1159   SearchWords: TStringList;
1160   SearchReader: TChmSearchReader;
1161   DocTitle: String;
1162   DocURL: String;
1163   i: Integer;
1164   j: Integer;
1165   k: Integer;
1166   Item: TContentTreeNode;
1167 begin
1168   //  if fKeywordCombo.Text = '' then Exit;
1169   SearchWords := TStringList.Create;
1170   try
1171     SearchWords.Delimiter := ' ';
1172     Searchwords.DelimitedText := fKeywordCombo.Text;
1173     if fKeywordCombo.Items.IndexOf(fKeywordCombo.Text) = -1 then
1174       fKeywordCombo.Items.Add(fKeywordCombo.Text);
1175     fSearchResults.BeginUpdate;
1176     fSearchResults.Items.Clear;
1177     //DebugLn('Search words: ', SearchWords.Text);
1178     for i := 0 to fChms.Count-1 do
1179     begin
1180       for j := 0 to SearchWords.Count-1 do
1181       begin
1182         if fChms.Chm[i].SearchReader = nil then
1183         begin
1184           FIftiMainStream := fchms.Chm[i].GetObject('/$FIftiMain');
1185           if FIftiMainStream = nil then
1186             continue;
1187           SearchReader := TChmSearchReader.Create(FIftiMainStream, True); //frees the stream when done
1188           fChms.Chm[i].SearchReader := SearchReader;
1189         end
1190         else
1191           SearchReader := fChms.Chm[i].SearchReader;
1192         TopicResults := SearchReader.LookupWord(SearchWords[j], TitleResults);
1193         // Body results
1194         for k := 0 to High(TopicResults) do
1195           UpdateTopic(TopicResults[k].TopicIndex, High(TopicResults[k].LocationCodes), 0, j = 0);
1196         // Title results
1197         for k := 0 to High(TitleResults) do
1198           UpdateTopic(TitleResults[k].TopicIndex, 0, High(TitleResults[k].LocationCodes), j = 0);
1199 
1200         // Remove documents that don't have results
1201         k := 0;
1202         while k <= High(FoundTopics) do
1203         begin
1204           if FoundTopics[k].FoundForThisRound = False then
1205             DeleteTopic(k)
1206           else
1207           begin
1208             FoundTopics[k].FoundForThisRound := False;
1209             Inc(k);
1210           end;
1211         end;
1212       end;
1213 
1214       // Clear out results that don't contain all the words we are looking for
1215 
1216       Item := nil;
1217       // Now lookup titles and urls to add to final search results
1218       for j := 0 to High(FoundTopics) do
1219       begin
1220         try
1221           DocURL := fChms.Chm[i].LookupTopicByID(FoundTopics[j].Topic, DocTitle);
1222           if (Length(DocURL) > 0) and (DocURL[1] <> '/') then
1223             Insert('/', DocURL, 1);
1224           if DocTitle = '' then
1225             DocTitle := slhelp_Untitled;
1226           Item := TContentTreeNode(fSearchResults.Items.Add(Item, DocTitle));
1227           Item.Data:= fChms.Chm[i];
1228           Item.Url:= DocURL;
1229         except
1230           //DebugLn('Exception');
1231           // :)
1232         end;
1233       end;
1234       // Sort the result
1235       fSearchResults.Items.SortTopLevelNodes(@fIndexView.DefaultTreeViewSort);
1236       SetLength(FoundTopics, 0);
1237     end;
1238     SetLength(FoundTopics, 0);
1239   finally
1240     SearchWords.Free;
1241   end;
1242 
1243   if fSearchResults.Items.Count = 0 then
1244   begin
1245     fSearchResults.Items.Add(nil, slhelp_NoResults);
1246   end;
1247   fSearchResults.EndUpdate;
1248 end;
1249 
1250 {$ENDIF}
1251 
CanGoBacknull1252 function TChmContentProvider.CanGoBack: Boolean;
1253 begin
1254   Result := fHistoryIndex > 0;
1255 end;
1256 
CanGoForwardnull1257 function TChmContentProvider.CanGoForward: Boolean;
1258 begin
1259   Result := fHistoryIndex < fHistory.Count-1
1260 end;
1261 
GetHistorynull1262 function TChmContentProvider.GetHistory: TStrings;
1263 begin
1264   Result:= fHistory;
1265 end;
1266 
LoadURLnull1267 function TChmContentProvider.LoadURL(const AURL: String; const AContext: THelpContext=-1): Boolean;
1268 var
1269   XFile: String;
1270   xURL: String = '';
1271   CurCHM: TChmReader;
1272   ContextURL: String;
1273 begin
1274   Result := False;
1275   XFile := GetUrlFilePath(AUrl);
1276   xURL := GetUrlFile(AUrl);
1277 
1278   fChmDataProvider.DoOpenChm(XFile, False);
1279 
1280   fHistoryIndex := -1;
1281   fHistory.Clear;
1282 
1283   CurCHM := GetChmReader(XFile);
1284   if CurCHM = nil then Exit;
1285 
1286   // Load TOC is executed by TChmContentProvider.NewChmOpened() now
1287 
1288   // AContext will override the URL if it is found
1289   if AContext <> -1 then
1290   begin
1291     ContextURL := CurCHM.GetContextUrl(AContext);
1292     if (Length(ContextURL) > 0) and not (ContextURL[1] in ['/', '\']) then
1293       Insert('/', ContextURL , 1);
1294     if Length(ContextURL) > 0 then
1295       xURL := ContextURL;
1296   end;
1297 
1298   if xURL <> '' then
1299     DoLoadUri(MakeURI(xURL, CurCHM))
1300   else
1301     DoLoadUri(MakeURI(CurCHM.DefaultPage, CurCHM));
1302   Result := True;
1303 
1304 end;
1305 
HasLoadedDatanull1306 function TChmContentProvider.HasLoadedData ( const AUrl: String ) : Boolean;
1307 begin
1308   Result:= (fChms <> nil) and fChms.IsAnOpenFile(GetUrlFilePath(AUrl));
1309 end;
1310 
1311 procedure TChmContentProvider.GoHome;
1312 begin
1313   if (fChms <> nil) and (fChms.Chm[0].DefaultPage <> '') then
1314   begin
1315     DebugLn('CHP GoHome() DefaultPage: ', fChms.Chm[0].DefaultPage);
1316     DoLoadUri(MakeURI(fChms.Chm[0].DefaultPage, fChms.Chm[0]));
1317   end;
1318 end;
1319 
1320 procedure TChmContentProvider.GoBack;
1321 begin
1322   if CanGoBack then
1323   begin
1324     Dec(fHistoryIndex);
1325     fIsUsingHistory:=True;
1326     fHtml.OpenURL(fHistory.Strings[fHistoryIndex]);
1327   end;
1328 end;
1329 
1330 procedure TChmContentProvider.GoForward;
1331 var
1332   HistoryChm: TChmReader;
1333 begin
1334   if CanGoForward then
1335   begin
1336     Inc(fHistoryIndex);
1337     fIsUsingHistory:=True;
1338     HistoryChm := TChmReader(fHistory.Objects[fHistoryIndex]);
1339     fChms.ObjectExists(fHistory.Strings[fHistoryIndex], HistoryChm); // this ensures that the correct chm will be found
1340     fHtml.OpenURL(fHistory.Strings[fHistoryIndex]);
1341   end;
1342 end;
1343 
1344 procedure TChmContentProvider.ActivateProvider;
1345 begin
1346   //DebugLn('CHP ActivateProvider() FLastUri: '+fLastURI);
1347   // For show Home after load of all chms from Lazarus
1348   if (fChms.Count >0) and (fLastURI = '') then
1349     GoHome;
1350 end;
1351 
1352 procedure TChmContentProvider.ActivateTOCControl;
1353 begin
1354   if fContentsTab.TabVisible then
1355   begin
1356     fTabsControl.ActivePage:= fContentsTab;
1357     if fContentsTree.Visible then
1358       fContentsTree.SetFocus
1359     else
1360       fContentsTab.SetFocus;
1361   end;
1362 end;
1363 
1364 procedure TChmContentProvider.ActivateIndexControl;
1365 begin
1366   if fIndexTab.TabVisible then
1367   begin
1368     fTabsControl.ActivePage:= fIndexTab;
1369     fIndexEdit.SetFocus;
1370   end;
1371 end;
1372 
1373 procedure TChmContentProvider.ActivateSearchControl;
1374 begin
1375   if fSearchTab.TabVisible then
1376   begin
1377     fTabsControl.ActivePage:= fSearchTab;
1378     fKeywordCombo.SetFocus;
1379   end;
1380 end;
1381 
1382 class function TChmContentProvider.GetProperContentProvider(const AURL: String
1383   ): TBaseContentProviderClass;
1384 begin
1385   Result:=TChmContentProvider;
1386 end;
1387 
1388 constructor TChmContentProvider.Create(AParent: TWinControl; AImageList: TImageList;
1389                                  AUpdateCount: Integer);
1390 const
1391   TAB_WIDTH = 215;
1392 begin
1393   inherited Create(AParent, AImageList, AUpdateCount);
1394 
1395   fHistory := TStringList.Create;
1396   fFillTOCStack := TFPList.Create;
1397 
1398   fTabsControl := TPageControl.Create(AParent);
1399   with fTabsControl do
1400   begin
1401     Width := TAB_WIDTH + 12;
1402     Align := alLeft;
1403     Parent := AParent;
1404     Visible := True;
1405   end;
1406 
1407   fContentsTab := TTabSheet.Create(fTabsControl);
1408   with fContentsTab do
1409   begin
1410     Caption := slhelp_Contents;
1411     Parent := fTabsControl;
1412   end;
1413   fContentsPanel := TPanel.Create(fContentsTab);
1414   with fContentsPanel do
1415   begin
1416     Parent := fContentsTab;
1417     Align := alClient;
1418     BevelOuter := bvNone;
1419     Caption := '';
1420     Visible := True;
1421   end;
1422   fContentsTree := TTreeView.Create(fContentsPanel);
1423   with fContentsTree do
1424   begin
1425     Parent := fContentsPanel;
1426     Align := alClient;
1427     BorderSpacing.Around := 6;
1428     ReadOnly := True;
1429     Visible := True;
1430     ShowHint:=True;
1431     OnShowHint:=@TreeViewShowHint;
1432     OnExpanded := @TOCExpand;
1433     OnCollapsed := @TOCCollapse;
1434     OnCreateNodeClass:= @GetTreeNodeClass;
1435     OnClick:= @ContentsTreeSelectionChanged;
1436     //OnKeyUp:= @ProcTreeKeyUp;
1437     OnKeyDown:= @ProcTreeKeyDown;
1438     Images := fImageList;
1439     //StateImages := fImageList;
1440   end;
1441 
1442   fIndexTab := TTabSheet.Create(fTabsControl);
1443   with fIndexTab do
1444   begin
1445     Caption := slhelp_Index;
1446     Parent := fTabsControl;
1447     TabVisible:= False;
1448   end;
1449 
1450   fIndexEdit := TLabeledEdit.Create(fIndexTab);
1451   with fIndexEdit do
1452   begin
1453     Parent := fIndexTab;
1454     Anchors := [akLeft, akRight, akTop];
1455     BorderSpacing.Around := 6;
1456     AnchorSide[akLeft].Control := fIndexTab;
1457     AnchorSide[akRight].Control := fIndexTab;
1458     AnchorSide[akRight].Side := asrBottom;
1459     AnchorSide[akTop].Control := fIndexTab;
1460     EditLabel.Caption := slhelp_Search;
1461     EditLabel.AutoSize := True;
1462     LabelPosition := lpAbove;
1463     OnChange := @SearchEditChange;
1464     OnKeyDown:= @ProcKeyDown;
1465     Visible := True;
1466   end;
1467 
1468   fIndexView := TTreeView.Create(fIndexTab);
1469   with fIndexView do
1470   begin
1471     Anchors := [akLeft, akTop, akRight, akBottom];
1472     BorderSpacing.Around := 6;
1473     AnchorSide[akLeft].Control := fIndexTab;
1474     AnchorSide[akRight].Control := fIndexTab;
1475     AnchorSide[akRight].Side := asrBottom;
1476     AnchorSide[akTop].Control := fIndexEdit;
1477     AnchorSide[akTop].Side := asrBottom;
1478     AnchorSide[akBottom].Control := fIndexTab;
1479     AnchorSide[akBottom].Side := asrBottom;
1480     Parent := fIndexTab;
1481     BorderSpacing.Around := 6;
1482     ReadOnly := True;
1483     Visible := True;
1484     ShowButtons:=False;
1485     ShowLines:=False;
1486     ShowRoot:=False;
1487     ShowHint:=True;
1488     OnShowHint:=@TreeViewShowHint;
1489     OnCollapsing:=@TreeViewStopCollapse;
1490     OnClick:= @ContentsTreeSelectionChanged;
1491     //OnKeyUp:= @ProcTreeKeyUp;
1492     OnKeyDown:= @ProcTreeKeyDown;
1493     OnCreateNodeClass:=@GetTreeNodeClass;
1494     OnCompare:=@CompareIndexNodes;
1495   end;
1496 
1497  {$IFDEF CHM_SEARCH}
1498   fSearchTab := TTabSheet.Create(fTabsControl);
1499   with fSearchTab do
1500   begin
1501     Caption := slhelp_Search;
1502     Parent := fTabsControl;
1503     TabVisible:= False;
1504   end;
1505   fKeywordLabel := TLabel.Create(fSearchTab);
1506   with fKeywordLabel do
1507   begin
1508     Parent := fSearchTab;
1509     Top := 6;
1510     Caption := slhelp_Keyword;
1511     Left := 6;
1512     AutoSize := True;
1513   end;
1514   fKeywordCombo := TComboBox.Create(fSearchTab);
1515   with fKeywordCombo do
1516   begin
1517     Parent := fSearchTab;
1518     Anchors := [akLeft, akRight, akTop];
1519     BorderSpacing.Around := 6;
1520     AnchorSide[akLeft].Control := fSearchTab;
1521     AnchorSide[akRight].Control := fSearchTab;
1522     AnchorSide[akRight].Side := asrBottom;
1523     AnchorSide[akTop].Control := fKeywordLabel;
1524     AnchorSide[akTop].Side := asrBottom;
1525     OnKeyDown  := @SearchComboKeyDown;
1526   end;
1527 
1528   fSearchBtn := TButton.Create(fSearchTab);
1529   with fSearchBtn do
1530   begin
1531     Parent := fSearchTab;
1532     Anchors := [akLeft, akTop];
1533     BorderSpacing.Around := 6;
1534     AnchorSide[akLeft].Control := fSearchTab;
1535     AnchorSide[akTop].Control := fKeywordCombo;
1536     AnchorSide[akTop].Side := asrBottom;
1537     Caption := slhelp_Find;
1538     OnClick := @SearchButtonClick;
1539   end;
1540   fResultsLabel := TLabel.Create(fSearchTab);
1541   with fResultsLabel do
1542   begin
1543     Parent := fSearchTab;
1544     Anchors := [akLeft, akTop];
1545     BorderSpacing.Around := 6;
1546     AnchorSide[akLeft].Control := fSearchTab;
1547     AnchorSide[akRight].Control := fSearchTab;
1548     AnchorSide[akRight].Side := asrBottom;
1549     AnchorSide[akTop].Control := fSearchBtn;
1550     AnchorSide[akTop].Side := asrBottom;
1551     Caption := slhelp_SearchResults;
1552     AutoSize := True;
1553   end;
1554   fSearchResults := TTreeView.Create(fSearchTab);
1555   with fSearchResults do
1556   begin
1557     Parent := fSearchTab;
1558     Anchors := [akLeft, akTop, akRight, akBottom];
1559     BorderSpacing.Around := 6;
1560     AnchorSide[akLeft].Control := fSearchTab;
1561     AnchorSide[akRight].Control := fSearchTab;
1562     AnchorSide[akRight].Side := asrBottom;
1563     AnchorSide[akTop].Control := fResultsLabel;
1564     AnchorSide[akTop].Side := asrBottom;
1565     AnchorSide[akBottom].Control := fSearchTab;
1566     AnchorSide[akBottom].Side := asrBottom;
1567     ReadOnly := True;
1568     ShowButtons := False;
1569     ShowLines := False;
1570     ShowRoot:=False;
1571     ShowHint:=True;
1572     OnShowHint:=@TreeViewShowHint;
1573     OnClick:= @ContentsTreeSelectionChanged;
1574     OnKeyDown:= @ProcTreeKeyDown;
1575     OnCollapsing:=@TreeViewStopCollapse;
1576     OnCreateNodeClass:=@GetTreeNodeClass;
1577     OnCompare:=@CompareIndexNodes;
1578   end;
1579  {$ENDIF}
1580 
1581   fHtml := TIpHtmlPanel.Create(AParent);
1582   with fHtml do
1583   begin
1584     OnDocumentOpen := @IpHtmlPanelDocumentOpen;
1585     OnHotChange := @IpHtmlPanelHotChange;
1586     OnHotClick := @IpHtmlPanelHotClick;
1587     //OnKeyDown:= @ProcTreeKeyDown;
1588     DataProvider := TIpChmDataProvider.Create(fHtml);
1589     Parent := AParent;
1590     Align := alClient;
1591   end;
1592 
1593   fChms:= TIpChmDataProvider(fHtml.DataProvider).Chms; // save only pointer for convenience
1594   fChms.OnOpenNewFile:= @NewChmOpened;
1595   fChmDataProvider:= TIpChmDataProvider(fHtml.DataProvider); // save only pointer for convenience
1596   fChmDataProvider.OnGetHtmlPage:=@LoadingHTMLStream;
1597 
1598   fSplitter := TSplitter.Create(AParent);
1599   with fSplitter do
1600   begin
1601     //Align  := alLeft;
1602     Left := 1;
1603     AnchorSide[akLeft].Control := fTabsControl;
1604     AnchorSide[akLeft].Side:= asrRight;
1605     AnchorSide[akRight].Control := fHtml;
1606     AnchorSide[akRight].Side := asrLeft;
1607     Parent := AParent;
1608   end;
1609 
1610   fPopUp := TPopupMenu.Create(fHtml);
1611   fPopUp.Items.Add(TMenuItem.Create(fPopup));
1612   with fPopUp.Items.Items[0] do
1613   begin
1614     Caption := slhelp_Copy;
1615     OnClick := @PopupCopyClick;
1616   end;
1617   fPopup.Items.Add(TMenuItem.Create(fPopup));
1618   with fPopup.Items.Items[1] do
1619   begin
1620     Caption := slhelp_CopyHtmlSource;
1621     OnClick := @PopupCopySourceClick;
1622   end;
1623   fHtml.PopupMenu := fPopUp;
1624 
1625   fStatusBar := TStatusBar.Create(AParent);
1626   with fStatusBar do
1627   begin
1628     Parent := AParent;
1629     Align := alBottom;
1630     SimplePanel := True;
1631   end;
1632 
1633   if isUpdate then
1634   begin
1635     fContentsTree.BeginUpdate;
1636     fIndexView.BeginUpdate;
1637   end;
1638 
1639 end;
1640 
1641 destructor TChmContentProvider.Destroy;
1642 begin
1643   fChmDataProvider.DoCloseChms;
1644   fHistory.Free;
1645   if fFillTOCStack.Count > 0 then
1646   begin
1647     Application.ProcessMessages;
1648     Sleep(200); // waiting a stop of async TOC creating
1649   end;
1650   fFillTOCStack.Free;
1651   inherited Destroy;
1652 end;
1653 
1654 initialization
1655 
1656   RegisterFileType('.chm', TChmContentProvider);
1657 
1658 end.
1659 
1660