// Author     : Daniel, Master Sourcerer at Kitana's Castle
// Last change: November 26, 2003
// Email      : sourcerer@kitana.org


unit pop3;

interface

uses
  SysUtils, StrUtils, Dialogs;

const
  maxattachments = 64;

type
  TFilenames = array [1..maxattachments] of string;
  TAttachments = array [1..maxattachments] of string;

function POP3Connect(servername:string; serverport:integer):integer;
procedure POP3Disconnect(h:integer);
function POP3Login(h:integer; username:string; password:string):boolean;
procedure POP3MailStat(h:integer; var nmails:integer; var boxsize:integer);
function POP3MessageID(h:integer; mailnr:integer):string;
function POP3GetMailhead(h:integer; mailnr:integer):string;
function POP3GetMail(h:integer; mailnr:integer):string;
function POP3DeleteMail(h:integer; mailnr:integer):boolean;
procedure POP3ExtractMailParts(head:string; body:string; var msg:string; var f:TFilenames; var a:TAttachments; var natt:integer);
function HeaderAttr(head:string; attr:string):string;


implementation

uses Sockets, main;

const
  maxconnections = 16;

var
  csockets : array [1..maxconnections] of TTcpClient;


{ Gibt eine Log-Meldung aus }
procedure Log(s:string);
begin
end;



{ Wandelt einen String in eine Dezimalzahl um }
function StrToIntS(s:string):integer;
var
  i : integer;

begin
  try
    i:=StrToInt(s);
  except
    i:=0;
  end;
  StrToIntS:=i;
end;



{ Wandelt einen 2-Byte Hex-String in eine Zahl um }
function HexstrToOrd(h:string):byte;
var
  i : integer;
  b : byte;
  c : char;

begin
  b:=0;
  if Length(h)=2 then
  begin
    for i:=1 to 2 do
    begin
      b:=b*16;
      c:=UpCase(h[i]);
      case c of
        '0' .. '9': b:=b+Ord(c)-48;
        'A' .. 'F': b:=b+Ord(c)-55;
      end;
    end;
  end;

  HexstrToOrd:=b;
end;



{ Konvertiert ein Base64 Zeichen in seinen Ordinalwert }
function Base64ChrToOrd(c:char):byte;
var
  b : byte;

begin
  b:=255;
  case c of
    'A' .. 'Z': b:=Ord(c)-65;
    'a' .. 'z': b:=Ord(c)-97+26;
    '0' .. '9': b:=Ord(c)-48+52;
    '+'       : b:=62;
    '/'       : b:=63;
  end;

  Base64ChrToOrd:=b;
end;



{ Parst einen durch Leerzeichen seperierten String }
function Parse(s:string; argnr:integer):string;
var
  i,n,l : integer;
  r : string;
  q : boolean;

begin
  n:=1;
  i:=1;
  l:=Length(s);
  q:=false;

  {alle Zeichen des Strings untersuchen}
  while (i<=l) and (n<argnr) do
  begin
    {Leerzeichen nehmen, wenn letztes Zeichen kein Leerzeichen war}
    if (not q) and (s[i]=' ') then n:=n+1;
    q:=(s[i]=' ');
    i:=i+1
  end;

  {String bis zum nächsten Leerzeichen extrahieren}
  r:=TrimLeft(Copy(s,i,l-i+1));
  i:=Pos(' ',r);
  if i>0 then r:=Copy(r,1,i-1);

  Parse:=r;
end;



{ Liefert einen Attributwert aus dem Mail-Header }
function HeaderAttr(head:string; attr:string):string;
var
  s,u : string;
  p,lh,la : integer;

begin
  {case-insensitive vergleichen}
  s:=UpperCase(attr)+':';
  la:=Length(s);
  u:=UpperCase(head)+#13+#10;
  lh:=Length(head);

  {alle Zeilen des Headers durchsuchen}
  p:=1;
  while p<=lh do
  begin
    if Copy(u,p,la)=s then
    begin
      s:=Copy(head,p+la,lh-la-p+1);
      p:=Pos(#13,s);
      HeaderAttr:=Trim(Copy(s,1,p-1));
      Exit;
    end;
    p:=PosEx(#13,u,p)+2;
  end;

  HeaderAttr:='';
end;



{ Liest einen mehrzeiligen Text aus einem Socket }
function GetMultiLine(h:integer):string;
var
  r,s : string;
  n,p : integer;

begin
  {Zeilen lesen, bis ein einzelner '.' kommt}
  r:='';
  repeat
    s:=StringOfChar(#0,2048);
    n:=csockets[h].ReceiveBuf(s[1],2048,0);
    s:=Copy(s,1,n);
    Log(s);
    r:=r+s;
    p:=Pos(#13+#10+'.'+#13+#10,r);
    if p>0 then r:=Copy(r,1,p+1);
  until p>0;

  {Escape-Sequenzen ersetzen}
  s:='';
  n:=1;
  while n<=Length(r) do
  begin
    p:=PosEx(#13+#10,r,n);
    if r[n]='.' then s:=s+Copy(r,n+1,p-n+1) else s:=s+Copy(r,n,p-n+2);
    n:=p+2;
  end;

  GetMultiLine:=s;
end;



{ Stellt eine Verbindung zum POP3-Server her }
function POP3Connect(servername:string; serverport:integer):integer;
var
  i : integer;
  cs:TTcpClient;

begin
  {freien Eintrag suchen}
  for i:=1 to maxconnections do if csockets[i]=nil then Break;
  if i>maxconnections then
  begin
    POP3Connect:=0;
    Exit;
  end;

  {Clientsocket erzeugen}
  cs:=TTcpClient.Create(nil);
  if cs=nil then
  begin
    POP3Connect:=0;
    Exit;
  end;

  {ClientSocket initialiseren}
  cs.RemoteHost:=servername;
  cs.RemotePort:=IntToStr(serverport);
  cs.Tag:=i;
  csockets[i]:=cs;
  cs.Connect;
  Log(cs.Receiveln());

  POP3Connect:=i;
end;



{ Schließt die Verbindung zum Server }
procedure POP3Disconnect(h:integer);
begin
  if csockets[h]<>nil then
  begin
    csockets[h].Sendln('QUIT');
    csockets[h].Close;
    csockets[h]:=nil;
  end;
end;



{ Meldet den Benutzer am Server an }
function POP3Login(h:integer; username:string; password:string):boolean;
var
  s : string;

begin
  if csockets[h]=nil then
  begin
    POP3Login:=false;
    Exit;
  end;

  {Benutzername senden}
  csockets[h].Sendln('USER '+username);
  s:=csockets[h].Receiveln();
  Log(s);
  if Copy(s,1,3)<>'+OK' then
  begin
    POP3Login:=false;
    Exit;
  end;

  {Passwort senden}
  csockets[h].Sendln('PASS '+password);
  s:=csockets[h].Receiveln();
  Log(s);

  POP3Login:=(Copy(s,1,3)='+OK')
end;



{ Ermittelt die Anzahl und Gesamtgröße der Mails }
procedure POP3MailStat(h:integer; var nmails:integer; var boxsize:integer);
var
  s : string;

begin
  {Standardwerte}
  nmails:=0;
  boxsize:=0;
  if csockets[h]=nil then Exit;

  {Statusanfrage senden}
  csockets[h].Sendln('STAT');
  s:=csockets[h].Receiveln();
  Log(s);
  if Copy(s,1,3)='+OK' then
  begin
    {Statusdaten extrahieren}
    nmails:=StrToIntS(Parse(s,2));
    boxsize:=StrToIntS(Parse(s,3));
  end;
end;



{ Liefert die Message-ID einer Mail }
function POP3MessageID(h:integer; mailnr:integer):string;
var
  s : string;

begin
  if csockets[h]=nil then
  begin
    POP3MessageID:='';
    Exit;
  end;

  {ID-Anfrage senden}
  csockets[h].Sendln('UIDL '+IntToStr(mailnr));
  s:=csockets[h].Receiveln();
  Log(s);
  if Copy(s,1,3)<>'+OK' then
  begin
    POP3MessageID:='';
    Exit;
  end;

  POP3MessageID:=Parse(s,3);
end;



{ Liefert den Header einer Mail }
function POP3GetMailhead(h:integer; mailnr:integer):string;
var
  s : string;

begin
  if csockets[h]=nil then
  begin
    POP3GetMailhead:='';
    Exit;
  end;

  {Header-Anfrage senden}
  csockets[h].Sendln('TOP '+IntToStr(mailnr)+' 0');
  s:=csockets[h].Receiveln();
  Log(s);
  if Copy(s,1,3)<>'+OK' then
  begin
    POP3GetMailhead:='';
    Exit;
  end;

  POP3GetMailhead:=GetMultiLine(h);
end;



{ Liefert eine komplette Mail }
function POP3GetMail(h:integer; mailnr:integer):string;
var
  s : string;
  p : integer;

begin
  if csockets[h]=nil then
  begin
    POP3GetMail:='';
    Exit;
  end;

  {Header-Anfrage senden}
  csockets[h].Sendln('RETR '+IntToStr(mailnr));
  s:=csockets[h].Receiveln();
  Log(s);
  if Copy(s,1,3)<>'+OK' then
  begin
    POP3GetMail:='';
    Exit;
  end;

  {Mail inklusive Header lesen}
  s:=GetMultiLine(h);

  {Header entfernen}
  p:=Pos(#13+#10+#13+#10,s);
  if p>0 then s:=Copy(s,p+4,Length(s)-p-3);

  POP3GetMail:=s;
end;



{ Löscht eine Mail vom Server }
function POP3DeleteMail(h:integer; mailnr:integer):boolean;
var
  s : string;

begin
  if csockets[h]=nil then
  begin
    POP3DeleteMail:=false;
    Exit;
  end;

  {Befehl senden}
  csockets[h].Sendln('DELE '+IntToStr(mailnr));
  s:=csockets[h].Receiveln();
  Log(s);

  POP3DeleteMail:=Copy(s,1,3)='+OK';
end;



{ Dekodiert eine 7-Bit kodierte Nachricht }
function POP3Decode7Bit(s:string):string;
begin
  POP3Decode7Bit:=s;
end;



{ Dekodiert eine 8-Bit kodierte Nachricht }
function POP3Decode8Bit(s:string):string;
begin
  POP3Decode8Bit:=s;
end;



{ Dekodiert eine Quoted-Printable kodierte Nachricht }
function POP3DecodeQuotedPrintable(s:string):string;
var
  t : string;
  i,l : integer;

begin
  t:='';
  l:=Length(s);
  i:=1;
  while i<=l do
  begin
    if s[i]='=' then  {Sonderzeichen folgt}
    begin
      if Copy(s,i+1,2)=#13+#10 then  {Zeichenumbruch unterdrücken}
      begin
        i:=i+2;
      end
      else                           {Sonderzeichen}
      begin
        t:=t+Chr(HexstrToOrd(Copy(s,i+1,2)));
        i:=i+2;
      end;
    end
    else                             {normales Zeichen}
    begin
      t:=t+s[i];
    end;
    i:=i+1;
  end;

  POP3DecodeQuotedPrintable:=t;
end;



{ Dekodiert eine Base64 kodierte Nachricht }
function POP3DecodeBase64(s:string):string;
var
  i,l,n : integer;
  d : longint;
  b : byte;
  t : string;

begin
  t:='';
  l:=Length(s);
  n:=0;
  d:=0;

  {alle Zeichen des Quellstrings verarbeiten}
  for i:=1 to l do
  begin
    {je 4 Quellzeichen zu einer 24-Bit Zahl zusammenfassen}
    b:=Base64ChrToOrd(s[i]);
    if b<64 then  {nur gültige Zeichen betrachtet}
    begin
      d:=d*64+b;
      n:=n+1;
    end;
    if n=4 then   {24 Bit sind gefüllt}
    begin
      t:=t+Chr((d shr 16) and 255)+Chr((d shr 8) and 255)+Chr(d and 255);
      n:=0;
      d:=0;
    end;
  end;

  {Restzeichen verarbeiten}
  case n of
    2: t:=t+Chr((d shr 4) and 255);
    3: t:=t+Chr((d shr 10) and 255)+Chr((d shr 2) and 255);
  end;

  POP3DecodeBase64:=t;
end;



{ Extrahiert Nachricht und Anhänge aus der Mail }
procedure POP3ExtractMailParts(head:string; body:string; var msg:string; var f:TFilenames; var a:TAttachments; var natt:integer);
var
  contenttype : string;
  encoding : string;
  boundary : string;
  s,h,fname : string;
  p,p2,p3,q,n,l : integer;

begin
  for n:=1 to maxattachments do
  begin
    f[n]:='';
    a[n]:='';
  end;

  {Content-Type und Encoding ermitteln}
  contenttype:=HeaderAttr(head,'Content-Type');
  encoding:=HeaderAttr(head,'Content-Transfer-Encoding');
  boundary:='';
  if UpperCase(Copy(contenttype,1,9))='MULTIPART' then
  begin
    p:=Pos('BOUNDARY=',UpperCase(head));  {Boundary suchen}
    if p>0 then
    begin
      q:=PosEx(#13,head,p);
      boundary:=Copy(head,p+9,q-p-9);     {Boundary extrahieren}
      if Length(boundary)>2 then          {ggf. Anführungszeichen entfernen}
      begin
        if boundary[1]=#34 then boundary:=Copy(boundary,2,Length(boundary)-1);
        if boundary[Length(boundary)]=#34 then boundary:=Copy(boundary,1,Length(boundary)-1);
      end;
      boundary:='--'+boundary;
    end;
  end;

  {Nachrichtenteile trennen}
  n:=0;
  msg:=body;
  if boundary<>'' then
  begin
    l:=Length(boundary);
    q:=1;
    repeat
      p:=PosEx(boundary,body,q);
      if p=0 then Break;
      p:=p+l+2;  {Boundary und Zeilenumbruch überspringen}
      q:=PosEx(boundary,body,p);
      if q=0 then Break;
      s:=Copy(body,p,q-p);           {eine Nachricht}
      p:=Pos(#13+#10+#13+#10,s);     {Trennzeile zwischen Header und Body suchen}
      h:=Copy(s,1,p+1);              {Header}
      s:=Copy(s,p+4,Length(s)-p-3);  {Body}

      {Nachrichtenteil entschlüsseln}
      encoding:=UpperCase(HeaderAttr(h,'Content-Transfer-Encoding'));
      Log('Encoding #'+IntToStr(n)+': '+encoding);
      if encoding='7BIT' then s:=POP3Decode7Bit(s);
      if encoding='8BIT' then s:=POP3Decode8Bit(s);
      if encoding='QUOTED-PRINTABLE' then s:=POP3DecodeQuotedPrintable(s);
      if encoding='BASE64' then s:=POP3DecodeBase64(s);

      {Dateiname des Anhangs ermitteln}
      if n>0 then
      begin
        p:=Pos('FILENAME=',UpperCase(h));
        if p>0 then
        begin
          p:=p+9;
          p2:=PosEx(#13,h,p);
          p3:=PosEx(';',h,p);
          if p2=0 then p2:=p3;
          if p3=0 then p3:=p2;
          if p3<p2 then p2:=p3;
          fname:=Trim(Copy(h,p,p2-p));
          if fname[1]=#34 then fname:=Copy(fname,2,Length(fname)-1);
          if fname[Length(fname)]=#34 then fname:=Copy(fname,1,Length(fname)-1);
          f[n]:=fname;
        end;
      end;

      {Nachrichtenteil speichern}
      if n=0 then msg:=s else a[n]:=s;
      n:=n+1;
    until n>maxattachments;
  end;
  natt:=n;

  Log(boundary);
end;

end.