VPF::Проверка домена и потоки - Форум программистов

navodri

Дата 5.9.2010, 21:54 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 173
Регистрация: 26.10.2007

Репутация: нет
Всего: -1

Я решил проверять подключения к Интернет с помощью проверки доступа к домену. За это отвечает функция CheckUrl. Я поместил ее в поток.
Всё нормально работает, когда есть подключение к Интернет. Но, когда модем (в моем случае ДСЛ, у других, понятно, будет чего-то другое) начинает подключатся к всемирной паутине, программа намертво "зависает".
Где я допустил ошибку? Код прилагается:

Код


program primer;

uses
 Windows, Messages, SysUtils, WinInet, ActiveX;

var
 wc: TWndClassEx;
 MainWnd: HWND;
 Mesg: TMsg;
 ThrID: THandle;

function StartThread(pFunction: TFNThreadStartRoutine; iPriority: Integer; iStartFlag: Integer): THandle;
var
 ThreadID: DWORD;
begin
 Result := CreateThread(nil, 0, pFunction, nil, iStartFlag, ThreadID);
  if Result <> 0 then SetThreadPriority(Result, iPriority);
end;

function CloseThread(ThreadHandle: THandle): Boolean;
begin
 Result := TerminateThread(ThreadHandle, 1);
 CloseHandle(ThreadHandle);
end;

function CheckUrl(url, InetName: string): boolean;
var
 hSession, hfile: hInternet;
 dwindex, dwcodelen :dword;
 dwcode: array[1..20] of char;
 res: pchar;
begin
 Result := false;
 if pos('http://', lowercase(url)) = 0 then url := 'http://' + url;
 hSession := InternetOpen(PChar(InetName), INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
  if assigned(hsession) then begin
   hfile := InternetOpenUrl(hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
   dwIndex  := 0;
   dwCodeLen := 10;
   HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
   res := pchar(@dwcode);
   result:= (res ='200') or (res ='302');
    if assigned(hfile) then
     InternetCloseHandle(hfile);
     InternetCloseHandle(hsession);
  end;
end;

procedure ThreadProc; stdcall;
begin
 CoInitializeEx(nil, COINIT_MULTITHREADED);
  //Если сервер доступен - выводим сообщение
 if CheckUrl('http://www.forum.vingrad.ru/', 'primer') then MessageBox(0,'OK','',0);
 CoUninitialize;
 CloseThread(ThrID);
end;

function WindowProc(wnd: HWND; Msg: Integer; Wparam: Wparam; Lparam: Lparam): Lresult; stdcall;
begin
 Result := 0;
  case msg of
   WM_CREATE:
     begin
      SetTimer(wnd, 666, 1000, nil);
     end;
   WM_TIMER: //Таймер
     case LOWORD(Wparam) of
      666:
       begin
        ThrID := StartThread(@ThreadProc, THREAD_PRIORITY_NORMAL, 0);
       end;
     end;
    WM_DESTROY:
      begin
       KillTimer(wnd, 666);
       postquitmessage(0);
      end;
  else Result := DefWindowProc(wnd, msg, wparam, lparam);
 end;
end;

begin
 wc.cbSize:=sizeof(wc);
 wc.style:=cs_hredraw or cs_vredraw;
 wc.lpfnWndProc:=@WindowProc;
 wc.cbClsExtra:=0;
 wc.cbWndExtra:=0;
 wc.hInstance:=HInstance;
 wc.hIcon:=LoadIcon(0,idi_application);
 wc.hCursor:=LoadCursor(0,idc_arrow);
 wc.hbrBackground:=COLOR_BTNFACE+1;
 wc.lpszMenuName:=nil;
 wc.lpszClassName:='my';
 if RegisterClassEx (wc) = 0 then
  MessageBox (0, 'Invalid class registration', 'Error', MB_OK)
else
  begin
    MainWnd:=CreateWindowEx(0, 'my', 'my', ws_overlappedwindow, 100, 100, 400, 300, 0, 0, Hinstance, nil);
    if MainWnd = 0 then
      MessageBox (0, 'Window not created', 'Error', MB_OK)
    else
      begin
        ShowWindow(MainWnd,CmdShow);
        while GetMessage(Mesg,0,0,0) do
        begin
          TranslateMessage(Mesg);
          DispatchMessage(Mesg);
        end;

      end;
  end;
end.

Пы.Сы. Код является всего лишь фрагментом, выдранным из программы, и перенесенным в отдельное приложение для наглядности.

Matematik

Дата 5.9.2010, 22:48 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1027
Регистрация: 11.3.2006

Репутация: 24
Всего: 50

Поищи в гугле как задавать timeout для функций WinInet

PS

Цитата

result:= (res ='200') or (res ='302');

Не очень надежная проверка. Сервер может отвечать не только этими двумя кодами.

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Сети \| Следующая тема »