Smtpsock.pas

unit SmtpSock;
{
 CrtSocket for Delphi 32
 Copyright (C) 1999-2001 Paul Toth <tothpaul@free.fr>
 http://tothpaul.free.fr
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
interface
uses
 CrtSock, Classes;
function SmtpOpen(Server: string): Integer;
function SmtpError: string;
procedure SmtpClose;
function SmtpFrom(Email: string): Boolean;
function SmtpTo(Email: string): Boolean;
function SmtpHead(From, Rcpt, Subject: string): Boolean;
function SmtpSend(From, Rcpt, Subject: string; Msg: TStrings): Boolean;
procedure SmtpJoin(Name: string; Stream: TStream; Count: Integer);
function SmtpDone: Boolean;
implementation
var
 sin, sout: TextFile;
 last: string;
function ReadString: string;
begin
 repeat
 ReadLn(sin, Result);
 // writeln(result);
 until (Length(Result) < 4) or (Result[4] <> '-');
 last := Result;
end;
procedure WriteString(s: string);
begin
 // writeln('>>>',s);
 WriteLn(sout, s);
end;
function Status: Char;
var
 s: string;
begin
 s := ReadString;
 if s = then Status := '?'
 else
 Status := s[1];
end;
function Exec(cmd: string): Char;
begin
 WriteString(cmd);
 Result := Status;
end;
function SmtpOpen(Server: string): Integer;
begin
 Last := 'Server not found';
 Result := CallServer(Server, 25);
 if Result > 0 then
 begin
 AssignCrtSock(Result, sin, sout);
 if Status = '2' then
 begin
 if Exec('HELO MySoft.Delphi') = '2' then exit;
 Disconnect(Result);
 Result := -3;
 end
 else
 begin
 Disconnect(Result);
 Result := -2;
 end;
 end;
end;
function SmtpError: string;
begin
 Result := Last;
end;
procedure SmtpClose;
begin
 CloseFile(sout);
end;
function SmtpFrom(Email: string): Boolean;
begin
 Result := (Exec('MAIL ' + 'From: ' + EMail) = '2');
end;
function SmtpTo(EMail: string): Boolean;
begin
 Result := (Exec('RCPT To:' + Email) = '2');
end;
function SmtpHead(From, Rcpt, Subject: string): Boolean;
begin
 Result := False;
 if Exec('DATA') <> '3' then exit;
 WriteString('From: ' + From);
 WriteString('To: ' + Rcpt);
 WriteString('Subject: ' + Subject);
 WriteString('Content-Type: text/plain; charset=ISO-8859-1');
 WriteString('Content-Transfer-Encoding: 8bit'#13#10);
 WriteString();
 Result := True;
end;
function SmtpSend(From, Rcpt, Subject: string; Msg: TStrings): Boolean;
begin
 Result := False;
 if not SmtpHead(From, Rcpt, Subject) then exit;
 WriteString(Msg.Text);
 Result := SmtpDone;
end;
function uchr(b: Byte): Char;
begin
 if b = 0 then Result := #96
 else
 Result := chr(b + 32);
end;
procedure SmtpJoin(Name: string; Stream: TStream; Count: Integer);
var
 s: string[76];
 size: Integer;
 u: string;
 ss: Integer;
 c1, c2: Byte;
 x: Integer;
begin
 WriteString('begin 600 ' + Name);
 size := 45;
 while Count > 0 do
 begin
 if size > Count then size := Count;
 Dec(Count, size);
 Stream.Read(s[1], size);
 u := uchr(size);
 ss := 2;
 c2 := 0;
 for x := 1 to size do
 begin
 c1 := Ord(s[x]);
 u := u + uchr(c2 or (c1 shr ss));
 c2 := (c1 shl (6 - ss)) and 63;
 ss := (ss + 2) and 7;
 if ss = 0 then
 begin
 ss := 2;
 u := u + uchr(c2);
 c2 := 0;
 end;
 end;
 if (ss > 2) then
 begin
 u := u + uchr(c2) + #96;
 if ss = 4 then u := u + #96;
 end;
 WriteString(u);
 end;
 WriteString('end');
end;
function SmtpDone: Boolean;
begin
 Result := (Exec('.') = '2');
 CloseFile(sout);
end;
end.
Category:Связь
Category:Сокеты