forum.clarionlife.net

Код: Выделить всё

GetStrHTTP           PROCEDURE  (xURL_,xPar_,xUser_,xPass_,xRequest_,xAnswer_,UShort xIndicator_ = 0) ! ,&String
TCurlHTTPClassEx  Class(TCurlHTTPClass),Type
XFerInfo            PROCEDURE(REAL dltotal, REAL dlnow, REAL ultotal, REAL ulnow), LONG, PROC, VIRTUAL
                  end

MyCurl          TCurlHTTPClassEx  !TCurlHttpClass
Loc:Res         CURLcode

Loc:RespBuffer  &IDynStr
oHH           &tagHTMLHelp
Loc:RetValue         &STRING                               ! 
Loc:Size             LONG(0)                               ! 
Loc:Delta            LONG                                  ! 
Loc:RCode            LONG(0)                               ! Код ответа сервиса

  CODE
  If xIndicator_ > 0
     xIndicator_{Prop:Progress} = 0
     Display(xIndicator_)
  end

  Loc:RetValue   &= NULL
  Loc:RespBuffer &= NewDynStr()

  MyCurl.Init()
  MyCurl.FreeHttpHeaders()

  ! --- Поддержка HTTPS

  If Sub(Lower(Clip(Left(xURL_))),1,5) = 'https'
     MyCurl.SetSSLVersion(CURL_SSLVERSION_DEFAULT)
     MyCurl.SetSSLVerifyHost(False)
     MyCurl.SetSSLVerifyPeer(False)
     !MyCurl.SetOpt(CURLSSH_AUTH_AGENT,Loc:UserAgent)
  end

  ! --- Вид запроса

  If InRange(xRequest_,1,3)
     Loc:Res = MyCurl.SetCustomRequest(Choose(xRequest_,'PUT','POST','DELETE'))
  else                               
     Loc:Res = MyCurl.SetHttpGET(True)
  end

  MyCurl.SetOpt(CURLOPT_CONNECTTIMEOUT,20)

  ! --- Пользователь и пароль

  If (Clip(Left(xUser_)) <> '') Or (Clip(Left(xPass_)) <> '') then MyCurl.SetUserPwd(Clip(Left(xUser_)),Clip(Left(xPass_))).

  Loc:Res = MyCurl.SetUserAgent('Mozilla/1.22 (compatible; MSIE 10.0; Windows 3.1)')

  ! --- Запрос

  Loc:Res = MyCurl.SendRequest(Clip(xURL_),Clip(xPar_),Loc:RespBuffer)

  !Loc:Res = MyCurl.SetPostFields(Clip(xPar_))
  !If Loc:Res <> CURLE_OK then Message('проблема с параметрами').
  !Loc:Res = MyCurl.FormPost(Clip(xURL_),Loc:RespBuffer)

  If Loc:Res = CURLE_OK

     ! --- Создать строку с ответом сервиса на запрос
     
     Loc:Size  = Loc:RespBuffer.StrLen()  ! Размер строки с ответом сервиса на запрос

     If Loc:Size > 0
        Loc:RetValue &= New(String(Loc:Size))  ! Создаем буфер для загрузки
        If ~(Loc:RetValue &= Null) then Loc:RespBuffer.CopyTo(Loc:RetValue,Loc:Size).
     end

     ! --- Показать ответ сервиса на запрос

     Loc:RCode = MyCurl.GetResponseCode()   ! Код ответа сервиса на запрос

     If ((xAnswer_ = 1) and (Loc:RCode <> 200)) Or (xAnswer_ = 2)
        Message('Код ответа сервиса: ' & Clip(Left(Loc:RCode)) & '|' & |
                Loc:RespBuffer.Str(),'Ответ сервиса',Choose(Loc:RCode = 200,Icon:Exclamation,Icon:Asterisk),'&1. Закрыть')
     end        

  elsIf Loc:Res = -1
     If xAnswer_ > 0 then Message('Неизвестная ошибка запроса: ' & Clip(Left(Loc:Res)),'У нас проблема ...',Icon:Exclamation,'&1. Закрыть').
  else
     If xAnswer_ > 0 then Message('Ошибка запроса: ' & Clip(Left(Loc:Res)) & '|' & MyCurl.StrError(Loc:Res),'У нас проблема ...',Icon:Exclamation,'&1. Закрыть').
  end

  Loc:RespBuffer.Kill()
  DisposeDynStr(Loc:RespBuffer)
  Loc:RespBuffer &= Null

  Return Loc:RetValue
TCurlHTTPClassEx.XFerInfo  PROCEDURE(REAL dltotal, REAL dlnow, REAL ultotal, REAL ulnow)
  Code
  If xIndicator_ > 0

     If dlnow
        If dltotal
           !xIndicator_{Prop:Hide} = False
           xIndicator_{Prop:Progress} = dlnow * 100 / dltotal
        else
           If dlnow > 100 then Loc:Delta += 1.
           xIndicator_{Prop:Progress} = dlnow - (Loc:Delta * 100)
           !-- The server probably doesn't send the Content-Length header. dltotal is always 0.
           !-- see https://curl.haxx.se/mail/lib-2008-01/0071.html
           !xIndicator_{Prop:Hide} = True
        end
     end
  end

  RETURN 0

Код: Выделить всё

WebLoadStr2          FUNCTION (lop:rFileName,lop:flagMessage) ! Объявление процедуры
FilesOpened          LONG
Loc:Bytes            LONG
Loc:Status           LONG
hSession    HINTERNET      !ссылка на сессию
hUrl        HINTERNET      !ссылка на remote-файл
MyUrl       CSTRING(255)   !имя remote-файла

Agent       CSTRING('WebCopy 0.000001b')  !агент

BufferSize      EQUATE(2048)   !значение размера буфера для загрузки файла
Buffer          Group          !буфер для загрузки файла
                  BYTE,DIM(BufferSize)
                End

BufferLength    DWORD    !размер буфера для загрузки файла (как переменная для передачи адреса в функциях api)
IndexNum        DWORD    !номер индекса для функции HttpQueryInfo
FileSize        DWORD    !размер загружаемого файла

Loc:Total       DWORD

Loc:Str1            &STRING                               !
Loc:Str2            &STRING

  CODE                                           ! Начало исполняемого кода
    !Пример вызова
    !loc:Str  &String
    !
    !loc:Str &= WebLoadStr2('http://www.finsofrz.ru/myScript.php',1)
    !if ~(loc:Str &= NULL) then message(loc:Str).
    !dispose(loc:Str)
  
      MyUrl = clip(lop:rFileName)      !имя remote-файла
      Loc:Str1 &= NULL
  
      hSession = InternetOpen(Agent,INTERNET_OPEN_TYPE_PRECONFIG,,,0)  !открыть сессию
      if hSession   !если сессия открыта успешно
        hUrl = InternetOpenUrl(hSession, myUrl,,0,INTERNET_FLAG_RELOAD,0)   !открыть ссылку на remote-файл
        if hUrl          !если есть ссылка на remote-файл
          Loc:Total  = 0                            !счетчик в буфер загруженных байт
          Loc:Str1 &= New(String(BufferSize))      !создать начальный буфер
  
          loop
             Buffer = All('<0>')     !инициализация буфера
             InternetReadFile(hUrl, Buffer, Buffersize, BufferLength)  !чтение порции
             if BufferLength > 0       !если что-то прочитано
                if (Loc:Total + BufferLength) > Size(Loc:Str1)         !если буфер мал
                   Loc:Str2 &= New(String(Loc:Total + BufferLength))   !увеличить его размер
                   Loc:Str2  = Loc:Str1
                   dispose(Loc:Str1)
                   Loc:Str1 &= Loc:Str2
                .
                Loc:Str1[(Loc:Total + 1):(Loc:Total + BufferLength)] = Buffer  !запись загруженного блока в буфер
                Loc:Total += BufferLength                                      !увеличить счетчик загрузки
             .
          Until BufferLength = 0
  
          InternetCloseHandle(hUrl)  !закрываем remote-файл
        elsif lop:flagMessage = 1
          FsMessagePr('Не найден запрос по HTTP!')
        .
        InternetCloseHandle(hSession)  !закрываем сессию
      elsif lop:flagMessage = 1
          FsMessagePr('Нет доступа по протоколу HTTP!')
      .
  
      Return Loc:Str1