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

sssssss7

Дата 12.3.2009, 07:40 (ссылка)

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

Загрузка ...

Шустрый

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

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

при любом url выдает false... пользуюсь Дельфи2009 есть подозрение что это все из за юникода... пробывал ставить за место char AnsiChar не помогает... значение переменной infoBuffe набор символов... Помогите разобратся....

Код


function IsUrlValid(const url: string): boolean;
var
  hInet: HINTERNET;
  hConnect: HINTERNET;
  infoBuffer: array [0..512] of char;
  dummy: DWORD;
  bufLen: DWORD;
  okay: LongBool;
  reply: String;
begin
    hInet := InternetOpen(PChar(application.title),INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY,nil,nil,0);
    hConnect := InternetOpenUrl(hInet,PChar(url),nil,0,INTERNET_FLAG_NO_UI,0);
  if not Assigned(hConnect) then
    result := false
  else
  begin
    dummy := 0;
    bufLen := Length(infoBuffer);
    okay := HttpQueryInfo(hConnect,HTTP_QUERY_STATUS_CODE,@infoBuffer[0],bufLen,dummy);
    if not okay then
      // Probably working offline, or no internet connection.
      result := False
    else
    begin
      reply := infoBuffer;
      if reply = '200' then
        // File exists, all ok.
        result := True
      else if reply = '401' then
        // Not authorised. Assume page exists,
        // but we can't check it.
        result := True
      else if reply = '404' then
        // No such file.
        result := False
      else if reply = '500' then
        // Internal server error.
        result := False
      else
        // Shouldn't get here! It means there is
        // a status code left unhandled.
        result := False;
    end;
    InternetCloseHandle(hConnect);
  end;
  InternetCloseHandle(hInet);
end;

sssssss7

Дата 12.3.2009, 09:45 (ссылка)

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

Загрузка ...

Шустрый

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

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

Весь инет завален этой функцией

Код


function CheckUrl(url: String): boolean;
var hSession, hfile: hInternet;
    dwindex, dwcodelen: dword;
    dwcode: array [1..20] of widechar;
    res: PChar;
begin
    if pos('http', lowercase(url)) = 0 then
        url := 'http://'+url;
    Result := false;
    hSession := InternetOpen(pwidechar(application.exename), PRE_CONFIG_INTERNET_ACCESS, nil, nil, 0);
    if assigned(hsession) then
    begin
        hfile :=InternetOpenURL(hSession,PChar(url),nil,0,0,0);
        dwIndex := 0;
        dwCodeLen := 10;
        HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
        form1.Memo1.Lines.Add(dwcode);
        res := PChar(@dwcode);
        result := (res = '200') or (res = '302');
        if assigned(hfile) then
            InternetCloseHandle(hfile);
        InternetCloseHandle(hsession);
    end;
end;

в делфи 7 работает как по маслу.. в 2009 не хочет... постоянно false smile

в чем причина???? кто подскажит рабочий на 2009 код проверки линка

Это сообщение отредактировал(а) sssssss7 - 12.3.2009, 09:46

MetalFan

Дата 12.3.2009, 13:11 (ссылка)

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

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128

тут два варианта - либо адаптировать функцию так, чтобы она вызывала и использовала однобайтовые строки и вызывала нужные функции, либо переделывать на двухбайтовые строки.
но сначала убедиться, какие функции реально вызываются (InternetXXX) - с расширением A или W. по идее должны уже с W.
2009й под рукой нет, проверить не могу.

счас перепишу на вайдстринги. вообще код какойто бредовый "распространен в интернете"

Это сообщение отредактировал(а) MetalFan - 12.3.2009, 13:15

--------------------

There are always someone smarter than you...

MetalFan

Дата 12.3.2009, 13:29 (ссылка)

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

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128

вот, переделал на вайдстринги и довел до ума. должно работать в любой версии делфи.

Код


function CheckUrl( AURL: WideString ): Boolean;
const
  C_CLIENT: WideString = 'checkurl';
  C_HTTP_W : WideString = 'http';
  C_ADD_W: WideString = '://';
var
  lSession,
  lFile: hInternet;
  lBuf,
  lLen,
  lIdx: DWORD;
begin
  if Pos( C_HTTP_W, WideLowerCase( AURL ) ) <> 1 then
    AURL := C_HTTP_W + C_ADD_W + AURL;
  Result := False;
  lSession := InternetOpenW( PWideChar(C_CLIENT), PRE_CONFIG_INTERNET_ACCESS, nil, nil, 0);
  if Assigned(lSession) then
  try
    lFile :=InternetOpenURLW( lSession, PWideChar(AURL), nil, 0 , INTERNET_FLAG_RELOAD, 0);
    if Assigned( lFile ) then
    try
      lIdx := 0;
      lLen := SizeOf(lBuf);
      if HttpQueryInfoW( lFile, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @lBuf, lLen, lIdx) then
        Result := (lBuf = 200) or (lBuf = 302);
    finally
      InternetCloseHandle( lFile )
    end;
  finally
    InternetCloseHandle(lSession);
  end;
end;

--------------------

There are always someone smarter than you...

sssssss7

Дата 12.3.2009, 14:15 (ссылка)

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

Загрузка ...

Шустрый

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

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

yandex.ru и google.com у меня почему то lFile=nil...

Это сообщение отредактировал(а) sssssss7 - 12.3.2009, 14:19

MetalFan

Дата 12.3.2009, 14:52 (ссылка)

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

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128

а интернет в системе настроен корректно?
у меня данный код отрабатывает на ура. правда д2006.

--------------------

There are always someone smarter than you...

sssssss7

Дата 12.3.2009, 14:58 (ссылка)

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

Загрузка ...

Шустрый

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

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

в коде я не сомниваюсь... вот только не пойму почему у меня не работает.. пробывал на дельфи 7 и 2009... а интернет в системе настроен норм.. файрволы и антивир отключены, подключение vpn... другие компоненты тот же idFTP работает норм.. мистика)

Это сообщение отредактировал(а) sssssss7 - 12.3.2009, 15:05

MetalFan

Дата 12.3.2009, 15:10 (ссылка)

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

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128

а попробуй вместо PRE_CONFIG_INTERNET_ACCESS вписать INTERNET_OPEN_TYPE_DIRECT... даже и не знаю, что еще можно предположить...
ай торможу! есть же GetLastError. попробуй такой код:

Код


var
  gLastError: string;

function InternetGetLastError(): WideString;
var
  lLen: dword;
  lErr: dword;
begin
  Result := '';
  lErr := 0;
  lLen := 1000;
  lErr := GetLastError;
  if lErr = ERROR_INTERNET_EXTENDED_ERROR  then
  begin
    SetLength( Result, lLen );
    if InternetGetLastResponseInfoW( lErr, PWideChar( Result ), lLen) then
      SetLength( Result, lLen )
    else
      Result := '';
  end
  else
    Result := 'Error:'+IntToStr(lErr)+' Text:'+ SysErrorMessage( lErr );
end;

function CheckUrl( AURL: WideString ): Boolean;
const
  C_CLIENT: WideString = 'checkurl';
  C_HTTP_W : WideString = 'http';
  C_ADD_W: WideString = '://';
var
  lSession,
  lFile: hInternet;
  lBuf,
  lLen,
  lIdx: DWORD;
begin
  if Pos( C_HTTP_W, WideLowerCase( AURL ) ) <> 1 then
    AURL := C_HTTP_W + C_ADD_W + AURL;
  Result := False;
  gLastError := '';
  lSession := InternetOpenW( PWideChar(C_CLIENT), PRE_CONFIG_INTERNET_ACCESS, nil, nil, 0);
  if not Assigned(lSession) then
    gLastError := InternetGetLastError
  else
  try
    lFile :=InternetOpenURLW( lSession, PWideChar(AURL), nil, 0 , INTERNET_FLAG_RELOAD, 0);
    if not Assigned( lFile ) then
      gLastError := InternetGetLastError
    else
    try
      lIdx := 0;
      lLen := SizeOf(lBuf);
      if HttpQueryInfoW( lFile, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @lBuf, lLen, lIdx) then
        Result := (lBuf = 200) or (lBuf = 302)
      else
        gLastError := InternetGetLastError
    finally
      InternetCloseHandle( lFile )
    end;
  finally
    InternetCloseHandle(lSession);
  end;
end;

ну и соотв. что там в gLastError попало?

Это сообщение отредактировал(а) MetalFan - 12.3.2009, 15:29

--------------------

There are always someone smarter than you...

sssssss7

Дата 12.3.2009, 15:24 (ссылка)

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

Загрузка ...

Шустрый

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

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

Ура заработала) MetalFan ты с большой буквы "Э" Эксперт... спасибо огромнейшее спас человека от нервоного истощения а компьютер от палета с балкона smile

ток вот еще что заметил... очень долгий timeout соединения при отключеном интернете где то сек 20-30..

кстати почему заработала не пойму.. ща буду ломать))

Это сообщение отредактировал(а) sssssss7 - 12.3.2009, 15:26

MetalFan

Дата 12.3.2009, 15:30 (ссылка)

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

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128

обновил код в предыдущем посте. посмотри, что в gLastError попадает, когда функция False возвращает...

--------------------

There are always someone smarter than you...

sssssss7

Дата 12.3.2009, 15:54 (ссылка)

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

Загрузка ...

Шустрый

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

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

false... lErr=12007 text=''

Это сообщение отредактировал(а) sssssss7 - 12.3.2009, 16:02

MetalFan

Дата 12.3.2009, 16:12 (ссылка)

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

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128

ERROR_INTERNET_NAME_NOT_RESOLVED
12007
The server name could not be resolved.

видимо либо DNS висит, либо до него трудно достучаться

--------------------

There are always someone smarter than you...

sssssss7

Дата 12.3.2009, 16:18 (ссылка)

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

Загрузка ...

Шустрый

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

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

yandex.ru, google.com, mastehost.ru... не висят точно да и захожу на них норм.. грузятся быстро... кстати опять не работает(не долго радовался smile

) и всё таже ошибка 12007 ... вообще не догоняю почему

Код


 lFile :=InternetOpenURLW( lSession, PWideChar(AURL), nil, 0 , INTERNET_FLAG_RELOAD, 0);

возвращает nil, интерет работает все просто летает...

Это сообщение отредактировал(а) sssssss7 - 12.3.2009, 16:36

sssssss7

Дата 12.3.2009, 17:28 (ссылка)

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

Загрузка ...

Шустрый

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

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

вывод один проблема с сеткой... MetalFan еще раз спасибо за код, реально понравился так как я новичок в winapi мне еще до такого далеко smile

... теперь думаю он будет гулять по инету smile

проблема решена ставьте галочку... тока вот думаю для проверки связи с нетом она не особо годится так как очень долгий timeout попытки соединения когда нет сети... около 30 -40 сек... с замерзанием формы... smile

Это сообщение отредактировал(а) sssssss7 - 12.3.2009, 17:31

MetalFan

Дата 12.3.2009, 18:21 (ссылка)

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

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 14
Всего: 128

Цитата(sssssss7 @ 12.3.2009, 17:28

)

тока вот думаю для проверки связи с нетом она не особо годится так как очень долгий timeout попытки соединения когда нет сети

можно использовать асинхронный режим вызова функций WinInet, или запихнуть все это в поток.
вот кстати окончательный вариант проверки URL с проверкой в синхронном режиме:

Код


function InternetCheckUrl( AURL: WideString;
                           AHTTPStatus: PDWORD = nil;
                           AConnectTimeout: Cardinal = INFINITE;
                           ARecieveTimeout: Cardinal = INFINITE;
                           ASendTimeout: Cardinal = INFINITE ): Integer;
const
  C_CLIENT: WideString = 'checkurl';
  C_HTTP_W : WideString = 'http';
  C_ADD_W: WideString = '://';
var
  lSession,
  lFile: hInternet;
  lBuf,
  lLen,
  lIdx: DWORD;
begin
  if Pos( C_HTTP_W, WideLowerCase( AURL ) ) <> 1 then
    AURL := C_HTTP_W + C_ADD_W + AURL;
  Result := -1;
  lSession := InternetOpenW( PWideChar(C_CLIENT), PRE_CONFIG_INTERNET_ACCESS, nil, nil, 0);
  if not Assigned(lSession) then
    Result := GetLastError
  else
  try
    if InternetSetOption( lSession, INTERNET_OPTION_CONNECT_TIMEOUT, @AConnectTimeOut, SizeOf(Cardinal) ) and
       InternetSetOption( lSession, INTERNET_OPTION_RECEIVE_TIMEOUT, @ARecieveTimeOut, SizeOf(Cardinal) ) and
       InternetSetOption( lSession, INTERNET_OPTION_SEND_TIMEOUT, @ASendTimeout, SizeOf(Cardinal) ) then
    begin
      lFile :=InternetOpenURLW( lSession, PWideChar(AURL), nil, 0 , INTERNET_FLAG_RELOAD, 0);
      if not Assigned( lFile ) then
        Result := GetLastError
      else
      try
        lIdx := 0;
        lLen := SizeOf(lBuf);
        if not Assigned( AHTTPStatus ) then
          AHTTPStatus := @lBuf;
        if not HttpQueryInfoW( lFile, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, AHTTPStatus, lLen, lIdx) then
          Result := GetLastError
        else
        if (AHTTPStatus^ = 200 ) or (AHTTPStatus^ = 302 ) then
          Result := 0 //если все ОК, то обнулим результат;
      finally
        InternetCloseHandle( lFile )
      end;
    end;
  finally
    InternetCloseHandle(lSession);
  end;
end;

Как пользоваться:
AURL - соотв ссылка, которую проверяем.
AHTTPStatus - HTTP статус запрошенной странички на сервере.
AConnectTimeout,
ARecieveTimeout,
ASendTimeout - соответственно таймауты на подключение, чтение и посылку данных. по умолчанию - бесконечность.
Result функции будут следующие:
-1: запрос по адресу странички выдал HTTP Status Code <> 200 или 302. если был передан указатель на DWORD вторым параметром, то по его адресу можно прочитать собственно выданный сервером статус.
0: Все нормально, сервер существует и вернул HTTP Status Code равным 200 или 302.
>0: ошибка произошла при вызове функций WinInet. результат работы GetLastError. для получения текстового представления (не для всех ошибок) можно вызвать SysErrorMessage для получения текста с сообщением об ошибке.

единственный косяк в функции, который сразу заметен, это разные типы Result'а функции и типа, возвращаемого GetLastError...
з.ы. можно сделать и асинхронный вариант проверки...

--------------------

There are always someone smarter than you...

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