overbyte.ics.httpclient.pas

搜索百度MP3并下载源码.批量下载.百度TOP100等

    FCtrlSocket.Close;
    FConnected := FALSE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpClient.SendCommand(const Cmd : String);
var
    Buf : String;
    I   : Integer;
begin
    Buf := Cmd;
    if Assigned(FOnCommand) then
        FOnCommand(Self, Buf);
    for I := 1 to Length(Buf) do
        FReqStream.Write(Byte(Buf[I]));  // We send ASCII code, not unicode
    FReqStream.Write(Byte(13));          // CR
    FReqStream.Write(Byte(10));          // LF
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpClient.SendRequest(const Method, Version: String);
var
    Headers : TStrings;
    N       : Integer;
begin
    Headers := TStringList.Create;
    try
        FReqStream.Clear;
        TriggerRequestHeaderBegin;
        OutputDebugString(method + ' ' + FPath + ' HTTP/' + Version);
        Headers.Add(method + ' ' + FPath + ' HTTP/' + Version);
        if FSender <> '' then
            Headers.Add('From: ' + FSender);
        if FAccept <> '' then
            Headers.Add('Accept: ' + FAccept);
        if FReference <> '' then
            Headers.Add('Referer: ' + FReference);
        if FConnection <> '' then
            Headers.Add('Connection: ' + FConnection);
        if FAcceptLanguage <> '' then
            Headers.Add('Accept-Language: ' + FAcceptLanguage);
        if ((FRequestType = httpPOST) or (FRequestType = httpPUT)) and
           (FContentPost <> '') then
            Headers.Add('Content-Type: ' + FContentPost);
        if FAgent <> '' then
            Headers.Add('User-Agent: ' + FAgent);
        Headers.Add('Host: ' + FTargetHost);
        if FNoCache then
            Headers.Add('Pragma: no-cache');
        if (FRequestType = httpPOST) or (FRequestType = httpPUT) then
            Headers.Add('Content-Length: ' + IntToStr(SendStream.Size));
        if FModifiedSince.Year > 1 then
 //       if FModifiedSince <> EncodeDate(0, 0, 0) then
            Headers.Add('If-Modified-Since: ' +
                        RFC1123_Date(FModifiedSince) + ' GMT');
        if FUsername <> '' then
            Headers.Add('Authorization: Basic ' +
                        EncodeStr(encBase64, FUsername + ':' + FPassword));
        if (FProxy <> '') and (FProxyUsername <> '') then
            Headers.Add('Proxy-Authorization: Basic ' +
                        EncodeStr(encBase64, FProxyUsername + ':' + FProxyPassword));
        if FCookie <> '' then
            Headers.Add('Cookie: ' + FCookie);
        if (FContentRangeBegin <> '') or (FContentRangeEnd <> '') then begin            {JMR!! Added this line!!!}
            Headers.Add('Range: bytes=' + FContentRangeBegin + '-' + FContentRangeEnd); {JMR!! Added this line!!!}
          FContentRangeBegin := '';                                                     {JMR!! Added this line!!!}
          FContentRangeEnd   := '';                                                     {JMR!! Added this line!!!}
        end;                                                                            {JMR!! Added this line!!!}
        FAcceptRanges := '';

{SendCommand('UA-pixels: 1024x768'); }
{SendCommand('UA-color: color8'); }
{SendCommand('UA-OS: Windows 95'); }
{SendCommand('UA-CPU: x86'); }
{SendCommand('Proxy-Connection: Keep-Alive'); }

        OutputDebugString(IntToStr(Headers.Count) + ' header lines to send');
        TriggerBeforeHeaderSend(Method, Headers);
        for N := 0 to Headers.Count - 1 do
            SendCommand(Headers[N]);

        TriggerRequestHeaderEnd;
        SendCommand('');
        FCtrlSocket.PutDataInSendBuffer(FReqStream.Memory, FReqStream.Size);
        FReqStream.Clear;
        FCtrlSocket.Send(nil, 0);
    finally
        Headers.Free;
        OutputDebugString('SendRequest Done');
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Data is pointed by FBodyData and FBodyDataLen as length                   }
procedure THttpClient.GetBodyLineNext;
var
    I : Integer;
begin
    OutputDebugString('GetBodyLineNext begin');
    if FBodyLineCount = 0 then
        TriggerDocBegin;
    Inc(FBodyLineCount);

    OutputDebugString('GetBodyLineNext FBodyDataLen=' + IntToStr( FBodyDataLen));

    if FBodyDataLen > 0 then begin
        FRcvdCount := FRcvdCount + FBodyDataLen;
        if Assigned(FRcvdStream) then begin
            //FRcvdStream.WriteBuffer((FBodyData^, FBodyDataLen);
            for I := FBodyData to FBodyData + FBodyDataLen - 1 do
                FRcvdStream.WriteBuffer(FReceiveBuffer[I]);
        end;
        TriggerDocData(FReceiveBuffer, FBodyData, FBodyDataLen);
    end;

    if FRcvdCount = FContentLength then begin
        { End of document }
        OutputDebugString('end of document');
        FBodyLineCount := 0;
        FNext          := nil;
        StateChange(httpBodyReceived);
        TriggerDocEnd;
        if (FResponseVer = '1.0') or (FRequestVer = '1.0') then
            FCtrlSocket.CloseDelayed
        else
            SetReady;
    end;
    OutputDebugString('GetBodyLineNext end');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpClient.GetHeaderLineNext;
var
    proto   : String;
    user    : String;
    pass    : String;
    port    : String;
    Host    : String;
    Path    : String;
    Field   : String;
    Data    : String;
    nSep    : Integer;
    tmpInt  : LongInt;
    bAccept : Boolean;
    DocExt  : String;
    SaveLoc : String;
begin
    if FHeaderLineCount = 0 then
        TriggerHeaderBegin
    else if FHeaderLineCount = -1 then   { HTTP/1.1 second header }
        FHeaderLineCount := 0;
    Inc(FHeaderLineCount);

    { Some server send HTML document without header ! I don't know if it is  }
    { legal, but it exists (AltaVista Discovery does that).                  }
    if (FHeaderLineCount = 1) and
       (UpperCase(Copy(FLastResponse, 1, 6)) = '<HTML>') then begin { 15/09/98 }
        if FContentType = '' then
            FContentType := 'text/html';
        StateChange(httpWaitingBody);
        FNext := GetBodyLineNext;
        TriggerHeaderEnd;
        FBodyData    := 0;
        FBodyDataLen := Length(FLastResponse);
        GetBodyLineNext;
        Exit;
    end;

    if FLastResponse = '' then begin
        OutputDebugString('end of header');
        if (FResponseVer = '1.1') and (FStatusCode = 100) then begin
            { HTTP/1.1 continue message. A second header follow. }
            { I should create an event to give access to this.   }
            FRcvdHeader.Clear;        { Cancel this first header }
            FHeaderLineCount := -1;   { -1 is to remember we went here }
            Exit;
        end;

        if FLocationFlag then begin
            TriggerHeaderEnd;
            FReceiveLen       := 0;
            FHeaderLineCount  := 0;
            FBodyLineCount    := 0;
            OutputDebugString('starting relocation process');
            if (FResponseVer     = '1.1') and
               (FCurrentHost     = FHostName) and
               (FCurrentPort     = FPort) and
               (FCurrentProtocol = FProtocol) then begin
                { No need to disconnect }
                { Trigger the location changed event  27/04/2003 }
                if Assigned(FOnLocationChange) then
                     FOnLocationChange(Self);
                SaveLoc := FLocation;  { 01/05/03 }
                InternalClear;
                FLocation := SaveLoc;
                FDocName  := FPath;
                AdjustDocName;
                { When relocation occurs doing a POST, new relocated page }
                { has to be GET.  01/05/03                                }
                if FRequestType = httpPOST then
                    FRequestType  := httpGET;
                PostMessage(FWindowHandle, WM_HTTP_LOGIN, 0, 0);
            end
            else begin
                FCtrlSocket.OnSessionClosed := LocationSessionClosed;
                FCtrlSocket.CloseDelayed;
            end;
            Exit;
        end;
        { FContentLength = -1 when server doesn't send a value }
        if (FContentLength = 0) or (FRequestType = httpHEAD) then begin
            TriggerHeaderEnd;
            SetReady;
            Exit;
        end;
        DocExt := LowerCase(ExtractFileExt(FDocName));
        if (DocExt = '.exe') or (DocExt = '') then begin
            if FContentType = 'text/html' then
                ReplaceExt(FDocName, 'htm');
        end;

        StateChange(httpWaitingBody);
        FNext := GetBodyLineNext;
        TriggerHeaderEnd;
        if FReceiveLen > 0 then begin
            FBodyData    := 0;
            if (FContentLength < 0) or
               ((FRcvdCount + FReceiveLen) <= FContentLength) then
                FBodyDataLen := FReceiveLen
            else
                FBodyDataLen := FContentLength - FRcvdCount;
            GetBodyLineNext;
            FReceiveLen := FReceiveLen - FBodyDataLen;
        end;
        if FStatusCode >= 400 then   { 01/11/01 }
            FCtrlSocket.Close;
        Exit;
    end;

    FRcvdHeader.Add(FLastResponse);

    nSep := pos(':', FLastResponse);
    if (FHeaderLineCount = 1) and
       ((Copy(FLastResponse, 1, 8) = 'HTTP/1.0') or
        (Copy(FLastResponse, 1, 8) = 'HTTP/1.1')) then begin
        FResponseVer  := Copy(FLastResponse, 6, 3);
        FStatusCode   := StrToInt(Copy(FLastResponse, 10, 3));
        FReasonPhrase := Copy(FLastResponse, 14, Length(FLastResponse));
    end
    else if nSep > 0 then begin
        Field := LowerCase(Copy(FLastResponse, 1, nSep - 1));
        { Skip spaces }
        Inc(nSep);
        while (nSep < Length(FLastResponse)) and
              (FLastResponse[nSep] = ' ') do
              Inc(nSep);
        Data  := Copy(FLastResponse, nSep, Length(FLastResponse));
        if Field = 'location' then begin { Change the URL ! }
            if FRequestType = httpPUT then begin
                 { Location just tell us where the document has been stored }
                 FLocation := Data;
            end
            else begin
                { OK, we have a real relocation !       }
                { URL with relocations:                 }
                { http://www.webcom.com/~wol2wol/       }
                { http://www.purescience.com/delphi/    }
                { http://www.maintron.com/              }
                { http://www.infoseek.com/AddURL/addurl }
                { http://www.micronpc.com/              }
                { http://www.amazon.com/                }
                { http://count.paycounter.com/?fn=0&si=44860&bt=msie&bv=5&    }
                { co=32&js=1.4&sr=1024x768&re=http://www.thesite.com/you.html }
                FLocationFlag := TRUE;
                if Proxy <> '' then begin
                    { We are using a proxy }
                    if Data[1] = '/' then begin
                        { Absolute location }
                        ParseURL(FPath, proto, user, pass, Host, port, Path);
                        if Proto = '' then
                            Proto := 'http';
                        FLocation := Proto + '://' + Host + Data;
                        FPath     := FLocation;

                        if (user <> '') and (pass <> '') then begin
                            { save user and password given in location @@@}
                            FUsername   := user;
                            FPassword   := pass;
                        end;
                    end
                    else if (Copy(Data, 1, 7) <> 'http://')
{$IFDEF USE_SSL}
                            and (Copy(Data, 1, 8) <> 'https://')
{$ENDIF}
                        then begin
                        { Relative location }
                        FPath     := GetBaseUrl(FPath) + Data;
                        { if Proto = '' then
                            Proto := 'http';
                          FLocation := Proto + '://' + FHostName + '/' + FPath;
                        }
                        FLocation := FPath;
                    end
                    else begin
                        ParseURL(Data, proto, user, pass, Host, port, Path);
                        if port <> '' then
                            FPort := port
                        else begin
{$IFDEF USE_SSL}
                            if proto = 'https' then
                                FPort := '443'
                            else
{$ENDIF}
                                FPort := '80';
                        end;

                        if (user <> '') and (pass <> '') then begin
                            { save user and password given in location @@@}
                            FUsername   := user;