nntpcli.pas

互联网套件

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]);
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               := AllocateHWnd(WndProc);
    FState                      := nntpNotConnected;
    FArticleNumber              := -1;
    FArticleID                  := '';
    FArticleFirst               := -1;
    FArticleLast                := -1;
    FArticleEstimated           := -1;
    FStatusCode                 := 503;  { program fault }
    FWSocket                    := TWSocket.Create(Self);
    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;
    DeallocateHWnd(FWindowHandle);
    inherited Destroy;
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
    if Assigned(FOnRequestDone) then
        FOnRequestDone(Self, TNntpRequest(Msg.WParam), Msg.LParam);
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);
end;


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

    FRequestType      := nntpConnect;
    FRequestDoneFlag  := FALSE;
    FReceiveLen       := 0;
    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;
    Error : Integer;
begin
    Data := GetInteger(@FLastResponse[1], FStatusCode);
    Data := GetInteger(Data, FArticleEstimated);
    Data := GetInteger(Data, FArticleFirst);
    GetInteger(Data, FArticleLast);
    if FStatusCode = 211 then
        Error := 0
    else
        Error := FStatusCode;
    TriggerRequestDone(Error);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.ArticleByNumber(Number : Integer; DestStream : TStream);
begin
    GetArticleByNumber(nntpArticleByNumber, Number, DestStream);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.ArticleByID(ID : String; DestStream : TStream);
begin
    GetArticleByID(nntpArticleByID, ID, DestStream);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.BodyByNumber(Number : Integer; DestStream : TStream);
begin
    GetArticleByNumber(nntpBodyByNumber, Number, DestStream);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.BodyByID(ID : String; DestStream : TStream);
begin
    GetArticleByID(nntpBodyByID, ID, DestStream);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.HeadByNumber(Number : Integer; DestStream : TStream);
begin
    GetArticleByNumber(nntpHeadByNumber, Number, DestStream);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.HeadByID(ID : String; DestStream : TStream);
begin
    GetArticleByID(nntpHeadByID, ID, DestStream);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.StatByNumber(Number : Integer);
begin
    GetArticleByNumber(nntpStatByNumber, Number, nil);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.StatByID(ID : String);
begin
    GetArticleByID(nntpStatByID, ID, nil);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.GetArticleByID(
    RqType     : TNntpRequest;
    ID         : String;
    DestStream : TStream);
begin
    GetArticle(RqType, ' <' + ID + '>', DestStream);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.GetArticleByNumber(
    RqType     : TNntpRequest;
    Number     : Integer;
    DestStream : TStream);
begin
    if Number > 0 then
        GetArticle(RqType, ' ' + IntToStr(Number), DestStream)
    else
        GetArticle(RqType, '', DestStream);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TNntpCli.GetArticle(
    RqType     : TNntpRequest;
    ID         : String;
    DestStream : TStream);
var
    Cmd : String;
begin
    case RqType of
    nntpArticleByID, nntpArticleByNumber:
        Cmd := 'ARTICLE';
    nntpBodyByID, nntpBodyByNumber:
        Cmd := 'BODY';
    nntpHeadByID, nntpHeadByNumber:
        Cmd := 'HEAD';
    nntpStatByID, nntpStatByNumber:
        Cmd := 'STAT';
    else