Do que se trata??
uma aplicação parecida com o messenger da microsoft??
[]'s
__________________________________________
David Leão Alves
Administrador de Banco de Dados
Governo do Estado do Amapá
Secretaria de Estado do Meio Ambiente - SEMA
Av. Mendonça Furtado, 53 - Centro / Macapá-AP
212-5318 - 212-5378
212-5303
[EMAIL PROTECTED]
www.sema.ap.gov.br
-------Mensagem original-------
De: [EMAIL PROTECTED]
Data: 10/22/04 17:15:03
Para: '[EMAIL PROTECTED]'
Assunto: [delphi-br] Achei isso no Delphi3000
This is an implementation of the msn messenger protocol in delphi it isnt
complete and in order to build it you will need the WSocket package, most of
what is
presented here is a part of the specification (still not enough to even make
a stripped down MSN Messenger clone).
The work you see here has its todos (most due to the fact that I am simply
new to sockets programming), this article is based on works of venkydude MSN
article and
a old version of KMerlin (an opensource msn messenger clone for linux).
This is the second article I write on Instant Messaging (The first one about
the yahoo protocol, something wich I have not been able to complete due to
time
constraints (lot of work))
I am planning in updating this article As Soon As Posible and I would like
some help, if you are interested (in helping me) contact me at my email
address
([EMAIL PROTECTED]) with the subject "YahooLib.pas" (Without quotes, this
way I know it is about the msn/yahoo protocols)
So enough chat in here is the code:
<---------------------------------CODE--------------------------------------
-->
{GLOBAL TODO: IMPLEMENT LOCAL TODO's, cleanup, extend}
unit MSNMessenger;
interface
uses
WSocket, MD5, Classes, SysUtils;
type
TUserState = (
usOnline, // you are online
usBusy, // Actually busy
usBRB, // Be Right Back
usAway, // Away
usOnPhone, //On Phone
usLunch, //Lunch
usHidden, //Hidden
usOffline //Offline
);
TMSNMessenger = class(TComponent)
private
FConnected: Boolean;
FUserName: String;
FPassword: String;
FFriendlyUserName: String;
FLog: TStrings;
FFriendlyNameChange: TNotifyEvent;
FState: TUserState;
function GetHost: String;
procedure SetHost(const Value: String);
function GetPort: String;
procedure SetPort(const Value: String);
procedure SetUserName(const Value: String);
procedure SetPassWord(const Value: String);
function GetFriendlyUserName: String;
procedure SetFriendlyUserName(const Value: String);
procedure SetState(const Value: TUserState);
protected
FSocket: TWSocket;
FTrialID: Integer;
procedure SendVER;
procedure ReceiveSYN;
procedure SocketWrite(const AString: String);
procedure LogWrite(const Data: String);
procedure ProcessCommand(const ACommand: String);
procedure SocketDisconnect(Sender: TObject; Error: Word);
procedure SocketDataAvailable(Sender: TObject; Error: Word);
procedure SocketConnect(Sender: TObject; Error: Word);
procedure TriggerFriendlyNameChange; dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Login;
procedure Logoff;
published
property Host: String read GetHost write SetHost;
property Port: String read GetPort write SetPort;
property UserName: String read FUserName write SetUserName;
property PassWord: String read FPassword write SetPassWord;
property FriendlyUserName: String read GetFriendlyUserName write
SetFriendlyUserName;
property Connected: Boolean read FConnected;
property Log: TStrings read FLog write FLog;
property FriendlyNameChange: TNotifyEvent read FFriendlyNameChange write
FFriendlyNameChange;
property Status: TUserState read FState write SetState;
end;
implementation
uses windows;
const RealState: array[TUserState] of String =
('CHG %d NLN', 'CHG %d BSY', 'CHG %d BRB', 'CHG %d AWY', 'CHG %d PHN',
'CHG %d LUN',
'CHG %d HDN', 'CHG %d FLN' );
type
CharSet = Set of char;
function UTF8ToAnsi(x: string): ansistring;
{ Function that recieves UTF8 string and converts
to ansi string }
var
i: integer;
b1, b2: byte;
begin
Result := x;
i := 1;
while i <= Length(Result) do begin
if (ord(Result[i]) and $80) <> 0 then begin
b1 := ord(Result[i]);
b2 := ord(Result[i + 1]);
if (b1 and $F0) <> $C0 then
Result[i] := #128
else begin
Result[i] := Chr((b1 shl 6) or (b2 and $3F));
Delete(Result, i + 1, 1);
end;
end;
inc(i);
end;
end;
function AnsiToUtf8(x: ansistring): string;
{ Function that recieves ansi string and converts
to UTF8 string }
var
i: integer;
b1, b2: byte;
begin
Result := x;
for i := Length(Result) downto 1 do
if Result[i] >= #127 then begin
b1 := $C0 or (ord(Result[i]) shr 6);
b2 := $80 or (ord(Result[i]) and $3F);
Result[i] := chr(b1);
Insert(chr(b2), Result, i + 1);
end;
end;
Function ExtractWord(N:Integer;S:String;WordDelims:CharSet):String;
Var
I,J:Word;
Count:Integer;
SLen:Integer;
Begin
Count := 0;
I := 1;
Result := '';
SLen := Length(S);
While I <= SLen Do Begin
{preskoc oddelovace}
While (I <= SLen) And (S[I] In WordDelims) Do Inc(I);
{neni-li na konci retezce, bude nalezen zacatek slova}
If I <= SLen Then Inc(Count);
J := I;
{a zde je konec slova}
While (J <= SLen) And Not(S[J] In WordDelims) Do Inc(J);
{je-li toto n-te slovo, vloz ho na vystup}
If Count = N Then Begin
Result := Copy(S,I,J-I);
Exit
End;
I := J;
End; {while}
End;
function WordAt(const Text : string; Position : Integer) : string;
begin
Result := ExtractWord(Position, Text, [' ']);
end;
{ TMSNMessenger }
constructor TMSNMessenger.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSocket := TWSocket.Create(Self);
FSocket.Addr := 'messenger.hotmail.com';
FSocket.Port := '1863';
FSocket.Proto:= 'tcp';
FSocket.OnSessionConnected := SocketConnect;
FSocket.OnSessionClosed := SocketDisconnect;
FSocket.OnDataAvailable := SocketDataAvailable;
FConnected := False;
end;
destructor TMSNMessenger.Destroy;
begin
FSocket.Free;
FSocket := nil;
inherited Destroy;
end;
function TMSNMessenger.GetFriendlyUserName: String;
begin
if not FConnected then
Result := FFriendlyUserName;
end;
function TMSNMessenger.GetHost: String;
begin
Result := FSocket.Addr;
end;
function TMSNMessenger.GetPort: String;
begin
Result := FSocket.Port;
end;
procedure TMSNMessenger.Login;
begin
FSocket.Connect;
end;
procedure TMSNMessenger.Logoff;
begin
end;
procedure TMSNMessenger.LogWrite(const Data: String);
begin
if Assigned( FLog ) then
FLog.Add(Data);
end;
{Processcommand here is akin to a windowproc
here we process all kind of info sent from the server
as of now it is IFFull (full of if's) perhaps if i have
some spare time will turn this into a case
TODO: Clean this procedure mess up
TODO: Add more commands}
procedure TMSNMessenger.ProcessCommand;
var
Tmp: String;
Hash: String;
begin
Tmp := WordAt(ACommand, 1);
if Tmp = 'VER' then
SocketWrite('INF %d');
if Tmp = 'INF' then
SocketWrite('USR %d MD5 I '+ FUserName);
if Tmp = 'USR' then
begin
if WordAt(ACommand, 4) = 'S' then
begin
Hash := WordAt(ACommand, 5);
Delete(Hash, pos(#13#10, Hash), Length(Hash));
Hash := StrMD5(Hash + PassWord);
SocketWrite('USR %d MD5 S ' + Lowercase(Hash));
end else
begin
FFriendlyUserName := WordAt(ACommand, 5);
SocketWrite('SYN %d 1');
ReceiveSYN;
end;
end;
{When you receive an XFR and you are not connected
to the msn server it means redirect to another server}
if (TMP = 'XFR') and not Connected then
begin
TMP := WordAt(ACommand, 4);
FSocket.Close;
Delete(Tmp, pos(':', Tmp), Length(Tmp));
FSocket.Addr := Tmp;
TMP := WordAt(ACommand, 4);
Delete(Tmp, 1, pos(':', Tmp));
FSocket.Port := Tmp;
FSocket.Connect;
Exit;
end;
{Rename Friendly name}
if (TMP = 'REA') then
begin
FFriendlyUserName := WordAt(ACommand, 5);
FFriendlyUserName := StringReplace(FFriendlyUserName, '%20', ' ',
[rfReplaceall]);
TriggerFriendlyNameChange;
end;
{The out command is received before the server
disconnects us, if it's because we've logged in another machine
we receive the message OUT OTH (OTHER MACHINE)
TODO write some event or something to retrieve this notification}
if (TMP = 'OUT') then
begin
if pos('OTH', ACommand) > 1 then
LogWrite('Logged out in another computer disconnecting');
end;
end;
{SYN is without a doubt the most informationfull MSN Messenger Command
SYN informs us of:
available email
Friend List
Block List
Reverse list (people that has you in their lists)
Phone numbers (Home, mobile, etc.)
MSN Messenger settings
etc.
however this comes with a price, since there is so much information
WSocket may not get all the info properly (a quality of non blocking
sockets)
thus in order to get it we will freeze this thread for 5 seconds
(meaning your forms will not receive any message and
seem unresponsive for a while), I
know there must be a better way around if somebody knows email me.
TODO : Parse the received content
TODO : look for a way wich does not have to freeze the thread
}
procedure TMSNMessenger.ReceiveSYN;
var
Tmp: String;
begin
FSocket.OnDataAvailable := nil;
Sleep(5000);
Tmp := FSocket.ReceiveStr;
FSocket.OnDataAvailable := SocketDataAvailable;
Tmp := UTF8ToAnsi(Tmp);
LogWrite('RECV : ' + Tmp);
SocketWrite('CHG %d NLN');
end;
procedure TMSNMessenger.SendVER;
begin
SocketWrite('VER %d CVR0 MSNP5 MSNP6 MSNP7')
end;
procedure TMSNMessenger.SetFriendlyUserName(const Value: String);
var
tmp: String;
begin
if FConnected and (FUserName <> Value) then
begin
tmp := StringReplace(Value, ' ', '%20', [rfReplaceAll]);
tmp := AnsiToUtf8(Tmp);
SocketWrite('REA %d ' + FUsername + ' '+ tmp);
end;
end;
procedure TMSNMessenger.SetHost(const Value: String);
begin
if not Connected then
if FSocket.Addr <> Value then
FSocket.Addr := Value;
end;
procedure TMSNMessenger.SetPassWord(const Value: String);
begin
if not Connected then
if (FPassword <> Value) then
FPassword := Value;
end;
procedure TMSNMessenger.SetPort(const Value: String);
begin
if not Connected then
if FSocket.Port <> Value then
FSocket.Port := Value;
end;
procedure TMSNMessenger.SetState(const Value: TUserState);
begin
if FConnected then
if (FState <> Value) then
SocketWrite( RealState[Value] );
end;
procedure TMSNMessenger.SetUserName(const Value: String);
begin
if not FConnected then
if FUsername <> Value then
FUserName := Value;
end;
procedure TMSNMessenger.SocketConnect(Sender: TObject; Error: Word);
begin
FTrialID := 1;
SendVER;
end;
procedure TMSNMessenger.SocketDataAvailable(Sender: TObject; Error: Word);
var
Tmp: String;
begin
Tmp := FSocket.ReceiveStr;
Tmp := UTF8ToAnsi(Tmp);
LogWrite('RECV : ' + Tmp);
ProcessCommand(Tmp);
end;
procedure TMSNMessenger.SocketDisconnect(Sender: TObject; Error: Word);
begin
FConnected := False;
LogWrite('Disconnected');
end;
procedure TMSNMessenger.SocketWrite(const AString: String);
begin
FSocket.SendStr(Format(AString, [FTrialID]) + #13+#10);
LogWrite('SENT : ' + Format(AString, [FTrialID]));
Inc(FTrialID);
end;
procedure TMSNMessenger.TriggerFriendlyNameChange;
begin
if Assigned(FFriendlyNameChange) then
FFriendlyNameChange(Self);
end;
end.
<---------------------------------/CODE-------------------------------------
-->
a sample would be:
AMSN := TMSNMessenger.Create(Self); // AMSN is a variable of type
TMSNMessenger
AMSN.UserName := ''; // This indicates the username wich should always be
of form [EMAIL PROTECTED]
AMSN.PassWord := '';//This indicates the password
AMSN.Log := MEmo1.Lines; // Log indicates a destination to dump the
received and sent information, I use it for retrieving protocol information
and stuff but it is not obligatory to use it
AMSN.Login; // procedure wich indicates that we should start the login
process
[]s
Walter Alves Chagas Junior
Projeto e desenvolvimento
Telemont Engenharia
[EMAIL PROTECTED]
Fone: (31) 3389-8215 Fax: (31) 3389-8200
[As partes desta mensagem que não continham texto foram removidas]
--
<<<<< FAVOR REMOVER ESTA PARTE AO RESPONDER ESTA MENSAGEM >>>>>
Para ver as mensagens antigas, acesse:
http://br.groups.yahoo.com/group/delphi-br/messages
Para falar com o moderador, envie um e-mail para:
[EMAIL PROTECTED] ou [EMAIL PROTECTED]
Links do Yahoo! Grupos
[As partes desta mensagem que não continham texto foram removidas]
--
<<<<< FAVOR REMOVER ESTA PARTE AO RESPONDER ESTA MENSAGEM >>>>>
Para ver as mensagens antigas, acesse:
http://br.groups.yahoo.com/group/delphi-br/messages
Para falar com o moderador, envie um e-mail para:
[EMAIL PROTECTED] ou [EMAIL PROTECTED]
Links do Yahoo! Grupos
<*> Para visitar o site do seu grupo na web, acesse:
http://br.groups.yahoo.com/group/delphi-br/
<*> Para sair deste grupo, envie um e-mail para:
[EMAIL PROTECTED]
<*> O uso que você faz do Yahoo! Grupos está sujeito aos:
http://br.yahoo.com/info/utos.html
