jvmultihttpgrabber.pas

East make Tray Icon in delphi

procedure TJvMultiHTTPGrabber.RaiseWebError(Infos: Pointer);
var
  dwIndex, dwBufLen: DWORD;
  Buf: array [0..1024] of Char;
begin
  if Assigned(FOnError) then
  begin
    dwIndex := 0;
    dwBufLen := SizeOf(Buf);
    InternetGetLastResponseInfo(dwIndex, Buf, dwBufLen);
    with PRequestInfos(Infos)^ do
      FOnError(Self, UserData, Url, StrPas(buf));
  end;
end;

function TJvMultiHTTPGrabber.StartConnection(UserData: Integer; IgnoreMessages: Boolean): Pointer;
var
  Infos: PRequestInfos;
  HostName, FilePath: string;
  HostPort: Word;

  procedure ParseUrl(Value: string);
  begin
    HostName := '';
    FilePath := '';
    if Pos('HTTP://', UpperCase(Value)) <> 0 then
      Value := Copy(Value, 8, Length(Value));
    if Pos('/', Value) <> 0 then
    begin
      HostName := Copy(Value, 1, Pos('/', Value) - 1);
      FilePath := Copy(Value, Pos('/', Value) + 1, Length(Value));
    end
    else
      HostName := Value;

    if Pos(':', HostName) <> 0 then
    begin // If URL contains a non-standard Port number, attempt to use it
      HostPort := StrToIntDef(Copy(HostName, Pos(':', HostName) + 1, Length(HostName)), INTERNET_DEFAULT_HTTP_PORT);
      HostName := Copy(HostName, 1, Pos(':', HostName) - 1);
    end
    else // If not, use the standard one
      HostPort := INTERNET_DEFAULT_HTTP_PORT;
  end;

begin
  Result := nil;

  Infos := New(PRequestInfos);
  Infos^.Url := Url;
  Infos^.Filename := FileName;
  Infos^.OutputMode := OutputMode;
  Infos^.UserData := UserData;
  Infos^.Grabber := Self;
  Infos^.IgnoreMsg := IgnoreMessages;

  //Opening the web session with the server
  Infos^.hSession := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG,
    nil, nil, 0);
  if Infos^.hSession = nil then
  begin
    RaiseError(Infos);
    Dispose(Infos);
    Exit;
  end;

  //Setting callback function
  InternetSetStatusCallback(Infos^.hSession, PFNInternetStatusCallback(@StatusCallback));

  //Open the internet connection
  ParseUrl(Url);
  Infos^.hHostConnect := InternetConnect(Infos^.hSession, PChar(HostName),
    HostPort, PChar(FUserName), PChar(FPassword), INTERNET_SERVICE_HTTP,
    0, Cardinal(Infos));
  if Infos^.hHostConnect = nil then
  begin
    RaiseWebError(Infos);
    InternetCloseHandle(Infos^.hSession);
    Dispose(Infos);
    Exit;
  end;

  //prepare the GET order
  Infos^.hRequest := HttpOpenRequest(Infos^.hHostConnect, 'GET', PChar(FilePath),
    'HTTP/1.0', PChar(FReferer), nil, INTERNET_FLAG_RELOAD, 0);

  Result := Infos;
end;

procedure TJvMultiHTTPGrabber.StopConnection(Infos: Pointer);
begin
  InternetCloseHandle(PRequestInfos(Infos)^.hRequest);
  InternetCloseHandle(PRequestInfos(Infos)^.hHostConnect);
  InternetCloseHandle(PRequestInfos(Infos)^.hSession);
end;

procedure TJvMultiHTTPGrabber.ThreadDateTerminated(Sender: TObject);
begin
  with Sender as TJvMultiDateHttpThread do
  begin
    with PRequestInfos(FInfos)^ do
      if Assigned(FOnDateRetrieved) then
        FOnDateRetrieved(Self, UserData, FValue, Url);

    StopConnection(FInfos);
    Dispose(FInfos);
//    Free; // (p3) FreeOnTerminate is set when creating, so don't free here
  end;
end;

procedure TJvMultiHTTPGrabber.ThreadTerminated(Sender: TObject);
var
  TT: TJvMultiHttpThread;
begin
  TT := Sender as TJvMultiHttpThread; // need this for debugging purposes
  try
    if (TT.FStream <> nil) and (TT.FStream.Size > 0) then
    begin
      if OutputMode = omStream then
      begin
        if Assigned(FOnDoneStream) then
          FOnDoneStream(Self, PRequestInfos(TT.FInfos)^.UserData, TT.FStream, TT.FStream.Size, PRequestInfos(TT.FInfos)^.Url);
      end
      else
      begin
        TT.FStream.SaveToFile(PRequestInfos(TT.FInfos)^.FileName);
        if Assigned(FOnDoneFile) then
          FOnDoneFile(Self, PRequestInfos(TT.FInfos)^.UserData, PRequestInfos(TT.FInfos)^.FileName, TT.FStream.Size, PRequestInfos(TT.FInfos)^.Url);
      end;
    end;

    StopConnection(PRequestInfos(TT.FInfos));
    Dispose(PRequestInfos(TT.FInfos));
    Dec(FCount);
  finally
//    TT.Free; // (p3) FreeOnTerminate is set when creating, so don't free here
  end;
end;

//=== TJvMultiHttpThread =====================================================

constructor TJvMultiHttpThread.Create(Value: Pointer);
begin
  inherited Create(True);
  FInfos := Value;
  FPosition := 0;
  FContinue := True;
  FStream := nil;
end;

destructor TJvMultiHttpThread.Destroy;
begin
  FreeAndNil(FStream);
  inherited Destroy;
end;

procedure TJvMultiHttpThread.Error;
var
  Infos: TRequestInfos;
begin
  Infos := PRequestInfos(FInfos)^;
  if Assigned(Infos.Grabber.FOnError) then
    Infos.Grabber.FOnError(Self, Infos.UserData, Infos.Url, RsErrorConnection);
end;

procedure TJvMultiHttpThread.Execute;
var
  Infos: PRequestInfos;
  Buffer: array [0..512] of Byte;
  BytesRead: DWORD;
  dLength, dReserved, dSize: DWORD;
begin
  // (p3) avoid memory leaks
  FreeAndNil(FStream);
  try
    Infos := PRequestInfos(FInfos);

    //Send the request
    if not HttpSendRequest(Infos^.hRequest, nil, 0, nil, 0) then
    begin
      Synchronize(Error);
      Exit;
    end;

    // Get the Size
    dLength := SizeOf(dSize);
    dReserved := 0;
    if HttpQueryInfo(Infos^.hRequest, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER,
      @dSize, dLength, dReserved) then
      Infos^.FileSize := dSize
    else
      Infos^.FileSize := -1;

    // Download the stuff
    Synchronize(Progress);
    if not FContinue then
      Exit;

    FStream := TMemoryStream.Create;
    repeat
      if not InternetReadFile(Infos^.hRequest, @Buffer[0], SizeOf(Buffer), BytesRead) then
        BytesRead := 0
      else
      begin
        Inc(FPosition, BytesRead);
        FStream.Write(buffer, BytesRead);
        Synchronize(Progress);
        if not FContinue then
          Exit;
      end;
    until BytesRead = 0;
    FStream.Position := 0;
  except
  end;
  Terminate;
end;

procedure TJvMultiHttpThread.Progress;
begin
  with PRequestInfos(FInfos)^ do
    if Assigned(Grabber.OnProgress) then
      Grabber.OnProgress(Grabber, UserData, FPosition, FileSize, Url, FContinue);
end;

//=== TJvMultiDateHttpThread =================================================

constructor TJvMultiDateHttpThread.Create(Value: Pointer);
begin
  inherited Create(True);
  FInfos := Value;
end;

procedure TJvMultiDateHttpThread.Error;
var
  Infos: TRequestInfos;
begin
  Infos := PRequestInfos(FInfos)^;
  if Assigned(Infos.Grabber.FOnError) then
    Infos.Grabber.FOnError(Self, Infos.UserData, Infos.Url, RsErrorConnection);
end;

procedure TJvMultiDateHttpThread.Execute;
var
  Infos: PRequestInfos;
  STime: TSystemTime;
  dLength, dReserved: DWORD;
begin
  // (rom) secure thread against exceptions
  try
    Infos := PRequestInfos(FInfos);

    dLength := SizeOf(TSystemTime);
    dReserved := 0;

    HttpSendRequest(Infos^.hRequest, nil, 0, nil, 0);

    if HttpQueryInfo(Infos^.hRequest, HTTP_QUERY_LAST_MODIFIED or HTTP_QUERY_FLAG_SYSTEMTIME,
      @STime, dLength, dReserved) then
      FValue := SystemTimeToDateTime(STime)
    else
      FValue := -1;
  except
  end;
end;

end.