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.