1 {
2 *****************************************************************************
3 See the file COPYING.modifiedLGPL.txt, included in this distribution,
4 for details about the license.
5 *****************************************************************************
6
7 Author: Mattias Gaertner
8
9 Abstract:
10 Installs a HTML control in the IDE using TIpHtmlPanel.
11 }
12 unit IPIDEHTMLControl;
13
14 {$mode objfpc}{$H+}
15
16 interface
17
18 uses
19 Classes, SysUtils, LCLProc, Forms, Graphics, Controls, Dialogs, ExtCtrls, Menus,
20 IpMsg, Ipfilebroker, IpHtml, IDEHelpIntf, LazHelpIntf, LazIDEIntf;
21
22 type
23 TLazIPHtmlControl = class;
24
25 { TLazIpHtmlDataProvider }
26
27 TLazIpHtmlDataProvider = class(TIpHtmlDataProvider)
28 private
29 FControl: TLazIPHtmlControl;
30 protected
DoGetStreamnull31 function DoGetStream(const URL: string): TStream; override;
32 public
33 property Control: TLazIPHtmlControl read FControl;
34 end;
35
36 { TLazIPHtmlControl }
37
38 TLazIPHtmlControl = class(TCustomPanel,TIDEHTMLControlIntf)
DataProviderCanHandlenull39 function DataProviderCanHandle(Sender: TObject; const {%H-}URL: string): Boolean;
40 procedure DataProviderCheckURL(Sender: TObject; const {%H-}URL: string;
41 var Available: Boolean; var ContentType: string);
42 procedure DataProviderGetHtml(Sender: TObject; const {%H-}URL: string;
43 const {%H-}aPostData: TIpFormDataEntity; var Stream: TStream);
44 procedure DataProviderGetImage(Sender: TIpHtmlNode; const URL: string;
45 var Picture: TPicture);
46 procedure DataProviderLeave(Sender: TIpHtml);
47 procedure DataProviderReportReference(Sender: TObject; const {%H-}URL: string);
48 procedure IPHTMLPanelHotClick(Sender: TObject);
49 private
50 FIDEProvider: TAbstractIDEHTMLProvider;
51 FIPHTMLPanel: TIpHtmlPanel;
52 FURL: string;
53 procedure SetIDEProvider(const AValue: TAbstractIDEHTMLProvider);
54 protected
55 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
56 public
57 constructor Create(AOwner: TComponent); override;
58 destructor Destroy; override;
GetURLnull59 function GetURL: string;
60 procedure SetURL(const AValue: string);
61 property IDEProvider: TAbstractIDEHTMLProvider read FIDEProvider write SetIDEProvider;
62 procedure SetHTMLContent(Stream: TStream; const NewURL: string);
63 procedure GetPreferredControlSize(out AWidth, AHeight: integer);
64 property IPHTMLPanel: TIpHtmlPanel read FIPHTMLPanel;
65 end;
66
67 { TLazIPHtmlControlClipboardPopup }
68
69 TLazIPHtmlControlClipboardPopup = class(TPopupMenu)
70 private
71 FCopy, FSelectAll: TMenuItem;
72 FPanel: TLazIPHtmlControl;
73 procedure DoCopy(Sender: TObject);
74 procedure DoSelectAll(Sender: TObject);
75 protected
76 procedure DoPopup(Sender: TObject); override;
77 public
78 constructor Create(AOwner: TComponent; APanel: TLazIPHtmlControl); reintroduce;
79 end;
80
IPCreateLazIDEHTMLControlnull81 function IPCreateLazIDEHTMLControl(Owner: TComponent;
82 var Provider: TAbstractIDEHTMLProvider;
83 {%H-}Flags: TIDEHTMLControlFlags = []): TControl;
84
85 procedure Register;
86
87 implementation
88
89 resourcestring
90 ipdCopy = '&Copy';
91 ipdSelectAll = 'Select &all';
92
93 procedure Register;
94 begin
95 CreateIDEHTMLControl:=@IPCreateLazIDEHTMLControl;
96 end;
97
IPCreateLazIDEHTMLControlnull98 function IPCreateLazIDEHTMLControl(Owner: TComponent;
99 var Provider: TAbstractIDEHTMLProvider;
100 Flags: TIDEHTMLControlFlags = []): TControl;
101 var
102 HTMLControl: TLazIPHtmlControl;
103 begin
104 //debugln(['IPCreateLazIDEHTMLControl ']);
105 HTMLControl:=TLazIPHtmlControl.Create(Owner);
106 Result:=HTMLControl;
107 if Provider=nil then
108 Provider:=CreateIDEHTMLProvider(HTMLControl);
109 //debugln(['IPCreateLazIDEHTMLControl Provider=',DbgSName(Provider)]);
110 HTMLControl.IDEProvider:=Provider;
111
112 if ihcWithClipboardMenu in Flags then
113 TLazIPHtmlControlClipboardPopup.Create(Owner, HTMLControl);
114 end;
115
116 { TLazIPHtmlControlClipboardPopup }
117
118 procedure TLazIPHtmlControlClipboardPopup.DoCopy(Sender: TObject);
119 begin
120 if FPanel.IPHTMLPanel <> nil then
121 FPanel.IPHTMLPanel.CopyToClipboard;
122 end;
123
124 procedure TLazIPHtmlControlClipboardPopup.DoSelectAll(Sender: TObject);
125 begin
126 if FPanel.IPHTMLPanel <> nil then
127 FPanel.IPHTMLPanel.SelectAll;
128 end;
129
130 procedure TLazIPHtmlControlClipboardPopup.DoPopup(Sender: TObject);
131 begin
132 if FPanel.IPHTMLPanel <> nil then
133 FCopy.Enabled := FPanel.IPHTMLPanel.HaveSelection;
134 inherited DoPopup(Sender);
135 end;
136
137 constructor TLazIPHtmlControlClipboardPopup.Create(AOwner: TComponent;
138 APanel: TLazIPHtmlControl);
139 begin
140 inherited Create(AOwner);
141 FPanel := APanel;
142 AutoPopup := True;
143
144 FCopy := TMenuItem.Create(Owner);
145 FCopy.Caption := ipdCopy;
146 FCopy.ShortCut := ShortCut(ord('C'), [ssCtrl]);
147 FCopy.OnClick := @DoCopy;
148 Items.Add(FCopy);
149
150 FSelectAll := TMenuItem.Create(Owner);
151 FSelectAll.Caption := ipdSelectAll;
152 FSelectAll.ShortCut := ShortCut(ord('A'), [ssCtrl]);
153 FSelectAll.OnClick := @DoSelectAll;
154 Items.Add(FSelectAll);
155
156 TControl(Owner).PopupMenu := Self;
157 end;
158
159 { TLazIpHtmlDataProvider }
160
DoGetStreamnull161 function TLazIpHtmlDataProvider.DoGetStream(const URL: string): TStream;
162 begin
163 //debugln(['TLazIpHtmlDataProvider.DoGetStream ',URL,' ',DbgSName(Control.IDEProvider)]);
164 Result:=Control.IDEProvider.GetStream(URL,false);
165 end;
166
167 { TLazIPHtmlControl }
168
TLazIPHtmlControl.DataProviderCanHandlenull169 function TLazIPHtmlControl.DataProviderCanHandle(Sender: TObject;
170 const URL: string): Boolean;
171 begin
172 //debugln(['TLazIPHtmlControl.DataProviderCanHandle URL=',URL]);
173 Result:=false;
174 end;
175
176 procedure TLazIPHtmlControl.DataProviderCheckURL(Sender: TObject;
177 const URL: string; var Available: Boolean; var ContentType: string);
178 begin
179 //debugln(['TLazIPHtmlControl.DataProviderCheckURL URL=',URL]);
180 Available:=false;
181 ContentType:='';
182 end;
183
184 procedure TLazIPHtmlControl.DataProviderGetHtml(Sender: TObject;
185 const URL: string; const aPostData: TIpFormDataEntity; var Stream: TStream);
186 begin
187 //debugln(['TLazIPHtmlControl.DataProviderGetHtml URL=',URL]);
188 Stream:=nil;
189 end;
190
191 procedure TLazIPHtmlControl.DataProviderGetImage(Sender: TIpHtmlNode;
192 const URL: string; var Picture: TPicture);
193 var
194 URLType: string;
195 URLPath: string;
196 URLParams: string;
197 Filename: String;
198 Ext: String;
199 Stream: TStream;
200 NewURL: String;
201 begin
202 //DebugLn(['TIPLazHtmlControl.HTMLGetImageX URL=',URL]);
203 if IDEProvider=nil then exit;
204 NewURL:=IDEProvider.MakeURLAbsolute(IDEProvider.BaseURL,URL);
205 //DebugLn(['TIPLazHtmlControl.HTMLGetImageX NewURL=',NewURL,' Provider.BaseURL=',IDEProvider.BaseURL,' URL=',URL]);
206
207 Picture:=nil;
208 Stream:=nil;
209 try
210 try
211 SplitURL(NewURL,URLType,URLPath,URLParams);
212 if URLPath='' then
213 URLPath:=NewURL;
214 Filename:=URLPathToFilename(URLPath);
215 Ext:=ExtractFileExt(Filename);
216 //DebugLn(['TIPLazHtmlControl.HTMLGetImageX URLPath=',URLPath,' Filename=',Filename,' Ext=',Ext]);
217 Picture:=TPicture.Create;
218 // quick check if file format is supported (raises an exception)
219 Picture.FindGraphicClassWithFileExt(Ext);
220 // get stream
221 Stream:=IDEProvider.GetStream(NewURL,true);
222 // load picture
223 Picture.LoadFromStreamWithFileExt(Stream,Ext);
224 finally
225 if Stream<>nil then
226 IDEProvider.ReleaseStream(NewURL);
227 end;
228 except
229 on E: Exception do begin
230 FreeAndNil(Picture);
231 DebugLn(['TIPLazHtmlControl.HTMLGetImageX ERROR: ',E.Message]);
232 end;
233 end;
234 end;
235
236 procedure TLazIPHtmlControl.DataProviderLeave(Sender: TIpHtml);
237 begin
238 //debugln(['TLazIPHtmlControl.DataProviderLeave ']);
239 end;
240
241 procedure TLazIPHtmlControl.DataProviderReportReference(Sender: TObject; const URL: string);
242 begin
243 //debugln(['TLazIPHtmlControl.DataProviderReportReference URL=',URL]);
244 end;
245
246 procedure TLazIPHtmlControl.IPHTMLPanelHotClick(Sender: TObject);
247 var
248 HotNode: TIpHtmlNode;
249 HRef: String;
250 //Target: String;
251 begin
252 HotNode:=FIPHTMLPanel.HotNode;
253 if HotNode is TIpHtmlNodeA then begin
254 HRef := TIpHtmlNodeA(HotNode).HRef;
255 //Target := TIpHtmlNodeA(HotNode).Target;
256 end else begin
257 HRef := TIpHtmlNodeAREA(HotNode).HRef;
258 //Target := TIpHtmlNodeAREA(HotNode).Target;
259 end;
260 //debugln(['TLazIPHtmlControl.IPHTMLPanelHotClick HRef="',HRef,'" Target="',Target,'"']);
261 IDEProvider.OpenURLAsync(HRef);
262 end;
263
264 procedure TLazIPHtmlControl.SetIDEProvider(const AValue: TAbstractIDEHTMLProvider);
265 begin
266 if FIDEProvider=AValue then exit;
267 //debugln(['TLazIPHtmlControl.SetIDEProvider Old=',DbgSName(FIDEProvider),' New=',DbgSName(FIDEProvider)]);
268 if FIDEProvider<>nil then begin
269 IDEProvider.ControlIntf:=nil;
270 end;
271 FIDEProvider:=AValue;
272 if FIDEProvider<>nil then begin
273 FreeNotification(FIDEProvider);
274 IDEProvider.ControlIntf:=Self;
275 end;
276 end;
277
278 procedure TLazIPHtmlControl.Notification(AComponent: TComponent; Operation: TOperation);
279 begin
280 inherited Notification(AComponent, Operation);
281 if Operation=opRemove then begin
282 if IDEProvider=AComponent then begin
283 if IDEProvider.ControlIntf=TIDEHTMLControlIntf(Self) then
284 IDEProvider.ControlIntf:=nil;
285 IDEProvider:=nil;
286 end;
287 end;
288 end;
289
290 constructor TLazIPHtmlControl.Create(AOwner: TComponent);
291 begin
292 inherited Create(AOwner);
293 FIPHTMLPanel:=TIpHtmlPanel.Create(Self);
294 with FIPHTMLPanel do begin
295 Name:='TLazIPHtmlControl_IPHTMLPanel';
296 Align:=alClient;
297 DefaultFontSize:=8;
298 MarginHeight:=2;
299 MarginWidth:=2;
300 Parent:=Self;
301 WantTabs := False;
302 OnHotClick:=@IPHTMLPanelHotClick;
303 end;
304 FIPHTMLPanel.DataProvider:=TLazIpHtmlDataProvider.Create(FIPHTMLPanel);
305 with TLazIpHtmlDataProvider(FIPHTMLPanel.DataProvider) do begin
306 FControl:=Self;
307 Name:='TLazIPHtmlControl_DataProvider';
308 OnCanHandle:=@DataProviderCanHandle;
309 OnGetHtml:=@DataProviderGetHtml;
310 OnGetImage:=@DataProviderGetImage;
311 OnLeave:=@DataProviderLeave;
312 OnCheckURL:=@DataProviderCheckURL;
313 OnReportReference:=@DataProviderReportReference;
314 end;
315 Caption:='';
316 BevelInner:=bvLowered;
317 end;
318
319 destructor TLazIPHtmlControl.Destroy;
320 begin
321 //debugln(['TLazIPHtmlControl.Destroy ',DbgSName(Self),' ',dbgs(Pointer(Self))]);
322 FreeAndNil(FIDEProvider);
323 inherited Destroy;
324 end;
325
GetURLnull326 function TLazIPHtmlControl.GetURL: string;
327 begin
328 Result:=FURL;
329 end;
330
331 procedure TLazIPHtmlControl.SetURL(const AValue: string);
332 var
333 Stream: TStream;
334 NewHTML: TIpHtml;
335 NewURL: String;
336 begin
337 if IDEProvider=nil then raise Exception.Create('TIPLazHtmlControl.SetURL missing Provider');
338 if FURL=AValue then exit;
339 NewURL:=IDEProvider.MakeURLAbsolute(IDEProvider.BaseURL,AValue);
340 if FURL=NewURL then exit;
341 FURL:=NewURL;
342 try
343 Stream:=IDEProvider.GetStream(FURL,true);
344 try
345 NewHTML:=TIpHtml.Create; // Beware: Will be freed automatically TIpHtmlPanel
346 FIPHTMLPanel.SetHtml(NewHTML);
347 NewHTML.LoadFromStream(Stream);
348 finally
349 IDEProvider.ReleaseStream(FURL);
350 end;
351 except
352 on E: Exception do begin
353 MessageDlg('Unable to open HTML file',
354 'URL: '+FURL+#13
355 +'Error: '+E.Message,mtError,[mbCancel],0);
356 end;
357 end;
358 end;
359
360 procedure TLazIPHtmlControl.SetHTMLContent(Stream: TStream; const NewURL: string);
361 var
362 NewHTML: TIpHtml;
363 begin
364 FURL:=NewURL;
365 try
366 NewHTML:=TIpHtml.Create; // Beware: Will be freed automatically TIpHtmlPanel
367 FIPHTMLPanel.SetHtml(NewHTML);
368 NewHTML.LoadFromStream(Stream);
369 except
370 on E: Exception do begin
371 MessageDlg('Unable to load HTML stream',
372 'URL: '+FURL+#13
373 +'Error: '+E.Message,mtError,[mbCancel],0);
374 end;
375 end;
376 end;
377
378 procedure TLazIPHtmlControl.GetPreferredControlSize(out AWidth, AHeight: integer);
379 begin
380 AWidth:=0;
381 AHeight:=0;
382 inherited GetPreferredSize(AWidth, AHeight);
383 end;
384
385 end.
386
387