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