nntpcli.pas

BaiduMp3 search baidu mp3

        FContentType         : TNntpContentType;
        FContentTypeStr      : String;
        FHdrSubject          : String;
        FHdrFrom             : String;
        FHdrGroup            : String;
        FHeader              : TStringList;
        FCharSet             : String;
        FShareMode           : Word;
        FStream              : TStream;
        procedure SetPlainText(const newValue: TStrings); virtual;
        procedure SetHtmlText(const newValue: TStrings); virtual;
        procedure SetAttachedFiles(const newValue: TStrings); virtual;
        procedure SetContentType(newValue : TNntpContentType); virtual;
        function  GetShareMode: TNntpShareMode; virtual;
        procedure SetShareMode(newValue: TNntpShareMode); virtual;
        procedure PostBlock; override;
        procedure BuildHeader; virtual;
        procedure GenerateBoundaries; virtual;
        procedure Display(const Msg: String); virtual;
        procedure SendLine(const MsgLine: String); virtual;
        procedure TriggerRequestDone(Request: TNntpRequest; ErrCode: Word); override;
    public
        constructor Create(AOwner : TComponent); override;
        destructor  Destroy; override;
        procedure   Post(FromStream : TStream); override;
    published
        property PlainText     : TStrings            read  FPlainText
                                                     write SetPlainText;
        property HtmlText      : TStrings            read  FHtmlText
                                                     write SetHtmlText;
        property AttachedFiles : TStrings            read  FAttachedFiles
                                                     write SetAttachedFiles;
        property ContentType   : TNntpContentType    read  FContentType
                                                     write SetContentType;
        property HdrSubject    : String              read  FHdrSubject
                                                     write FHdrSubject;
        property HdrGroup      : String              read  FHdrGroup
                                                     write FHdrGroup;
        property HdrFrom       : String              read  FHdrFrom
                                                     write FHdrFrom;
        property CharSet       : String               read  FCharSet
                                                     write FCharSet;
        property ShareMode     : TNntpShareMode      read  GetShareMode
                                                     write SetShareMode;
    end;

procedure ParseListLine(const Line          : String;
                        var NewsGroupName   : String;
                        var LastArticle     : Integer;
                        var FirstArticle    : Integer;
                        var PostingFlag     : Char);
procedure Register;

implementation


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
function TrimRight(Str : String) : String;
var
    I : Integer;
begin
    I := Length(Str);
    while (I > 0) and (Str[I] = ' ') do
        I := I - 1;
    Result := Copy(Str, 1, I);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TrimLeft(Str : String) : String;
var
    I : Integer;
begin
    if Str[1] <> ' ' then
        Result := Str
    else begin
        I := 1;
        while (I <= Length(Str)) and (Str[I] = ' ') do
            I := I + 1;
        Result := Copy(Str, I, Length(Str) - I + 1);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function Trim(Str : String) : String;
begin
    Result := TrimLeft(TrimRight(Str));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure SetLength(var S: string; NewLength: Integer);
begin
    S[0] := chr(NewLength);
end;
{$ENDIF}


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Step over blank spaces                                                    }
function StpBlk(Data : PChar) : PChar;
begin
    Result := Data;
    if Result <> nil then begin
        while (Result^ <> #0) and (Result^ in [' ', #9, #13, #10]) do
            Inc(Result);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function  GetInteger(Data : PChar; var Number : Integer) : PChar;
var
    bSign : Boolean;
begin
    Number := 0;
    Result := StpBlk(Data);

    if (Result = nil) then
        Exit;

    { Remember the sign }
    if Result^ in ['-', '+'] then begin
        bSign := (Result^ = '-');
        Inc(Result);
    end
    else
        bSign  := FALSE;

    { Convert any number }
    while (Result^ <> #0) and (Result^ in ['0'..'9']) do begin
        Number := Number * 10 + ord(Result^) - ord('0');
        Inc(Result);
    end;

    { Correct for sign }
    if bSign then
        Number := -Number;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function GetMessageID(Data : PChar; var ID : String) : PChar;
begin
    ID     := '';
    Result := StpBlk(Data);
    if Data = nil then
        Exit;

    while not (Result^ in [#0, '<']) do
        Inc(Result);
    if Result^ = '<' then begin
        while Result^ <> #0 do begin
            Inc(Result);
            if Result^ = '>' then
                break;
            ID := ID + Result^;
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function GetNewsGroupName(Data : PChar; var GroupName : String) : PChar;
begin
    GroupName := '';
    Result    := StpBlk(Data);
    if Data = nil then
        Exit;

    { Copy until first white space }
    while (Result^ <> #0) and (not (Result^ in [' ', #9])) do begin
        GroupName := GroupName + Result^;
        Inc(Result);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function GetChar(Data : PChar; var Ch : Char) : PChar;
begin
    Ch     := #0;
    Result := StpBlk(Data);
    if Data = nil then
        Exit;

    Ch := Result^;
    if Ch <> #0 then
        Inc(Result);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function atoi(Data : String) : Integer;
begin
{$IFDEF VER80}
    { Nul terminate string for Delphi 1 }
    Data[Length(Data) + 1] := #0;
{$ENDIF}
    GetInteger(@Data[1], Result);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure Register;
begin
    RegisterComponents('FPiette', [TNntpCli, THtmlNntpCli]);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TNntpCli.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
{$IFDEF DUMP}
    FDumpStream := TFileStream.Create('c:\temp\nntpcli.log', fmCreate);
    FDumpBuf    := '---- START -----' + #13 + #10;
    FDumpStream.WriteBuffer(FDumpBuf[1], Length(FDumpBuf));
{$ENDIF}
    FWindowHandle               := nntpcliAllocateHWnd(WndProc);
    FState                      := nntpNotConnected;
    FArticleNumber              := -1;
    FArticleID                  := '';
    FArticleFirst               := -1;
    FArticleLast                := -1;
    FArticleEstimated           := -1;
    FStatusCode                 := 503;  { program fault }
{$IFDEF VER80}
    FLineLimit                  := 255;
{$ELSE}
    FLineLimit                  := 65536;
{$ENDIF}
    FPort                       := 'nntp';
    FWSocket                    := TWSocket.Create(Self);
    FWSocket.LineMode           := TRUE;
    FWSocket.LineEnd            := #13#10;
	FWSocket.LineLimit          := FLineLimit;
    FWSocket.ComponentOptions   := FWSocket.ComponentOptions + [wsoNoReceiveLoop];
    FWSocket.OnSessionConnected := WSocketSessionConnected;
    FWSocket.OnDataAvailable    := WSocketDataAvailable;
    FWSocket.OnSessionClosed    := WSocketSessionClosed;
    FWSocket.OnDnsLookupDone    := WSocketDnsLookupDone;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TNntpCli.Destroy;
begin
{$IFDEF DUMP}
    if Assigned(FDumpStream) then begin
        FDumpBuf := '---- STOP -----' + #13 + #10;
        FDumpStream.WriteBuffer(FDumpBuf[1], Length(FDumpBuf));
        FDumpStream.Destroy;
    end;
{$ENDIF}
    if Assigned(FWSocket) then
        FWSocket.Destroy;
    nntpcliDeallocateHWnd(FWindowHandle);
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.SetLineLimit(NewValue: Integer);
begin
    if FLineLimit <> NewValue then begin
        FLineLimit         := NewValue;
        FWSocket.LineLimit := FLineLimit;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.WndProc(var MsgRec: TMessage);
begin
     with MsgRec do begin
         case Msg of
         WM_NNTP_REQUEST_DONE : WMNntpRequestDone(MsgRec);
         else
             Result := DefWindowProc(Handle, Msg, wParam, lParam);
         end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.WMNntpRequestDone(var msg: TMessage);
begin
    TriggerRequestDone(TNntpRequest(Msg.WParam), Msg.LParam);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.TriggerRequestDone(
    Request : TNntpRequest;
    ErrCode : Word);
begin
    if Assigned(FOnRequestDone) then
        FOnRequestDone(Self, Request, ErrCode);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.StateChange(NewState : TNntpState);
begin
    if FState <> NewState then begin
        FState := NewState;
        TriggerStateChange;
    end;
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.SendRequest;
begin
    FLastCmdResponse := '';
{$IFDEF DUMP}
    FDumpBuf := '<|';
    FDumpStream.WriteBuffer(FDumpBuf[1], Length(FDumpBuf));
    FDumpStream.WriteBuffer(FRequest[1], Length(FRequest));
    FDumpBuf := '|' + #13#10;
    FDumpStream.WriteBuffer(FDumpBuf[1], Length(FDumpBuf));
{$ENDIF}
    FWSocket.SendStr(FRequest + #13 + #10);
    FSendCount := (FSendCount + Length(FRequest) + 2) and $7FFFFFF;
    TriggerSendData;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.Connect;
begin
    if FState <> nntpNotConnected then
         raise NntpException.Create('Already connected');

    FRequestType      := nntpConnect;
    FRequestDoneFlag  := FALSE;
    FRequest          := '';
    FArticleNumber    := -1;
    FArticleID        := '';
    FArticleFirst     := -1;
    FArticleLast      := -1;
    FArticleEstimated := -1;
    StateChange(nntpDnsLookup);
    FWSocket.DnsLookup(FHost);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.Group(NewsGroupName : String);
begin
    if FState <> nntpReady then
        raise NntpException.Create('Not ready for GROUP');

    FRequestDoneFlag := FALSE;
    FRequestType     := nntpGroup;
    FRequest         := 'GROUP ' + Trim(NewsGroupName);
    FNext            := GroupNext;
    StateChange(nntpWaitingResponse);
    SendRequest;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.GroupNext;
var
    Data    : PChar;
    ErrCode : Integer;
begin
    Data := GetInteger(@FLastResponse[1], FStatusCode);
    Data := GetInteger(Data, FArticleEstimated);
    Data := GetInteger(Data, FArticleFirst);
    Data := GetInteger(Data, FArticleLast);
    GetNewsGroupName(Data, FGroupName);
    if FStatusCode = 211 then
        Errcode := 0
    else
        ErrCode := FStatusCode;
    DelayedRequestDone(Errcode);
end;