icqclient.pas

本程序是转载的

unit ICQClient {v. 1.19};
{************************************************
    For updates checkout: http://www.cobans.net
      (C) Alex Demchenko([e-mail])
          Gene Reeves([e-mail])
*************************************************}
{$R-}                   //Remove range checking
{$DEFINE USE_FORMS}     //If you don't use forms unit remove this line



//Some needed defines, do not remove them!
{$IFDEF VER90}
  {$DEFINE OLD_DELPHI}
{$ENDIF}
{$IFDEF VER100}                                
  {$DEFINE OLD_DELPHI}
{$ENDIF}
{$IFDEF VER120}
  {$DEFINE OLD_DELPHI}
{$ENDIF}
{$IFDEF VER130}
  {$DEFINE OLD_DELPHI}
{$ENDIF}

//{$DEFINE HTTP_DEBUG}



interface
uses
  Windows, Messages, Classes {StringLists}, WinSock,
  ICQWorks, ICQSock, ICQDirect2, ICQLang, Forms, SysUtils;

{$IFNDEF USE_FORMS}
  {$DEFINE OLD_DELPHI}
{$ENDIF}

type
  //UIN Entry used in direct connections
  PUINEntry = ^TUINEntry;
  TUINEntry = record
    UIN: LongWord;
    Nick: ShortString;
    CType: Word;
    CTag: Word;
    CGroupID: Word;
    CGroup: ShortString;
    Cellular: ShortString;
    Authorized: Boolean; // *yegor
  end;

  TMyTimer = class;

  //Callback function types
  TOnPktParseAdv = procedure(Sender: TObject; Buffer: Pointer; BufLen: LongWord; Incoming: Boolean) of object;
  TOnHandlePkt = procedure(Flap: TFlapHdr; Buffer: Pointer) of object;
  TOnMsgProc = procedure(Sender: TObject; Msg, UIN: String) of object;
  TOnOffMsgProc = procedure(Sender: TObject; DateTime: TDateTime; Msg, UIN: String) of object;
  TOnURLProc = procedure(Sender: TObject; Description, URL, UIN: String) of object;
  TOnOffURLProc = procedure(Sender: TObject; DateTime: TDateTime; Description, URL, UIN: String) of object;
  TOnStatusChange = procedure(Sender: TObject; UIN: String; Status: LongWord) of object;
  TOnOnlineInfo = procedure(Sender: TObject; UIN: String; Port: Word; InternalIP, ExternalIP: String; ProtoVer, UserCaps: Byte) of object;
  TOnUserEvent = procedure(Sender: TObject; UIN: String) of object;
  TOnUserGeneralInfo = procedure(Sender: TObject; UIN, NickName, FirstName, LastName, Email, City, State, Phone, Fax, Street, Cellular, Zip, Country: String; TimeZone: Byte; PublishEmail: Boolean) of object;
  TOnUserWorkInfo = procedure (Sender: TObject; UIN, WCity, WState, WPhone, WFax, FAddress, WZip, WCountry, WCompany, WDepartment, WPosition, WOccupation, WHomePage: String) of object;
  TOnUserInfoMore = procedure (Sender: TObject; UIN: String; Age: Word; Gender: Byte; HomePage: String; BirthYear: Word; BirthMonth: Word; BirthDay: Word; Lang1, Lang2, Lang3: String) of object;
  TOnUserInfoAbout = procedure(Sender: TObject; UIN, About: String) of object;
  TOnUserInfoInterests = procedure(Sender: TObject; UIN: String; Interests: TStringList) of object;
  TOnUserInfoMoreEmails = procedure(Sender: TObject; UIN: String; Emails: TStringList) of object;
  TOnUserInfoBackground = procedure(Sender: TObject; UIN: String; Pasts, Affiliations: TStringList) of object;
  TOnUserFound = procedure(Sender: TObject; UIN, Nick, FirstName, LastName, Email: String; Status: Word; Gender, Age: Byte; SearchComplete: Boolean; Authorize: Boolean) of object;
  TOnServerListRecv = procedure(Sender: TObject; SrvContactList: TList) of object;
  TOnAdvMsgAck = procedure(Sender: TObject; UIN: String; ID: Word; AcceptType: Byte; AcceptMsg: String) of object;
  TOnMsgAck = procedure(Sender: TObject; UIN: String; ID: Word) of object;
  TOnAutoMsgResponse = procedure(Sender: TObject; UIN: String; ID: Word; RespStatus: Byte; Msg: String) of object;
  TOnContactListRecv = procedure(Sender: TObject; UIN: String; ContactList: TStringList) of object;
  TOnContactListReq = procedure(Sender: TObject; UIN, Reason: String) of object;
  TOnDirectPktAck = procedure(Sender: TObject; ID: Word) of object;
  TOnSMSAck = procedure(Sender: TObject; Source, Network, MsgId: String; Deliverable: Boolean) of object;
  TOnSMSReply = procedure(Sender: TObject; Source, SmsSender, Time, Text: String) of object;
  TOnInfoChanged = procedure(Sender: TObject; InfoType: TInfoType; ChangedOk: Boolean) of object;
  TOnAuthResponse = procedure(Sender: TObject; UIN: String; Granted: Boolean; Reason: String) of object;
  TOnChangeResponse = procedure(Sender: TObject; ErrorCode: Word) of object;
  TOnFTRequest = procedure(Sender: TObject; RequestRec: TFTRequestRec) of object;
  TOnUserInfoShort = procedure(Sender: TObject; UIN, NickName, FirstName, LastName, Email: String; UserFound, AuthRequired: Boolean) of object;
  TOnAuthRequest = Procedure(Sender:TObject; UIN:String; Var Reason:String; Var Authorize:Boolean) of Object;

  {TICQNet -- Object implementing sending/receiving packets between Client and ICQ Server.}
  TICQNet = class(TObject)
  private
    FSrcBuf: array[0..MAX_DATA_LEN - 1] of Byte;        //.              .
    FSrcLen: Word;                                      //.PACKET READING.
    FNewFlap: TFlapHdr;                                 //.     DATA     .
    FFlapSet: Boolean;                                  //.              .

    FSocket: TEventSocket;
    FSendSocket: TEventSocket;
    FCanSend: Boolean;                                  //Can send data through HTTP proxy

    FHost: String;
    FPort: Word;

    FProxyType: TProxyType;
    FProxyHost: String;
    FProxyPort: Word;
    FProxyUser: String;
    FProxyPass: String;
    FProxyAuth: Boolean;
    FProxyResolve: Boolean;

    FOnError: TOnError;
    FOnHandlePkt: TOnHandlePkt;
    FOnDisconnect: TNotifyEvent;
    FOnConnectError: TNotifyEvent;
    FOnPktParse: TOnPktParseAdv;

    FHTTPBuffer: TNetBuffer;
    FHTTPConnected: Boolean;
    FHTTPSid: String;
    FHTTPIP: String;
    FHTTPPort: Word;
    FHTTPSeq: Word;
    FHTTPFirstResend: Boolean;

    FErrLang: TICQLangType;


    procedure _OnConnect(Sender: TObject);
    procedure _OnError(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String);
    procedure _OnConnectError(Sender: TObject);
    procedure _OnDisconnect(Sender: TObject);
    procedure _OnReceive(Sender: TObject; Buffer: Pointer; BufLen: LongWord);
    procedure _OnDataSent(Sender: TObject);
    procedure SendHTTPData;
    procedure HTTPReconnect;
    procedure HTTPResend;
    procedure HandleHTTPDataPak(Buffer: Pointer; BufLen: LongWord);
    procedure HandleHTTPData(Buffer: Pointer; BufLen: LongWord);
    procedure HandleFlapData(Buffer: Pointer; BufLen: LongWord);
    procedure FreeSocket(var Socket: TEventSocket);
  public
    constructor Create;
    destructor Destroy; override;

    property Host: String read FHost write FHost;
    property Port: Word read FPort write FPort;

    property ProxyType: TProxyType read FProxyType write FProxyType;
    property ProxyHost: String read FProxyHost write FProxyHost;
    property ProxyPort: Word read FProxyPort write FProxyPort;
    property ProxyUser: String read FProxyUser write FProxyUser;
    property ProxyPass: String read FProxyPass write FProxyPass;
    property ProxyAuth: Boolean read FProxyAuth write FProxyAuth default False;
    property ProxyResolve: Boolean read FProxyResolve write FProxyResolve default False;

    procedure Connect;
    procedure SendData(var Data; DataLen: LongWord);
    procedure FreeSockets;
    procedure Disconnect;

    property ErrorLanguage: TICQLangType write FErrLang default LANG_EN;
  published
    property OnError: TOnError read FOnError write FOnError;
    property OnHandlePkt: TOnHandlePkt read FOnHandlePkt write FOnHandlePkt;
    property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
    property OnConnectError: TNotifyEvent read FOnConnectError write FOnConnectError;
    property OnPktParse: TOnPktParseAdv read FOnPktParse write FOnPktParse;
  end;

  {TICQClient -- ICQ Component}
  TICQClient = class(TComponent)
  private
    FSock: TICQNet;                                     //Client's socket
    FLUIN: LongWord;                                    //Client's UIN
    FLPass: String;                                     //Client's password
    FFirstConnect: Boolean;                             //Flag, used in login sequence
    FSeq: Word;                                         //Main Flap Seq
    FSeq2: Word;                                        //TO_ICQSRV Seq
    FDSeq: Word;                                        //Direct connection Seq
    FCookie: String;                                    //Temporary cookie, used in login sequence, we can use String type, becouse ICQ server doesn't send 0x00 chars in it's Cookie part
    FIp: String;                                        //Ip to connect to
    FPort: Word;                                        //Port to connect to
    FDConnCookie: LongWord;                             //Direct connection cookie
    FDirect: TDirectControl;                            //Direct control
    //-- Proxy settings
    FProxyType: TProxyType;                             //.
    FProxyHost: String;                                 //.
    FProxyPort: Word;                                   //. Proxy Configaration
    FProxyAuth: Boolean;                                //.        Data
    FProxyPass: String;                                 //.
    FProxyUser: String;                                 //.
    FProxyResolve: Boolean;
    //-- Events & other stuff --
    FContactLst: TStrings;
    FVisibleLst: TStrings;
    FInvisibleLst: TStrings;
    FOnMsg: TOnMsgProc;
    FOnURL: TOnURLProc;
    FOnOffMsg: TOnOffMsgProc;
    FOnOffURL: TOnOffURLProc;
    FOnLogin: TNotifyEvent;
    FOnLogOff: TNotifyEvent;
    FOnPktParse: TOnAdvPktParse;
    FOnDPktParse: TOnParseDirectPkt;
    FOnConnectionFailed: TNotifyEvent;
    FOnStatusChange: TOnStatusChange;
    FOnUserOffline: TOnUserEvent;
    FOnAddedYou: TOnUserEvent;
    FOnUserGeneralInfo: TOnUserGeneralInfo;
    FOnUserWorkInfo: TOnUserWorkInfo;
    FOnUserInfoMore: TOnUserInfoMore;
    FOnUserInfoAbout: TOnUserInfoAbout;
    FOnUserInfoInterests: TOnUserInfoInterests;
    FOnUserInfoMoreEmails: TOnUserInfoMoreEmails;
    FOnUserInfoBackground: TOnUserInfoBackground;
    FStatus: LongWord;
    FDoPlain: Boolean;
    FInfoChain: TStringList;
    FSInfoChain: TStringList;
    FLastInfoUin: String;
    FLastSInfoUin: String;
    FLoggedIn: Boolean;
    FRegisteringUIN: Boolean;
    FRegPassword: String;
    FOnUserFound: TOnUserFound;
    FOnUserNotFound: TNotifyEvent;
    FOnServerListRecv: TOnServerListRecv;
    FOnAdvMsgAck: TOnAdvMsgAck;
    FOnMsgAck: TOnMsgAck;
    FOnNewUINRegistered: TOnUserEvent;
    FOnNewUINRefused: TNotifyEvent;
    FOnAutoMsgResponse: TOnAutoMsgResponse;
    FAutoAwayMsg: String;
    FOnUnregisterOk: TNotifyEvent;
    FOnUnregBadPass: TNotifyEvent;
    FOnContactListRecv: TOnContactListRecv;
    FOnContactListReq: TOnContactListReq;
    FOnDirectPktAck: TOnDirectPktAck;
    FOnSmsRefused: TNotifyEvent;
    FOnSMSAck: TOnSMSAck;
    FOnOnlineInfo: TOnOnlineInfo;
    FUseDirect: Boolean;
    FOnError: TOnError;
    FTimer: TMyTimer;
    FTimeout: Byte;
    FOnSMSReply: TOnSMSReply;
    FOnInfoChanged: TOnInfoChanged;
    FOnAuthSet: TNotifyEvent;
    FOnAuthResponse: TOnAuthResponse;
    FOnChangeResponse: TOnChangeResponse;
    FOnFTRequest: TOnFTRequest;
    FOnFTInit: TOnFTInit;
    FOnFTStart: TOnFTStart;
    FOnFTFileData: TOnFTFileData;
    FOnSendFileStart: TOnSendFileStart;
    FOnSendFileData : TOnSendFileData;
    FOnSendFileFinish: TOnSendFileFinish;
    FLastError: String;
    FOnUserInfoShort: TOnUserInfoShort;
    FOnAuthReq:TOnAuthRequest;
    FErrLang: TICQLangType;

    procedure InitNetICQ;
    procedure OnIntError(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String);
    procedure HandlePacket(Flap: TFlapHdr; Data: Pointer);
    procedure SetStatus(NewStatus: LongWord);
    //-- Handling Snac packet procedures
    procedure HSnac0407(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac1503(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac030B(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac131C(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac1319(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac1306(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac040b(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac040C(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac1705(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac131b(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HSnac130e(Flap: TFlapHdr; Snac: TSnacHdr; Pkt: PRawPkt);
    procedure HDirectMsg(Sender: TObject; UIN: LongWord; Pak: PRawPkt; Len: LongWord);
    procedure FTOnConnectError(Sender: TObject);
    procedure FTOnDisconnect(Sender: TObject);
    procedure FTOnDirectParse(Sender: TObject; Buffer: Pointer; BufLen: LongWord; Incoming: Boolean; UIN:Cardinal);
    procedure FTOnPktParse(Sender: TObject; Buffer: Pointer; BufLen: LongWord; Incoming: Boolean);
    procedure OnFTInitProc(Sender: TObject; UIN: LongWord; FileCount, TotalBytes, Speed: LongWord; NickName: String);
    procedure OnFTStartProc(Sender: TObject; StartRec: TFTStartRec; FileName: String; FileSize, Speed: LongWord);
    procedure OnFTFileDataProc(Sender: TObject; UIN: LongWord; Data: Pointer; DataLen: LongWord; LastPacket: Boolean);
    procedure OnSendFileStartProc(Sender:TObject; UIN: LongWord; SendFileRec:TSendFileRec);
    Procedure OnSendFileDataProc(Sender:TObject; UIN:LongWord; Data:Pointer;Var DataLen:LongWord; Var IsLastPacket:Boolean);
    {$HINTS OFF}
    Procedure OnSendFileFinishProc(Sender:TObject; UIN:LongWord; SendFileRec:TSendFileRec; Aborted:Boolean);
    {$HINTS ON}    
    procedure SetContactList(Value: TStrings);
    procedure SetVisibleList(Value: TStrings);
    procedure SetInvisibleList(Value: TStrings);
    procedure OnTimeout(Sender: TObject);
    procedure SetErrorLang(NewLang: TICQLangType);
    procedure SetPortLast(aPort:Word);
    procedure SetPortFirst(aPort:word);
    function GetPortLast:Word;
    function GetPortFirst:Word;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Login(Status: LongWord = S_ONLINE; BirthDay: Boolean = False);
    procedure RequestOfflineMessages; // *yegor
    procedure LogOff;
    procedure RegisterNewUIN(const Password: String);
    procedure Disconnect;
    procedure SendMessage(UIN: LongWord; const Msg: String);
    procedure SendURL(UIN: LongWord; const URL, Description: String);
    function AddContact(UIN: LongWord): Boolean;
    function AddContactMulti(UINList: Array of LongWord):Boolean;
    Function AddContactVisible(UIN: LongWord):Boolean;
    Function AddContactInvisible(UIN: LongWord):Boolean;
    procedure RemoveContact(UIN: LongWord);
    procedure RemoveContactVisible(UIN: LongWord);
    procedure RemoveContactInvisible(UIN: LongWord);
    procedure RequestInfo(UIN: LongWord);
    procedure RequestInfoShort(UIN: LongWord);
    procedure SearchByMail(const Email: String);
    procedure SearchByUIN(UIN: LongWord);
    procedure SearchByName(const FirstName, LastName, NickName, Email: String);
    procedure SearchRandom(Group: Word);
    procedure SearchWhitePages(const FirstName, LastName, NickName, Email: String; MinAge, MaxAge: Word; Gender: Byte; const Language, City, Country, Company, Department, Position, Occupation, Organization, OrganKeyWords, PastAffiliation, AffiKeyWords, KeyWord: String; Online: Boolean);
    procedure SetSelfInfoGeneral(NickName, FirstName, LastName, Email, City, State, Phone, Fax, Street, Cellular, Zip, Country: String; TimeZone: Byte; PublishEmail: Boolean);
    procedure SetSelfInfoMore(Age: Word; Gender: Byte; const HomePage: String; BirthYear: Word; BirthMonth, BirthDay: Byte; Language1, Language2, Language3: String);
    procedure SetSelfInfoAbout(const About: String);
    procedure RequestContactList;
    procedure DestroyUINList(var List: TList);
    procedure SendSMS(const Destination, Text: String);
    procedure SendMessageAdvanced(UIN: LongWord; const Msg: String; ID: Word; RTFFormat: Boolean);
    function SendMessageDirect(UIN: LongWord; const Msg: String; RTFFormat: Boolean): Word;
    Function SendFileDC(UIN:LongWord; FileName, Description:String): Word;
    Procedure SendFileCancel(UIN: LongWord);
    procedure RequestAwayMsg(UIN: LongWord; ID: Word; ReqStatus: Byte);
    procedure UnregisterUIN(const Password: String);
    procedure ChangePassword(const NewPassword: String);
    procedure ChangePasswordPtr(Buffer: Pointer; BufLen: Word);
    function DirectConnectionEstabilished(UIN: LongWord): Boolean;
    function SendContacts(UIN: LongWord; Contacts: TStringList; ID: Word): Boolean;
    function RequestContacts(UIN: LongWord; const Reason: String; ID: Word): Boolean;
    function SendContactsDC(UIN: LongWord; Contacts: TStringList): Word;
    function RequestContactsDC(UIN: LongWord; const Reason: String): Word;
    procedure SendKeepAlive;
    procedure SetAuthorization(AuthorizationRequired, WebAware: Boolean);
    procedure SendAuthRequest(UIN: LongWord; Msg: String);
    procedure SSLChangeStart(FirstUpload: Boolean);
    procedure SSLChangeEnd;
    procedure SSLAddGroup(GroupName: String; GroupID: Word);
    procedure SSLAddUser(GroupID, UserID: Word; UIN, Name, SMSNumber: String; Authorize, UpdateUser: Boolean);
    procedure SSLDelUser(GroupID, UserID: Word; UIN, Name, SMSNumber: String; Authorize: Boolean);
    procedure SSLDelGroup(GroupName: String; GroupID: Word);
    procedure SSLUpdateGroup(GroupName: String; GroupID: Word; UserIDs: TStringList);
    procedure SSLAddUserIntoList(UserID: Word; UIN: String; BuddyType: Word);
    procedure SSLDelUserFromList(UserID: Word; UIN: String; BuddyType: Word);
    function FTResponse(ResponseRec: TFTRequestRec; Accept: Boolean; Reason: String): Boolean;
    procedure FTCancel(UIN: LongWord);
    function FTStartResponse(StartRec: TFTStartRec): Boolean;
    property LastError: String read FLastError;
    property Status: LongWord read FStatus write SetStatus;
    property LoggedIn: Boolean read FLoggedIn;
  published