nntpcli.pas

互联网套件

{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Author:       Fran鏾is PIETTE
Description:  TNntpCli is a client for the NNTP protocol (RFC-977)
EMail:        [e-mail]
              [e-mail]             http://www.rtfm.be/fpiette
Creation:     December 19, 1997
Version:      1.07
Support:      Use the mailing list [e-mail] See website for details.
Legal issues: Copyright (C) 1997, 1998, 1999 by Fran鏾is PIETTE
              Rue de Grady 24, 4053 Embourg, Belgium. Fax: [phone]
              <[e-mail]>

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely, subject to the following
              restrictions:

              1. The origin of this software must not be misrepresented,
                 you must not claim that you wrote the original software.
                 If you use this software in a product, an acknowledgment
                 in the product documentation would be appreciated but is
                 not required.

              2. Altered source versions must be plainly marked as such, and
                 must not be misrepresented as being the original software.

              3. This notice may not be removed or altered from any source
                 distribution.

              4. You must register this software by sending a picture postcard
                 to the author. Use a nice stamp and mention your name, street
                 address, EMail address and any comment you like to say.

Updates:
Dec 30, 1997  V0.91 Bug: StatusCode was not updated for Connect
              Added PostingPermited property and ParseListLine procedure as
              suggested by J. Peter Mugaas <[e-mail]>
Dec 31, 1997  V0.92 Added XOVER, LIST OVERVIEW.FMT and DATE commands
Jan 10, 1998  V0.93 Added OnStateChange event as suggested by J. Peter Mugaas
              <[e-mail]>
Jan 13, 1998  V0.94 Added readonly property State
Feb 02, 1998  V0.95 Corrected a message in the Quit method.
              Added the NntpCliVersion constant.
Feb 03, 1998  V0.96 Added Authenticate method, UserName and PassWord properties.
Apr 13, 1998  V1.00 Added an intermediate message for OnRequestDone event
              Created the Handle property and related WndProc stuff
Apr 21, 1998  V1.01 Corrected buffer overflow in the OnDataAvailable event.
              Thanks to Tim Skinner [e-mail] who found that bug.
Sep 29, 1998  V1.02 Checked length of FLastResponse before writing it to stream.
              Thanks to Michael Bartos <[e-mail]> for the hint.
Feb 01, 1999  V1.03 Added nntpConnect to solve connection problem after an
              abort. Thanks to Eric Fortier <[e-mail]>.
Feb 27, 1999  V1.04 Made Connect, Abort and Quit method virtual so that they
              can be overriden in descending components.
              Checked line length in ParseListLine.
Mar 31, 1999  V1.05 Made all methods virtual.
Aug 14, 1999  V1.06 Implemented MODE READER and XHDR
Aug 20, 1999  V1.07 Revised conditional compilation, adapted for BCB4, set
              compile options same as TWSocket.

 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit NntpCli;

{.DEFINE DUMP}

interface

{$B-}           { Enable partial boolean evaluation   }
{$T-}           { Untyped pointers                    }
{$X+}           { Enable extended syntax              }
{$IFNDEF VER80} { Not for Delphi 1                    }
    {$H+}       { Use long strings                    }
    {$J+}       { Allow typed constant to be modified }
{$ENDIF}
{$IFDEF VER110} { C++ Builder V3.0                    }
    {$ObjExportAll On}
{$ENDIF}
{$IFDEF VER125} { C++ Builder V4.0                    }
    {$ObjExportAll On}
{$ENDIF}

uses
    WinTypes, WinProcs, SysUtils, Messages, Classes, Forms, WinSock, WSocket;

const
    NntpCliVersion     = 107;
    CopyRight : String = ' TNntpCli (c) 97-99 F. Piette V1.07 ';
{$IFDEF VER80}
    { Delphi 1 has a 255 characters string limitation }
    NNTP_RCV_BUF_SIZE = 255;
{$ELSE}
    NNTP_RCV_BUF_SIZE = 4096;
{$ENDIF}
  WM_NNTP_REQUEST_DONE = WM_USER + 1;

type
    TNntpDisplay = procedure(Sender: TObject; Msg : PChar; Len : Integer) of object;
    TNntpState = (nntpNotConnected, nntpDnsLookup, nntpWaitingBanner,
                  nntpReady, nntpWaitingResponse);
    TNntpRequest = (nntpGroup,           nntpList,         nntpConnect,
                    nntpPost,            nntpHelp,
                    nntpNewGroups,       nntpNewNews,
                    nntpArticleByNumber, nntpArticleByID,
                    nntpBodyByID,        nntpBodyByNumber,
                    nntpHeadByID,        nntpHeadByNumber,
                    nntpStatByID,        nntpStatByNumber,
                    nntpNext,            nntpLast,
                    nntpQuit,            nntpAbort,
                    nntpXOver,           nntpListOverViewFmt,
                    nntpDate,            nntpAuthenticate,
                    nntpModeReader,      nntpXHdr);
    TRequestDone = procedure(Sender: TObject; RqType: TNntpRequest; Error: Word) of object;

    NntpException = class(Exception);

    TNntpCli = class(TComponent)
        constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
        procedure   Connect; virtual;
        procedure   Abort; virtual;
        procedure   Quit; virtual;
        procedure   Group(NewsGroupName : String); virtual;
        procedure   ArticleByNumber(Number : Integer; DestStream : TStream); virtual;
        procedure   ArticleByID(ID : String; DestStream : TStream); virtual;
        procedure   HeadByNumber(Number : Integer; DestStream : TStream); virtual;
        procedure   HeadByID(ID : String; DestStream : TStream); virtual;
        procedure   BodyByNumber(Number : Integer; DestStream : TStream); virtual;
        procedure   BodyByID(ID : String; DestStream : TStream); virtual;
        procedure   StatByNumber(Number : Integer); virtual;
        procedure   StatByID(ID : String); virtual;
        procedure   Next; virtual;
        procedure   Last; virtual;     { It is really Prior, but RFC-977 call it Last !}
        procedure   List(DestStream : TStream); virtual;
        procedure   Post(FromStream : TStream); virtual;
        procedure   Help(DestStream : TStream); virtual;
        procedure   Authenticate; virtual;
        procedure   XOver(Articles : String; DestStream : TStream); virtual;
        procedure   ListOverViewFmt(DestStream : TStream); virtual;
        procedure   Date; virtual;
        procedure   ModeReader; virtual;
        procedure   XHdr(DestStream : TStream;
                         Header     : String;
                         Range      : String); virtual;
        procedure   NewGroups(When          : TDateTime;
                              GMTFLag       : Boolean;
                              Distributions : String;
                              DestStream    : TStream);  virtual;
        procedure   NewNews(When          : TDateTime;
                            GMTFLag       : Boolean;
                            NewsGroupName : String;
                            Distributions : String;
                            DestStream    : TStream); virtual;
    protected
        FWindowHandle       : HWND;
{$IFDEF DUMP}
        FDumpStream         : TFileStream;
        FDumpBuf            : String;
{$ENDIF}
        FHost               : String;
        FState              : TNntpState;
        FWSocket            : TWSocket;
        FRequest            : String;
        FRequestType        : TNntpRequest;
        FRequestDoneFlag    : Boolean;
        FSentFlag           : Boolean;
        FStatusCode         : Integer;
        FSendBuffer         : array [0..NNTP_RCV_BUF_SIZE - 1] of char;
        FReceiveBuffer      : array [0..NNTP_RCV_BUF_SIZE - 1] of char;
        FReceiveLen         : Integer;
        FLastResponse       : String;
        FLastCmdResponse    : String;
        FErrorMessage       : String;
        FArticleEstimated   : Integer;
        FArticleFirst       : Integer;
        FArticleLast        : Integer;
        FArticleNumber      : Integer;
        FArticleID          : String;
        FServerDate         : TDateTime;
        FDataStream         : TStream;
        FUserName           : String;
        FPassWord           : String;
        FNext               : procedure of object;
        FPostingPermited    : Boolean;
        FOnSessionConnected : TSessionConnected;
        FOnSessionClosed    : TSessionClosed;
        FOnDataAvailable    : TDataAvailable;
        FOnRequestDone      : TRequestDone;
        FOnDisplay          : TNntpDisplay;
        FOnMessageBegin     : TNotifyEvent;
        FOnMessageEnd       : TNotifyEvent;
        FOnMessageLine      : TNotifyEvent;
        FOnXHdrBegin        : TNotifyEvent;
        FOnXHdrEnd          : TNotifyEvent;
        FOnXHdrLine         : TNotifyEvent;
        FOnStateChange      : TNotifyEvent;
        procedure WndProc(var MsgRec: TMessage);
        procedure WMNntpRequestDone(var msg: TMessage); message WM_NNTP_REQUEST_DONE;
        procedure WSocketDnsLookupDone(Sender: TObject; Error: Word);
        procedure WSocketSessionConnected(Sender: TObject; Error: Word);
        procedure WSocketDataAvailable(Sender: TObject; Error: Word);
        procedure WSocketSessionClosed(Sender: TObject; Error: Word);
        procedure WSocketDataSent(Sender: TObject; Error: Word);
        procedure TriggerRequestDone(Error: Word); virtual;
        procedure TriggerStateChange; virtual;
        procedure StateChange(NewState : TNntpState); virtual;
        procedure SendRequest; virtual;
        procedure GroupNext; virtual;
        procedure QuitNext; virtual;
        procedure XHdrLineNext; virtual;
        procedure GetArticleNext; virtual;
        procedure GetArticleLineNext; virtual;
        procedure GetArticleByNumber(RqType: TNntpRequest; Number : Integer; DestStream : TStream); virtual;
        procedure GetArticleByID(RqType: TNntpRequest; ID : String; DestStream : TStream); virtual;
        procedure GetArticle(RqType: TNntpRequest; ID : String; DestStream : TStream); virtual;
        procedure PostNext; virtual;
        procedure PostDone; virtual;
        procedure PostBlock; virtual;
        procedure PostSendNext; virtual;
        procedure DateNext; virtual;
        procedure ModeReaderNext; virtual;
        procedure XHdrNext; virtual;
        procedure AuthenticateNext1; virtual;
        procedure AuthenticateNext2; virtual;
        property  Handle        : HWND                  read FWindowHandle;
    published
        property WSocket : TWSocket                     read  FWSocket;
        property State   : TNntpState                   read  FState;
        property Host : String                          read  FHost
                                                        write FHost;
        property ErrorMessage : String                  read  FErrorMessage;
        property LastResponse : String                  read  FLastResponse;
        property StatusCode : Integer                   read  FStatusCode;
        property PostingPermited    : Boolean           read  FPostingPermited;
        property ArticleEstimated   : Integer           read  FArticleEstimated;
        property ArticleFirst       : Integer           read  FArticleFirst;
        property ArticleLast        : Integer           read  FArticleLast;
        property ArticleNumber      : Integer           read  FArticleNumber;
        property ArticleID          : String            read  FArticleID;
        property ServerDate         : TDateTime         read  FServerDate;
        property UserName           : String            read  FUserName
                                                        write FUserName;
        property PassWord           : String            read  FPassWord
                                                        write FPassWord;
        property OnSessionConnected : TSessionConnected read  FOnSessionConnected
                                                        write FOnSessionConnected;
        property OnSessionClosed : TSessionClosed       read  FOnSessionClosed
                                                        write FOnSessionClosed;
        property OnDataAvailable : TDataAvailable       read  FOnDataAvailable
                                                        write FOnDataAvailable;
        property OnRequestDone : TRequestDone           read  FOnRequestDone
                                                        write FOnRequestDone;
        property OnDisplay : TNntpDisplay               read  FOnDisplay
                                                        write FOnDisplay;
        property OnMessageBegin : TNotifyEvent          read  FOnMessageBegin
                                                        write FOnMessageBegin;
        property OnMessageEnd : TNotifyEvent            read  FOnMessageEnd
                                                        write FOnMessageEnd;
        property OnMessageLine : TNotifyEvent           read  FOnMessageLine
                                                        write FOnMessageLine;
        property OnXHdrBegin : TNotifyEvent             read  FOnXHdrBegin
                                                        write FOnXHdrBegin;
        property OnXHdrEnd : TNotifyEvent               read  FOnXHdrEnd
                                                        write FOnXHdrEnd;
        property OnXHdrLine : TNotifyEvent              read  FOnXHdrLine
                                                        write FOnXHdrLine;
        property OnStateChange : TNotifyEvent           read  FOnStateChange
                                                        write FOnStateChange;
    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;
{$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;