Smtpsock.pas
Материал из DRKB
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.