{  
------------------------------------------------------------------------ 
- }
{ Mailadresse ('@' in der Mitte) in einem String erkennen und ausschneiden  }
{ Ist remove=true, dann wird aus 's' die Mailadresse ausgeschnitten.        }
{ Wird keine gltige Adresse erkannt, wird der komplette String an die      }
{ Funktion zurckgegeben.                                                   }
{                                                                           }
{                                                                           }
{ Žnderungen my 10/2004:                                                    }
{ ----------------------                                                    }
{                                                                           }
{ 1. Zus„tzliche Variable 's1' eingefhrt. Wird keine gltige Adresse       }
{    erkannt, wird 's1' ein Leerstring zugewiesen, anderenfalls wird die    }
{    Adresse sowohl an die Funktion als auch an 's1' zurckgegeben.         }
{                                                                           }
{ my: Kommentare, quoted-strings, quoted-pairs und Domain-Literale werden   }
{     jetzt beachtet, die Adresse wird aber ansonsten *nicht* auf syntak-   }
{     tische Korrektheit gem„á RFC2822 berprft! Leerzeichen drfen nur in }
{     Kommentaren, quoted-strings und Domain-Literalen vorkommen.           }
{                                                                           }
{     Die Adresse muá durch WSPs vom restlichen Text getrennt oder in '<>'  }
{     eingeschlossen sein oder sich ganz am Anfang des Strings befinden.    }
{                                                                           }
{     Sie sollte danach noch mittels RFC2822_Remove von Kommentaren sowie   }
{     berflssigen quoted-strings und quoted-pairs bereinigt werden (falls }
{     sie berhaupt verwendet wird, d.h. remove=false ist).                 }
{                                                                           }
{     Wenn remove=true und sich sowohl links als auch rechts von der        }
{     Adresse je ein Leerzeichen befindet, wird das rechte mitgel”scht.     }
{     Spitze Klammern werden ebenfalls gel”scht (aber nicht in der Adresse  }
{     bergeben).                                                           }
{                                                                           }
{     Wenn der Versuch, beim ersten Vorkommen von "@" eine gltige Adresse  }
{     zu erkennen, fehlschl„gt, wird die Routine nicht wie bisher ohne      }
{     Ergebnis abgebrochen, sondern es wird solange weitergesucht, bis eine }
{     Adresse gefunden wurde oder kein "@" mehr vorhanden ist.              }
{                                                                           }
{ ------------------------------------------------------------------------- }
function mailstring(s:string; var s1:string; const remove:boolean):string;
const sc = #9#32+'()<>[]:;@,"';
var q,p1,p2,incomment : byte;
    ok,char_seen,
    inquote,lastdot   : boolean;
label start;
begin
  p2:=cpos('@',s);                                         { '@' vorhanden? }
start:
  ok:=false;
  while not ok do
  begin
    inquote:=false;
    char_seen:=false;
    lastdot:=false;
    incomment:=0;
    if (p2>1) and (p2<length(s)) then
    begin
      p1:=p2;
      while p1>1 do                                         { Anfang suchen }
      begin
        dec(p1);
        while (p1>1) and (s[p1-1]='\') and
               ((inquote and (s[p1]<chr(127)) and (s[p1]<>'\')) or
                (incomment>0)) do       { Zeichen in Kommentaren irrelevant }
        begin
          q:=p1-1;
          while (q>1) and (s[q-1]='\') do dec(q);
          if (odd(p1-q)) then
            if p1>2 then
              dec(p1,2)
            else
              dec(p1);
        end;
        case s[p1] of
          '\' : if inquote then break;          { "\" alleine nicht erlaubt }
          '"' : if not (char_seen or inquote) then
                  inquote:=true else
                if (char_seen and inquote) then            { "user"@do.main }
                begin
                  inquote:=false; break;
                end else
                if char_seen then  { inquote=false }   {     "user@do.main" }
                begin                                  { => '"' ignorieren! }
                  inc(p1); break;
                end
                else break; { char_seen=false, inquote=true }  { ""@do.main }
          ')' : if not inquote then inc(incomment);
          '(' : if not inquote then
                  if incomment>0 then
                    dec(incomment) else
                  if char_seen then                    {     (user@do.main) }
                  begin                                { => '(' ignorieren! }
                    inc(p1); break;
                  end
                  else break; { char_seen=false, incomment=0 } { (@do.main) }
          '<' : if char_seen then                      {     <user@do.main> }
                begin                                  { => '<' ignorieren! }
                  inc(p1); break;
                end
                else break;  { char_seen=false }               { <@do.main> }
          #9,
          ' ' : if char_seen and not (inquote or (incomment>0)) then
                begin
                  inc(p1); break;
                end;
          '.' : if lastdot then
                begin                           { Fehler bei '..' erzwingen }
                  char_seen:=false; break;
                end
                else lastdot:=not (inquote or (incomment>0));
        else if inquote and (s[p1]>chr(127)) then
          break
        else if incomment=0 then
          char_seen:=true;
        end;  { case }
      end;
      if inquote or (incomment>0) or       { ungltiger local-part, evtl.   }
         not char_seen then                { '@' in quoted-string gefunden? }
      begin
        q:=p2;
        p2:=cpos('@',mid(s,q+1));               { => n„chstes '@' probieren }
        if p2>0 then inc(p2,q);
      end else
        ok:=true;
    end
    else begin                                    { '@' am Anfang oder Ende }
      p1:=0;
      p2:=0;
      ok:=true;
    end;
  end;
  { ----------------------------------------------------------------------- }
  { ab hier steht 'inquote' fr "in domain-literal" }
  inquote:=false;
  char_seen:=false;
  incomment:=0;
  if (p1<p2) and (s[p2]='@') then
  begin
    q:=p2;  { p2 sichern }
    while p2<length(s) do                                     { Ende suchen }
    begin
      inc(p2);
      case s[p2] of
        '\' : if inquote or (incomment>0) then inc(p2);
        '[' : if not inquote and (incomment=0) and not char_seen then
                inquote:=true else if inquote then break;
        ']' : if inquote then inquote:=false else if incomment=0 then break;
        '(' : if not inquote then inc(incomment);
        ')' : if not inquote then
                if incomment>0 then dec(incomment) else
                begin incomment:=1; break; end;
      else if not (inquote or (incomment>0)) and (cpos(s[p2],sc)>0) then
      begin
        dec(p2);
        break;
      end else
        if incomment=0 then char_seen:=true;
      end
    end;
    if inquote or (incomment>0) or                   { ungltige Domain :-( }
       not char_seen then
    begin
      p2:=cpos('@',mid(s,q+1));                 { => n„chstes '@' probieren }
      if p2>0 then inc(p2,q);
      goto start;
    end;
  end
  else begin                             { keine Adresse im String gefunden }
    s1:='';
    mailstring:=s;
    exit;
  end;
  { ----------------------------------------------------------------------- }
  s1:=copy(s,p1,(p2-p1)+1);                              { Adresse gefunden }
  if remove then
  begin
    if (p1>1) and (s[p1-1]='<') then dec(p1);              { angle brackets }
    if (p2<length(s)) and (s[p2+1]='>') then inc(p2);      { mit entfernen  }
    if ((p1=1) or ((p1>1) and (s[p1-1] in [' ',#9]))) and
       (p2<length(s)) and (s[p2+1] in [' ',#9]) then inc(p2);
    delete(s,p1,(p2-p1)+1);
    mailstring:=s;
  end
  else begin
    s1:=copy(s,p1,(p2-p1)+1);
    mailstring:=s1;
  end;
end;

