source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/EwbUrl.pas@ 800

Last change on this file since 800 was 541, checked in by Kevin Toppenberg, 15 years ago

TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 24.4 KB
RevLine 
[541]1//***********************************************************
2// URL Tools *
3// (Uniform Resource identifier) *
4// *
5// For Borland Delphi *
6// Freeware Unit *
7// by Eran Bodankin - bsalsa - bsalsa@gmail.com *
8// *
9// QueryUrl function is based on Indy algorithm *
10// from: http://www.indyproject.org/ *
11// *
12// Documentation and updated versions: *
13// http://www.bsalsa.com *
14//***********************************************************
15
16{*******************************************************************************}
17{LICENSE:
18THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
19EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
20WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
21YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
22AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
23AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
24OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
25OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
26INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
27OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
28AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
29DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
30
31You may use, change or modify the component under 4 conditions:
321. In your website, add a link to "http://www.bsalsa.com"
332. In your application, add credits to "Embedded Web Browser"
343. Mail me (bsalsa@gmail.com) any code change in the unit
35 for the benefit of the other users.
364. Please, consider donation in our web site!
37{*******************************************************************************}
38//$Id: EwbUrl.pas,v 1 2007/02/15 21:01:42 bsalsa Exp $
39{
40QueryUrl Structure:
41 Protocol + :// + UserName + : + Password + HostName + Port + Path +
42 Document + Parameters+ Bookmark
43
44CrackUrl Structure:
45<Scheme>://<UserName>:<Password>@<HostName>:<PortNumber>/<UrlPath><ExtraInfo>
46 Note by MS:
47(Some fields are optional.) For example, consider this URL:
48http://someone:secret@www.microsoft.com:80/visualc/stuff.htm#contents
49
50CrackUrl parses it as follows:
51* Scheme: "http" or ATL_URL_SCHEME_HTTP
52* UserName: "someone"
53* Password: "secret"
54* HostName: "www.microsoft.com"
55* PortNumber: 80
56* UrlPath: "visualc/stuff.htm"
57* ExtraInfo: "#contents"
58
59URL_COMPONENTS = record that contains:
60 dwStructSize: DWORD; = size of this structure. Used in version check
61 lpszScheme: LPSTR; = pointer to scheme name
62 dwSchemeLength: DWORD; = length of scheme name
63 nScheme: TInternetScheme; = enumerated scheme type (if known)
64 lpszHostName: LPSTR; = pointer to host name
65 dwHostNameLength: DWORD; = length of host name
66 nPort: INTERNET_PORT; = converted port number
67 pad: WORD; = force correct allignment regardless of comp. flags
68 lpszUserName: LPSTR; = pointer to user name
69 dwUserNameLength: DWORD; = length of user name
70 lpszPassword: LPSTR; = pointer to password
71 dwPasswordLength: DWORD; = length of password
72 lpszUrlPath: LPSTR; = pointer to URL-path
73 dwUrlPathLength: DWORD; = length of URL-path
74 lpszExtraInfo: LPSTR; = pointer to extra information (e.g. ?foo or #foo)
75 dwExtraInfoLength: DWORD; = length of extra information
76
77URL_COMPONENTS on MSDN:
78http://msdn2.microsoft.com/en-us/library/aa385420.aspx
79
80CoInternetQueryInfo Function fags:
81http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/moniker/reference/enums/queryoption.asp
82}
83
84unit EwbUrl;
85
86{$I EWB.inc}
87
88{$DEFINE USE_DebugString}
89
90interface
91
92uses
93 Dialogs, Windows, WinInet;
94
95const
96 TEMP_SIZE = 1024;
97 MAX_BUFFER = 256;
98 WebDelim = '/';
99 ProtocolDelim = '://';
100 QueryDelim = '?';
101 BookmarkDelim = '#';
102 EqualDelim = '=';
103 DriveDelim = ':'; //I know it's in SysUtils already but, not in D5.
104type
105 TQueryOption = ULONG;
106 TCoInternetQueryInfo = function(pwzUrl: LPCWSTR; QueryOptions: TQueryOption; dwQueryFlags: DWORD;
107 pvBuffer: Pointer; cbBuffer: DWORD; var pcbBuffer: DWORD; dwReserved: DWORD): HResult; stdcall;
108
109type
110 TOnError = procedure(Sender: TObject; ErrorCode: integer; ErrMessage: string) of object;
111type
112 TUrl = class
113 private
114 FDocument: string;
115 FProtocol: string;
116 FUrl: string;
117 FPort: Integer;
118 FUrlPath: string;
119 FHostName: string;
120 FExtraInfo: string;
121 FUserName: string;
122 FPassword: string;
123 FBookmark: string;
124 FOnError: TOnError;
125 FParameters: string;
126 FUrlComponent: URL_COMPONENTS;
127 CoInternetQueryInfo: TCoInternetQueryInfo;
128 function initCoInternetQueryInfo: boolean;
129 protected
130 procedure SetUrl(const Value: string);
131 procedure FillUrlComponent;
132 public
133 function FixUrl(Url: string): string;
134 function BuildUrl: WideString;
135 function CanonicalizeUrl(const Url: string; dwFlags: integer): WideString;
136 function CombineUrl(const BaseUrl, RelativaUrl: string; dwFlags: DWord): WideString;
137 function CompareUrl(const pwzUrl1, pwzUrl2: WideString): HResult;
138 function CrackUrl(const Url: string; dwFlags: DWord): WideString;
139 function CreateUrl(const dwFlags: DWord): WideString;
140 function EncodeUrl(const InputStr: string; const bQueryStr: Boolean): string;
141 function DecodeUrl(const InputStr: string): string;
142 function IsUrlValid(const Url: string): boolean;
143 function IsUrlCached(const Url: string): boolean;
144 function GetUrlSize(const Url: string): string;
145 function GetUrlType(const Url: string): string;
146 function GetUrlProtocolVersion(const Url: string): string;
147 function GetUrlServerDetails(const Url: string): string;
148 function GetUrlCharSet(const Url: string): string;
149 function GetUrlServer(const Url: string): string;
150 function GetUrlLastModified(const Url: string): string;
151 function GetUrlDate(const Url: string): string;
152 function GetUrlStatusCode(const Url: string): string;
153 function GetUrlEntityTag(const Url: string): string;
154 function QueryInfo(const Url: string; dwInfoFlag: Integer): string;
155 function CoInetQueryInfo(const Url: WideString; QueryOptions: Cardinal): Boolean;
156 function ReadFile(const URL: string; TimeOut: LongWord): string;
157 procedure Clear;
158 procedure ClearUrlComponent;
159 procedure QueryUrl(Url: string);
160 constructor Create(const Url: string); overload;
161 public
162 property Bookmark: string read FBookmark write FBookmark;
163 property Document: string read FDocument write FDocument;
164 property ExtraInfo: string read FExtraInfo write FExtraInfo;
165 property HostName: string read FHostName write FHostName;
166 property Parameters: string read FParameters write FParameters;
167 property Password: string read FPassword write FPassword;
168 property Port: Integer read FPort write FPort;
169 property Protocol: string read FProtocol write FProtocol;
170 property OnError: TOnError read FOnError write FOnError;
171 property Url: string read FUrl write SetUrl;
172 property UrlComponent: URL_COMPONENTS read FUrlComponent write FUrlComponent;
173 property UrlPath: string read FUrlPath write FUrlPath;
174 property UserName: string read FUserName write FUserName;
175 end;
176
177implementation
178
179uses
180 EwbCoreTools, SysUtils, Forms, IEConst;
181
182constructor TUrl.Create(const Url: string);
183begin
184 if Length(Url) > 0 then
185 FUrl := Url;
186end;
187
188procedure TUrl.SetUrl(const Value: string);
189begin
190 if Length(Value) > 0 then
191 QueryUrl(Value);
192end;
193
194//==============================================================================
195
196procedure TUrl.Clear;
197begin
198 FBookmark := '';
199 FHostName := '';
200 FProtocol := '';
201 FUrlPath := '';
202 FDocument := '';
203 FPort := 80;
204 FExtraInfo := '';
205 FUserName := '';
206 FPassword := '';
207 FParameters := '';
208 ClearUrlComponent;
209end;
210
211procedure TUrl.ClearUrlComponent;
212begin
213 with FUrlComponent do
214 begin
215 lpszScheme := nil;
216 lpszHostName := nil;
217 lpszUrlPath := nil;
218 lpszUserName := nil;
219 lpszPassword := nil;
220 lpszExtraInfo := nil;
221 end;
222end;
223
224procedure TUrl.FillUrlComponent;
225begin
226 ClearUrlComponent;
227 with FUrlComponent do
228 begin
229 dwStructSize := SizeOf(URL_COMPONENTS);
230 if FProtocol <> '' then
231 begin
232 lpszScheme := PChar(FProtocol);
233 dwSchemeLength := Length(FProtocol);
234 end
235 else
236 lpszScheme := nil;
237 if FHostName <> '' then
238 begin
239 lpszHostName := PChar(FHostName);
240 dwHostNameLength := Length(PChar(FHostName));
241 end
242 else
243 lpszHostName := nil;
244 if FUrlPath <> '' then
245 begin
246 lpszUrlPath := PChar(FUrlPath);
247 dwUrlPathLength := Length(FUrlPath);
248 end
249 else
250 lpszUrlPath := nil;
251 if FUserName <> '' then
252 begin
253 lpszUserName := PChar(FUserName);
254 dwUserNameLength := Length(FUserName);
255 end
256 else
257 lpszUserName := nil;
258 if FPassword <> '' then
259 begin
260 lpszPassword := PChar(FPassword);
261 dwPasswordLength := Length(FPassword);
262 end
263 else
264 lpszPassword := nil;
265 if FExtraInfo = '' then
266 FExtraInfo := FDocument + FParameters;
267 if FBookmark <> '' then
268 FExtraInfo := FExtraInfo + BookmarkDelim + FBookmark;
269 if FExtraInfo <> '' then
270 begin
271 lpszExtraInfo := PChar(FExtraInfo);
272 dwExtraInfoLength := Length(FExtraInfo);
273 end
274 else
275 lpszExtraInfo := nil;
276 if (FPort = 0) then
277 nPort := FPort;
278{$IFDEF DELPHI6_UP}
279 pad := 1; //force correct allignment regardless of comp. flags
280{$ENDIF}
281 end;
282end;
283
284function TUrl.initCoInternetQueryInfo: boolean;
285var
286 lh: HMODULE;
287begin
288 Result := False;
289 CoInternetQueryInfo := nil;
290 lh := loadlibrary('URLMON.DLL');
291 if lh = 0 then
292 Exit;
293 CoInternetQueryInfo := GetProcAddress(lh, 'CoInternetQueryInfo');
294 Result := (@CoInternetQueryInfo) <> nil;
295end;
296
297procedure TUrl.QueryUrl(Url: string);
298var
299 TmpStr: string;
300 IdxPos, CharPos: Integer;
301begin
302 Clear;
303 Url := FixUrl(Url);
304 FormatPath(Url);
305 IdxPos := AnsiPos(ProtocolDelim, Url);
306 if IdxPos > 0 then
307 begin
308 FProtocol := Copy(Url, 1, IdxPos - 1);
309 Delete(Url, 1, IdxPos + 2);
310 TmpStr := CutString(Url, WebDelim, True);
311 IdxPos := AnsiPos('@', TmpStr);
312 FPassword := Copy(TmpStr, 1, IdxPos - 1);
313 if IdxPos > 0 then
314 Delete(TmpStr, 1, IdxPos);
315 FUserName := CutString(FPassword, DriveDelim, True);
316 if Length(FUserName) = 0 then
317 begin
318 FPassword := '';
319 end;
320 if (AnsiPos('[', TmpStr) > 0) and (AnsiPos(']', TmpStr) > AnsiPos('[', TmpStr)) then
321 begin
322 FHostName := CutString(TmpStr, ']');
323 CutString(FHostName, '[');
324 CutString(TmpStr, DriveDelim);
325 end
326 else
327 begin
328 FHostName := CutString(TmpStr, DriveDelim, True);
329 end;
330 FPort := StrToIntDef(TmpStr, 80);
331 CharPos := AnsiPos(QueryDelim, Url);
332 if CharPos > 0 then
333 begin
334 IdxPos := GetPos(WebDelim, Url, CharPos);
335 end
336 else
337 begin
338 CharPos := AnsiPos(EqualDelim, Url);
339 if CharPos > 0 then
340 begin
341 IdxPos := GetPos(WebDelim, Url, CharPos);
342 end
343 else
344 begin
345 IdxPos := GetPos(WebDelim, Url, -1);
346 end;
347 end;
348 FUrlPath := WebDelim + Copy(Url, 1, IdxPos);
349 if CharPos > 0 then
350 begin
351 FDocument := Copy(Url, 1, CharPos - 1);
352 Delete(Url, 1, CharPos - 1);
353 FParameters := Url;
354 end
355 else
356 FDocument := Url;
357 Delete(FDocument, 1, IdxPos);
358 FBookmark := FDocument;
359 FDocument := CutString(FBookmark, BookmarkDelim);
360 end
361 else
362 begin
363 CharPos := AnsiPos(QueryDelim, Url);
364 if CharPos > 0 then
365 begin
366 IdxPos := GetPos(WebDelim, Url, CharPos);
367 end
368 else
369 begin
370 CharPos := AnsiPos(EqualDelim, Url);
371 if CharPos > 0 then
372 begin
373 IdxPos := GetPos(WebDelim, Url, CharPos);
374 end
375 else
376 begin
377 IdxPos := GetPos(WebDelim, Url, -1);
378 end;
379 end;
380 FUrlPath := Copy(Url, 1, IdxPos);
381 if CharPos > 0 then
382 begin
383 FDocument := Copy(Url, 1, CharPos - 1);
384 Delete(Url, 1, CharPos - 1);
385 FParameters := Url;
386 end
387 else
388 begin
389 FDocument := Url;
390 end;
391 Delete(FDocument, 1, IdxPos);
392 end;
393 if FBookmark = '' then
394 begin
395 FBookmark := FParameters;
396 FParameters := CutString(FBookmark, BookmarkDelim);
397 end;
398 FillUrlComponent;
399end;
400
401function TUrl.CrackUrl(const Url: string; dwFlags: DWord): WideString;
402var
403 Buffers: array[0..5, 0..MAX_BUFFER - 1] of Char;
404 bResult: boolean;
405begin
406 Clear;
407 FUrl := FixUrl(Url);
408 ZeroMemory(@FUrlComponent, SizeOf(URL_COMPONENTS));
409 with FUrlComponent do
410 begin
411 dwStructSize := SizeOf(URL_COMPONENTS);
412 dwSchemeLength := INTERNET_MAX_SCHEME_LENGTH;
413 lpszScheme := Buffers[0];
414 dwHostNameLength := INTERNET_MAX_HOST_NAME_LENGTH;
415 lpszHostName := Buffers[1];
416 dwUserNameLength := INTERNET_MAX_USER_NAME_LENGTH;
417 lpszUserName := Buffers[2];
418 dwPasswordLength := INTERNET_MAX_PASSWORD_LENGTH;
419 lpszPassword := Buffers[3];
420 dwUrlPathLength := INTERNET_MAX_PATH_LENGTH;
421 lpszUrlPath := Buffers[4];
422 dwExtraInfoLength := INTERNET_MAX_URL_LENGTH;
423 lpszExtraInfo := Buffers[5];
424 end;
425 bResult := InternetCrackURL(PChar(Url), 0, dwFlags, FUrlComponent);
426 if bResult then
427 begin
428 with FUrlComponent do
429 begin
430 FHostName := lpszHostName;
431 FProtocol := lpszScheme;
432 FUrlPath := lpszUrlPath;
433 FPort := nPort;
434 FExtraInfo := lpszExtraInfo;
435 FUserName := lpszUserName;
436 FPassword := lpszPassword;
437 Result := Url;
438 end;
439 end
440 else
441 begin
442 Clear;
443 if Assigned(FOnError) then
444 FOnError(Self, GetLastError, SysErrorMessage(GetLastError));
445{$IFDEF USE_DebugString}
446 OutputDebugString(PChar(SysErrorMessage(GetLastError)));
447{$ENDIF}
448 Result := '';
449 end;
450end;
451
452function TUrl.CombineUrl(const BaseUrl, RelativaUrl: string; dwFlags: DWord): WideString;
453var
454 Buffer: array[0..255] of Char;
455 Size: DWORD;
456 bResult: boolean;
457begin
458 Size := SizeOf(Buffer);
459 bResult := InternetCombineUrl(PChar(BaseUrl), PChar(RelativaUrl),
460 Buffer, Size, dwFlags);
461 if bResult then
462 begin
463 Result := Buffer;
464 FUrl := Result;
465 end
466 else
467 begin
468 if Assigned(FOnError) then
469 FOnError(Self, GetLastError, SysErrorMessage(GetLastError));
470{$IFDEF USE_DebugString}
471 OutputDebugString(PChar(SysErrorMessage(GetLastError)));
472{$ENDIF}
473 Result := '';
474 end;
475
476end;
477
478function TUrl.CanonicalizeUrl(const Url: string; dwFlags: integer): WideString;
479var
480 Buffer: array[0..255] of Char;
481 Size: DWORD;
482 bResult: boolean;
483begin
484 Size := SizeOf(Buffer);
485 bResult := InternetCanonicalizeUrl(PChar(Url), Buffer, Size, dwFlags);
486 if bResult then
487 begin
488 Result := Buffer;
489 FUrl := Result;
490 end
491 else
492 begin
493 if Assigned(FOnError) then
494 FOnError(Self, GetLastError, SysErrorMessage(GetLastError));
495{$IFDEF USE_DebugString}
496 OutputDebugString(PChar(SysErrorMessage(GetLastError)));
497{$ENDIF}
498 Result := '';
499 end;
500end;
501
502function TUrl.CreateUrl(const dwFlags: DWord): WideString;
503var
504 Size: DWORD;
505 Buffer: array[0..511] of Char;
506 bResult: boolean;
507begin
508 FillUrlComponent;
509 Size := FUrlComponent.dwStructSize;
510 bResult := InternetCreateUrl(FUrlComponent, dwFlags, Buffer, Size);
511 if bResult then
512 begin
513 Result := Buffer;
514 FUrl := Result;
515 end
516 else
517 begin
518{$IFDEF USE_DebugString}
519 OutputDebugString(PChar(SysErrorMessage(GetLastError)));
520{$ENDIF}
521 if Assigned(FOnError) then
522 FOnError(Self, GetLastError, SysErrorMessage(GetLastError));
523 end;
524end;
525
526function TUrl.FixUrl(Url: string): string;
527
528 function AnsiEndsStr(const ASubText, AText: string): Boolean;
529 var
530 SubTextLocation: Integer;
531 begin
532 SubTextLocation := Length(AText) - Length(ASubText) + 1;
533 if (SubTextLocation > 0) and (ASubText <> '') and
534 (ByteType(AText, SubTextLocation) <> mbTrailByte) then
535 Result := AnsiStrComp((PChar(ASubText)), Pointer(@AText[SubTextLocation])) = 0
536 else
537 Result := False;
538 end;
539var
540 DotPos, ipos: Integer;
541begin
542 Result := Url;
543 if not AnsiEndsStr('/', Url) then
544 begin
545 ipos := LastDelimiter('/', Url);
546 DotPos := LastDelimiter('.', Url);
547 if DotPos < ipos then
548 Result := Url + '/';
549 end;
550end;
551
552function TUrl.EncodeURL(const InputStr: string; const bQueryStr: Boolean): string;
553var
554 Idx: Integer;
555begin
556 Result := '';
557 for Idx := 1 to Length(InputStr) do
558 begin
559 case InputStr[Idx] of
560 'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.':
561 Result := Result + InputStr[Idx];
562 ' ':
563 if bQueryStr then
564 Result := Result + '+'
565 else
566 Result := Result + '%20';
567 else
568 Result := Result + '%' + SysUtils.IntToHex(Ord(InputStr[Idx]), 2);
569 end;
570 end;
571end;
572
573function TUrl.DecodeUrl(const InputStr: string): string;
574var
575 Idx: Integer;
576 Hex: string;
577 Code: Integer;
578begin
579 Result := '';
580 Idx := 1;
581 while Idx <= Length(InputStr) do
582 begin
583 case InputStr[Idx] of
584 '%':
585 begin
586 if Idx <= Length(InputStr) - 2 then
587 begin
588 Hex := InputStr[Idx + 1] + InputStr[Idx + 2];
589 Code := SysUtils.StrToIntDef('$' + Hex, -1);
590 Inc(Idx, 2);
591 end
592 else
593 Code := -1;
594 if Code = -1 then
595 raise SysUtils.EConvertError.Create('Invalid hex digit in URL');
596 Result := Result + Chr(Code);
597 end;
598 '+':
599 Result := Result + ' '
600 else
601 Result := Result + InputStr[Idx];
602 end;
603 Inc(Idx);
604 end;
605end;
606
607function TUrl.BuildUrl: WideString;
608begin
609 FillUrlComponent;
610 if (FProtocol = '') or (FHostName = '') then
611 begin
612 if Assigned(FOnError) then
613 FOnError(Self, 0, 'Can not Create Url. Protocol or HostName are not valid!');
614{$IFDEF USE_DebugString}
615 OutputDebugString('Can not Create Url. Protocol or HostName are not valid!');
616{$ENDIF}
617 Exit;
618 end;
619 Result := FProtocol + ProtocolDelim;
620 if (FUserName <> '') then
621 begin
622 Result := Result + FUserName;
623 if FPassword <> '' then
624 begin
625 Result := Result + DriveDelim + FPassword;
626 end;
627 Result := Result + '@';
628 end;
629 Result := Result + FHostName;
630 if (FPort <> 0) and (FPort <> 80) then
631 begin
632 Result := Result + DriveDelim + IntToStr(FPort);
633 end;
634 Result := Result + FUrlPath + FDocument + FParameters;
635 if (FBookmark <> '') then
636 begin
637 Result := Result + BookmarkDelim + FBookmark;
638 end;
639end;
640
641function TUrl.CompareUrl(const pwzUrl1, pwzUrl2: WideString): HResult;
642begin
643 if (pwzUrl1 = '') or (pwzUrl2 = '') then
644 begin
645{$IFDEF USE_DebugString}
646 OutputDebugString('Can not Compare Url. pwzUrl1 or pwzUrl2 are empty!');
647{$ENDIF}
648 if Assigned(FOnError) then
649 FOnError(Self, 0, 'Can not Compare Url. pwzUrl1 or pwzUrl2 are empty!');
650 end;
651 Result := AnsiCompareText(pwzUrl1, pwzUrl2);
652end;
653
654function TUrl.CoInetQueryInfo(const Url: WideString; QueryOptions: Cardinal): boolean;
655var
656 pcbBuffer: DWORD;
657 dwCached: DWORD;
658begin
659 if not initCoInternetQueryInfo then
660 begin
661 Result := False;
662 Exit;
663 end;
664 pcbBuffer := SizeOf(dwCached);
665 if CoInternetQueryInfo(PWideChar(Url), QueryOptions, 0, @dwCached,
666 SizeOf(dwCached), pcbBuffer, 0) <> S_OK then
667 begin
668 if Assigned(FOnError) then
669 FOnError(Self, GetLastError, SysErrorMessage(GetLastError));
670{$IFDEF USE_DebugString}
671 OutputDebugString(PChar(SysErrorMessage(GetLastError)));
672{$ENDIF}
673 end;
674 Result := dwCached <> 0;
675end;
676
677function TUrl.QueryInfo(const Url: string; dwInfoFlag: Integer): string;
678var
679 hInet: HINTERNET;
680 hConnect: HINTERNET;
681 infoBuffer: array[0..512] of char;
682 dummy: DWORD;
683 bufLen: DWORD;
684 ok: LongBool;
685begin
686 hInet := InternetOpen(PChar(Forms.Application.Title),
687 INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY, nil, nil, 0);
688 hConnect := InternetOpenUrl(hInet, PChar(Url), nil, 0, INTERNET_FLAG_NO_UI, 0);
689 if not Assigned(hConnect) then
690 begin
691 if Assigned(FOnError) then
692 FOnError(Self, GetLastError, SysErrorMessage(GetLastError));
693{$IFDEF USE_DebugString}
694 OutputDebugString(PChar(SysErrorMessage(GetLastError)));
695{$ENDIF}
696 Result := '';
697 end
698 else
699 begin
700 dummy := 0;
701 bufLen := Length(infoBuffer);
702 ok := HttpQueryInfo(hConnect, dwInfoFlag, @infoBuffer[0], bufLen, dummy);
703 if ok then
704 Result := infoBuffer
705 else
706 Result := '';
707 InternetCloseHandle(hConnect);
708 end;
709 InternetCloseHandle(hInet);
710end;
711
712function TUrl.ReadFile(const URL: string; TimeOut: LongWord): string;
713var
714 hInet: HInternet;
715 hConnect: HInternet;
716 infoBuffer: array[0..TEMP_SIZE - 1] of Char;
717 iRead, iTimeOut: DWORD;
718 strRead: string;
719begin
720 strRead := '';
721 hInet := InternetOpen(PChar(Forms.Application.Title), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, INTERNET_FLAG_NO_CACHE_WRITE);
722 if Assigned(hInet) then
723 begin
724 InternetQueryOption(hInet, INTERNET_OPTION_CONNECT_TIMEOUT, @iTimeOut, iRead);
725 iTimeOut := TimeOut;
726 InternetSetOption(hInet, INTERNET_OPTION_CONNECT_TIMEOUT, @iTimeOut, iRead);
727 try
728 hConnect := InternetOpenURL(hInet, PChar(Url), nil, 0, 0, 0);
729 if Assigned(hConnect) then
730 try
731 repeat
732 FillChar(infoBuffer, SizeOf(infoBuffer), #0);
733 InternetReadFile(hConnect, @infoBuffer, sizeof(infoBuffer), iRead);
734 strRead := strRead + string(infoBuffer);
735 until iRead < TEMP_SIZE;
736 finally
737 InternetCloseHandle(hConnect);
738 end
739 else
740 begin
741 if Assigned(FOnError) then
742 FOnError(Self, GetLastError, SysErrorMessage(GetLastError));
743{$IFDEF USE_DebugString}
744 OutputDebugString(PChar(SysErrorMessage(GetLastError)));
745{$ENDIF}
746 Result := '';
747 end;
748 finally
749 InternetCloseHandle(hInet);
750 end;
751 Result := strRead;
752 end
753 else
754 begin
755 if Assigned(FOnError) then
756 FOnError(Self, GetLastError, SysErrorMessage(GetLastError));
757{$IFDEF USE_DebugString}
758 OutputDebugString(PChar(SysErrorMessage(GetLastError)));
759{$ENDIF}
760 Result := '';
761 end;
762end;
763
764function TUrl.IsUrlValid(const Url: string): boolean;
765var
766 Reply: string;
767begin
768 Reply := QueryInfo(Url, HTTP_QUERY_STATUS_CODE);
769 if (Reply = '200') or (Reply = '401') then
770 Result := True
771 else
772 Result := False;
773end;
774
775function TUrl.GetUrlSize(const Url: string): string;
776begin
777 Result := QueryInfo(Url, HTTP_QUERY_CONTENT_LENGTH);
778end;
779
780function TUrl.GetUrlType(const Url: string): string;
781begin
782 Result := QueryInfo(Url, HTTP_QUERY_CONTENT_TYPE);
783end;
784
785function TUrl.GetUrlDate(const Url: string): string;
786begin
787 Result := QueryInfo(Url, HTTP_QUERY_DATE);
788end;
789
790function TUrl.GetUrlLastModified(const Url: string): string;
791begin
792 Result := QueryInfo(Url, HTTP_QUERY_LAST_MODIFIED);
793end;
794
795function TUrl.GetUrlStatusCode(const Url: string): string;
796begin
797 Result := QueryInfo(Url, HTTP_QUERY_STATUS_CODE);
798end;
799
800function TUrl.GetUrlServer(const Url: string): string;
801begin
802 Result := QueryInfo(Url, HTTP_QUERY_SERVER);
803end;
804
805function TUrl.GetUrlEntityTag(const Url: string): string;
806begin
807 Result := QueryInfo(Url, HTTP_QUERY_ETAG);
808end;
809
810function TUrl.GetUrlCharset(const Url: string): string;
811begin
812 Result := QueryInfo(Url, HTTP_QUERY_ACCEPT_CHARSET);
813end;
814
815function TUrl.GetUrlServerDetails(const Url: string): string;
816begin
817 Result := QueryInfo(Url, HTTP_QUERY_RAW_HEADERS_CRLF);
818end;
819
820function TUrl.GetUrlProtocolVersion(const Url: string): string;
821begin
822 Result := QueryInfo(Url, HTTP_QUERY_VERSION);
823end;
824
825function TUrl.IsUrlCached(const Url: string): boolean;
826begin
827 Result := CoInetQueryInfo(Url, QUERY_IS_CACHED);
828end;
829{=====================================================================================}
830
831end.
Note: See TracBrowser for help on using the repository browser.