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