1 (* ***** BEGIN LICENSE BLOCK *****
2 * Version: MPL 1.1
3 *
4 * The contents of this file are subject to the Mozilla Public License Version
5 * 1.1 (the "License"); you may not use this file except in compliance with
6 * the License. You may obtain a copy of the License at
7 * http://www.mozilla.org/MPL/
8 *
9 * Software distributed under the License is distributed on an "AS IS" basis,
10 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
11 * for the specific language governing rights and limitations under the
12 * License.
13 *
14 * The Original Code is TurboPower Internet Professional
15 *
16 * The Initial Developer of the Original Code is
17 * TurboPower Software
18 *
19 * Portions created by the Initial Developer are Copyright (C) 2000-2002
20 * the Initial Developer. All Rights Reserved.
21 *
22 * Contributor(s):
23 *
24 * ***** END LICENSE BLOCK ***** *)
25
26 (* Part of Ipbroker.pas allowing to use local files Armin <diehl@nordrhein.de> Jun 2006 *)
27
28 unit Ipfilebroker;
29
30 {$I ipdefine.inc}
31
32 interface
33
34 {$IFDEF IP_LAZARUS}
35 uses Classes, SysUtils, LResources, Graphics, LCLProc, LazFileUtils, LazUTF8,
36 ipconst, iputils, iphtml, ipmsg;
37 {$ELSE}
38 uses
39 Windows, SysUtils, Graphics, Classes, Dialogs, ShellApi,
40 IpConst, IpUtils, {IpSock, IpCache,} IpHtml, {IpHttp,} IpMsg, IpStrms{, IpFtp};
41 {$ENDIF}
42
43 const
44 IP_DEFAULT_SCHEME : string = 'HTTP';
45
46 {$IFDEF IP_LAZARUS}
expandLocalHtmlFileNamenull47 function expandLocalHtmlFileName (URL : string) : string;
48 {$ENDIF}
49
50 type
51
52 TIpGetHtmlDataEvent =
53 procedure(Sender : TObject; const URL : string; const PostData : TIpFormDataEntity; var Stream : TStream) of object;
54 TIpGetImageDataEvent =
55 procedure(Sender : TIpHtmlNode; const URL : string; var Picture : TPicture) of object;
56 TIpLeaveHtmlDocumentEvent =
57 procedure(Sender : TIpHtml) of object;
58 TIpCheckURLEvent =
59 procedure(Sender : TObject; const URL : string; var Available :Boolean; var ContentType : string) of object;
60 TIpReportReferenceEvent =
61 procedure(Sender : TObject; const URL : string) of object;
62 TIpExternalResourceEvent =
63 procedure(Sender : TObject; const URL : string) of object;
64 TIpCanHandleEvent =
endernull65 function(Sender : TObject; const URL : string) : Boolean of object;
66
67
68 TIpCustomHtmlDataProvider = class(TIpAbstractHtmlDataProvider)
69 private
70 FProtocols : TStrings;
71 FGetHtml : TIpGetHtmlDataEvent;
72 FGetImage : TIpGetImageDataEvent;
73 FLeave : TIpLeaveHtmlDocumentEvent;
74 FCheckURL : TIpCheckURLEvent;
75 FReportReference : TIpReportReferenceEvent;
76 FCanHandle : TIpCanHandleEvent;
GetProtocolsnull77 function GetProtocols : TStrings;
78 procedure SetProtocols(const Value : TStrings);
79 protected
80 // Nothing
81 public
82 constructor Create(AOwner : TComponent); override;
83 destructor Destroy; override;
DoGetHtmlStreamnull84 function DoGetHtmlStream(const URL : string; PostData : TIpFormDataEntity) : TStream; override;
DoCheckURLnull85 function DoCheckURL(const URL : string; var ContentType : string) : Boolean; override;
86 procedure DoLeave(Html : TIpHtml); override;
87 procedure DoReference(const URL : string); override;
88 procedure DoGetImage(Sender : TIpHtmlNode; const URL : string; var Picture : TPicture); override;
GetHtmlStreamnull89 function GetHtmlStream(const URL : string; PostData : TIpFormDataEntity) : TStream; virtual;
CheckURLnull90 function CheckURL(const URL : string; var ContentType : string) : Boolean; virtual;
91 procedure Leave(Html : TIpHtml); virtual;
92 procedure Reference(const URL : string); virtual;
93 procedure GetImage(Sender : TIpHtmlNode; const URL : string; var Picture : TPicture); virtual;
CanHandlenull94 function CanHandle(const URL : string) : Boolean; override;
BuildURLnull95 function BuildURL(const Old, New : string) : string; override;
96 property HandledProtocols : TStrings read GetProtocols write SetProtocols;
97 property OnCanHandle : TIpCanHandleEvent read FCanHandle write FCanhandle;
98 property OnGetHtml : TIpGetHtmlDataEvent read FGetHtml write FGetHtml;
99 property OnGetImage : TIpGetImageDataEvent read FGetImage write FGetImage;
100 property OnLeave : TIpLeaveHtmlDocumentEvent read FLeave write FLeave;
101 property OnCheckURL : TIpCheckURLEvent read FCheckURL write FCheckURL;
102 property OnReportReference : TIpReportReferenceEvent read FReportReference write FReportReference;
103 published
104 // Nothing
105 end;
106
107 TIpHtmlDataProvider = class(TIpCustomHtmlDataProvider)
108 public
109 published
110 property HandledProtocols;
111 property OnCanHandle;
112 property OnGetHtml;
113 property OnGetImage;
114 property OnLeave;
115 property OnCheckURL;
116 property OnReportReference;
117 end;
118
119 { TIpFileDataProvider }
120
121 TIpFileDataProvider = class(TIpCustomHtmlDataProvider)
122 private
123 FOldURL : string;
124 public
125 constructor Create(AOwner : TComponent); override;
GetHtmlStreamnull126 function GetHtmlStream(const URL : string; PostData : TIpFormDataEntity) : TStream; override;
127 {$IFDEF IP_LAZARUS}
DoGetStreamnull128 function DoGetStream(const URL: string): TStream; override;
129 {$ENDIF}
CheckURLnull130 function CheckURL(const URL : string; var ContentType : string) : Boolean; override;
131 procedure Leave(Html : TIpHtml); override;
132 procedure Reference(const URL : string); override;
133 procedure GetImage(Sender : TIpHtmlNode; const URL : string; var Picture : TPicture); override;
CanHandlenull134 function CanHandle(const URL : string) : Boolean; override;
135 end;
136
137 procedure Register;
138
139 implementation
140
141 {$IFDEF IP_LAZARUS}
expandLocalHtmlFileNamenull142 function expandLocalHtmlFileName (URL : string) : string;
143 begin
144 if pos ('FILE://', ansiuppercase(URL)) = 0 then
145 result := 'file://'+DOSToNetPath(ExpandFileNameUTF8(URL))
146 else
147 result := URL;
148 end;
149 {$ENDIF}
150
151 { TIpCustomHtmlDataProvider }
152 constructor TIpCustomHtmlDataProvider.Create(AOwner : TComponent);
153 begin
154 inherited Create(AOwner);
155 FProtocols := TStringList.Create;
156 end;
157
158 destructor TIpCustomHtmlDataProvider.Destroy;
159 begin
160 FProtocols.Free;
161 inherited Destroy;
162 end;
163
BuildURLnull164 function TIpCustomHtmlDataProvider.BuildURL(const Old,
165 New : string) : string;
166 begin
167 Result := IpUtils.BuildURL(Old, New);
168 {$IFDEF IP_LAZARUS}
169 //DebugLn('TIpCustomHtmlDataProvider.BuildURL Old="',old,'" new="',New,'"');
170 {$ENDIF}
171 end;
172
TIpCustomHtmlDataProvider.CanHandlenull173 function TIpCustomHtmlDataProvider.CanHandle(const URL : string) : Boolean;
174 var
175 AddrRec : TIpAddrRec;
176 begin
177 Initialize(AddrRec);
178 if Assigned(FCanHandle) then begin
179 Result := FCanHandle(self, URL);
180 end
181 else begin
182 Result := False;
183 IpParseURL(URL, AddrRec);
184 if AddrRec.Scheme = '' then begin
185 if FProtocols.Count > 1 then
186 AddrRec.Scheme := FProtocols[1]
187 else
188 AddrRec.Scheme := IP_DEFAULT_SCHEME;
189 end;
190 if FProtocols.IndexOf(UpperCase(AddrRec.Scheme)) > -1 then
191 Result := True
192 end;
193 Initialize(AddrRec);
194 Finalize(AddrRec);
195 end;
196
CheckURLnull197 function TIpCustomHtmlDataProvider.CheckURL(const URL : string;
198 var ContentType : string) : Boolean;
199 begin
200 ContentType := '';
201 Result := False;
202 end;
203
DoCheckURLnull204 function TIpCustomHtmlDataProvider.DoCheckURL(const URL : string;
205 var ContentType : string) : Boolean;
206 begin
207 Result := False;
208 if Assigned(FCheckURL) then
209 FCheckURL(Self, URL, Result, ContentType)
210 else
211 Result := CheckURL(URL, ContentType);
212 end;
213
214 procedure TIpCustomHtmlDataProvider.DoGetImage(Sender : TIpHtmlNode;
215 const URL : string; var Picture : TPicture);
216 begin
217 if Assigned(OnGetImage) then begin
218 OnGetImage(Sender, URL, Picture)
219 end
220 else
221 GetImage(Sender, URL, Picture);
222
223 if (Picture <> nil) then begin
224 if not (Picture is TPicture) then
225 raise Exception.Create(ProviderUnknownPicture);
226 end;
227 end;
228
229 procedure TIpCustomHtmlDataProvider.DoLeave;
230 begin
231 if assigned(FLeave) then
232 FLeave(Html)
233 else
234 Leave(Html);
235 end;
236
237 procedure TIpCustomHtmlDataProvider.DoReference(const URL : string);
238 begin
239 if assigned(FReportReference) then
240 FReportReference(Self, URL)
241 else
242 Reference(URL);
243 end;
244
DoGetHtmlStreamnull245 function TIpCustomHtmlDataProvider.DoGetHtmlStream(const URL : string;
246 PostData : TIpFormDataEntity) : TStream;
247 begin
248 Result := nil;
249 if Assigned(FGetHtml) then
250 FGetHtml(Self, URL, PostData, Result)
251 else
252 Result := GetHtmlStream(URL, PostData);
253 end;
254
GetHtmlStreamnull255 function TIpCustomHtmlDataProvider.GetHtmlStream(const URL : string;
256 PostData : TIpFormDataEntity) : TStream;
257 begin
258 { return defaults }
259 Result := nil;
260 end;
261
262 procedure TIpCustomHtmlDataProvider.GetImage(Sender : TIpHtmlNode;
263 const URL : string; var Picture : TPicture);
264 begin
265 { return defaults }
266 Picture := nil;
267 end;
268
GetProtocolsnull269 function TIpCustomHtmlDataProvider.GetProtocols : TStrings;
270 begin
271 Result := FProtocols;
272 end;
273
274 procedure TIpCustomHtmlDataProvider.Leave(Html : TIpHtml);
275 begin
276 { do nothing }
277 end;
278
279 procedure TIpCustomHtmlDataProvider.Reference(const URL : string);
280 begin
281 { do nothing }
282 end;
283
284 procedure TIpCustomHtmlDataProvider.SetProtocols(const Value : TStrings);
285 begin
286 FProtocols.Assign(Value);
287 end;
288
289 { TIpFileDataProvider }
290 constructor TIpFileDataProvider.Create(AOwner : TComponent);
291 begin
292 inherited Create(AOwner);
293 HandledProtocols.Add('FILE');
294 end;
295
CanHandlenull296 function TIpFileDataProvider.CanHandle(const URL : string) : Boolean;
297 var
298 FileAddrRec : TIpAddrRec;
299 ContentType, FN : string;
300 begin
301 Initialize(FileAddrRec);
302 {$IFDEF IP_LAZARUS}
303 //DebugLn('TIpFileDataProvider.CanHandle('+URL+')');
304 {$ENDIF}
305 FN := BuildURL(FOldURL, URL);
306 IpParseURL(FN, FileAddrRec);
307 FN := NetToDosPath(FileAddrRec.Path);
308 {$IFDEF IP_LAZARUS}
309 //DebugLn('TIpFileDataProvider.CanHandle FN="'+FN+'"');
310 {$ENDIF}
311 ContentType := UpperCase(GetLocalContent(FN));
312 Result := (FileExistsUTF8(FN)) and ((Pos('TEXT/HTML', ContentType) > 0) or
313 (Pos('IMAGE/', ContentType) > 0));
314 Finalize(FileAddrRec);
315 end;
316
CheckURLnull317 function TIpFileDataProvider.CheckURL(const URL : string;
318 var ContentType : string) : Boolean;
319 var
320 FileAddrRec : TIpAddrRec;
321 FN : string;
322 begin
323 Initialize(FileAddrRec);
324 IpParseURL(URL, FileAddrRec);
325 FN := NetToDosPath(FileAddrRec.Path);
326 Result := FileExistsUTF8(FN);
327 ContentType := GetLocalContent(FN);
328 Finalize(FileAddrRec);
329 end;
330
GetHtmlStreamnull331 function TIpFileDataProvider.GetHtmlStream(const URL : string;
332 PostData : TIpFormDataEntity) : TStream;
333 var
334 FileAddrRec : TIpAddrRec;
335 FN : string;
336 begin
337 Initialize(FileAddrRec);
338 IpParseURL(URL, FileAddrRec);
339 FN := NetToDosPath(FileAddrRec.Path);
340 Result := TMemoryStream.Create;
341 TMemoryStream(Result).LoadFromFile(UTF8ToSys(FN));
342 FOldURL := URL;
343 Finalize(FileAddrRec);
344 end;
345
346 {$IFDEF IP_LAZARUS}
TIpFileDataProvider.DoGetStreamnull347 function TIpFileDataProvider.DoGetStream(const URL: string): TStream;
348 var
349 FileAddrRec : TIpAddrRec;
350 FN : string;
351 begin
352 Initialize(FileAddrRec);
353 IpParseURL(URL, FileAddrRec);
354 FN := NetToDosPath(FileAddrRec.Path);
355 Result := TMemoryStream.Create;
356 try
357 TMemoryStream(Result).LoadFromFile(UTF8ToSys(FN));
358 except
359 Result.Free;
360 Result:=nil;
361 end;
362 Finalize(FileAddrRec);
363 end;
364 {$ENDIF}
365
366 procedure TIpFileDataProvider.GetImage(Sender : TIpHtmlNode;
367 const URL : string; var Picture : TPicture);
368 var
369 FileAddrRec : TIpAddrRec;
370 Content, FN : string;
371 begin
372 Initialize(FileAddrRec);
373 Picture := nil;
374 IpParseURL(URL, FileAddrRec);
375 FN := NetToDosPath(FileAddrRec.Path);
376 Content := UpperCase(GetLocalContent(FN));
377 if Pos('IMAGE/', Content) > 0 then begin
378 try
379 Picture := TPicture.Create;
380 Picture.LoadFromFile(FN);
381 except
382 on EInvalidGraphic do begin
383 Picture.Free;
384 Picture := nil;
385 end;
386 end;
387 end;
388 Finalize(FileAddrRec);
389 end;
390
391 procedure TIpFileDataProvider.Leave(Html : TIpHtml);
392 begin
393 inherited Leave(Html);
394 { Do Nothing }
395 end;
396
397 procedure TIpFileDataProvider.Reference(const URL : string);
398 begin
399 inherited Reference(URL);
400 { Do Nothing }
401 end;
402
403 procedure Register;
404 begin
405 RegisterComponents('IPro', [TIpFileDataProvider, TIpHTMLDataProvider]);
406 end;
407
408
409 end.
410