{ ------------------------------------------------------------------- }
{ Dieser Quelltext ist urheberrechtlich geschuetzt.                   }
{ (c) 1991-1999 Peter Mandrella                                       }
{ (c) 2000-2001 OpenXP-Team                                           }
{ (c) 2002-2026 FreeXP, http://www.freexp.de                          }
{ CrossPoint ist eine eingetragene Marke von Peter Mandrella.         }
{                                                                     }
{ Die Nutzungsbedingungen fuer diesen Quelltext finden Sie in der     }
{ Datei SLIZENZ.TXT oder auf http://www.crosspoint.de/oldlicense.html }
{ ------------------------------------------------------------------- }

{ Deklarationen und diverse ausgelagerte Routinen fuer UUZ.PAS }

{$I XPDEFINE.INC }

unit uuz0;

interface  { ---------------------------------------------------------- }

uses  xpglobal,ems,crt,dos,dosx,video,typeform,xpovl,fileio,montage,clip,
      mimedec,compdate,lfn;

const
      uuzsubver   = '';        { UUZ-Subversion (an XP-Version angeh ngt) }
      LProgname   = 'Enhanced UUZ/II';  { vollst ndiger Programmname }
      SProgname   = 'E-UUZ/II';         { abgek rzter Programmname }
      midlen      = 160;
      adrlen      = 238;       { L nge Adresse (255-CRLF-"Diskussion-in: ") }
      realnlen    = 160;       { L nge Realname }
      hderrlen    = 60;
      maxabs      = 50;
      maxreplyto  = maxabs;
      maxemp      = 125;
      maxkop      = maxemp;
      maxulines   = 60;        { max. zus tzliche U-Zeilen }
      maxrefs     = 20;        { max. gespeicherte References }
      maxfollow   = 50;        { max. Followup-To-Zeilen }
      bufsize     = 16384;
      outbufsize  = 16384;
      BetreffLen  = 248;
      readempflist= true;
      custheadlen = 60;

      attrFile    = $0010;     { File Attach }
      AttrMPbin   = $0040;     { Multipart-Binary }
      attrReqEB   = $1000;     { EB anfordern }
      attrIsEB    = $2000;     { EB }
      AttrPmReply = $0100;     { PM-Reply auf AM (Maus/RFC) }
      AttrControl = $0020;     { Cancel-Nachricht }
      AttrQPC     = $0001;

      fPGP_encoded  = $0001;   { Nachricht ist PGP-codiert  }
      fPGP_avail    = $0002;   { PGP-Key vorhanden          }
      fPGP_signed   = $0004;   { Nachricht ist mit PGP sign.}
      fPGP_clearsig = $0008;   { Clear-Signatur             }
      fPGP_sigok    = $0010;   { Signatur war ok            }
      fPGP_sigerr   = $0020;   { Signatur war fehlerhaft    }
      fPGP_please   = $0040;   { Verifikations-Anforderung  }
      fPGP_request  = $0080;   { Key-Request                }
      fPGP_haskey   = $0100;   { Nachricht enth lt PGP-Key  }
      fPGP_comprom  = $0200;   { Nachricht enth lt compromise }

      nt_ZConnect = 2;
      nt_RFC      = 40;
      nt_Client   = 41;
      uncompress  = 'compress.exe -df ';
      unfreeze    = 'freeze.exe -dif ';
      ungzip      = 'gzip.exe -df ';
      SwapFileName= 'UUZ.SWP';
      TempFileName= 'UUZ.TMP';
      OptFileName = 'UUZ.OPT';      { Optionen f r UUZ-Kommandozeile        }
      LogFileName = 'UUZ_ERR.LOG';  { Logdatei f r Fehler                   }
      MailFileName= 'MAIL.RFC';     { zus tzliche RFC-Mailheader  (nur -zu) }
      NewsFileName= 'NEWS.RFC';     { zus tzliche RFC-Newsheader  (nur -zu) }
      PathFileName= 'ADDPATH';      { zus tzlicher Pfad           (nur -zu) }
      GateFileName= 'ADDGATE';      { zus tzlicher Gateway-Header (-zu/-uz) }
      DLLFileName = 'XP_NTVDM.DLL'; { DLL f r WinNT/2K/XP                   }

      RunOS  : string[30] = '';   { OS-Kurzbezeichnung f r "User-Agent:"  }
      FRunOS : string[30] = '';   { OS-Familie         f r "User-Agent:"  }

      xp_name     = 'CrossPoint';            { Lizenzname }
      xp_2        = 'xp2';                   { XP2-String, mehrfach benutzt }
      UUserver    = 'UUCP-Fileserver';
      tspecials   = '()<>@,;:\"/[]?=';       { RFC2045-Special Chars }
      tspecials2  = tspecials+' ';           { RFC1341-Special Chars }
      BackupId    = 'X-Orig-';               { Prefix f r Backup-Header }
      Truncater   = '[...]';
      mboxline    = 'From ';

      firsterror    : boolean = true;        { erster Eintrag im Fehlerlog?    }
      MailHdrFileOK : boolean = false;       { Flag f r MAIL.RFC }
      NewsHdrFileOK : boolean = false;       { Flag f r NEWS.RFC }

      XpWindow    : byte = 0;

      ParSize     : boolean = false;         { Size negotiation }
      SMTP        : boolean = false;
      cSMTP       : boolean = false;         { compressed SMTP  }
      fSMTP       : boolean = false;         { frozen SMTP      }
      zsmtp       : boolean = false;         { GNU-Zipped SMTP  }
      MakeQP      : boolean = false;         { -qp: MIME-quoted-printable }
{ Envelope-Empf nger aus Received auslesen? }
      getrecenvemp: boolean = false;
      client      : boolean = false;         { -client (f r UKA* etc.) }
      mbox        : byte = 0;                { mbox-Format, 1=mboxo, 2=mboxrd }
      chkbody     : boolean = false;         { Body pr fen (Schalter) }
      checkbody   : boolean = false;         { Body pr fen (intern/Schalter) }
      add_gate    : string[120] = '';        { Domain/String f r 'X-Gateway' }
      noEuro      : boolean = false;         { #238 nach #101 statt #164 }
      UseEnvTo    : boolean = false;
      OSfamily    : boolean = false;         { OS-Familie statt -Version in "User-Agent:" }
      paranoia    : boolean = false;         { OS-Infos in "User-Agent:" unterdr cken }
      noxpver     : boolean = false;         { "X-XP-Version:" nicht erzeugen }
      noUAgent    : boolean = false;         { "User-Agent:" nicht erzeugen }
      MailUser    : string[30] = 'mail';     { f r U-Zeile im X-File }
      NewsUser    : string[30] = 'news';
      FileUser    : string[30] = 'root';
      OwnSite     : string[60] = '';         { f r Empf ngeradresse von Mails }
      Boxname     : string[20] = '';         { Boxname f r "X-XP-BOX:" }
      xpboundary  : string = '-=_-';         { 06.01.2000 robo }
      shrinkheader: boolean = false;         { uz: r-Schalter }
      nomailer    : boolean = false;
      UseLFN      : boolean = false;
      xp2         : boolean = false;         { XP2-Kompatibilit t }

      tText       = 1;        { Content-Types: plain, richtext       }
      tMultipart  = 2;        { mixed, parallel, alternative, digest }
      tMessage    = 3;        { rfc822, partial, external-body       }
      tApplication= 4;        { octet-stream, postscript, oda        }
      tImage      = 5;        { gif, jpeg                            }
      tAudio      = 6;        { basic                                }
      tVideo      = 7;        { mpeg                                 }
      tModel      = 8;        { model                                }

      encBase64   = 1;        { Content-Transfer-Encodings           }
      encQP       = 2;        { quoted-printable                     }
      enc8bit     = 3;
      enc7bit     = 4;
      encBinary   = 5;

      { Die folgenden Konstanten definieren, an welcher Position }
      { im Array 'LongHdr' welcher lange dynamische ZC-Header    }
      { (bis 65500 Zeichen) steht.                               }

      LSub  =  1;        { 'BET'             }
      LPath =  2;        { 'ROT'             }
      LProg =  3;        { 'MAILER'          }
      LOrg  =  4;        { 'ORG'             }
      LPost =  5;        { 'Post'            }
      LTele =  6;        { 'Telefon'         }
      LHome =  7;        { 'U-X-Homepage'    }
      LKey  =  8;        { 'Stichwort'       }
      LSum  =  9;        { 'Zusammenfassung' }
      LGate = 10;        { 'X-Gateway'       }

  (*  LFile = 11;        { 'Datei'           }  *)
  (*  LBdry = 12;        { 'X-XP-Boundary'   }  *)

      LongHdrAnz = 10;   { Anzahl Header in 'LongHdr' }

      { Array f r lange dynamische unstrukturierte ZC-Header bis 65500 }
      { Zeichen, die in voller L nge in den Puffer geschrieben werden  }

      LongHdr : array[1..LongHdrAnz] of record
                                          hdr   : LongHdrP;
                                          len   : word;
                                          rest  : string[4];
                                          trunc : boolean;
                                        end =
        (
         { 1}  (hdr: nil; len: 0; rest: ''; trunc: false),
         { 2}  (hdr: nil; len: 0; rest: ''; trunc: false),
         { 3}  (hdr: nil; len: 0; rest: ''; trunc: false),
         { 4}  (hdr: nil; len: 0; rest: ''; trunc: false),
         { 5}  (hdr: nil; len: 0; rest: ''; trunc: false),
         { 6}  (hdr: nil; len: 0; rest: ''; trunc: false),
         { 7}  (hdr: nil; len: 0; rest: ''; trunc: false),
         { 8}  (hdr: nil; len: 0; rest: ''; trunc: false),
         { 9}  (hdr: nil; len: 0; rest: ''; trunc: false),
         {10}  (hdr: nil; len: 0; rest: ''; trunc: false)
        );

type  mimedata = record
                   mversion : string[10];     { MIME-Version              }
                   encoding : byte;           { Content-Transfer-Encoding }
                   ctype    : byte;           { Content-Type              }
                   subtype  : string[20];     { Content-Subtype           }
                   charset  : string[30];     { text/*; charset=...       }
                   filetype : string[20];     { application/o-s; type=... }
                   boundary : string[100];    { multipart: boundary=...   }
                 end;

      mimeproc = procedure(var s:string);

      { F r Variablen, die die folgenden Array-Typen verwenden, mu  }
      { via 'DummyMem' entsprechend Speicher reserviert werden!     }

      abslistp  = ^abslistt;
      abslistt  = array[1..maxabs] of record
                                        adr  : ^string;
                                        name : ^string;
                                      end;
      senderp   = ^sendert;
      sendert   = record
                    adr  : ^string;
                    name : ^string;
                  end;
      rtolistp  = ^rtolistt;
      rtolistt  = array[1..maxreplyto] of record
                                            adr  : ^string;
                                            name : ^string;
                                          end;
      empflistp = ^empflistt;
      empflistt = array[1..maxemp] of ^string;
      koplistp  = ^koplistt;
      koplistt  = array[1..maxkop] of record
                                        adr  : ^string;
                                        name : ^string;
                                      end;
      fuplistp  = ^fuplistt;
      fuplistt  = array[1..maxfollow] of ^string;

      { /bis hier }

      { Verkettete Liste f r RFC-U/X-Header }

      UlisteP = ^UlisteT;
      UlisteT = record
                  hdr   : LongHdrP;           { Header (bis 65500 Zeichen)  }
                  len   : word;               { Headerl nge                 }
                  rest  : string[4];          { max. 4  berh ngende Zeichen }
                  trunc : boolean;            { Header ist abgeschnitten    }
                  Id    : ^string;            { RFC-Identifier              }
                  next  : UlisteP;
                end;

      SlisteP = ^SlisteT;                   { Verkettete Liste f r Strings  }
      SlisteT = record                      { (z.B. Keywords bei "uuz -zu") }
                  s    : ^string; 
                  next : SlisteP;
                end;

      empfnodep =^empfnode;
      empfnode  = record
                    next   : empfnodep;
                    empf   : string[adrlen];
                  end;

      header  = record
                  netztyp    : byte;
                  ulines     : byte;          { Anzahl "U-"-Zeilen }
                  lines      : longint;       { "Lines:" }
                  archive    : boolean;       { archivierte PM }
                  empfaenger : string[AdrLen];
                  kopien     : empfnodep;
                  xempf      : empflistp;
                  empfanz    : integer;       { Anzahl EMP:-Zeilen }
                  xoem       : empflistp;
                  oemanz     : integer;       { Anzahl OEM:-Zeilen }
                  xkop       : koplistp;
                  kopanz     : integer;       { Anzahl KOP:-Zeilen }
                  xabs       : abslistp;
                  absanz     : integer;       { Anzahl From:-Absender }
                  xsender    : senderp;
                  xreplyto   : rtolistp;
                  replytoanz : integer;       { Anzahl Antwort-an:-Zeilen }
                  followup   : fuplistp;
                  followups  : integer;       { Anzahl Diskussion-in:-Zeilen }
                  betreff    : string[BetreffLen];
                  absender   : string[AdrLen];
                  realname   : string[realnlen];
                  datum      : string[11];    { Netcall-Format }
                  zdatum     : string[22];    { ZConnect-Format }
                  pfad       : string;        { Netcall-Format }
                  msgid,ref  : string[midlen];{ ohne <> }
                  ersetzt    : string[midlen];{ ohne <> }
                  addrefs    : integer;
                  addref     : array[1..maxrefs] of string[midlen];
                  typ        : string[1];     { T / B }
                  crypttyp   : string[1];
                  groesse    : longint;
                  komlen     : longint;       { Kommentar-L nge }
                  ckomlen    : longint;

                  programm   : string;        { Mailer-Name }
                  datei      : string[40];    { Dateiname }
                  ddatum     : string[22];    { Dateidatum, jjjjmmtthhmmss }
                  prio       : byte;          { 10=direkt, 20=Eilmail }
                  real_box   : string[20];    { falls Adresse = User@Point }
                  hd_point   : string[25];    { eigener Pointname }
                  pm_bstat   : string[20];    { Bearbeitungs-Status }
                  attrib     : word;          { Attribut-Bits }
                  filterattr : word;
                  fido_to    : string[36];
                  organisation  : string[80];
                  postanschrift : string[80];
                  telefon    : string[60];
                  homepage   : string[90];
                  PmReplyTo  : string[AdrLen];   { Antwort-an, nicht benutzt }
                  AmReplyTo  : string[AdrLen];   { Diskussion-in, nicht benutzt }
                  amrepanz   : integer;
                  error      : string[hdErrLen]; { ERR-Header }
                  ReplyPath  : string[8];
                  ReplyGroup : string[40];
                  wab        : string[AdrLen];   { Envelope-Absender }
                  oemlist    : empfnodep;
                  oem,oab    : string[AdrLen];   { oab/oar werden auch als }
                                                 { 'Zwischenlager' genutzt }
                  oar,war    : string[realnlen]; { Realnames }

                  gateway    : string[242];
                  empfbestto : string[AdrLen];
                  x_charset  : string[30];
                  keywords   : string[242];
                  summary    : string[236];
                  priority   : byte;             { Priority by MH }
                  distribution:string[40];
                  pm_reply   : boolean;
                  MIME       : mimedata;
                  QuoteString: string[20];
                  charset    : string[30];
                  ccharset   : string[30];
                  org_msgid  : string[midlen];
                  org_xref   : string[midlen];
                  pgpflags   : word;
                  pgp_uid    : string[80];
                  vertreter  : string[80];
                  XPointCtl  : longint;
                  nokop      : boolean;
                  boundary   : string[100];
                  mimetyp    : string[30];
                  mimereltyp : string[30];       { multipart/related, "type="       (RFC2387) }
                  mimerelstart : string[midlen]; { multipart/related, "start="      (RFC2387) }
                  mimerelsinfo : string[midlen]; { multipart/related, "start-info=" (RFC2387) }

                  { X-No-Archive Konvertierung }
                  xnoarchive : boolean;
                  Cust1,Cust2: string[custheadlen];
                  control    : string[midlen+9]; { midlen + 'cancel <>' }
                  { Envelope-Empf nger }
                  envemp     : string[AdrLen];
                  xpmode     : string[20];

                end;
      charr   = array[0..65530] of char;
      charrp  = ^charr;
      ulinea  = array[1..maxulines] of string;

var   OwnPath       : pathstr;       { UUZ-Verzeichnis       }
      ShellPath     : pathstr;       { aktuelles Verzeichnis }
      source,dest   : pathstr;       { Quell-/Zieldateien  }
      f1,f2,                         { Quell/Zieldatei     }
      MailHdrFile,                   { MAIL.RFC (Header)   }
      NewsHdrFile   : file;          { NEWS.RFC (Header)   }
      u2z           : boolean;       { Richtung; mail/news }
      mails,news    : longint;       { Counter             }
      uuzstartdate  : datetimest;    { Datum UUZ-Start                 }
      uuzstarttime  : datetimest;    { Uhrzeit UUZ-Start               }
      membefore     : longint;       { memavail vor 'allocMem'         }
      maxbefore     : longint;       { maxavail vor 'allocMem'         }
      run_time      : real;          { Laufzeitberechnung              }
      TotalSize     : real;          { Gr  e Quelldatei(en) in KB      }
      TotalMsgs     : longint;       { Anzahl bearbeiteter Nachrichten }
      buffer        : array[0..bufsize] of char;    { Kopierpuffer }
      bufpos,bufanz : integer;       { Leseposition / Anzahl Zeichen }
      hd            : header;
      empflist      : empfnodep;
      uline         : ^ulinea;
      uunumber      : word;          { fortlaufende Hex-Paketnummer }
      _from,_to     : string[20];    { UUCP-Systemnamen }
      outbuf        : charrp;
      outbufpos     : word;
      s             : String;
      MaxSlen       : longint;       { max. L nge f r ReadString() }
      MaxReadLen    : word;          { max. L nge f r Teilstrings in        }
                                     { ReadString (*mu * wegen 'cmp di,...' }
                                     { in ReadString word sein, nie byte!)  }
      qprint,b64    : boolean;       { MIME-Content-TT's (ReadRFCheader) }
      binaer        : boolean;       { Bin rnachricht eingehend/ausgehend }
      encode_rest   : string[3];     { Reststring bei b64/qp-Decodierung }
      s_rest        : string;        { Reststring hinter CR|LF bei b64/qp-Texten }
      last_cr       : boolean;       { letzter b64/qp-String endete mit CR }
      fpos          : longint;
      eol           : byte;          { ReadString ist am Zeilenende angekommen }
      lasteol       : boolean;       { eol der vorausgehenden Zeile>0 }
      addpath       : string;
      xp_received   : string;        { Mailerstring f r "Received:"-Header,   }
                                     { wenn "User-Agent:" erzeugt werden kann }
      ReceivedEnv   : string[AdrLen];{ Envelope-Empf nger in "Received:" }
      InReplyTo     : string[midlen];{ Letzte MsgID in 'In-Reply-To:' }
      convcharset   : boolean;       { Charset mu  konvertiert werden }
      mpart         : boolean;       { ist MIME-Multipart }
      NGisOK        : boolean;       { "Newsgroups:"-Header enth lt mind. 1 Newsgroup }
      mailinglist   : boolean;       { eingehende Mailinglisten-Mail }

      HdrLine       : LongHdrP;
      HdrLen        : word;

      { erg nzende Variablen f r aktuelle Headerzeile ('HdrLine') }
      overflow      : boolean;    { Header > 65500 Zeichen? }
      truncated     : boolean;    { Header abgeschnitten?   }
      rest          : string[4];  { '?=' an Pos. 65500 oder 65501 behandeln }

      Ustart,
      Ulauf         : UlisteP;    { verkettete Liste f r RFC-U/X-Header }

      keystart,
      keylauf       : SListeP;    { verkettete Keyword-Liste }


const
      { Wird zum Einlesen der Customizable Headerlines ben tigt }
      mheadercustom : array[1..2] of string[custheadlen] = ('','');

      { Dummy-Array zum Reservieren von minimalem Speicher f r bestimmte    }
      { relevante lange dynamische Header bis 65500 Zeichen:                }
      { Der Multiplikator gibt die Mindestanzahl der jeweiligen Variablen   }
      { an, f r die immer ausreichend Speicher zur Verf gung stehen mu      }
      { (f r hd.xkop steht also z.B. immer der Speicher f r mindestens 20   }
      { Adressen und 20 Realnames mit jeweils maximaler Variablenl nge zur  }
      { Verf gung). F r hd.xoem wird Speicher f r nur 1 Adresse reserviert, }
      { weil in 'WriteZcHeader' hd.xempf ggf. auf hd.xoem kopiert wird und  }
      { wir danach nur noch den zus tzlichen Speicher f r die Envelope-     }
      { Adresse in hd.xempf^[1] und das Array hd.xempf selbst ben tigen.    }
      { Falls die Deklaration von 'empflistt' und der  brigen entsprechen-  }
      { den Typen ge ndert werden sollte, ist darauf zu achten, da  die     }
      { Berechnung des f r das Anlegen der Arrays mittels "new()" erforder- }
      { lichen Speicherplatzes ("((((4*maxemp)-1) div 8)*8) + 8)") ggf.     }
      { ge ndert werden mu  (der von TP angeforderte Speicher ist immer ein }
      { Vielfaches von 8, deshalb diese Berechnung).                        }

      LEmp = 1;  { Position 'EMP:'           (hd.xempf)    in 'DummyMem' }
      LOem = 2;  { Position 'OEM:'           (hd.xoem)     in 'DummyMem' }
      LKop = 3;  { Position 'KOP:'           (hd.xkop)     in 'DummyMem' }
      LAbs = 4;  { Position 'ABS:'           (hd.xabs)     in 'DummyMem' }
      LWab = 5;  { Position 'WAB:'           (hd.xsender)  in 'DummyMem' }
      LAnt = 6;  { Position 'ANTWORT-AN:'    (hd.xreplyto) in 'DummyMem' }
      LDis = 7;  { Position 'Diskussion-in:' (hd.followup) in 'DummyMem' }

      DummyAnz = 7;  { Anzahl Elemente in DummyMem }

      DummyMem : array[1..DummyAnz] of record
                                         memPtr : LongHdrP;
                                         memVal : word;
                                       end =
        (
         {1}  (memPtr: nil; memVal: 20*(((adrlen div 8)*8)+8)
                                  + ((((4*maxemp)-1) div 8)*8) + 8),
         {2}  (memPtr: nil; memVal:  1*(((adrlen div 8)*8)+8)
                                  + ((((4*maxemp)-1) div 8)*8) + 8), 
         {3}  (memPtr: nil; memVal: 20*((((adrlen div 8)*8)+8) +
                                        (((realnlen div 8)*8)+8))
                                  + (2*((((4*maxkop)-1) div 8)*8) + 8)),
         {4}  (memPtr: nil; memVal:  5*((((adrlen div 8)*8)+8) +
                                        (((realnlen div 8)*8)+8))
                                  + (2*((((4*maxabs)-1) div 8)*8) + 8)),
         {5}  (memPtr: nil; memVal:  1*((((adrlen div 8)*8)+8) +
                                        (((realnlen div 8)*8)+8))
                                  + (2*((((4*maxabs)-1) div 8)*8) + 8)),
         {6}  (memPtr: nil; memVal:  5*((((adrlen div 8)*8)+8) +
                                        (((realnlen div 8)*8)+8))
                                  + (2*((((4*maxkop)-1) div 8)*8) + 8)),
         {7}  (memPtr: nil; memVal: 20*(((adrlen div 8)*8)+8)
                                  + ((((4*maxfollow)-1) div 8)*8) + 8)
        );

procedure GetOwnPath;
procedure logo;
procedure HelpPage;
procedure error(s:string);
procedure GetPar;
procedure initvar;
procedure donevar;
procedure AppendLog(const fehler:string; const no:longint; const fn:string;
                    const id:string; const mail:boolean);
procedure testfiles;
function  FieldNameOK(const name:string):boolean;
function  rawmail(const msg:string):boolean;
procedure fmove(var f1,f2:file);
function  RFC2Zdate(var s0:string):string;
function  ContainsUmlaut(const s:string):boolean;
procedure AddToEmpflist(empf:string);
procedure DisposeEmpflist(var list:empfnodep);
procedure DisposeAbsList;
procedure DisposeKeywordList;
procedure DisposeLongHdr(const n:byte);
procedure DisposeAllLongHdr;
function  compmimetyp(typ:string):string;
procedure FlushOutbuf;
procedure wrfs(var s:Hugestring);
procedure WriteZcHeader(const mail:boolean);
procedure allocMem;
procedure releaseMem(const n:byte);
procedure CheckMem(const no:longint; const fn:pathstr; const mail:boolean);
function  GetMemAmount(const memget:word):longint;
procedure QuoteStr(var s:string; qspace:boolean);
procedure GetMimeVersion(var s:string);
procedure GetCTencoding(var s:string);
procedure GetContentType(var s:string);
procedure MimeAuswerten;
procedure RFC2047form;
procedure GetBinType(fn:pathstr);
procedure SetMimeData;
procedure setIBM2ISO;
procedure shell(prog:string; space:word);
procedure ReadBuf;
procedure ReadString(umbruch:boolean);
function  nextchar(const n:byte):char;
function  is_nextstring(const s:string):boolean;
function  end_of_mail(const typ:byte):boolean;
function  is_mailinglist(const typ:byte; const id:string):boolean;
procedure ReadBinString(bytesleft:longint);
procedure SaveLongHdr(const n,maxLen:byte; var s,shortHdr:string;
                      const MIMEdecode:boolean; const structured:byte);
procedure ReadRfcBody(const msgtyp:byte; const write:boolean; ss:longint);
procedure GetRunOS;
function  UserAgent(var xp:string):boolean;
function  is_xp2:boolean;
function  uuztime(const formatted:boolean; const typ:byte):string;
function  get_date:datetimest;
function  get_time:datetimest;
function  time_diff(const t1,t2:datetimest):real;
function  strSecs(t:real):datetimest;
function  sizeKB(f:string):real;


implementation  { ----------------------------------------------------- }


{ Hier nicht ben tigte Variable 'eol' f r  }
{ aktuelle Anzahl der bereits ausgegebenen }
{ Zeilen mi brauchen                       }

procedure wr_line(const s:string; const help:boolean);
var         t : char;
const sclines : byte = 0;

  procedure stop_page;
  begin
    if help and not outputredirected then
    begin
      if sclines=0 then sclines:=getscreenlines;
      if eol mod (sclines-1)=0 then
      begin
        write('Press any key...');
        t:=readkey;
        write(#13,sp(16),#13);
      end;
    end;
  end;

begin
  if eol=0 then sclines:=0;  { sclines bei erster Zeile zur cksetzen }
  inc(eol);
  writeln(s);
  stop_page;
end;

procedure logo;
begin
  assign(output, '');
  rewrite(output);
  eol:=0;
  wr_line('',false);
  wr_line('ZConnect <-> RFC/UUCP/SMTP Converter with MIME  (c) 1993-1999 Peter Mandrella',false);
  wr_line(xp_display+'-Version '+verstr+uuzsubver+betastr+'  '+x_copyright +
          ' by '+author_name+' <'+author_mail+'>',false);
  wr_line('',false);
  {$IFNDEF NO386}
  wr_line('Compiled on '+uuztime(true,1)+' at '+uuztime(true,2)+' with '+compiler+' (i386)',false); 
  {$ELSE}
  wr_line('Compiled on '+uuztime(true,1)+' at '+uuztime(true,2)+' with '+compiler+' (8086)',false); 
  {$ENDIF}
  wr_line('Detected OS: '+RunOS+iifs(FRunOS=RunOS,'',' (family name: '+FRunOS+')'),false);
  wr_line('',false);
  wr_line(LProgname+' - considerably improved RFC1036/2045-2049/2822 compliance,',false);
  wr_line(dup(length(LProgname),' ')+'   long string support and Unicode (UTF) decoding routines',false);
  wr_line('',false);
end;

procedure HelpPage;
begin
  wr_line('UUZ -uz [Switches] <Source file(s)> <Destination file> [ownsite.domain]',true);
  wr_line('UUZ -zu [Switches] <Source file> <Dest.Dir.> <fromSite> <toSite> [Number]',true);
  wr_line('',true);
  wr_line('uz switches:  -UseEnvTo =  Get envelope recipient from Envelope header',true);
  wr_line('                           ("Envelope-To:", "X-Envelope-To:", "X-Original-To:",',true);
  wr_line('                            "Original-Recipient:", "Delivered-To:")',true);
  wr_line('              -graberec =  Grab envelope recipient from "Received:" headers',true);
  wr_line('              -rfcMime  =  MIME decoding strictly according to RFC2047',true);
  wr_line('                           (default: follow robustness principle)',true);
  wr_line('              -client   =  Mode for net type RFC/Client [RFC/PPP]',true);
  wr_line('               [-ppp]      (=> "X-XP-NTP: 41")',true);
  wr_line('              -mboxo    =  Convert "mboxo" mailbox format',true);
  wr_line('                           (irreversible ">From_ quoting")',true);
  wr_line('              -mboxrd   =  Convert "mboxrd" mailbox format',true);
  wr_line('               [-mbox]     (reversible ">From_ quoting")',true);
  wr_line('              -bBoxname =  Name of Serverbox (=> "X-XP-BOX: <Boxname>")',true);
  wr_line('',true);
  wr_line('zu switches:  -s        =  Taylor UUCP size negotiation',true);
  wr_line('              -SMTP     =  Batched SMTP (-c/f/zSMTP = compressed)',true);
  wr_line('              -qp       =  MIME: quoted-printable (default: 8bit)',true);
  wr_line('              -uUser    =  User to return error messages to',true);
  wr_line('              -client   =  Mode for net type RFC/Client [RFC/PPP]',true);
  wr_line('               [-ppp]      (creates one file per outgoing message,',true);
  wr_line('                            implicates -SMTP)',true);
  wr_line('              -chkbody  =  Mode for external conversion of plain ZConnect',true);
  wr_line('                           messages (checks message body for 8bit characters)',true);
  wr_line('              -OSfamily =  Expose OS family instead of OS version in header',true);
  wr_line('                           "User-Agent:" (e.g. Win98, WinXP => Win9x, WinNT)',true);
  wr_line('              -privacy  =  Hide OS information in "User-Agent:" entirely',true);
  wr_line('              -noUAgent =  No "User-Agent:" header in USEFOR syntax (original',true);
  wr_line('                           XP mailer string => "X-Mailer:" and "X-Newsreader:")',true);
  wr_line('              -noXPver  =  No "X-XP-Version:" header (switch not recommended',true);
  wr_line('                           for all unpatched UKAW versions 2.43-3.35, strongly',true);
  wr_line('                           recommended for UKAW v3.50 (bug!) and all non-UKAW',true);
  wr_line('                           environments, UKAW patch see '+author_url+')',true);
  wr_line('              -noEuro   =  Disable '+xp_display+' Euro support',true);
  wr_line('',true);
  wr_line('zu/uz:        -LFN      =  Support Long Filenames',true);
  wr_line('              -xp2      =  XP2 compatibility mode (implicates -chkbody)',true);
  halt(1);
end;

procedure error(s:string);
begin
  writeln('Fehler: ',s);
  donevar;
  halt(1);
end;

procedure GetOwnPath;
begin
  OwnPath:=progpath;
  if OwnPath='' then getdir(0,OwnPath);
  if lastchar(OwnPath)<>DirSepa then
    OwnPath:=OwnPath+DirSepa;
  if cpos(':',OwnPath)=0 then
  begin
    if firstchar(OwnPath)<>DirSepa then
      OwnPath:=DirSepa+OwnPath;
    OwnPath:=getdrive+':'+OwnPath;
  end;
{ OwnPath:=ustr(OwnPath); }       { LFNs k nnen hier noch nicht aktiv sein! }
end;

procedure GetPar;
var i        : integer;
    t        : text;
    switch   : string[10];
    gate_ver : string;
const gate_uz = 'RFC1036/2822/2047 ';  { Gate RFC=>ZC }
      gate_zu = 'ZCONNECT ';           { Gate ZC=>RFC }

  procedure GetUZpar(par:string);
  begin
    if left(par,1)='-' then
    begin
      switch:=lstr(mid(par,2));
      if left(switch,2)='w:' then
        XpWindow:=minmax(ival(mid(switch,3)),15,60) else
      { Envelope-Empf nger aus Received auslesen? }
      if switch='graberec' then
        getrecenvemp:=true else
      if switch='useenvto' then
        UseEnvTo:=true else
      if switch='lfn' then
      begin
        EnableLFN;
        UseLFN:=true;
      end else
      if switch='r' then
        shrinkheader:=true else
      if switch='rfcmime' then
        rfcMime:=true else
      if (switch='client') or (switch='ppp') then
        client:=true else
      if left(switch,4)='mbox' then
      begin
        if mid(switch,5)='o' then
          mbox:=1
        else if (byte(switch[0])=4) or (mid(switch,5)='rd') then
          mbox:=2
      end else
      if switch[1]='b' then
        boxname:=mid(par,3) else
      if switch=xp_2 then
        xp2:=true;
    end
    else
      if source=''  then source:=ustr(par) else
      if dest=''    then dest:=ustr(par) else
      if OwnSite='' then OwnSite:=par;
  end;

  procedure GetZUpar(par:string);
  begin
    if left(par,1)='-' then
    begin
      switch:=lstr(mid(par,2));
      if left(switch,2)='w:' then
        XpWindow:=minmax(ival(mid(switch,3)),15,60) else
      if switch='s' then ParSize:=true else
      if switch='smtp' then SMTP:=true else
      if switch='csmtp' then begin
        SMTP:=true; cSMTP:=true; end else
      if switch='fsmtp' then begin
        SMTP:=true; fSMTP:=true; end else
      if switch='zsmtp' then begin
        SMTP:=true; zSMTP:=true; end else
      if switch='qp' then
        MakeQP:=true else
      if (switch='client') or (switch='ppp') then begin
        SMTP:=true; client:=true; end else
      if switch='lfn' then
        EnableLFN else
      if (switch='chkbody') or (switch='gate') then
        chkbody:=true else
      if (switch='osfamily') then
        OSfamily:=true else
      if (switch='privacy') then
        paranoia:=true else
      if (switch='nouagent') then
        noUAgent:=true else
      if (switch='noxpver') then
        noxpver:=true else
      if switch='noeuro' then
        noEuro:=true else
      if switch=xp_2 then
        xp2:=true else
      if switch[1]='u' then
      begin
        MailUser:=mid(par,3);
        NewsUser:=Mailuser;
        FileUser:=MailUser;
      end;
    end
    else
      if source='' then source:=ustr(par) else
      if dest=''   then dest:=ustr(par) else   { Ziel-*Verzeichnis* }
      if _from=''  then _from:=par else
      if _to=''    then _to:=par else
      uunumber:=hexval(par);
  end;

  procedure ReadOptFile;
  var opt    : string[15];   { switch[10]+'-uz: ' }
      target : char;         { Richtung uz/zu }
  begin
    if exist(OwnPath+OptFileName) then
    begin
      assign(t,OwnPath+OptFileName);
      reset(t);
      while not eof(t) do
      begin
        readln(t,opt);
        opt:=trim(lstr(opt));
        target:=#0;
        if (left(lstr(opt),3)='uz:') or
           (left(lstr(opt),4)='-uz:') then
          target:='z'
        else if (left(lstr(opt),3)='zu:') or
                (left(lstr(opt),4)='-zu:') then
          target:='u';
        if target<>#0 then  { richtungsspezifische Optionen ggf. ignorieren }
        begin
          opt:=trim(mid(opt,cpos(':',opt)+1));
          if ((opt='-client') or
              (opt='-lfn') or
              (opt='-xp2')) and
             ((u2z and (target='u')) or
              (not u2z and (target='z'))) then
            opt:='';
        end;
        if (firstchar(opt)='-') and (length(opt)>1) then
        begin
          if u2z then
            GetUZpar(opt)
          else
            GetZUpar(opt);
        end;
      end;
      close(t);
    end;
  end;

begin
  gate_ver:= ' ['+SProgname+' '+xp_display+' '+
             verstr+uuzsubver+betastr+']';
  if (lstr(paramstr(1))<>'-uz') and (lstr(paramstr(1))<>'-zu') then
    HelpPage;
  if lstr(paramstr(1))='-uz' then
  begin
    if paramcount<3 then helppage;
    u2z:=true;
    source:=''; dest:=''; OwnSite:='';
    ReadOptFile;
    for i:=2 to paramcount do
      GetUZpar(paramstr(i));
  end
  else begin
    u2z:=false;
    if paramcount<3 then helppage;
    source:=''; dest:=''; _from:=''; _to:='';
    ReadOptFile;
    for i:=2 to paramcount do
      GetZUpar(paramstr(i));
  end;
  if exist(OwnPath+GateFileName) then                { ADDGATE: Zusatz f r  }
  begin                                              { "X-Gateway:"/"GATE:" }
    assign(t,OwnPath+GateFileName);
    reset(t);
    readln(t,add_gate);
    close(t);
    if add_gate<>'' then
    begin
      if u2z then
        add_gate:=gate_uz+add_gate+gate_ver
      else
        add_gate:=gate_zu+add_gate+gate_ver;
    if (add_gate<>'') and (right(add_gate,length(gate_ver))<>gate_ver) then
      error('Gate-Domain in Datei '''+GateFileName+''' zu lang (max. '+
            strs((sizeof(add_gate)-1)-(iif(u2z,length(gate_uz),length(gate_zu))+length(gate_ver)))+
            ' Zeichen)');
    end;
  end;
  xp2:=xp2 or is_xp2;       { ggf. XPOINT.CFG auf XP2 pr fen  }
  chkbody:=chkbody or xp2;  { bei XP2 immer 'chkbody' setzen! }
  if exist('igate.exe') then nomailer:=true;
end;

procedure initvar;
var t : text;

  { -------------------------------------------------- }
  { my: Dateien MAIL/NEWS.RFC pr fen                   }
  {                                                    }
  {     Die Dateien werden ge ffnet, auf semantische   }
  {     Konformit t mit RFC2822  berpr ft und (sofern  }
  {     OK) erst in 'donevar' wieder geschlossen.      }
  {                                            12/2005 }
  { -------------------------------------------------- }

  procedure CheckHdrFile(const fn:pathstr; var hf:file; const mail:boolean);
  var legal,ok,
        folded : boolean;
      p1,p2,p3,
      c,lines  : word;         { p1=Zeilenbeginn, p2=pos(':'), p3=pos(CRLF) }
        hdrbuf : LongHdrP;
       hdfsize : longint;
             s : string;

    function body_OK:boolean;             { 'field body' des Headers pr fen }
    var WSP_only : boolean;
    begin
      c:=p2+1;
      ok:=hdrbuf^[c] in [' ',#9];
      WSP_only:=true;
      while ok and (c<p3) do
      begin
        if WSP_only then WSP_only:=hdrbuf^[c] in [' ',#9];
        ok:=hdrbuf^[c] in [#1..#9,#11..#12,#14..#127];
        inc(c);
      end;
      body_OK:=ok and not WSP_only;
    end;

  begin
    if exist(OwnPath+fn) then
    begin
      assign(hf,OwnPath+fn);
      reset(hf,1);
      hdfsize:=FileSize(hf);
      if hdfsize>sizeof(hdrbuf^) then
        writeln('Warning: File '+fn+' too large, max. size '+
                 strs(sizeof(hdrbuf^))+' bytes'#7)
      else if hdfsize>0 then
      begin
        getmem(hdrbuf,hdfsize);
        blockread(hf,hdrbuf^,hdfsize);
        lines:=0;
        p3:=0;
        repeat
          inc(lines);
          p1:=p3+1;
          p3:=min(posLong(#13#10,hdrbuf,p1,hdfsize,true), { LF-Zeilenenden  }
                  posLong(#10,hdrbuf,p1,hdfsize,true));   { ber cksichtigen }
          if p3=0 then p3:=hdfsize+1;                     { kein EOL        }
          folded:=(lines>1) and (hdrbuf^[p1] in [' ',#9]);
          if not folded then
          begin
            p2:=posLong(':',hdrbuf,p1,p3,true);
            if p2-p1<256 then
            begin
              byte(s[0]):=p2-p1;
              fastmove(hdrbuf^[p1],s[1],byte(s[0]));
            end
            else begin
              p2:=0;
              s:='';
            end;
          end
          else
            p2:=p1-1;                                      { wegen body_OK! }
          legal:={ -------- alle Zeilen -------- }
                 (p3=p1) or                         { Leerzeilen ignorieren }
                 ((p3-p1<999) and                        { max. Zeilenl nge }
                 { -------- Headerzeile -------- }
                  ((not folded and
                    (p2>p1+1) and (p3>p2+1) and
                    FieldNameOK(s) and body_OK) or
                 { ----- gefoldete Zeilen ------ }
                   (folded and body_OK)));
                 { ----------------------------- }
          while (p3<hdfsize) and (hdrbuf^[p3+1] in [#13,#10]) do inc(p3);
        until not legal or (p3>=hdfsize);
        if mail then
          MailHdrFileOK:=legal
        else
          NewsHdrFileOK:=legal;
        if not legal then
        begin
          close(hf);
          c:=min(32,p3-p1);
          fastmove(hdrbuf^[p1],s[1],min(32,c));
          byte(s[0]):=c;
          if p3-p1>c then
            s:=left(s,length(s)-length(truncater))+truncater;
          writeln('Warning: Illegal Line #'+strs(lines)+' in '+
                   fn+': "'+s+'"'#7);
        end;
        freemem(hdrbuf,hdfsize);
      end
      else begin                                             { 0-Byte-Datei }
        close(hf);
        writeln('Warning: File '+fn+' is empty'#7);
      end;
    end;
  end;

begin
  {$IFNDEF NO386}
  If (WinVersion = 3) or { Win 9x/Me/... }
     ((WinVersion = 4) and (lo(WinNTVersion)>=5)) then { Win 2k/XP/... }
  begin
    EnableLFN;
    UseLfn := true;
  end;
{$ENDIF}
  mails:=0; news:=0;
  run_time:=0;
  TotalSize:=0;
  TotalMsgs:=0;
  uunumber:=0;
  MaxSlen:=255;
  MaxReadLen:=253;

  if not u2z then
  begin
    if exist(OwnPath+PathFileName) then     { ADDPATH: Zusatz f r Pfadzeile }
    begin
      assign(t,OwnPath+PathFileName);
      reset(t);
      readln(t,addpath);
      close(t);
      if (addpath<>'') and (lastchar(addpath)<>'!') then
        addpath:=addpath+'!';
    end
    else addpath:='';
    CheckHdrFile(MailFileName,MailHdrFile,true);
    CheckHdrFile(NewsFileName,NewsHdrFile,false);
  end;
  getmem(outbuf,outbufsize);
end;

procedure donevar;
begin
  freemem(outbuf,outbufsize);
  close(MailHdrFile);
  close(NewsHdrFile);
end;

procedure AppendLog(const fehler:string; const no:longint; const fn:string;
                    const id:string; const mail:boolean);
var uuzlog : text;
         i : byte;
begin
  assign(uuzlog,OwnPath+LogFileName);
  if not existf(uuzlog) then
  begin
    rewrite(uuzlog);
    writeln(uuzlog,xp_display+' UUZ error log');
    writeln(uuzlog);
    writeln(uuzlog,'If you find this file in your '+xp_display+' directory, please send a bug report');
    writeln(uuzlog,'along with this log file and the RFC messages indicated below to:');
    writeln(uuzlog);
    writeln(uuzlog,'  <mw@freexp.de>     (max. message size 5MB)');
    writeln(uuzlog);
    writeln(uuzlog,'Thanks for your cooperation and happy '+xp_display+'''ing...');
    writeln(uuzlog);
    writeln(uuzlog,dup(78,'='));
  end;
  append(uuzlog);
  if firsterror then
  begin
    writeln(uuzlog);
    writeln(uuzlog,'Conversion started at: '+uuzstartdate+', '+uuzstarttime);
    writeln(uuzlog,'Version: '+SProgname+' ['+xp_display+' '+verstr+uuzsubver+betastr+'] @ '+uuztime(false,0));
    write(uuzlog,'Parameters: "');
    for i:=1 to paramcount do write(uuzlog,iifs(i>1,' ','')+paramstr(i));
    writeln(uuzlog,'"');
    writeln(uuzlog,dup(78,'-'));
  end;
  write(uuzlog,'* Error at '+iifs(mail,'Mail','News')+' #'+strs(no)+' in file ');
  writeln(uuzlog,fn+iifs(id<>'',',',':'));
  if id<>'' then
    writeln(uuzlog,'  MsgID <'+id+'>:')
  else
    writeln(uuzlog,'  [... MsgID not available :-( ...]');
  write(uuzlog,'  ');
  writeln(uuzlog,fehler);
  close(uuzlog);
  firsterror:=false;
end;

procedure testfiles;
begin
  s:='/'+SwapFileName+'/'+TempFileName+'/'+OptFileName+'/'+LogFileName+
     '/'+MailFileName+'/'+NewsFileName+'/'+PathFileName+'/'+GateFileName+
     '/'+DLLFileName+'/';
  if pos('/'+source+'/',s)>0 then
    error('ung ltige Quelldatei: '+source);
  if (pos('/'+dest+'/',s)>0) or
     (u2z and (not validfilename(dest,false) or (source=dest))) then
    error('ung ltige Zieldatei: '+dest);
  if not exist(source) then error('Quelldatei fehlt');
  if not u2z then
  begin
    if (right(dest,1)<>':') and (right(dest,1)<>'\') then
      dest:=dest+'\';
    if not IsPath(dest) then
      error('ung ltiges Zielverzeichnis: '+dest);
  end;
end;

{ ----------------------------------------------------- }
{ my: G ltigkeit eines RFC-Headerbezeichners  berpr fen }
{ ----------------------------------------------------- }
function FieldNameOK(const name:string):boolean;
var p  : byte;
    ok : boolean;
begin
  FieldNameOK:=false;
  if length(name)>1 then
  begin
    ok:=true;
    p:=0;
    while ok and (p<length(name)) do
    begin
      inc(p);
      ok:=name[p] in [#33..#126];
    end;
    FieldNameOK:=ok;
  end;
end;

{ --------------------------------------------- }
{ my: Pr fen, ob eine Datei eine halbwegs       }
{     g ltige RFC2822-Mail im Raw-Format ist    }
{     (d.h. ob die erste Zeile einen syntak-    }
{     tisch g ltigen Header-Bezeichner enth lt) }
{                                               }
{                                       01/2006 }
{ --------------------------------------------- }
function rawmail(const msg:string):boolean;
var t : text;
    s : string;
begin
  rawmail:=false;
  assign(t,msg);
  reset(t);
  readln(t,s);
  close(t);
  s:=(left(s,cpos(':',s)));
  if length(s)>0 then
  begin
    dellast(s);
    s:=rtrim(s);
    rawmail:=FieldNameOK(s);
  end;
end;

procedure fmove(var f1,f2:file);
var rr : word;
begin
  while not eof(f1) do begin
    blockread(f1,buffer,bufsize,rr);
    blockwrite(f2,buffer,rr);
    end;
end;


{ Datumsformate:         11 Jan 92 01:02 GMT [DST]
                    Mon, 11 Jan 1992 01:02:03 GMT [DST]
                    Mon Jan 11, 1992 01:02:03 XYZ [DST] }

function RFC2Zdate(var s0:string):string;
const tzones = 53;
      tzone  : array[0..tzones-1,0..1] of string[7] =
               (('GMT','W+0'),('MST','W-7'),('MET','W+1'),('CET','W+1'),
                ('CEST','S+2'),('MEST','S+2'),('MES','S+2'),('MESZ','S+2'),
                ('NT','W-11'),('AHST','W-10'),('YST','W-9'),('PST','W-8'),
                ('PDT','S-7'),('CST','W-6'),('MDT','S-6'),
                ('EST','W-5'),('CDT','S-5'),('AST','W-4'),('EDT','S-4'),
                ('NST','W-3:30'),('GST','W-3'),('ADT','S-3'),('AT','W-2'),
                ('WAT','W-1'),('UT','W+0'),('Z','W+0'),('BST','S+1'),
                ('MEWT','W+1'),('SWT','W+1'),
                ('FWT','W+1'),('HFH','W+1'),('EET','W+2'),
                ('SST','S+2'),('FST','S+2'),('HFE','S+2'),('BT','W+3'),
                ('ZP4','W+4'),('ZP5','W+5'),('IST','W+5:30'),('ZP6','W+6'),
                ('WAST','W+7'),('JT','W+7:30'),('WADT','S+8'),('CCT','W+8'),
                ('JST','W+9'),('CAST','W+9:30'),('SAST','W+9:30'),
                ('EAST','W+10'),('CADT','S+10:30'),('SADT','S+10:30'),
                ('NZT','W+12'),('NZST','W+12'),('NZDT','S+13'));

var p,p2  : byte;
    t,m,j : word;
    h,min,s : integer;
    ti    : datetimest;
    zone  : string[10];
    i     : integer;
    zonename : boolean;

  function getstr:string;
  var p : byte;
  begin
    p:=cpos(' ',s0); if p=0 then p:=cpos(#9,s0);
    if p=0 then
    begin
      getstr:=s0;
      s0:='';
    end
    else begin
      getstr:=left(s0,p-1);
      s0:=trim(mid(s0,p+1));
    end;
  end;

  procedure CorrTime;           { Zonenoffset zu Zeit addieren }
  var res     : integer;
      off,moff: integer;
      p       : byte;
  begin
    val(copy(ti,1,2),h,res);
    val(copy(ti,4,2),min,res);
    val(copy(ti,7,2),s,res);
    p:=cpos(':',zone);
    if p=0 then
    begin
      off:=minmax(ival(mid(zone,2)),-13,13);
      moff:=0;
    end
    else begin
      off:=minmax(ival(copy(zone,2,p-2)),-13,13);
      moff:=minmax(ival(mid(zone,p+1)),0,59);
    end;
    if zonename and (ustr(left(s0,3))='DST') then inc(off);
    zone:=left(zone,2)+formi(abs(off),2)+iifs(moff<>0,':'+formi(moff,2),'');
    dec(min,sgn(off)*moff);
    dec(h,off);
    while min<0  do begin  inc(min,60); dec(h); end;
    while min>59 do begin  dec(min,60); inc(h); end;
    while h<0    do begin  inc(h,24);   dec(t); end;
    while h>23   do begin  dec(h,24);   inc(t); end;
    if t<1 then
    begin
      dec(m);
      if m=0 then
      begin
        m:=12;
        dec(j);
      end;
      schalt(j);
      t:=monat[m].zahl;
    end
    else begin
      schalt(j);
      if t>monat[m].zahl then
      begin
        t:=1; inc(m);
        if m>12 then begin m:=1; inc(j); end;
      end;
    end;
  end;

begin
  zonename:=false;
  p:=cpos(',',s0);
  p2:=cpos(' ',s0);
  if p>0 then
    if (p2=0) or (p2>p) then
      s0:=trim(mid(s0,p+1))   { Mon, 11 Jan ...   Wochentag killen }
    else begin                { [Mon ]Jan 11, ... }
      p2:=p-1;
      while s0[p2]<>' ' do dec(p2);
      s0:=copy(s0,p2+1,p-p2-1)+' '+copy(s0,max(1,p2-3),3)+' '+trim(mid(s0,p+1));
      end;
  t:=minmax(ival(getstr),1,31);
  p:=pos(lstr(getstr),'janfebmaraprmayjunjulaugsepoctnovdec');
  if p>0 then m:=(p+2)div 3 else m:=1;
  j:=minmax(ival(getstr),0,2099);
  if j<100 then
    if j<70 then inc(j,2000)   { 2stellige Jahreszahl erg nzen }
    else inc(j,1900);
  ti:=getstr;
  if cpos(':',ti)=0 then
    if length(ti)=4 then ti:=left(ti,2)+':'+right(ti,2)+':00'  { RFC 822 }
    else ti:='00:00:00';
  zone:=getstr;
  if zone='' then zone:='W+0'
  else if (zone[1]='+') or (zone[1]='-') then
  begin
    zone:='W'+left(zone,3)+':'+copy(zone,4,2);
    if lastchar(zone)=':' then zone:=zone+'00';
  end
  else begin
    zonename:=true;
    UpString(zone);
    i:=0;
    while (i<tzones) and (zone<>tzone[i,0]) do inc(i);
    if i=tzones then zone:='W+0'
    else zone:=tzone[i,1];
  end;
  CorrTime;
  RFC2Zdate:=formi(j,4)+formi(m,2)+formi(t,2)+formi(h,2)+formi(min,2)+
             formi(s,2)+zone;
end;

function ContainsUmlaut(const s:string):boolean; assembler;
asm
           push  ds
           cld
           lds   si,s
           lodsb
           mov   cl,al
           mov   ch,0
           jcxz  @cu_ende
@cu_loop:  lodsb
           or    al,al
           js    @cu_found
           loop  @cu_loop
           jmp   @cu_ende
@cu_found: mov   cx,1
@cu_ende:  mov   ax,cx
           pop   ds
end;


{ --- ZConnect-Header verarbeiten ----------------------------------- }

procedure AddToEmpflist(empf:string);
var p : empfnodep;
begin
  p:=@empflist;
  while p^.next<>nil do p:=p^.next;
  new(p^.next);
  p^.next^.next:=nil;
  p^.next^.empf:=empf;
end;

procedure DisposeEmpflist(var list:empfnodep);
var p : empfnodep;
begin
  while list<>nil do
  begin
    p:=list^.next;
    dispose(list);
    list:=p;
  end;
end;

{ ---------------------------------------------------------- }
{ my: Absender-Liste freigeben                       05/2004 }
{                                                            } 
{     Diese Routine *mu * in ZC=>RFC-Richtung nach *jeder*   }
{     Nachricht aufgerufen werden!!                          }
{                                                            } 
{     Theoretisch ist es m glich, da  wir in dieser Richtung }
{     einen ZC-Header einlesen, aber anschliessend gar nicht }
{     als RFC-Header schreiben. Daher kann anders als in     }
{     RFC=>ZC-Richtung der Speicher nicht bereits in der     }
{     Write-Routine ('WriteFrom') freigegeben werden, weil   }
{     wir dort m glicherweise gar nicht vorbeikommen.        }
{ ---------------------------------------------------------- }

procedure DisposeAbsList;
var i : byte;
begin
  if (hd.xabs<>nil) then with hd do
  begin
    for i:=1 to absanz do
    begin
      freemem(xabs^[i].adr,length(xabs^[i].adr^)+1);
      freemem(xabs^[i].name,length(xabs^[i].name^)+1);
      xabs^[i].adr:=nil;
      xabs^[i].name:=nil;
    end;
    dispose(xabs);
    xabs:=nil;
    absanz:=0;
  end;
end;

{ my: Keyword-Liste und Speicher freigeben   12/2002 }

procedure DisposeKeywordList;
begin
  while assigned(keystart) do
  begin
    keylauf:=keystart^.next;
    freemem(keystart^.s,length(keystart^.s^)+1);
    dispose(keystart);
    keystart:=keylauf;
  end;
end;

procedure DisposeLongHdr(const n:byte);
begin
  if (LongHdr[n].hdr<>nil) then
  begin
    freemem(LongHdr[n].hdr,LongHdr[n].len);
    LongHdr[n].hdr:=nil;
    LongHdr[n].len:=0;
    LongHdr[n].rest:='';
    LongHdr[n].trunc:=false;
  end;
end;

{ ---------------------------------------------------------- }
{ my: Gesamtes Long-Header-Array freigeben           05/2004 }
{                                                            } 
{     Diese Routine *mu * in ZC=>RFC-Richtung nach *jeder*   }
{     Nachricht aufgerufen werden!!                          }
{                                                            } 
{     Theoretisch ist es m glich, da  wir in dieser Richtung }
{     einen ZC-Header einlesen, aber anschliessend gar nicht }
{     als RFC-Header schreiben. Daher kann anders als in     }
{     RFC=>ZC-Richtung der Speicher nicht bereits in der     }
{     Write-Routine ('WriteLongRfcHdr') freigegeben werden,  }
{     weil wir dort m glicherweise gar nicht vorbeikommen.   }
{ ---------------------------------------------------------- }

procedure DisposeAllLongHdr;
var i : byte;
begin
  for i:=1 to LongHdrAnz do DisposeLongHdr(i);
end;

function compmimetyp(typ:string):string;
begin
  if left(typ,12)='application/' then
    compmimetyp:=lstr(mid(typ,12))
  else
    compmimetyp:=lstr(typ);
end;

procedure FlushOutbuf;
begin
  if outbufpos>0 then
    blockwrite(f2,outbuf^,outbufpos);
  outbufpos:=0;
end;

procedure wrfs(var s:Hugestring);
begin
  if outbufpos+length(s)>=outbufsize then
    FlushOutbuf;
  FastMove(s[1],outbuf^[outbufpos],length(s));
  inc(outbufpos,length(s));
end;


{ my: kompletter Rewrite 08/2002-04/2003 }

procedure WriteZcHeader(const mail:boolean);
var  i,j : integer;
      ss : Hugestring;
    dupe : boolean;

  procedure wrs(s:Hugestring);
  begin
    TruncStr(s,253);
    s:=s+#13#10;
    wrfs(s);
  end;

  { my: Neue Routine im Zuge des Rewrite 08/2002-04/2003 }
  {     (Langes Char-Array in ZC-Header schreiben)       }
  procedure wrls(const hdr:LongHdrP; const len:word);
  begin
    if longint(outbufpos)+longint(len)>=longint(outbufsize) then
      FlushOutbuf;
    if len>outbufsize then
      blockwrite(f2,hdr^[1],len)
    else begin
      FastMove(hdr^[1],outbuf^[outbufpos],len);
      inc(outbufpos,len);
    end;
  end;

  { my: Neue Routine im Zuge des Rewrite 08/2002-04/2003 }
  {     (Schreiben langer ZC-Header bis 65500 Zeichen)   }
  function WriteLongZcHdr(const n:byte; const Id:string):boolean;
  begin
    if LongHdr[n].hdr<>nil then
    begin
      WriteLongZcHdr:=true;
      ss:=Id+': '; wrfs(ss);
      wrls(LongHdr[n].hdr,LongHdr[n].len);
      wrs(iifs(LongHdr[n].trunc,LongHdr[n].rest+truncater,LongHdr[n].rest));
    end
    else WriteLongZcHdr:=false;
  end;

  { my: Neue Routine im Zuge des Rewrite 08/2002-04/2003    }
  {     (Unterst tzung langer U/X-Header bis 65500 Zeichen) }
  procedure WriteUHdr;
  begin
    if Ustart<>nil then                                  { Header schreiben }
    begin
      Ulauf:=Ustart;
      while Ulauf<>nil do
      begin
        ss:=Ulauf^.Id^+': '; wrfs(ss);
        wrls(Ulauf^.hdr,Ulauf^.len);
        wrs(iifs(Ulauf^.trunc,Ulauf^.rest+truncater,Ulauf^.rest));
        Ulauf:=Ulauf^.next;
      end;
      while assigned(Ustart) do              { Liste und Speicher freigeben }
      begin
        Ulauf:=Ustart^.next;
        freemem(Ustart^.hdr,Ustart^.len);
        freemem(Ustart^.Id,length(Ustart^.Id^)+1);
        dispose(Ustart);
        Ustart:=Ulauf;
      end;
    end;
  end;

  { my: Anpassung im Zuge des Rewrite 08/2002-04/2003            }
  {     (Unterst tzung langer Stichwort-Header bis 65500 Zeichen }
  {      und Ber cksichtigung von (auch gequoteten) Phrasen)     }
  procedure WriteStichworte(keywords:string);
  var p,p1,
      hlen,
      klen : word;
       stw : string;
      lstw : LongHdrP;
         q : word;
         t : boolean;  { f r Parameter 'truncated' in 'GetHeader' }

    function QuotedChar(const c:word):boolean;
    var qc : word;
    begin
      qc:=c;
      while (qc>1) and (LongHdr[LKey].hdr^[qc-1]='\') do dec(qc);
      QuotedChar:=odd(c-qc);
    end;

  begin
    q:=0;
    if LongHdr[LKey].hdr<>nil then                  { langer Keyword-Header }
    begin
      hlen:=LongHdr[LKey].len;
      ss:='Stichwort: ';
      lstw:=nil;
      while LongHdr[LKey].hdr<>nil do
      begin
        p:=0;
        repeat
          inc(p);
          case LongHdr[LKey].hdr^[p] of
            '"' : if q=0 then                      { nicht in quoted-string }
                  begin
                    q:=p+1;
                    while (q<hlen) and not     { schlie endes DQUOTE suchen }
                          ((LongHdr[LKey].hdr^[q]='"') and
                           not QuotedChar(q))
                      do inc(q);
                    if (LongHdr[LKey].hdr^[q]='"') and
                       not QuotedChar(q) then
                      q:=p                        {  ffnendes DQUOTE merken }
                    else
                      q:=0;
                  end
                  else begin                             { in quoted-string }
                    move(LongHdr[LKey].hdr^[p+1],        { schlie endes     }
                         LongHdr[LKey].hdr^[p],          { DQUOTE entfernen }
                         hlen-p);
                    move(LongHdr[LKey].hdr^[q+1],        {  ffnendes        }
                         LongHdr[LKey].hdr^[q],          { DQUOTE entfernen }
                         hlen-q-1);
                    dec(hlen,2);
                    dec(p,2);
                    q:=0;
                  end;
            '\' : if q>0 then                            { in quoted-string }
                  begin
                    move(LongHdr[LKey].hdr^[p+1],   { quoted-pair entfernen }
                         LongHdr[LKey].hdr^[p],
                         hlen-p);
                    dec(hlen);
                  end;
          end;
        until (p=hlen) or                                    { Komma suchen }
              ((LongHdr[LKey].hdr^[p]=',') and (q=0));
        p1:=p;
        while (p1>0) and                                 { 'p1' auf letztes }
              (LongHdr[LKey].hdr^[p1] in [',',' ']) do   { Zeichen vor ','  }
          dec(p1);
        while (p<hlen) and                               { 'p' auf erstes   }
              (LongHdr[LKey].hdr^[p] in [',',' ']) do    { Zeichen nach ',' }
          inc(p);
        if (p1>253) and (lstw=nil) and (maxavail>=p1)
        then begin
          wrfs(ss);                                         { 'Stichwort: ' }
          getmem(lstw,p1);
          fastmove(LongHdr[LKey].hdr^[1],lstw^[1],p1);
          if (p>=hlen) then
          begin
            t:=LongHdr[LKey].trunc;
            stw:=LongHdr[LKey].rest;    { 'stw' f r 'GetHeader' mi brauchen }
          end
          else begin
            t:=false;
            stw:='';
          end;
          klen:=p1;
          GetHeader(lstw,klen,stw,t,false,true,false,1); { MIME-Decodierung }
          if (p>=hlen) then
          begin
            LongHdr[LKey].trunc:=t;
            LongHdr[LKey].rest:=stw;
          end;
          wrls(lstw,klen);                       { langes Keyword schreiben }
          freemem(lstw,p1);
          lstw:=nil;
        end
        else if p1>0 then begin
          wrfs(ss);                                         { 'Stichwort: ' }
          fastmove(LongHdr[LKey].hdr^[1],stw[1],p1);
          stw[0]:=chr(p1);
          RFC2047_Decode(stw,1);
          wrfs(stw);       { kurzes oder langes Keyword (gek rzt) schreiben }
        end;
        if p>=hlen then                                   { letztes Keyword }
        begin
          if p1>0 then
            wrs(iifs(LongHdr[LKey].trunc,LongHdr[LKey].rest+truncater,
                LongHdr[LKey].rest));
          freemem(LongHdr[LKey].hdr,LongHdr[LKey].len);
          LongHdr[LKey].hdr:=nil;                    { hier notwendig wegen }
        end                                          { Schleifenbedingung!  }
        else begin
          if p1>0 then wrs('');
          dec(hlen,p-1);
          move(LongHdr[LKey].hdr^[p],LongHdr[LKey].hdr^[1],hlen);
        end;
      end;
    end
    else while keywords<>'' do             { Backdoor, falls Speicher knapp }
    begin                                  { bzw. Keyword nicht "lang" ist  }
      stw:=RfcUnquoteToken(keywords);
      RFC2047_Decode(stw,1);
      if stw<>'' then wrs('Stichwort: '+stw);
    end;
  end;

begin   { of WriteZcHeader }
  with hd do
  begin
    if (empfanz>0) and (xempf<>nil) then
      for i:=1 to empfanz do
      begin
        if not mail and                         { Mailadresse in Newsgroups }
           (cpos('@',xempf^[i]^)>0) and
           ((NGisOK) or (i>1)) then
          wrs('OEM: '+xempf^[i]^)
        else
          wrs('EMP: '+xempf^[i]^);
      end
    else wrs('EMP: /UNZUSTELLBAR');

    if xoem<>nil then
    begin
      for i:=1 to oemanz do
      begin
        if (xoem^[i]^<>'') and
           (lstr(xoem^[i]^)<>lstr(xempf^[1]^)) then
          wrs('OEM: '+xoem^[i]^);
        freemem(xoem^[i],length(xoem^[i]^)+1);
        xoem^[i]:=nil;
      end;
      dispose(xoem);
    end;

    if xkop<>nil then
    begin
      for i:=1 to kopanz do
      begin
        ss:='KOP: '; wrfs(ss);
        wrfs(xkop^[i].adr^);
        wrs(iifs(xkop^[i].name^<>'',' ('+xkop^[i].name^+')',''));
        freemem(xkop^[i].adr,length(xkop^[i].adr^)+1);
        freemem(xkop^[i].name,length(xkop^[i].name^)+1);
        xkop^[i].adr:=nil;
        xkop^[i].name:=nil;
      end;
      dispose(xkop);
    end;

    if xabs<>nil then         { hd.xabs darf hier eigentlich nie 'nil' sein }
    begin
      ss:='ABS: ';                                  { hd.xabs^[1] => 'ABS:' }
      for i:=1 to absanz do
      begin
        if i>1 then                      { ab hd.xabs^[2] => 'antwort-An:'  }
          ss:='antwort-An: ';            { (Gemeine wegen Unterscheidung zu }
        wrfs(ss);                        { "ANTWORT-AN:" <=> "Reply-To:")   }
        wrfs(xabs^[i].adr^);
        wrs(iifs(xabs^[i].name^<>'',' ('+xabs^[i].name^+')',''));
        if (i=1) and (wab<>'') then
        begin
          ss:='WAB: ';
          wrfs(ss);
          wrfs(wab);
          wrs(iifs(war<>'',' ('+war+')',''));
        end;
      end;
    end;

    if xreplyto<>nil then                      { "echte" Antwort-an:-Header }
    begin
      for i:=1 to replytoanz do
      begin
        for j:=1 to absanz do                               { Dupes filtern }
        begin
          dupe:=lstr(xreplyto^[i].adr^)=lstr(xabs^[j].adr^);
          if dupe then break;
        end;
        if not dupe then
        begin                           { Versalien wegen Unterscheidung zu }
          ss:='ANTWORT-AN: ';           { "antwort-An:" <=> "From:"         }
          wrfs(ss);
          wrfs(xreplyto^[i].adr^);
          wrs(iifs(xreplyto^[i].name^<>'',' ('+xreplyto^[i].name^+')',''));
        end;
        freemem(xreplyto^[i].adr,length(xreplyto^[i].adr^)+1);
        freemem(xreplyto^[i].name,length(xreplyto^[i].name^)+1);
        xreplyto^[i].adr:=nil;
        xreplyto^[i].name:=nil;
      end;
      dispose(xreplyto);
    end;

    if followup<>nil then
    begin
      for i:=1 to followups do
      begin
        if not ((empfanz=1) and (followups=1) and         { Dupes vermeiden }
                (xempf^[1]^=followup^[1]^)) then
        begin
          if (cpos('@',followup^[i]^)>0) then   { Mailadresse in Newsgroups }
            wrs('ANTWORT-AN: '+followup^[i]^)
          else
            wrs('Diskussion-in: '+followup^[i]^);
        end;
        freemem(followup^[i],length(followup^[i]^)+1);
        followup^[i]:=nil;
      end;
      dispose(followup);
    end;

    if (xempf<>nil) then        { hd.xempf erst jetzt freigeben/disposen,   }
    begin                       { weil oben f r 'OEM:' und 'Diskussion-in:' }
      for i:=1 to empfanz do    { noch ben tigt!                            }
      begin
        freemem(xempf^[i],length(xempf^[i]^)+1);
        xempf^[i]:=nil;
      end;
      dispose(xempf);
    end;

    if not WriteLongZcHdr(LSub,'BET') then   { Langen BET:-Header schreiben }
      wrs('BET: '+betreff);                                 { Backdoor BET: }
    if (LongHdr[LPath].Hdr<>nil) and        { Langen ROT:-Header schreiben, }
       (LongHdr[LPath].Len>=length(pfad)) then    { wenn l nger als hd.pfad }
      WriteLongZcHdr(LPath,'ROT')                 { (evtl. Speichermangel!) }
    else
      wrs('ROT: '+pfad);                                    { Backdoor ROT: }
    wrs('MID: '+msgid);
    wrs('EDA: '+zdatum);
    if typ='B'        then wrs('TYP: BIN');
    if datei<>''      then wrs('File: '   +datei);
    if ddatum<>''     then wrs('DDA: '    +ddatum);
    if InReplyTo<>'' then                { 'In-Reply-To:' mit 'References:' }
    begin                                { mergen, falls MsgID nicht in     }
      if ref='' then                     { 'References:' enthalten ist (es  }
      begin                              { gibt Mail-Clients wie Eudora,    }
        ref:=InReplyTo;                  { die zwar beide Header erzeugen,  }
        InReplyTo:='';                   { wo aber der direkte Bezug nur in }
      end                                { 'In-Reply-To:' enthalten ist)    }
      else if ref=InReplyTo then
        InReplyTo:=''
      else for i:=1 to addrefs do
      begin
        if addref[i]=InReplyTo then InReplyTo:='';
        if InReplyTo='' then break;
      end;
      if InReplyTo<>'' then             { MsgID aus 'In-Reply-To:' anh ngen }
      begin
        if addrefs<maxrefs then
          inc(addrefs)
        else
          FastMove(hd.addref[2],hd.addref[1],
                  (maxrefs-1)*sizeof(hd.addref[1]));
        addref[addrefs]:=InReplyTo;
      end;
    end;
    if ref<>''        then wrs('BEZ: '    +ref);
    for i:=1 to addrefs do wrs('BEZ: '    +addref[i]);
    if (ersetzt<>'') and (not mail or mailinglist) then
      wrs('ERSETZT: '+ersetzt);
    if not WriteLongZcHdr(LProg,'MAILER') and            { Langen MAILER:-  }
       (programm<>'') then                               { Header schreiben }
      wrs('MAILER: '+programm);                          { Backdoor MAILER: }
    if charset<>''    then wrs('CHARSET: '+charset);
    if error<>''      then wrs('ERR: '    +error);
    if priority<>0    then wrs('U-X-Priority: '+strs(priority));
    if prio<>0        then wrs('Prio: '   +strs(prio));
    if not WriteLongZcHdr(LOrg,'ORG') and                { Langen ORG:-     }
       (organisation<>'') then                           { Header schreiben }
      wrs('ORG: '+organisation);                         { Backdoor ORG:    }
    if not WriteLongZcHdr(LPost,'Post') and              { Langen Post:-    }
       (postanschrift<>'') then                          { Header schreiben }
      wrs('Post: '+postanschrift);                       { Backdoor Post:   }
    if not WriteLongZcHdr(LTele,'Telefon') and          { Langen Telefon:-  }
       (telefon<>'') then                               { Header schreiben  }
      wrs('Telefon: '+telefon);                         { Backdoor Telefon: }
    if not WriteLongZcHdr(LHome,'U-X-Homepage') and    { Langen Homepage:-  }
       (homepage<>'') then                             { Header schreiben   }
      wrs('U-X-Homepage: '+homepage);                  { Backdoor Homepage: }
    if EmpfBestTo<>'' then wrs('EB: ' +
                                iifs(empfbestto<>xabs^[1].adr^,empfbestto,''));
    if attrib and attrIsEB<>0  then wrs('STAT: EB');

    if (xabs<>nil) then            { hd.xabs erst jetzt freigeben/disposen, }
    begin                          { weil oben f r 'ANTWORT-AN:' und 'EB:'  }
      for i:=1 to absanz do        { noch ben tigt!                         }
      begin
        freemem(xabs^[i].adr,adrlen+1);
        freemem(xabs^[i].name,realnlen+1);
        xabs^[i].adr:=nil;
        xabs^[i].name:=nil;
      end;
      dispose(xabs);
    end;

    if pm_reply       then wrs('STAT: PM-REPLY');
    if pgpflags and fPGP_encoded<>0 then wrs('CRYPT: PGP');
    WriteStichworte(keywords);         { Langen Stichwort:-Header schreiben }
    if not WriteLongZcHdr(LSum,'Zusammenfassung') and   { Lange Zusammen-   }
       (summary<>'') then                               { fassung schreiben }
      wrs('Zusammenfassung: '+summary);          { Backdoor Zusammenfassung }
    if mime.boundary<>'' then wrs('X-XP-Boundary: '+mime.boundary);
    if not WriteLongZcHdr(LGate,'GATE') then             { Langen Gateway-  }
    begin                                                { Header schreiben }
      if gateway<>'' then
        wrs('GATE: '+gateway)                            { Backdoor Gateway }
      else if add_gate<>'' then
        wrs('GATE: '+add_gate);                    { eigener Gateway-Header }
    end;
    if control<>'' then
    begin
      if lstr(left(control,7))='cancel ' then
      begin
        if not xp2 then
        begin
          if not mail or mailinglist then    { Cancels nur bei News oder    }
          begin                              { Mailinglisten-Mails erlauben }
            wrs('STAT: CTL');
            wrs('CONTROL: '+control);
          end;
        end
        else if not mail or mailinglist then
          attrib:=attrib or attrControl;        { XP2-Cancel-Kompatibilit t }
      end
      else if not (xp2 or mail) then
        wrs('CONTROL: '+control);
    end;
    if xpmode<>''   then wrs('X-XP-MODE: '+xpmode);
    if boxname<>''  then wrs('X-XP-BOX: '+boxname);
    wrs('X-XP-NTP: '+strs(netztyp));
    attrib:=attrib and not (attrReqEB+attrIsEB);
    if attrib<>0    then wrs('X-XP-ATT: '+hex(attrib,4));
    if fido_to<>''  then wrs('F-TO: '+fido_to);
    if XPointCtl<>0 then wrs('X-XP-CTL: '+strs(XPointCtl));
    WriteUHdr;                          { alle  brigen U/X-Header schreiben }
    if cs_fallback  then wrs('X-Fallback-Charset: '+fcs);
    wrs('LEN: '+strs(groesse));     { LEN:-Header immer zuletzt schreiben,  }
    wrs('');                        { sonst kann PktXCode Probleme bekommen }
  end;
  DisposeAllLongHdr;
  for i:=1 to DummyAnz do                     { Dummy-Array freigeben, um   }
    releaseMem(i);                            { Speicher zu defragmentieren }
end;   { of WriteZcHeader }


{ --- UUCP/RFC -> ZConnect ------------------------------------------ }

{ my: Speicherminimum f r alle dynamischen ZC-Adressen-Header reservieren }
{     [1]=xempf,    [2]=xoem,     [3]=xkop,     [4]=xabs,                 }
{     [5]=xsender,  [6]=xreplyto, [7]=followup                            }

procedure allocMem;
var memVal : longint;
         i : byte;
begin
  memVal:=0;
  for i:=1 to DummyAnz do
    if DummyMem[i].memPtr=nil then
      memVal:=memVal+longint(DummyMem[i].memVal);
  if maxavail<memVal then
    error('Could not allocate sufficient memory for dynamic arrays - conversion halted.');
  for i:=1 to DummyAnz do
    if DummyMem[i].memPtr=nil then
      getmem(DummyMem[i].memPtr,DummyMem[i].memVal);
  if maxavail<sizeof(HdrLine)+sizeof(HdrLine^) then         { = 65504 Bytes }
  begin
    for i:=1 to DummyAnz do releaseMem(i);
    error('Could not allocate sufficient memory for HdrLine array - conversion halted.');
  end;
end;


{ my: Reserviertes Speicherminimum f r einzelnen      }
{     dynamischen ZC-Adressen-Header wieder freigeben }

procedure releaseMem(const n:byte);
begin
  if DummyMem[n].memPtr<>nil then
  begin
    freemem(DummyMem[n].memPtr,DummyMem[n].memVal);
    DummyMem[n].memPtr:=nil;
  end;
end;


procedure CheckMem(const no:longint; const fn:pathstr; const mail:boolean);
begin
  if (memavail<>membefore) or (maxavail<>maxbefore) then
    AppendLog('memory check failed, before/after: '+strs(membefore)+'/'+
               strs(memavail)+' bytes (memavail), '+strs(maxbefore)+'/'+
               strs(maxavail)+' bytes (maxavail)',
              no,ustr(fn),hd.msgid,mail);
  membefore:=memavail;                      { Vergleichswerte aktualisieren }
  maxbefore:=maxavail;
end;


{ my: Tats chliche Speichermenge berechnen, die     }
{     BP sich bei einem Aufruf von 'getmem()' holt. }
{     Sollte immer verwendet werden, wenn addierte  }
{     Werte von Elementen gepr ft werden, f r die   }
{     der Speicher in Einzelaufrufen von new() bzw. }
{     getmem() alloziert wird.                      }

function GetMemAmount(const memget:word):longint;
begin
  if memget>0 then
    GetMemAmount:=(((memget-1) div 8)*8)+8
  else
    GetMemAmount:=0;
end;

{ --- MIME ---------------------------------------------------------- }

{ Content-Types:  text        plain            charset=us-ascii
                              richtext                 iso-8859-x

                  multipart   mixed, parallel  boundary=...
                              alternative        "
                              digest             "

                  message     rfc822
                              partial          number=  total=  id=
                              external-body    access-type=  size= ...

                  application octet-stream     name= type= conversions=
                              postscript, oda    x-date=

                  image       gif, jpeg        x-filename=  x-date=
                  audio       basic
                  video       mpeg

  MIMEdata      : mversion : string[10];     MIME-Version
                  encoding : byte;           Content-Transfer-Encoding
                  ctype    : byte;           Content-Type
                  subtype  : string[20];     Content-Subtype
                  charset  : string[30];     text/*; charset=...
                  filetype : string[20];     application/o-s; type=...
                  boundary : string[100];    multipart; boundary=...   }


procedure QuoteStr(var s:string; qspace:boolean);   { Quoting erzeugen }
var p : byte;
begin
  if (qspace and multipos(tspecials2,s)) or
     (not qspace and multipos(tspecials,s)) then begin
    for p:=length(s) downto 1 do
      if s[p] in ['"','\'] then insert('\',s,p);
    s:='"'+s+'"';
    end;
end;


procedure GetMimeVersion(var s:string);
begin
  hd.mime.mversion:=s;
end;

procedure GetCTencoding(var s:string);
begin
  LoString(s);
  with hd.mime do
    if s='7bit' then encoding:=enc7bit else
    if s='8bit' then encoding:=enc8bit else
    if s='quoted-printable' then encoding:=encQP else
    if s='base64' then encoding:=encBase64 else
    if s='binary' then encoding:=encBinary
    else encoding:=enc8bit;       { Default: 8bit }
end;


procedure GetContentType(var s:string);
var p     : byte;
    s1    : string[30];
    value : string;

  procedure SkipWhitespace;
  begin
    inc(p);
    while (p<=length(s)) and (s[p] in [' ',#9]) do inc(p);    { whitespaces  berlesen }
    delete(s,1,p-1);
    p:=1;
  end;

  function filename:string;
  var p : byte;
  begin
    p:=length(value);
    while (p>0) and not (value[p] in ['/','\',':']) do dec(p);
    filename:=mid(value,p+1);
  end;

begin
  with hd.mime do
  begin
    p:=1;
    while (p<=length(s)) and not (s[p] in ['/',' ',#9]) do inc(p);
    s1:=lstr(left(s,p-1));
    if s1='text'        then ctype:=tText else    { --- Type }
    if s1='application' then ctype:=tApplication else
    if s1='multipart'   then ctype:=tMultipart else
    if s1='message'     then ctype:=tMessage else
    if s1='image'       then ctype:=tImage else
    if s1='audio'       then ctype:=tAudio else
    if s1='video'       then ctype:=tVideo else
    if s1='model'       then ctype:=tModel
    else ctype:=tApplication;     { Default: Application }
    while (p<=length(s)) and (s[p]<>'/') do inc(p)  ;   { / suchen }
    SkipWhitespace;
    if s<>'' then
    begin
      while (p<=length(s)) and not (s[p] in [';',' ',#9]) do inc(p);
      subtype:=lstr(left(s,p-1));       { --- Subtype  }
      if p>1 then delete(s,1,p-1);
      repeat                            { --- Parameter }
        p:=1;
        while (p<=length(s)) and (s[p]<>';') do inc(p);
        SkipWhitespace;
        if s<>'' then
        begin
          while (p<=length(s)) and (s[p]<>'=') do inc(p);
          s1:=lstr(trim(left(s,p-1)));
          SkipWhitespace;
          if s<>'' then
          begin
            if s[1]='"' then
              repeat inc(p) until (p=length(s)) or (s[p] in ['"',';'])
            else
              repeat inc(p) until (p=length(s)) or (s[p] in [';',' ',#9]);
            value:=trim(left(s,p));
            if lastchar(value)=';' then
              dellast(value);
            inc(p);
            RFC2822_Remove(value,3);
            case ctype of                     { my: hier noch kein locase! }
              tText       : if s1='charset'   then charset:=value;
              tApplication: if s1='name'      then hd.datei:=filename else
                            if s1='type'      then filetype:=value else
                            if s1='x-date'    then hd.ddatum:=RFC2Zdate(value);
              tMultipart  : if s1='boundary'  then boundary:=value;
              tMessage    : ;
              else          if s1='x-filename'then hd.datei:=value else
                            if s1='x-date'    then hd.ddatum:=RFC2Zdate(value);
            end;
          end;
        end;
      until s='';
    end;
    if subtype='' then
      case ctype of
        tText        : subtype:='plain';
        tApplication : subtype:='octet-stream';
        tMultipart   : subtype:='mixed';
        tMessage     : subtype:='rfc822';
      end;
  end;
end;


procedure MimeAuswerten;  { RFC => ZConnect }
begin
  with hd.mime do
  begin
    if ctype in [tMultipart,tMessage,tText] then
      hd.typ:='T'
    else
      hd.typ:='B';
    mpart:=ctype=tMultipart;
    binaer:=hd.typ='B';
    (* no decoding for multipart/* and message/* *)
    if (mpart or (ctype=tMessage)) and
       not (encoding in [enc7bit,enc8bit,encBinary]) then
      encoding:=enc8bit;
    qprint:=encoding=encQP;
    b64:=encoding=encBase64;
    (* no charset conversion for multipart/* and message/* *)
    convcharset:=not (mpart or binaer or
                      (ctype=tMessage) or
                      (subtype='html') or
                      (subtype='richtext') or
                      (subtype='enriched'));
    { my: Default-Charset auf 'Win-1252' ge ndert. Wenn wir   }
    {     bei Nachrichten ganz ohne Content-Type-Header wegen }
    {     des bekannten OE-Verhaltens von Win ausgehen, dann  }
    {     ist es unlogisch, wenn wir bei Content-Type-Headern }
    {     ohne Charset-Parameter von 'us-ascii' ausgehen.     }
    if convcharset then
    begin
      if charset='' then
        charset:=RFC_CharsetName(cs_win1252)
      else if not supported_charset(LStr(charset)) then
      begin
        hd.error:='Unsupported character set: '+charset;
        hd.charset:=ZC_CharsetName(charset);  { => "CHARSET: <charset>" }
      end;
    end
    else if (ctype=tText) and (charset<>'') then
      hd.charset:=ZC_CharsetName(charset);    { => "CHARSET: <charset>" }
    charset:=LStr(charset);
  end;
end;


{ evtl. s mit quoted-printable codieren }

procedure RFC2047form;
var p,p1,p2 : integer;
    encoded : boolean;
    cs      : String[30];
begin
  if not noEuro and (cpos(#164,s)>0) then
    cs:=RFC_CharsetName(cs_iso8859_15)
  else
    cs:=RFC_CharsetName(cs_iso8859_1);
  p1:=0;
  p2:=0;
  for p:=1 to length(s) do
    if s[p]>#127 then
      if p1=0 then
      begin
        p1:=p;
        p2:=p;
      end
      else p2:=p;
  if p1=0 then
  begin
    p1:=1;
    p2:=length(s);
  end
  else begin
    p:=posn(' ',reverse(s),length(s)-p1+1);
    if p=0 then p1:=1 else p1:=length(s)-p+2;
    p:=posn(' ',s,p2);
    if p=0 then p2:=length(s) else p2:=p-1;
  end;
  p:=p1;
  { wenn =? und ?= von Hand in den Header geschrieben wurden, m ssen
    sie codiert werden: }
  encoded:=(pos('=?',copy(s,p1,p2-p1+1))>0) and
           (pos('?=',copy(s,p1,p2-p1+1))>0);
  while p<=p2 do                 { qp-Codierung }
  begin
    if s[p]>=#127 then
    begin
      insert(hex(ord(s[p]),2),s,p+1);
      s[p]:='=';
      inc(p,2);
      inc(p2,2);
      encoded:=true;
    end
    else if s[p]='=' then s[p]:=#255;
    inc(p);
  end;
  if encoded then
  begin
    p:=p1;
    while p<=p2 do               { qp-Codierung }
    begin
      if s[p]=' ' then
        s[p]:='_'
      else
        if (s[p] in [#255,'?','_']) then
        begin
          if s[p]=#255 then s[p]:='=';
          insert(hex(ord(s[p]),2),s,p+1);
          s[p]:='=';
          inc(p,2);
          inc(p2,2);
        end;
      inc(p);
    end;
    insert('?=',s,p2+1);
    insert('=?'+cs+'?Q?',s,p1);
  end
  else
    for p:=1 to length(s) do
      if s[p]=#255 then s[p]:='=';
end;


procedure GetBinType(fn:pathstr);    { vgl. MAGGI.PAS }
var p   : byte;
    ext : string[6];
    t   : text;
    s   : string;
begin
  with hd.mime do
  begin
    ctype:=tApplication;
    subtype:='octet-stream';
    p:=rightpos('.',fn);
    if p>0 then
    begin
      ext:=mid(fn,p+1);
      assign(t,'MIMETYP.CFG');
      reset(t);
      if ioresult=0 then
      begin
        while not eof(t) do
        begin
          readln(t,s);
          if (s<>'') and (firstchar(s)<>'#') and
             stricmp(ext,GetToken(s,'=')) then
            GetContentType(s);
        end;
        close(t);
      end;
    end;
  end;
end;


procedure SetMimeData;  { ZConnect => RFC }
begin
  with hd,hd.mime do
  begin
    binaer:=typ='B';
    mversion:='1.0';
    convcharset:=false;             { Default f r multipart/* und message/* }
    if not binaer then
    begin
      mpart:=left(mimetyp,9)='multipart';
      { ------------------------------------------------------------------- }
      if mpart then                                           { multipart/* }
      begin
        ctype:=tMultipart;
        subtype:=mid(mimetyp,11);
        xpboundary:=hd.boundary;
        encoding:=enc8bit;             { my: Multiparts immer 8bit!         }
      end                              {     (Body checken dauert zu lange) }
      { ------------------------------------------------------------------- }
      else if left(mimetyp,7)='message' then                    { message/* }
      begin
        ctype:=tMessage;
        subtype:=mid(mimetyp,9);
        xpboundary:=hd.boundary;
        encoding:=enc8bit;
      end
      { ------------------------------------------------------------------- }
      else begin                                        { Singlepart text/* }
        ctype:=tText;
        if left(mimetyp,5)='text/' then
        begin
          subtype:=mid(mimetyp,6);
          if subtype='richtext' then subtype:='enriched';   { RFC1341=>1896 }
        end else
          subtype:='plain';
        if hd.charset<>'' then                       { 'CHARSET: <charset>' }
          hd.charset:=any2rfc_charset(hd.charset);
        convcharset:=((hd.charset='') and
                      (subtype<>'html') and      { html/enriched auch dann  }
                      (subtype<>'richtext') and  { nicht konvertieren, wenn }
                      (subtype<>'enriched')) or  { kein Charset deklariert! }
                     (hd.charset=RFC_CharsetName(cs_us_ascii)) or
                     (hd.charset=RFC_CharsetName(cs_cp_437));
        if not convcharset then                     { 'hd.charset' hat Prio }
          x_charset:='';                            { vor 'hd.x_charset'    }
        if x_charset<>'' then
        begin
          x_charset:=any2rfc_charset(x_charset);
          if (x_charset<>RFC_CharsetName(cs_us_ascii)) and
             (x_charset<>RFC_CharsetName(cs_iso8859_1)) and
             (x_charset<>RFC_CharsetName(cs_iso8859_15)) then
            x_charset:='';
        end;
        if MakeQP then             { encQP bei Schalter "-qp" immer setzen! }
          encoding:=encQP;
        checkbody:=chkbody or (convcharset and (x_charset=''));
        if not checkbody then
        begin
          if convcharset then
          begin
            charset:=x_charset;
            if noEuro and (charset=RFC_CharsetName(cs_iso8859_15)) then
              charset:=RFC_CharsetName(cs_iso8859_1);
          end
          else charset:=hd.charset;
          if not MakeQP then
          begin
            if (charset=RFC_CharsetName(cs_us_ascii)) or
               (charset=RFC_CharsetName(cs_utf_7)) then
              encoding:=enc7bit
            else
              encoding:=enc8bit;
          end;
        end;
      end;
    end
    else begin                                          { Binary-Attachment }
      { ------------------------------------------------------------------- }
      if attrib and AttrMPbin<>0 then                           { Multipart }
      begin
        mpart:=true;
        ctype:=tMultipart;
        subtype:='mixed';
        encoding:=enc7bit;                 { my: Hier ist 7bit OK (base64)! }
        xpboundary:=MakeMimeBoundary;
      end
      { ------------------------------------------------------------------- }
      else begin                                               { Singlepart }
        encoding:=encBase64;
        if datei='' then
        begin
          ctype:=tApplication;
          subtype:='octet-stream';
        end
        else GetBinType(datei);              { MIMETYP.CFG f r CT auswerten }
      end;
      { ------------------------------------------------------------------- }
    end;
  end;
end;


procedure setIBM2ISO;
begin
  if not iso15 then           { ISO1 }
  begin
    IBM2ISOtab[171]:=189;
    IBM2ISOtab[172]:=188;
    IBM2ISOtab[euro]:=101;
  end
  else begin                  { ISO15 }
    IBM2ISOtab[171]:=46;
    IBM2ISOtab[172]:=46;
    IBM2ISOtab[euro]:=164;
  end;
end;


{ --- Shell --------------------------------------------------------- }

procedure shell(prog:string; space:word);  { Externer Aufruf }
{$ifndef ver55}
  const freeptr : pointer = nil;
{$endif}
type so = record
            o,s : word;
          end;
var regs  : registers;
    p     : pointer;
    fs    : word;
    brk   : boolean;
    paras : word;            { belegte Paragraphs von M2  }
    free  : word;            { freie Paras nach Set Block }
    envir : array[0..1023+18] of byte;    { neues Environment }
    dpath : pathstr;
    para  : string;
    pp    : byte;
    sm2t  : boolean;

    swapfile : file;
    swappars : word;        { auszulagernde Paragraphen }
    EMShandle: word;        { EMS-Handle, oder 0        }
    heapfree : word;
    swapok   : boolean;


  function memfree:word;
  var regs : registers;
  begin
    with regs do begin
      ah:=$48;                { Test, ob residentes Prog. geladen }
      bx:=$ffff;
      msdos(regs);
      memfree:=bx;
      end;
  end;

  procedure SwapOut(swapp,count:word);
  var page,spar,rr : word;
  begin
    if EmsAvail>=count div 1024 +1 then
    begin
      EMSAlloc(count div 1024+1,EMShandle);
      page:=0;
      repeat
        EmsPage(EMShandle,0,page);
        if count>=1024 then spar:=1024
        else spar:=count;
        FastMove(mem[swapp:0],mem[emsbase:0],spar*16);
        inc(swapp,spar);
        dec(count,spar);
        inc(page);
      until count=0;
      swapok:=true;
      end
    else begin
      EmsHandle:=0;
      assign(swapfile,OwnPath+SwapFileName);
      rewrite(swapfile,1);
      repeat
        blockwrite(swapfile,mem[swapp:0],min(count,$ff0)*16,rr);
        if (count>0) and (rr=0) then
          inoutres:=101;
        inc(swapp,rr div 16);
        dec(count,rr div 16);
      until (count=0) or (inoutres<>0);
      close(swapfile);
      if inoutres=0 then
        setfattr(swapfile,readonly);
      swapok:=inoutres=0;
      if not swapok then begin
        error('Fehler beim Speicherauslagern!');
        if existf(swapfile) then erase(swapfile);
        end;
      end;
  end;

  procedure SwapIn(swapp,count:word);
  var rr,page,spar : word;
  begin
    if emshandle<>0 then begin
      page:=0;
      repeat
        EmsPage(EMShandle,0,page);
        if count>=1024 then spar:=1024
        else spar:=count;
        FastMove(mem[emsbase:0],mem[swapp:0],spar*16);
        inc(swapp,spar);
        dec(count,spar);
        inc(page);
      until count=0;
      EmsFree(EMShandle);
      end
    else begin
      setfattr(swapfile,0);
      reset(swapfile,1);
      if ioresult<>0 then error('SWAP-File nicht mehr vorhanden!');
      { swapp:=so(heapptr).s-swappars+2; count:=swappars; }
      repeat
        blockread(swapfile,mem[swapp:0],min(count,$ff0)*16,rr);
        inc(swapp,rr div 16);
        dec(count,rr div 16);
      until (count=0) or (rr=0) or (inoutres<>0);
      if (count<>0) or (inoutres<>0) then
        error('Fehler beim Lesen des SWAP-Files');
      close(swapfile);
      erase(swapfile);
      end;
  end;

  { MK Funktion ist eigentlich sinnlos, rausnehmen ? }
{
  procedure geterrorlevel;
  var
    regs : registers;
  begin
    errorlevel:=lo(dosexitcode);
    if errorlevel=0 then begin
      regs.ah:=$4d;
      msdos(regs);
      errorlevel:=regs.al;
      end;
  end;
}

begin
  doserror:=0;
  if maxavail<$8000 then
    writeln('Zu wenig freier Speicher f r externen Programmaufruf!')
  else
  begin
    pp:=cpos(' ',prog);
    if pp=0 then para:=''
    else begin
      para:=' '+trim(copy(prog,pp+1,127));
      prog:=left(prog,pp-1);
      end;
    prog:=ustr(prog);

    {$IFDEF DPMI}
      exec(prog,para);
    {$ELSE}

      if so(freeptr).o>0 then          { Gr  e der Free-Liste ermitteln }
        fs:=$1000a-so(freeptr).o
      else
        fs:=0;
      if fs>0 then begin               { Freeliste sichern }
        getmem(p,fs);
        FastMove(freeptr^,p^,fs);
        end;


      paras:=memw[prefixseg:2]-prefixseg+1;
      space:=(space+1)*64;   { KB -> Paragraphs, + 1 extra-KB }
      heapfree:=prefixseg+paras-so(heapptr).s;
      swapok:=true;
      if (heapfree>=space) or (so(heapptr).s-ovrheaporg<64) then
        swappars:=0
      else begin
        swappars:=min(space-heapfree,so(heapptr).s-ovrheaporg-2);
        SwapOut(so(heapptr).s-swappars+2,swappars);
        end;

      if swapok then begin
        with regs do begin
          ah:=$4a;          { set block }
          bx:=so(heapptr).s+3-prefixseg-swappars;
          es:=prefixseg;
          msdos(regs);                   { Speicher freigeben }
          end;
        free:=memfree;

        if (cpos('|',para)>0) or (cpos('>',para)>0) or (cpos('<',para)>0) then
          dpath:=''
        else begin
          if exist(prog) then dpath:=prog
          else dpath:=UStr(fsearch(prog,getenv('PATH')));
          if (right(dpath,4)<>'.EXE') and (right(dpath,4)<>'.COM') then
            dpath:='';
          end;
        swapvectors;
        if (para<>'') and (para[1]<>' ') then para:=' '+para;
        if dpath<>'' then
          exec(dpath,para)
        else
          exec(getenv('comspec'),' /c '+prog+iifs(para<>'',para,''));
        swapvectors;
{        geterrorlevel; }

        with regs do begin
          ah:=$4a;                { Speicherblock wieder herstellen }
         { bx:=paras;  - klappt nicht bei DR-DOS 3.41 }
          bx:=$ffff;
          es:=prefixseg;
          msdos(regs);
          ah:=$4a;
          es:=prefixseg;
          msdos(regs);
          end;

        if swappars>0 then SwapIn(so(heapptr).s-swappars+2,swappars);
        end;  { is swapok }

      if fs>0 then begin
        FastMove(p^,freeptr^,fs);
        freemem(p,fs);
        end;

    {$ENDIF}    { not DPMI }

    if doserror<>0 then
      error('Fehler '+strs(doserror)+' bei Programm-Aufruf');
    end;
end;


function is_xp2:boolean;
var t : text;
    s : string;
begin
  is_xp2:=false;
  s:='';
  assign(t,'XPOINT.CFG');
  if existf(t) then
  begin
    reset(t);
    readln(t,s);
    close(t);
    s:=lstr(s);
    is_xp2:=pos(xp_2,s)>0;
  end;
end;


{ ----------------------------------------------------------- }
{ Compile- bzw. Erstelldatum von UUZ.EXE als String  bergeben }
{                                                             }
{ formatted: true  = "2004/05/10, 22:10:25"                   }
{            false = "200405102210"                           }
{ type:      0 = Datum und Uhrzeit                            }
{            1 = nur Datum                                    }
{            2 = nur Uhrzeit                                  }
{ ----------------------------------------------------------- }
function uuztime(const formatted:boolean; const typ:byte):string;
var d      : datetime;
    dsepa,
    tsepa  : string[1];
    dtsepa : string[2];
begin
  if formatted then begin
    dsepa := '/'; tsepa:=':'; dtsepa:=', '; end
  else begin
    dsepa := ''; tsepa:=''; dtsepa:=''; end;
  if comp_YY='0000' then                        { Datei-Timestamp verwenden }
  begin                                         { (else Compile-Timestamp)  }
    unpacktime(filetime(paramstr(0)),d);
    comp_YY:=strs(d.year);
    comp_MO:=formi(d.month,2);
    comp_DD:=formi(d.day,2);
    comp_HH:=formi(d.hour,2);
    comp_MI:=formi(d.min,2);
    comp_SS:=formi(d.sec,2);
  end;
  uuztime:=iifs(typ<>2,comp_YY+dsepa+comp_MO+dsepa+comp_DD+
                       iifs(typ=0,dtsepa,''),'')+
           iifs(typ<>1,comp_HH+tsepa+comp_MI+
                       iifs(formatted,tsepa+comp_SS,''),'')
end;

function get_date:datetimest;
var YY,MM,DD,day : word;
begin
  getdate(YY,MM,DD,day);
  get_date:=strs(YY)+'/'+formi(MM,2)+'/'+formi(DD,2);
end;

function get_time:datetimest;
var hh,mm,ss,proz : word;
begin
  gettime(hh,mm,ss,proz);
  get_time:=formi(hh,2)+':'+formi(mm,2)+':'+formi(ss,2)+''''+formi(proz,2);
end;

function time_diff(const t1,t2:datetimest):real;

  function TimeSecs(const t:datetimest):real;
  begin
    TimeSecs:=3600*ival(left(t,2))+60*ival(copy(t,4,2))+ival(copy(t,7,2))+ival(right(t,2))/100;
  end;

begin
  if t2>=t1 then
    time_diff:=round(TimeSecs(t2)-TimeSecs(t1),2)
  else
    time_diff:=round((24*3600-TimeSecs(t1))+TimeSecs(t2),2);
end;

function strSecs(t:real):datetimest;
var hh,mm,ss,proz : longint;
begin
  hh:=0; mm:=0; ss:=0; proz:=0;
  t:=round(t,2);
  if t>=3600 then
  begin
    hh:=trunc(t) div 3600;
    t:=t-hh*3600;
  end;
  if t>=60 then
  begin
    mm:=trunc(t) div 60;
    t:=t-mm*60;
  end;
  ss:=trunc(t);
  proz:=trunc(frac(t)*100);
  strSecs:=strs(hh)+':'+formi(mm,2)+':'+formi(ss,2)+''''+formi(proz,2);
end;

function sizeKB(f:string):real;
begin
  sizeKB:=_filesize(f)/1024;
end;


{$R-}
{ ----------------------------------------------------------------- }
{ umbruch: false = Zeile komplett bis CR/LF lesen, aber alles nach  }
{                  'MaxReadLen'+1 verwerfen (sinnvoll z.B. zum      }
{                   berlesen von Headerzeilen; nie verwenden, wenn  }
{                  der vollst ndige String ben tigt wird!).         }
{          true  = Zeile nur bis MaxReadLen oder bis zum ersten     }
{                  CR/LF davor lesen                                }
{ ----------------------------------------------------------------- }
{ my: Neue Behandlung von 'eol' (Zeilenende)                        }
{     1. Die Routine betrachtet jetzt auch ein allein vorkommendes  }
{        CR als g ltiges Zeilenende (bisher produzierte der UUZ bei }
{        Nachrichten mit alleine vorkommenden CRs mitunter eine     }
{        Endlosschleife). Zusammengeh rige CRLFs werden weiterhin   }
{        als solche korrekt erkannt.                                }
{     2. Zeilenenden werden jetzt auch dann korrekt erkannt, wenn   }
{        der String zuf llig exakt die L nge von 'MaxReadLen'       }
{        besitzt und danach die Zeile endet (bisher wurde dann ein  }
{        Wert von 0 an 'eol'  bergeben). Diese Erkennung funktio-   }
{        niert auch dann zuverl ssig, wenn zuf llig gleichzeitig    }
{        das Ende des Lesepuffers erreicht sein sollte (dann mu     }
{        ggf. nachgeladen werden) und sie ist unverzichtbar f r     }
{        eine korrekte Multibyte-Decodierung (UTF-7/8, qp/base64)   }
{        sowie das Ziehen richtiger Schl sse beim Lesen und Schrei- }
{        ben (speziell des Body) allgemein.                         }
{     3. Wenn ein Zeilenende (CR|LF|CRLF) erkannt wurde, wird jetzt }
{        immer ein Wert von 2 an 'eol'  bergeben. Der Wert 1 wird   }
{        nur als Zwischenergebnis innerhalb der Routine in dem Fall }
{        verwendet, da  ein CR bereits gelesen wurde, auf ein nach- }
{        folgendes LF jenseits der aktuellen Position im Lesepuffer }
{        aber noch gepr ft werden mu  (bzw. da  diese Pr fung erge- }
{        ben hat, da  kein LF vorhanden ist).                       }
{     4. Am Dateiende wird immer ein Wert von 3 an 'eol'  bergeben  }
{        (auch wenn gar kein Zeilenende vorhanden sein sollte).     }
{        Dadurch werden jetzt auch ZC-Puffer ohne abschlie endes    }
{        CR/LF korrekt konvertiert (bisher fehlte dann die letzte   }
{        Zeile fast vollst ndig, nur das erste Zeichen wurde ohne   }
{        Zeilenumbruch an das letzte Zeichen der vorherigen Zeile   }
{        angeh ngt).                                                }
{     So k nnen Routinen, die 'ReadString' aufrufen, bei Bedarf zu- }
{     verl ssig Zeilen- und Dateiende "vorhersehen", auch wenn sich }
{     dieses bei Erreichen der max. Stringl nge genau ein Zeichen   }
{     jenseits der aktuellen Position im Puffer befinden sollte.    }
{     Mit anderen Worten: Wenn 'eol' gleich 0 ist, folgen in jedem  }
{     Fall noch weitere Zeichen <> CR/LF in derselben Zeile (was    }
{     bisher nicht garantiert war, und insofern konnte man aus dem  }
{     Wert von 'eol' bisher nichts wirklich Handfestes schlie en,   }
{     tat es aber mitunter trotzdem).                               }
{                                                           04/2004 }
{ ----------------------------------------------------------------- }
procedure ReadString(umbruch:boolean);
const savedi : word = 0;
      savebx : word = 0;

  procedure reload;  far;
  begin
    if eof(f1) then { ok:=false }
    else ReadBuf;
  end;

  { my: Sicherstellen, da  sich immer mindestens noch 5 Bytes im    }
  {     Puffer befinden, die von anderen Routinen wie 'ReadRfcBody' }
  {     und 'WriteS' "vorausschauend" gepr ft werden k nnen.        }
  procedure add2buf (const minbuf:byte);
  var tempbuf : array[0..3] of char;
      temppos,
      restanz : integer;
  begin
    if bufpos>=bufanz then exit;  { Dateiende }
    restanz:=bufanz-bufpos;
    if restanz<minbuf then
    begin
      fpos:=filepos(f1)-restanz;
      move(buffer[bufpos],buffer[0],restanz);
      blockread(f1,tempbuf,minbuf-restanz,temppos);
      if temppos>0 then
        fastmove(tempbuf[0],buffer[restanz],temppos);
      bufanz:=restanz+temppos;
      bufpos:=0;
    end;
  end;

begin
  lasteol:=(eol>0);
  eol:=0;
   asm
     mov si,bufpos
     mov di,0                    { l:=0 }
     mov ah,0
     mov dl,umbruch
     mov bx,word ptr maxslen
     mov dh,byte ptr maxslen+2   { maxslen>$ffff -> dh<>0 }
     or dh,byte ptr maxslen+3
     mov cx,bufanz
@@1: cmp si,cx                   { bufpos>=bufanz? }
     jb @_1                      { Ende der Eingabedatei }
     mov eol,3                   { Flag f r Dateiende setzen }
     jmp @@9
@_1: or dh,dh                    { l<maxslen? }
     jnz @@2
     cmp di,bx
     jae @@8
@@2: or dl,dl                    { not umbruch or .. }
     jz @@3
     cmp di,MaxReadLen           { .. l<MaxReadLen? }
     jae @@8
@@3: mov al,byte ptr buffer[si]
     inc si                      { c:=buffer[bufpos] }
     cmp al,13                   { CR? }
     je @@5
     cmp al,10                   { LF? }
     je @_6
     cmp al,00h                  { #0 abfangen }
     jne @3z
     mov al,' '
@3z: cmp al,1ah                  { Ctrl-Z abfangen }
     jne @_3
     mov al,'>'
     { ------------------------------------------------------ }
     { my: Die folgende Pr fung ist nur bei umbruch = false   }
     {     relevant, im Falle umbruch = true k nnen wir hier  }
     {     gar nicht sein, wenn 'MaxReadLen' bereits erreicht }
     {     worden w re (siehe 'cmp di,MaxReadLen' in @@2)     }
     { ------------------------------------------------------ }
@_3: cmp di,MaxReadLen           { max. Stringl nge erreicht? }
     ja @@7                      { dann ggf. nachladen }
     inc di                      { inc(l)  }
     mov byte ptr s+di,al        { s[l]:=c }
@@4: { ------------------------------------------------ }
     { my: Sonderfallpr fung - falls Stringl nge *nach* }
     {     der  bernahme des Zeichens nach 's' exakt    }
     {     'MaxReadLen', dann n chste Zeichen auf CR/LF }
     {     pr fen, um 'eol' korrekt setzen zu k nnen.   }
     { ------------------------------------------------ }
     cmp di,MaxReadLen           { jetzt max. Stringl nge erreicht? }
     jb @@7                      { n , dann ggf. nachladen }
     cmp si,cx                   { bufpos>=bufanz? }
     jb @_4                      { n , n chstes Zeichen pr fen }
     mov ah,1                    { Flag, da  wir zu @_4 wieder zur ck m ssen }
     jmp @_7                     { nachladen und danach weiterpr fen }
@_4: mov ah,0                    { Flag zur cksetzen! }
     cmp byte ptr buffer[si],13  { *n chstes* Zeichen auf CR pr fen }
     jne @_5                     { kein CR, LF pr fen }
     inc si                      { CR, Zeiger um 1 weiter ... }
     { ---------------------- }
     { /my: Sonderfallpr fung }
     { ---------------------- }
@@5: inc eol                     { (al=CR) oder (buffer[si]=CR) }
     cmp si,cx                   { bufpos>=bufanz? }
     jb @_5                      { n , n chstes Zeichen pr fen }
     mov ah,2                    { Flag, da  wir zu @_5 wieder zur ck m ssen }
     jmp @_7                     { nachladen und danach weiterpr fen }
@_5: mov ah,0                    { Flag zur cksetzen! }
     cmp byte ptr buffer[si],10  { auf LF pr fen (evtl. auch nach CR) }
     jne @@6                     { kein LF, evtl. aber CR => pr fen! }
     inc si                      { LF|CRLF, Zeiger um 1 weiter ... }
     jmp @_6
@@6: cmp eol,0                   { kein LF, aber CR? }
     je @@7                      { n , ggf. nachladen }
@_6: mov eol,2                   { CR|LF|CRLF: 'eol' immer auf 2 setzen! }

@@7: cmp si,cx                   { bufpos>=bufanz? }
     jb @7c                      { n , nix nachzuladen }
@_7: push ax
     mov savebx,bx
     mov savedi,di
     mov bufpos,si
     mov bufanz,cx
     push cs
     call reload                 { nachladen }
     mov si,bufpos
     mov cx,bufanz
     mov di,savedi
     mov bx,savebx
     pop ax
@7c: cmp eol,2                   { Zeilenende erreicht? }
     jae @@9                     { jup, Zeile => 's' }
     cmp ah,1                    { zur ck zur Pr fung auf CR? }
     je @_4                      { jup }
     cmp ah,2                    { zur ck zur Pr fung auf LF? }
     je @_5                      { jup }

     jmp @@1                     { weiterlesen oder ggf. beenden }

@@8: cmp dl,0                    { Wenn Umbruch aktiv ist: }
     je @@9
     lea bx,[s+di+1]             { vom Stringende zur ck bis zum }
     xor cx,cx
@_8: dec bx
     mov al,byte ptr[bx]         { letzten Trennzeichen gehen }
     cmp al,' '
     je @@9
     cmp al,9
     je @@9
     cmp al,','
     je @@9
     cmp al,';'
     je @@9
     cmp si,0
     je @8e                      { Abbruch, kein Trenner im Puffer }
     inc cx
     dec si
     dec di
     jne @_8                     { weitersuchen, solange L nge > 0 }
@8e: add si,cx          { wenn keine Trennm glichkeit gefunden wurde, }
     add di,cx          { Stringl nge und Bufferposition zur cksetzen }

@@9: mov ax,di
     mov byte ptr s,al           { s[0]:=char(l) }
     mov bufpos,si
   end;
  MaxSlen:=255;
  add2buf(5);  { ggf. bis zu 4 Restbytes nachladen }
end;


{ N chstes n-tes Zeichen im Buffer pr fen, falls vorhanden }
function nextchar(const n:byte):char;
begin
  if bufpos+n<bufanz then        { 'bufpos' steht hier bereits }
    nextchar:=buffer[bufpos+n]   { auf dem *n chsten* Zeichen! }
  else
    nextchar:=#0;        { Ende des Buffers bzw. der Nachricht }
end;


{  bergebenen String mit n chsten Zeichen im Buffer vergleichen }
function is_nextstring(const s:string):boolean;
var p  : byte;
    ok : boolean;
begin
  ok:=false;
  p:=0;
  if s='' then
  begin
    ok:=nextchar(0)=#0;
  end
  else repeat
    inc(p);
    ok:=nextchar(p-1)=s[p];
  until not ok or (p=length(s));
  is_nextstring:=ok;
end;


function end_of_mail(const typ:byte):boolean;
begin
  end_of_mail:=(eol>0) and
               (((typ in [4,5]) and is_nextstring(mboxline)) or
                ((typ=3) and (((nextchar(0)='.') and (nextchar(1) in [#13,#10])) or
                              (LastEol and (s='.')))));
end;


{ my: Mailinglisten-Mail anhand der in RFC2369/2919 definierten      }
{     Header erkennen (wegen Supersedes/Cancel-Behandlung bei Mail), }
{     zus tzlich Mailman-propriet ren Header "X-List-Administrivia"  }
{     ber cksichtigen                                                }
function is_mailinglist(const typ:byte; const id:string):boolean;
begin
  is_mailinglist:=(typ>1) and
                  (pos(';'+id+';',
                       ';u-list-help;u-list-subscribe;u-list-unsubscribe'+
                       ';u-list-post;u-list-owner;u-list-archive;u-list-id'+
                       ';x-list-administrivia;')>0);
end;


procedure ReadBinString(bytesleft:longint);    { Base64-Codierung }
const b64chr : array[0..63] of char =
      'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
var   b1,b2,b3,p : byte;

  function getbyte:byte;
  begin
    if bufpos=bufanz then
      getbyte:=0
    else begin
      getbyte:=byte(buffer[bufpos]);
      inc(bufpos);
      if (bufpos=bufanz) and not eof(f1) then
        ReadBuf;
      end;
  end;

begin
  if (bytesleft>54) and (bufpos<bufanz-54) then
  asm
      cld
      mov   si,offset buffer
      add   si,bufpos
      mov   dx,18                { 18 byte-Tripel konvertieren }
      mov   cl,2
      mov   bx,offset b64chr
      mov   di,offset s[1]
      mov   ax,ds
      mov   es,ax
 @@1: lodsb                      { Byte 1 }
      mov   ah,al
      lodsb                      { Byte 2 }
      shr   ax,1
      rcr   ch,1
      shr   ax,1
      rcr   ch,1
      xchg  al,ah
      xlat
      stosb                      { Bit 7..2/1 }
      mov   al,ch
      shr   ax,cl
      xchg  al,ah
      xlat
      stosb                      { Bit 1..0/1 + Bit 7..4/2 }
      lodsb                      { Byte 3 }
      shr   ah,cl
      shr   ah,cl
      shl   ax,cl
      xchg  al,ah
      xlat
      stosb                      { Bit 3..0/2 + Bit 7..6/3 }
      mov   al,ah
      shr   al,cl
      xlat
      stosb                      { Bit 5..0/3 }
      dec   dx
      jnz   @@1
      mov   byte ptr s[0],72
      add   bufpos,54
  end else
  begin
    p:=0;
    repeat
      b1:=getbyte; b2:=getbyte; b3:=getbyte;
      s[p+1]:=b64chr[b1 shr 2];
      s[p+2]:=b64chr[(b1 and 3) shl 4 + b2 shr 4];
      s[p+3]:=b64chr[(b2 and 15) shl 2 + b3 shr 6];
      s[p+4]:=b64chr[b3 and 63];
      inc(p,4); dec(bytesleft,3);
      if bytesleft<0 then begin
        s[p]:='=';
        if bytesleft<-1 then s[p-1]:='=';
        end;
    until (p>70) or (bytesleft<=0);
    SetLength(s, p);
    end;
end;
{$IFDEF Debug }
  {$R+}
{$ENDIF }


procedure ReadBuf;
begin
  fpos:=filepos(f1);
  blockread(f1,buffer,bufsize,bufanz);
  bufpos:=0;
end;


{ ------------------------------------------------------ }
{ my: Neue Routine im Zuge des Rewrite 08/2002-05/2004   }
{     (Ablegen langer unstrukturierter String-Header bis }
{      65500 Zeichen im Array 'LongHdr')                 }
{ ------------------------------------------------------ }

procedure SaveLongHdr(const n,maxLen:byte; var s,shortHdr:string;
                      const MIMEdecode:boolean; const structured:byte);
var ml        : byte;
    add_hdr   : string;
    add_len   : integer;
    add_token : string[2];

  procedure SaveHdr;
  begin
    if add_hdr<>'' then
    begin
      if sizeof(HdrLine^)-HdrLen>=add_len then                   { pa t ... }
      begin
        move(HdrLine^[1],HdrLine^[add_len+1],HdrLen);
        inc(HdrLen,add_len);
        fastmove(add_hdr[1],HdrLine^[1],length(add_hdr));
        if add_token<>'' then
        begin
          HdrLine^[length(add_hdr)+1]:=add_token[1];
          if byte(add_token[0])>1 then
            HdrLine^[length(add_hdr)+2]:=add_token[2];
        end;
      end
      else begin                                           { pa t nicht ... }
        truncated:=truncated or
                   (HdrLen-(sizeof(HdrLine^)-add_len)>sizeof(rest)-1);
        byte(rest[0]):=min(HdrLen-(sizeof(HdrLine^)-add_len),
                           sizeof(rest)-1);
        fastmove(HdrLine^[sizeof(HdrLine^)-(length(add_hdr)+1)],
                 rest[1],length(rest));
        move(HdrLine^[1],HdrLine^[add_len+1],sizeof(HdrLine^)-add_len);
        fastmove(add_hdr[1],HdrLine^[1],length(add_hdr));
        if add_token<>'' then
        begin
          HdrLine^[length(add_hdr)+1]:=add_token[1];
          if byte(add_token[0])>1 then
            HdrLine^[length(add_hdr)+2]:=add_token[2];
        end;
        HdrLen:=sizeof(HdrLine^);
      end;
    end;
    DisposeLongHdr(n);          { bereits vorher gelesenen Header wegwerfen }
    if maxavail>=HdrLen then
    begin                                { aktueller Header => 'LongHdr[n]' }
      getmem(LongHdr[n].hdr,HdrLen);
      fastmove(HdrLine^[1],LongHdr[n].hdr^[1],HdrLen);
      LongHdr[n].len:=HdrLen;
      LongHdr[n].rest:=rest;
      LongHdr[n].trunc:=truncated;
    end;
  end;

begin
  ml:=min(maxLen,253);                        { auf 253 Zeichen begrenzen }
  add_hdr:='';
  add_len:=0;
  add_token:='';
  if (n=LGate) and (add_gate<>'') then  { eigenen Gateway-Header addieren }
  begin
    add_hdr:=add_gate;
    add_token:=', ';
  end
  else if (n=LPath) and (addpath<>'') then        { eigenen Pfad addieren }
    add_hdr:=addpath;
  add_len:=length(add_hdr)+length(add_token);
  if MIMEdecode then
    s:=GetHeader(HdrLine,HdrLen,rest,truncated,        { MIME-Decodierung }
                 overflow,true,false,structured);
  if HdrLen+add_len>ml then
  begin
    if add_hdr<>'' then
    begin
      shortHdr:=left(add_hdr,ml); { eigenen Gate/Pfad-Header voranstellen }
      if length(shortHdr)<=ml-(length(truncater)+length(add_token)) then
        shortHdr:=shortHdr+add_token+        { originalen Header anh ngen }
                  left(s,ml-(length(shortHdr)+length(add_token)+
                             length(truncater)))+truncater;
    end else                                              { s formatieren }
      shortHdr:=left(s,ml-length(truncater))+truncater;   { (Backdoor)    }
    SaveHdr;                                        { Header => 'LongHdr' }
  end
  else shortHdr:=add_hdr+add_token+s;     { alles pa t zusammen in String }
end;


{ ------------------------------------------------------------------------ }
{ my: Body der RFC-Nachricht lesen, b64/qp- und charset-decodieren und     }
{     L nge ermitteln bzw. schreiben                                       }
{     msgtyp: 1=Newsbatch, 2=UUCP/Raw-Mail, 3=SMTP-Mail, 4=mboxo, 5=mboxrd }
{ ------------------------------------------------------------------------ }
procedure ReadRfcBody(const msgtyp:byte; const write:boolean; ss:longint);
var   softbrk,
      mailende,
      qchars_only : boolean;
      MaxReadBak  : word;
      p           : byte;
const current_cs  : word = 0;  { Nummer aktueller MIME-Charset }

  { base64- oder qp-codierte Zeilen bei Bedarf   }
  { sauber in in sich abgeschlossene Teilstrings }
  { splitten (ver ndert 's' und gibt Reststring  }
  { zur ck)                                      }
  function split_encoded:string;
  var i : byte;
  begin
    split_encoded:='';
    if (eol>0) or (s='') then exit;
    if b64 then               { Base64 }
    begin
      i:=0;
      if byte(s[0])>4 then
        i:=byte(s[0]) mod 4;  { Rest nach Div. durch 4 => split_encoded }
      if i>0 then
      begin
        split_encoded:=right(s,i);
        dec(byte(s[0]),i);
      end;
    end
    else if qprint then       { quoted-printable }
    begin
      if s[byte(s[0])-1]='=' then       { endet z.B. mit '=E4=E' }
      begin
        split_encoded:=right(s,2);
        dec(byte(s[0]),2);
      end
      else if (s[byte(s[0])]='=') then  { endet z.B. mit '=E4='  }
      begin
        split_encoded:=lastchar(s);
        dec(byte(s[0]));
      end;
    end;
  end;

  { base64-decodierte Textzeilen sauber bei CRLF }
  { splitten und CR bzw. LF nach CRLF umwandeln  }
  { (ver ndert 's' und gibt Reststring zur ck)   }
  function split_decoded:string;
  var p,p1 : byte;
  begin
    split_decoded:='';
    if s='' then
    begin
      last_cr:=false;
      exit;
    end;
    if (s[1]=#10) and last_cr then    { letzte Trennung war zw. CR und LF }
      s:=mid(s,2);
    p:=cpos(#13,s);                   { erstes CR suchen }
    p1:=cpos(#10,s);                  { erstes LF suchen }
    if (p>0) and (p1>0) then
      p:=min(p,p1)                    { p = erstes CR|LF im String }
    else if p=0 then
      p:=p1;
    last_cr:=(p=byte(s[0])) and (s[p]=#13);
    if last_cr then                   { gefundenes CR ist letztes Zeichen }
      s:=s+#10
    else if (p>0) and not             { String mu  gesplittet werden... }
            ((p=byte(s[0])-1) and
             (right(s,2)=#13#10))     { ... wenn nicht letzte Zeichen = CRLF }
    then begin
      if s[p]=#10 then                { einzelnes LF gefunden }
      begin
        split_decoded:=mid(s,p+1);
        s:=left(s,p-1)+#13#10;        { LF => CRLF }
      end
      else begin                      { CR oder CRLF gefunden }
        if s[p+1]=#10 then
        begin
          split_decoded:=mid(s,p+2);  { CRLF gefunden }
          s:=left(s,p+1);
        end
        else begin
          split_decoded:=mid(s,p+1);  { CR gefunden, LF anh ngen }
          s:=left(s,p)+#10;
        end;
      end;
    end;
  end;

  { String charset-konvertieren und ggf. CRLF ans Ende anh ngen }
  procedure convert_string;
  var ii : byte;
  begin
    if (((msgtyp=1) and (ss<=0)) or               { Newsbatch }
        ((msgtyp=2) and (bufpos>=bufanz)) or      { UUCP-Mail }
        ((msgtyp in [3..5]) and                   { SMTP/mbox }
         ((bufpos>=bufanz) or mailende))) and
       not binaer and
       { Befinden wir uns bei einem bereits vollst ndig     }
       { gelesenen und decodierten b64/qp-String in einem   }
       { gesplitteten Teilstring davon, weil der decodierte }
       { String Zeilenumbr che enthielt? Wenn ja, sind wir  }
       { nicht am Ende der Nachricht und d rfen kein CRLF   }
       { anh ngen!                                          }
       not ((qprint or b64) and (s_rest<>'')) and
       { /Test auf gesplitteten Teilstring                  }
       (right(s,2)<>#13#10) then
    begin
      if lastchar(s)=#13 then                      { ggf. CR/LF ans Ende    }
        s:=s+#10                                   { der Nachricht anh ngen }
      else if lastchar(s)=#10 then
        s:=left(s,byte(s[0])-1)+#13#10
      else
        s:=s+#13#10;
    end;
    end_of_UTF:=(right(s,2)=#13#10);                   { 'sc_rest' belegen? }
    if not binaer then with hd.mime do
    begin
      if not (write or cs_fallback) and         { Charset-Fallback nur beim }
         (fcs<>'') then                         { ersten Durchlauf (L nge   }
      begin                                     { ermitteln) pr fen         }
        ii:=0;
        repeat                                      { bei erstem gefundenen }
          inc(ii);                                  { Zeichen abbrechen und }
          cs_fallback:=byte(s[ii]) in [$80..$9f];   { Routine nicht wieder  }
        until cs_fallback or (ii=byte(s[0]));       { aufrufen              }
      end;
      if convcharset and                                { Charset im ersten }
         (write or (current_cs>=cs_utf_7)) then         { Durchlauf nur bei }
        CharsetToIBM(iifs(cs_fallback,fcs,charset),s);  { UTF-7/8 konvert.  }
      if write and (qprint or b64) then
      begin
        repeat
          ii:=cpos(#0,s);                           { codiertes #0 ersetzen }
          if ii>0 then s[ii]:=' ';
        until ii=0;
        repeat
          ii:=cpos(#26,s);                    { codiertes <Ctrl-Z> ersetzen }
          if ii>0 then s[ii]:='>';
        until ii=0;
      end;
    end;
    start_of_UTF:=end_of_UTF;                       { 'sc_rest' ignorieren? }
    if not ((msgtyp in [4,5]) and                    { mbox: Leerzeile am   }
            ((bufpos>=bufanz) or mailende) and       {       Ende  berlesen }
            (s=#13#10)) then
    begin
      if write then                  { Body anh ngen }
        wrfs(s)
      else
        inc(hd.groesse,length(s));   { Gr  e berechnen }
    end;
  end;

begin
  MaxReadBak:=MaxReadLen;
  MaxReadLen:=maxUTFLen;         { wegen UTF-Decodierung auf 248 begrenzen! }
  start_of_UTF:=true;      { evtl. 'sc_rest' bei UTF-Decodierung ignorieren }
  last_cr:=false;
  qchars_only:=false;
  encode_rest:='';
  s_rest:='';
  if not write then
  begin
    current_cs:=convertible_charset(hd.mime.charset);
    fcs:=fallback_charset(current_cs);                   { Fallback-Charset }
    cs_fallback:=false;
  end;
  mailende:=end_of_mail(msgtyp);
  while (bufpos<bufanz) and
        (((msgtyp=1) and (ss>0)) or                 { Newsbatch }
         (msgtyp=2) or                              { UUCP-Mail }
         ((msgtyp in [3..5]) and not mailende)) do  { SMTP/mbox }
  begin
    if msgtyp=1 then MaxSlen:=ss;
    softbrk:=false;
    ReadString(true);
    mailende:=end_of_mail(msgtyp);
    case msgtyp of
      1 : dec(ss,length(s)+minmax(eol,0,1));  { News: Size aktualisieren }
          (* dec(ss,length(s)+eol); *)
      3 : if LastEol and (firstchar(s)='.') then   { SMTP: '.' entfernen }
            delfirst(s);
      4 : if LastEol and                          { mboxo: '>' entfernen }
             (left(s,length(mboxline)+1)='>'+mboxline) then
            delfirst(s);
      5 : if LastEol or qchars_only then         { mboxrd: erstes '>'    }
          begin                                  { in '>>..>>' entfernen }
            p:=0;
            while (p<length(s)) and (s[p+1]='>') do inc(p);
            if p>0 then
            begin
              qchars_only:=(eol=0) and (p=MaxReadLen);    { lange Zeile! }
              if not qchars_only then
              begin
                     { ----------------------------------------- }
                     { case1: Das letzte Quotezeichen befindet   }
                     {        sich weniger als 5 Stellen links   }
                     {        von MaxReadLen und danach folgt    }
                     {        'From '                            }
                     { ----------------------------------------- }
                if ((p<=MaxReadLen-length(mboxline)) and
                    (copy(s,p+1,length(mboxline))=mboxline)) or
                     { ----------------------------------------- }
                     { case2: Zeile wird fortgesetzt und das     }
                     {        Stringende befindet sich mitten in }
                     {        'From ' (wenn 'eol=0', *muss* der  }
                     {        String 'MaxReadLen' Zeichen lang   }
                     {        sein!)                             }
                     { ----------------------------------------- }
                   ((eol=0) and (p>MaxReadLen-length(mboxline)) and
                    (mid(s,p+1)=left(mboxline,MaxReadLen-p)) and
                    is_nextstring(mid(mboxline,(MaxReadLen+1)-p))) then
                     delfirst(s);
              end
                { ----------------------------------------- }
                { case3: Zeile wird fortgesetzt und das     }
                {        Stringende befindet sich genau vor }
                {        'From '                            }
                { ----------------------------------------- }
              else if is_nextstring(mboxline) then
                delfirst(s);
            end
            else qchars_only:=false;
          end;
    end;
    if qprint or b64 then
    begin
      s:=encode_rest+s;             { gesplittete Sequenz zusammensetzen }
      encode_rest:=split_encoded;   { unvollst ndige Sequenz splitten    }
      if qprint then
        softbrk:=UnQuotePrintable(s,eol)
      else
        DecodeBase64(s);
    end;
    if not (b64 or softbrk) and (eol>0) then    { CRLF an Zeile anh ngen }
      s:=s+#13#10;
    if (qprint or b64) and not binaer then
    repeat
      s_rest:=split_decoded;   { setzt auch last_cr! }
      convert_string;          { konvertiert/schreibt 's' (b64/qp-Text) }
      s:=s_rest;
    until s_rest=''
    else convert_string;       { konvertiert/schreibt 's' (kein b64/qp-Text) }
  end;
  MaxReadLen:=MaxReadBak;      { resetten! }
end;


procedure GetRunOS;
const rOS_DOS = 'DOS';           { Runtime-Plattform DOS          }
      rOS_Win = 'Win';           { Runtime-Plattform Windows      }
      rOS_OS2 = 'OS2';           { Runtime-Plattform OS/2         }
      rOS_Lnx = 'Linux[DOSEMU]'; { Runtime-Plattform Linux/DOSEMU }
      rOS_DBx = 'DOSBox';        { Runtime-Plattform DOSBox       }
var build: DWORD;
begin
  {$IFNDEF NO386}
  RunOS:=DOSEmuVersion;
  
  if RunOS<>'' then
  begin
    FRunOS:=rOS_Lnx;
    RunOS:=left(rOS_Lnx,length(rOS_Lnx)-1)+'-'+RunOS+lastchar(rOS_Lnx);
  end
  else if DOSBOX then
  begin
    FRunOS:=rOS_DBx;
    RunOS:=rOS_DBx;
  end
  else if lo(dosversion)>=10 then
  begin
    FRunOS:=rOS_OS2;
    case (lo(dosversion) div 10) of
      1 : RunOS:=rOS_OS2+'-'+strs(lo(dosversion) div 10)+
                         '.'+strs(hi(dosversion));
      2 : begin
            str(hi(dosversion)/10:3:1,RunOS);
            RunOS:=rOS_OS2+'-'+RunOS;
          end;
    end;
  end
  else case WinVersion of
    2 : begin                                                 { Windows 3.x }
          FRunOS:=rOS_Win+'3.x';
          RunOS:=FrunOS;
        end;
    3 : begin                                            { Windows 95/98/Me }
          FRunOS:=rOS_Win+'9x';
          if lo(TrueWinVersion)<5 then
            RunOS:=rOS_Win+'95'                                { Windows 95 }
          else case lo(dosversion) of
            7 : RunOS:=rOS_Win+'98';                           { Windows 98 }
            8 : RunOS:=rOS_Win+'Me';                           { Windows Me }
          end;
        end;
    4 : begin                                            { Windows NT/2K/XP }
          FRunOS:=rOS_Win+'NT';
          if lo(WinNTVersion)=0 then                    { ohne XP_NTVDM.DLL }
            RunOS:=FRunOS
          else begin                                     { mit XP_NTVDM.DLL }
                 case lo(WinNTVersion) of
                   5: begin
                        case hi(WinNTVersion) of
                          0: RunOS:=rOS_Win+'2K';            { Windows 2000 }
                          1: RunOS:=rOS_Win+'XP';              { Windows XP } 
                          2: RunOS:=rOS_Win+'2K3';    { Windows Server 2003 }
                        else RunOS:=FRunOS;                    { Windows NT }
                        end;
                      end;
                   6: begin
                        case hi(WinNTVersion) of
                          0: RunOS:=rOS_Win+'Vista';        { Windows Vista }
						  1: RunOS:=rOS_Win+'7';            { 'Windows 7'       }
						  2: RunOS:=rOS_Win+'8';            { 'Windows 8'       }
						  3: RunOS:=rOS_Win+'8.1';          { 'Windows 8.1'       }
                        else RunOS:=FRunOS;                    { Windows NT }
                        end;
                      end;
				   10: 	case Hi(WinNTVersion) of
                        0: begin
							build:=	Winntversion shr 16;
							IF build>=22000 then
								RunOS:=rOS_Win+'11'	{ 'Windows 11'       }
							ELSE
								RunOS:=rOS_Win+'10';	{ 'Windows 10'       }
						 end;
						 end;
                   else RunOS:=FRunOS;                         { Windows NT }
			 end;
          end;
        end;
    else begin                                                  { plain DOS }
	{$ENDIF}
      FRunOS:=rOS_DOS;
      RunOS:=rOS_DOS+'-'+strs(lo(dosversion))+
                     '.'+formi(hi(dosversion),2);
	{$IFNDEF NO386}
    end;
  end;  { case }
  {$ENDIF}
end;


{ ------------------------------------------------------------------ }
{                                                                    }
{ my: "User-Agent:" gem   USEFOR-Draft aus MAILER:-Headern von       }
{     XP-Versionen (SLizenz) erzeugen                                }
{                                                                    }
{     Verarbeitet werden Header in folgenden Formaten:               }
{                                                                    }
{     CrossPoint/<Version> ...     (alle Derivate)                   }
{     CrossPoint [<Version>] ...   (alle Derivate)                   }
{     CrossPoint ... (www.xp2.de)  (nur XP2)                         }
{                                                            12/2005 }
{ ------------------------------------------------------------------ }
{                                                                    }
{ Beispiele f r real vorkommende Header, die diese Routine           }
{ verarbeitet (es werden aber auch weit "schr gere" Header           }
{ korrekt verarbeitet):                                              }
{                                                                    }
{ CrossPoint/OpenXP v3.20d R/A15685                                  }
{ CrossPoint/OpenXP v3.20e R/A22422                                  }
{ CrossPoint/OpenXP v3.30.2beta R/C20959                             }
{ CrossPoint/OpenXP v3.30.6beta@0809001754 R/C8054                   }
{ CrossPoint/OpenXP v3.40RC2@0101010000                              }
{ CrossPoint/OpenXP v3.40RC3@0512010926 R/A24130                     }
{ CrossPoint/OpenXP v3.40RC3@1301012220 R/                           }
{ CrossPoint/OpenXP v3.40myRC3@1801022309 R/C7799                    }
{ CrossPoint/OpenXP v3.40myRC3@0601021904 Kom-R/C816                 }
{                                                                    }
{ CrossPoint [OpenXP/16] v3.40RC3@0703022038                         }
{ CrossPoint [OpenXP/16] v3.40 RC3                                   }
{ CrossPoint [OpenXP/16] v3.40 RC3 @ 0102031713 R/C816               }
{ CrossPoint [OpenXP/16] v3.40 RC3 @ 2804022000 R/A1388- CS R        }
{ CrossPoint [OpenXP/16] v3.40 RC3 @ 1706032324 R/Free               }
{ CrossPoint [OpenXP/16] v3.40 RC3 @ 2804022000 Kom-R/C14099         }
{ CrossPoint [OpenXP/16] v3.40 RC3-MW2-JM @ 2804022000 R/C16641      }
{ CrossPoint [OpenXP/16] v3.40 RC3 (EMS) @ 0107030055 R/C816         }
{ CrossPoint [OpenXP/16] v3.40 RC3 (XMS) @ 0107030055 R/C816         }
{ CrossPoint [OpenXP/16] v3.40mime RC3 @ 3103022150 R/C816           }
{ CrossPoint [OpenXP/16-mw] v3.40.2 Pre R/A16750                     }
{                                                                    }
{ CrossPoint [FreeXP] v3.40 RC3 (XMS) @ 2607031752 R/C816            }
{ CrossPoint/FreeXP v3.40 RC3 @ 3108030130 R/Free                    }
{ CrossPoint/FreeXP v3.40 RC3 @ 2908031644 R/C16641                  }
{ CrossPoint/FreeXP v3.40 RC3 (EMS) @ 1108030054 R/C816              }
{ CrossPoint/FreeXP v3.40 RC3 (XMS) @ 0808030057 R/C816              }
{ CrossPoint/FreeXP v3.40 RC3 (XMS) @ 0201051300 Kom-R/C14099        }
{ CrossPoint/FreeXP v3.40 DOSBOX-Edition (XMS) @ 0305041035 R/C11064 }
{ CrossPoint/FreeXP v3.40 RC4 (Halloween) (EMS) R/A994               }
{ CrossPoint/FreeXP v3.40 RC4 (Halloween) (EMS) R/Free               }
{ CrossPoint/FreeXP v3.40 RC5 (XMS) @ 1611051002 Kom-R/C14099        }
{ CrossPoint/FreeXP v3.40 RC5 @ 1611051002 R/C24108                  }
{ CrossPoint/FreeXP v3.45 alpha 1 (XMS) @ 1311051115 Kom-R/C14099    }
{                                                                    }
{ CrossPoint/TrueXP v3.40 RC3 (EMS) @ 0501052204 R/C9933             }
{                                                                    }
{ CrossPoint v3.30.016 Beta DOS/16 R/C2547 (www.xp2.de)              }
{ CrossPoint [XP2] v3.30.019.kan Beta DOS/16                         }
{ CrossPoint [XP2] v3.30.020 Beta DOS/16 R/B12524                    }
{ CrossPoint [XP2] v3.30.xmas Beta DOS/16                            }
{ CrossPoint [XP2] v3.30.pre6 DOS/16 R/C3899                         }
{ CrossPoint [XP2] v3.30.pre7 DOS/16 Kom-R/C14099                    }
{ CrossPoint [XP2] v3.31.001 Beta DOS/16 R/A2062                     }
{ CrossPoint [XP2] v3.31.006 Beta DOS/16                             }
{ CrossPoint [XP2] v3.31.006 Beta DOS/16 Kom-R/C14099                }
{ CrossPoint [XP2]/UKAW (www.gohel.de) R/C17726                      }
{                                                                    }
{ ------------------------------------------------------------------ }
{                                                                    }
{ Der erzeugte "User-Agent:"-Header hat folgendes einheitliche       }
{ Format (wegen der Zeilenl nge gefolded):                           }
{                                                                    }
{   User-Agent: FreeXP (CrossPoint)/3.40-RC3 ("Halloween")           }
{    (R/C816; DOS16/Win9x [XMS]; 3007030004)                         }
{                                                                    }
{ Im Originalheader nicht existierende Angaben werden weggelassen,   }
{ lediglich die Compiler-Plattform wird bei bestimmten Versionen     }
{ fest definiert (Details siehe Source).                             }
{                                                                    }
{ ------------------------------------------------------------------ }

function UserAgent(var xp:string):boolean;
var   ua,xt,nick : string;      { xt = Arbeitskopie von xp, ua = UA-Header }
      os         : string[8];   { Compiler-Plattform }
      ovr        : string[3];   { 'EMS/XMS' (FreeXP) }
	  bitti      : string[3];   { 'x86/x64' (FreeXP) }
      c          : char;
      p1,p2,p3,len,
      firstpos   : byte;
      hasVer,
      hasBracket,
      hasOS      : boolean;
const cOS_DOS16     = 'DOS16';        { Compiler-Plattform DOS/16 }
      { ------ Suchstrings ------ }
      openxp16      = 'openxp16';
      openxp        = 'openxp';
      truexp        = 'truexp';
      xp2_web       = ' (www.'+xp_2+'.de)';
      alpha         = 'alpha';
      beta          = 'beta';
      pre           = 'pre';
      rc            = 'rc';
      ver           = ' v';
      reg           = 'R/';           { nicht ' R/' wegen 'Kom-' und 'Org-' }
      ems           = ' (EMS)';
      xms           = ' (XMS)';
      dbx_edi       = ' dosbox-edition';
      cOS_DOS16_xp2 = ' DOS/16';
      cOS_DOS32_xp2 = ' DOS/32';
      cOS_DOSXL_xp2 = ' DOS/XL';
      cOS_W32_xp2   = ' W32';
      cOS_OS2_xp2   = ' OS/2';
      cOS_LNX_xp2   = ' Linux';

  procedure GetNick(const freexp:boolean);
  begin
    nick:='';
    p2:=firstpos;
    repeat
      p1:=posn(iifs(freexp,'(','("'),xt,p2);
      if p1>length(xt)-iif(freexp,2,4) then  { kann nur ein Leerstring sein }
        p1:=0
      else if p1>0 then
      begin
        p2:=posn(iifs(freexp,')','")'),xt,p1+iif(freexp,1,2));
        if p2>0 then
        begin
          nick:=trim(copy(xt,p1+iif(freexp,1,2),(p2-p1)-iif(freexp,1,2)));
          if freexp then
          begin
            if firstchar(nick)='"' then delfirst(nick);
            if lastchar(nick)='"' then dellast(nick);
          end;
          if nick='' then
          begin
            if p2>length(xt)-iif(freexp,3,6) then
              p1:=0
            else
              inc(p2,iif(freexp,1,2));                { Schleife fortsetzen }
          end
          else nick:=' ("'+nick+'")';
        end
        else p1:=0;                   { keine schlie ende Klammer vorhanden }
      end;
    until (p1=0) or (nick<>'');
  end;

  procedure MakeReceived;
  begin
    xp_received:=xp;
    RFC2822_Remove(xp_received,4);
    repeat
      p1:=cpos(' ',xp_received);
      if p1>0 then delete(xp_received,p1,1);
    until p1=0;
  end;

begin
  xt:=xp;
  if pos(' ('+xp_name+')',xt)>2 then          { bei uz/zu-Konvertierung von }
  begin                                       { dieser Routine erzeugten    }
    MakeReceived;                             { Header nicht anfassen, aber }
    UserAgent:=true;                          { unbedingt Kurzform f r      }
    exit;                                     { "Received:" erzeugen        }
  end;
  UserAgent:=false;
  if noUAgent or                 { Im Gatemode "User-Agent:" nicht erzeugen }
     (add_gate<>'') then         { (wir m  ten sonst die Syntax pr fen und  }
    exit;                        { w rden au erdem das Original ver ndern)  }
  c:=#0;
  if pos(lstr(xp_name)+'/',lstr(xt))=1 then              { 'CrossPoint/...' }
    c:='/'
  else if pos(lstr(xp_name)+' [',lstr(xt))=1 then      { 'CrossPoint [...]' }
    c:='['
  else if (pos(lstr(xp_name)+' ',lstr(xt))=1) and      { '... (www.xp2.de)' }
          (right(lstr(xt),length(xp2_web))=xp2_web) then
    c:='(';
  if c<>#0 then
  begin
    hasVer:=false; hasBracket:=false; hasOS:=false;
    {                                                                       }
    { ----------------- "Produktname" ermitteln/schreiben ----------------- }
    {                                                                       }
    if c='(' then
    begin
      ua:=ustr(xp_2);
      firstpos:=11;
    end
    else begin
      p1:=cpos(c,xt);
      p2:=p1+1;
      if c='[' then while (p2<length(xt)) and (xt[p2+1]<>']') do
        inc(p2)
      else while (p2<length(xt)) and (xt[p2+1]<>' ') do
        inc(p2);
      if (p2>0) and (p2-p1>2) then
        ua:=copy(xt,p1+1,p2-p1)
      else exit;
      firstpos:=iif(c='/',12,14)+length(ua);
      p1:=cpos('/',ua);                     { Slash entfernen ('OpenXP/16') }
      if p1>0 then
      begin
        delete(ua,p1,1);
        p1:=0;
      end;
      if (lstr(ua)<>'ukaw') and (lstr(ua)<>'agent') then
        while p1<length(ua) do             { auf unzul ssige Zeichen pr fen }
        begin
          if (cpos(ua[p1+1],tspecials2)>0) or
             (ua[p1+1] in [#0..#31,#127..#255]) then
            exit;
          inc(p1);
        end
        else exit;                              { 'UKAW' oder 'Agent' (XP2) }
    end;
    ua:=ua+' ('+xp_name+')';                 { jetzt: 'FreeXP (CrossPoint)' }
    {                                                                       }
    { ----------------- 'EMS/XMS' finden/merken/entfernen ----------------- }
    {           (damit sie beim Finden des Rufnamens nicht st ren)          }
    {                                                                       }
    ovr:='';
    repeat
      p1:=posn(ems,xt,firstpos);
      if p1>0 then
      begin
        ovr:=copy(ems,3,3);
        delete(xt,p1,length(ems));
      end;
    until p1=0;
    len:=length(xms);
    repeat
      p1:=posn(xms,xt,firstpos);
      if p1>0 then
      begin
        ovr:=copy(xms,3,3);
        delete(xt,p1,length(xms));
      end;
    until p1=0;
	
	repeat
      p3:=posn('x86',xt,firstpos);
      if p3>0 then
      begin
        bitti:='x86';
        delete(xt,p1,length('x86'));
      end;
    until p1=0;
	
	repeat
      p3:=posn('x64',xt,firstpos);
      if p3>0 then
      begin
        bitti:='x64';
        delete(xt,p1,length('x64'));
      end;
    until p1=0;
    {                                                                       }
    { ----- "Rufnamen" finden/zwischenlagern und Kommentare entfernen ----- }
    {           (wegen '(www.xp2.de)' und '(www.gohel.de)' in XP2           }
    {           bei Versionen <> FreeXP nur nach '("...")' suchen)          }
    {                                                                       }
    { -------- 'OpenXP/16-mw' existiert, daher bei allen Pr fungen -------- }
    {         auf Produktnamen nicht auf trailing blanks pr fen :-(         }
    {                                                                       }
    GetNick(false);
    if (nick='') and
       ((lstr(left(ua,length(xp_display)))=lstr(xp_display)) or
        (lstr(left(ua,length(truexp)))=truexp)) then
    begin
      GetNick(true);
      if nick='' then
      begin
        p1:=posn(dbx_edi,lstr(xt),firstpos);            { FreeXP-Sonderfall }
        if p1>0 then
          nick:=' ("'+trim(copy(xt,p1,length(dbx_edi)))+'")';
      end;
    end;
    RFC2822_Remove(xt,4);    { Kommentare entfernen / Multi-WSPs reduzieren }
    {                                                                       }
    { --------------- Versionsnummer "v3.x" finden/anh ngen --------------- }
    {                                                                       }
    len:=length(ver);
    p2:=firstpos;
    repeat
      p1:=posn(ver,lstr(xt),p2);
      if p1>length(xt)-(len+2) then    { kann keine Versionsnr. 'v3.x' sein }
        p1:=0
      else if p1>0 then
      begin
        p2:=posn('.',xt,p1+2);
        if p2>0 then
        begin
          if (p1+len+2>=p2) and (xt[p1+len] in ['0'..'9']) and
             (p2<length(xt)) and (xt[p2+1] in ['0'..'9']) and
             (xt[p2-1] in ['0'..'9']) then  { zweistellige Versionsnummer?! }
          begin
            inc(p2);                     { 'v3.40myRC3@0601021904' zerlegen }
            while (p2<length(xt)) and not
                  (xt[p2+1] in [' ','@']) and not
                  (((lstr(copy(xt,p2+1,5))=alpha) or
                    (lstr(copy(xt,p2+1,4))=beta) or
                    (lstr(copy(xt,p2+1,3))=pre) or
                    ((lstr(copy(xt,p2+1,2))=rc) and
                     (firstchar(trim(mid(xt,p2+3))) in ['0'..'9']))) and
                   (xt[p2]<>'.')) do
              inc(p2);
            ua:=ua+'/'+copy(xt,p1+2,(p2-p1)-1);
            hasVer:=true;
          end
          else if p1<length(xt)-(len+4) then
            p2:=p1+len                    { Schleife hinter p1+1 fortsetzen }
          else
            p1:=0;            { keine Versionsnr. und weitere Suche sinnlos }
        end
        else p1:=0;            { keinen '.' gefunden, weitere Suche sinnlos }
      end;
    until (p1=0) or hasVer;
    {                                                                       }
    { ------- "Alpha..", "Beta..", "Pre" oder "RC.." finden/anh ngen ------ }
    { (bei XP2 geh rt 'pre' immer zur Versionsnummer, ansonsten gibt es nur }
    { eine OpenXP/16-Version von MW, die den Zusatz " Pre" tr gt)           }
    {                                                                       }
    len:=length(rc);
    if (p1=firstpos) and hasVer then
      firstpos:=p2+1                            { neue Startposition setzen }
    else if hasVer then
      inc(p2)                             { hinter Versionsnr. weitersuchen }
    else
      p2:=firstpos;
    p1:=posn(beta,lstr(xt),p2);
    if p1>0 then
      p2:=p1+(length(beta)-1)
    else begin
      p1:=posn(alpha,lstr(xt),p2);
      if p1>0 then
        p2:=p1+(length(alpha)-1)
      else begin
        p1:=posn(pre,lstr(xt),p2);
        if p1>0 then
          p2:=p1+(length(pre)-1)
        else repeat
          p1:=posn(rc,lstr(xt),p2);
          if p1>length(xt)-len then                    { 'RC' am Stringende }
            p1:=0
          else if p1>0 then
          begin
            if firstchar(trim(mid(xt,p1+len))) in ['0'..'9'] then
            begin
              p2:=p1+(len-1);
              break;                        { 'RCn ' gefunden, rausspringen }
            end
            else if p1<length(xt)-(len+1) then
              p2:=p1+len                  { Schleife hinter p1+1 fortsetzen }
            else
              p1:=0;           { 'RC' ohne Ziffer und weitere Suche sinnlos }
          end;
        until p1=0;
      end;
    end;
    if p1>0 then                                        { alpha/beta/pre/RC }
    begin
      if p1<=firstpos+1 then
      begin
        firstpos:=p2+1;                         { neue Startposition setzen }
        c:='f';                           { Hilfsflag f r Update 'firstpos' }
      end;
      ua:=ua+iifs(hasVer,'-','/')+                { jetzt: 'FreeXP/3.40-RC' }
          copy(xt,p1,(p2-p1)+1);
      if firstchar(trim(mid(xt,p2+1))) in ['0'..'9'] then
      begin                                    { 'alpha 1' existiert, grmpf }
        p1:=p2;
        inc(p2);
        while (p2<length(xt)) and not (xt[p2+1] in [' ','@']) do
          inc(p2);
        ua:=ua+copy(xt,p1+1,p2-p1);              { jetzt: 'FreeXP/3.40-RC3' }
        p1:=posn(' ',ua,length(ua)-(p2-p1));
        if p1>0 then delete(ua,p1,1);  { m glichen Blank entfernen ('RC 3') }
        if c='f' then firstpos:=p2+1;                  { 'firstpos' updaten }
      end;
    end;
    {                                                                       }
    { ------------- ab hier immer auf max. L nge (254) testen! ------------ }
    {                                                                       }
    {                                                                       }
    { ------------------------ "Rufnamen" anh ngen ------------------------ }
    {                                                                       }
    if nick<>'' then
    begin
      if length(ua)+length(nick)<255 then
        ua:=ua+nick
      else
        exit;
    end;
    {                                                                       }
    { ----------- Registrierungsvermerk "R/nnn" finden/anh ngen ----------- }
    {                                                                       }
    len:=length(reg);
    p2:=firstpos;
    repeat
      p1:=posn(reg,xt,p2);
      if p1>length(xt)-(len+1) then     { kann kein g ltiger R-Eintrag sein }
        p1:=0
      else if p1>0 then
      begin
        if (((xt[p1+len] in ['A'..'C']) and
             (xt[p1+len+1] in ['0'..'9'])) or
            (copy(xt,p1+len,4)='Free')) and
           (xt[p1-1] in [' ','-']) then     { '-' wegen 'Kom-R/' + 'Org-R/' }
        begin
          p2:=p1+len+1;
          while (p1>0) and (xt[p1-1]<>' ') do
            dec(p1);
          while (p2<length(xt)) and                      { wegen 'R/Free' & }
                (xt[p2+1] in ['0'..'9','F','r','e']) do  { 'R/C816- CS R'   }
            inc(p2);
          if length(ua)+(p2-p1)+3<255 then
          begin
            ua:=ua+' ('+copy(xt,p1,(p2-p1)+1);
            hasBracket:=true;
          end
          else exit;
        end
        else if p1<length(xt)-(len+3) then
          p2:=p1+len                      { Schleife hinter p1+2 fortsetzen }
        else
          p1:=0;    { 'R/' ohne zul ssige Zeichen und weitere Suche sinnlos }
      end;
    until (p1=0) or hasBracket;
    {                                                                       }
    { -------------------- OS-Informationen schreiben --------------------- }
    {                                                                       }
    if not paranoia then
    begin
      os:='';
    {                                                                       }
    { ---------------- Compiler-Plattform finden (nur XP2) ---------------- }
    {                                                                       }
      if lstr(left(ua,length(xp_2)))=xp_2 then
      begin
        p1:=posn(cOS_DOS16_xp2,xt,firstpos);
        if p1>0 then
          p2:=p1+(length(cOS_DOS16_xp2)-1)
        else begin
          p1:=posn(cOS_DOS32_xp2,xt,firstpos);
          if p1>0 then
            p2:=p1+(length(cOS_DOS32_xp2)-1)
          else begin
            p1:=posn(cOS_DOSXL_xp2,xt,firstpos);
            if p1>0 then
              p2:=p1+(length(cOS_DOSXL_xp2)-1)
            else begin
              p1:=posn(cOS_W32_xp2,xt,firstpos);
              if p1>0 then
                p2:=p1+(length(cOS_W32_xp2)-1)
              else begin
                p1:=posn(cOS_OS2_xp2,xt,firstpos);
                if p1>0 then
                  p2:=p1+(length(cOS_OS2_xp2)-1)
                else begin
                  p1:=posn(cOS_LNX_xp2,xt,firstpos);
                  if p1>0 then
                    p2:=p1+(length(cOS_LNX_xp2)-1);
                end;
              end;
            end;
          end;
        end;
        if p1>0 then
        begin
          os:=copy(xt,p1+1,p2-p1);
          if length(ua)+(p2-p1)+iif(cpos('/',os)>0,1,2)<255 then
          begin
            ua:=ua+iifs(hasBracket,'; ',' (')+os;
            hasBracket:=true;
            hasOS:=true;
          end
          else exit;
          p2:=length(ua)-((p2-p1)-1);
          p1:=posn('/',ua,p2);
          if p1>0 then delete(ua,p1,1);                   { Slash entfernen }
        end;
      end
    {                                                                       }
    { -------- Compiler-Plattform f r bekannte Versionen definieren ------- }
    {                                                                       }
      else if (lstr(left(ua,length(xp_display)))=lstr(xp_display)) or
              (lstr(left(ua,length(truexp)))=truexp) or
              (lstr(left(ua,length(openxp16)))=openxp16) or
              ((lstr(left(ua,length(openxp)))=openxp) and
               hasVer and (copy(ua,cpos('/',ua),3)='/3.') and
               (ua[cpos('/',ua)+3] in ['2'..'4'])) then
      begin
        os:=cOS_DOS16;
        if length(ua)+length(cOS_DOS16)+2<255 then
        begin
          ua:=ua+iifs(hasBracket,'; ',' (')+os;
          hasBracket:=true;
          hasOS:=true;
        end;                { hier bei zu gro er L nge nicht rausspringen!  }
      end;                  { (weil nicht Bestandteil des Original-Headers) }
    {                                                                       }
    { ---------------------- OS-Plattform schreiben ----------------------- }
    {                                                                       }
      if OSfamily then RunOS:=FRunOS;
      if (RunOS<>'') and not (hasOS and (lstr(left(ua,length(xp_2)))=xp_2) and
                            { ((right(ua,length(trim(cOS_OS2_xp2)))=trim(cOS_OS2_xp2)) or }
                               (right(ua,length(trim(cOS_LNX_xp2)))=trim(cOS_LNX_xp2))) {)} then
      begin
        if length(ua)+length(RunOS)+iif(hasOS,1,2)<255 then
        begin
          ua:=ua+iifs(hasOS,'/',iifs(hasBracket,'; ',' ('))+RunOS;
          hasOS:=true;
          hasBracket:=true;
        end;                { hier bei zu gro er L nge nicht rausspringen!  }
      end;                  { (weil nicht Bestandteil des Original-Headers) }
    {                                                                       }
    { ------------------------- 'EMS/XMS' anh ngen ------------------------ }
    {                                                                       }
      if ovr<>'' then
      begin
        if length(ua)+length(ovr)+iif(hasOS,3,iif(hasBracket,4,2))<255 then
        begin
          ua:=ua+iifs(hasOS,' [',iifs(hasBracket,'; [',' ('))+ovr+','+bitti+
				 iifs(hasOS or hasBracket,']','');
          hasBracket:=true;
        end
        else exit;
      end;
    end;   { not paranoia }
    {                                                                       }
    { ------------------------ Compile-Datum finden ----------------------- }
    {                                                                       }
    p2:=firstpos;
    repeat
      p1:=posn('@',xt,p2);
      if p1>length(xt)-8 then             { kann kein plausibles Datum sein }
        p1:=0
      else if p1>0 then
      begin
        while (p1<length(xt)) and (xt[p1+1]=' ') do
          inc(p1);
        if (p1<length(xt)) and (xt[p1+1] in ['0'..'9']) then
        begin
          p2:=p1+1;
          while (p2<length(xt)) and (xt[p2+1] in ['0'..'9']) do
            inc(p2);
          if p2-p1>7 then                       { halbwegs plausibles Datum }
          begin
            if length(ua)+(p2-p1)+2<255 then
            begin
              ua:=ua+iifs(hasBracket,'; ',' (')+copy(xt,p1+1,p2-p1);
              hasBracket:=true;
              break;                         { Datum gefunden, rausspringen }
            end
            else exit;
          end
          else if p2<length(xt)-8 then      { Schleife hinter p2 fortsetzen }
            inc(p2)
          else
            p1:=0;        { kein plausibles Datum und weitere Suche sinnlos }
        end
        else if p1<length(xt)-8 then        { Schleife hinter p1 fortsetzen }
          p2:=p1+1
        else
          p1:=0;          { kein plausibles Datum und weitere Suche sinnlos }
      end;
    until p1=0;
    {                                                                       }
    { -------------------------------- Ende ------------------------------- }
    {                                                                       }
    if hasBracket then
      if (length(ua)<254) then
        ua:=ua+')'
      else exit;
    xp:=ua;
    MakeReceived;                       { Kurzform f r "Received:" erzeugen }
    UserAgent:=true;
  end;
end;

end.
