{ ------------------------------------------------------------------- }
{ Dieser Quelltext ist urheberrechtlich geschuetzt.                   }
{ (c) 1991-1999 Peter Mandrella                                       }
{ (c) 2000-2001 OpenXP-Team                                           }
{ (c) 2002-2024 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 }
{ ------------------------------------------------------------------- }

{ Fido-Modul, Teil 2        }

{$I XPDEFINE.INC       }
{$IFDEF BP        }
  {$O+,F+       }
{$ENDIF        }

unit xpf2;

interface

uses xpglobal, crt, dos,typeform,fileio,archive,montage,
     xp0,xp1,xp1o,xp3,xp3o, lfn;


procedure TestTICfiles(var logfile:string);   { TIC-Files verarbeiten        }


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

uses xpnt,xp3o2,xpovl,xpdatum;

{ TIC-Files verarbeiten; BoxPar^ muá korrekt geladen sein!        }

procedure TestTICfiles(var logfile:string);
Type
  TIC_Rec  =Record
    tstr   :String;
    tnext  :Pointer;
  End;

Var
  TIC_Ptr  :Pointer;
  TIC_Size :Longint;
  mchk     :LongInt;
  t        :Text;
  s        :String[80];
  at       :ShortInt;
  ar       :ArchRec;
  sr       :SearchRec;
  f        :File;
  tmp      :PathStr;
  count    :Longint;
  name1    :String[14];


  Function UNIX2Zdate(secs:longint):string;
  Const tage : Array[1..12] of byte = (31,28,31,30,31,30,31,31,30,31,30,31);
        tagsec = 86400;  { 24*60*60        }
  Var y,m,d,dow : Word;
      h,min   : Word;

    Procedure setfeb(y:word);
    Begin
      If schaltj(y) Then tage[2]:=29 Else tage[2]:=28;
    End;

  Begin
    y:=1970;
    While secs>=iif(schaltj(y),366,365)*tagsec Do
    Begin
      dec(secs,iif(schaltj(y),366,365)*tagsec);
      inc(y);
    End;
    setfeb(y); m:=1;
    While (secs>=tagsec*tage[m]) Do
    Begin
      dec(secs,tagsec*tage[m]);
      inc(m);
    End;
    d:=secs Div tagsec+1;
    secs:=secs Mod tagsec;
    h:=secs Div 3600;
    secs:=secs Mod 3600;
    min:=secs Div 60;
    secs:=secs Mod 60;
    UNIX2Zdate:=formi(y Mod 100,2)+formi(m,2)+formi(d,2)+formi(h,2)+formi(min,2);
  End;


  Function IsTIC(name:pathstr):boolean;
  Begin
    UpString(name);
    IsTIC:=(right(name,4)='.TIC');
  End;

  { True -> passende Datei ist vorhanden        }


  Function CopyTIC(write:boolean):boolean;
  var
    dg  : Longint;
    tp1 : ^TIC_Rec;
  Begin
    dg:=0;
    While TIC_Ptr <> Nil Do
    Begin
      tp1:=TIC_Ptr;
      if write then
        BlockWrite(f,tp1^.tstr[1],Length(tp1^.tstr));
      dg:=dg+Length(tp1^.tstr);
      TIC_Ptr:=tp1^.tnext;
      FreeMem(tp1,Sizeof(TIC_Rec));
    End;
    CopyTIC:=dg=TIC_Size;
  End;


  Function ProcessTICFile(fn:pathstr):boolean;
  var t2         :Text;
      hdp        :headerp;
      s1,s2      :String;
      feld       :String[20];
      p          :Byte;
      od         :String[12];
      ld         :Longint;
      ok         :boolean;

    Procedure StoreTIC(ts:String);
    var
    tp1,tp2  :^TIC_Rec;
    Begin
      If MaxAvail > Sizeof(TIC_Rec) Then
      Begin
        GetMem(tp1,Sizeof(TIC_Rec));
        tp1^.tnext:=Nil;
        If Length(ts) < 253 Then
          ts:=ts+#13+#10
        Else
          ts:=Copy(ts,1,253)+#13+#10;
        tp1^.tstr:=ts;
        TIC_Size:=TIC_Size+Length(ts);
        If TIC_Ptr = Nil Then
        Begin
          TIC_Ptr:=tp1;
        End
        Else Begin
          tp2:=TIC_Ptr;
          While tp2^.tnext <> Nil Do tp2:=tp2^.tnext;
          tp2^.tnext:=tp1;
        End;
      End
      Else trfehler(402,30);  { 'zu wenig freier Arbeitsspeicher'        }
    End;

  Begin  { of ProcessTICFile        }
    mchk:=MemAvail;
    ProcessTICfile:=false;
    New(hdp);
    Fillchar(hdp^,sizeof(hdp^),0);
    Assign(t2,fn);
    Reset(t2);
    TIC_Ptr:=Nil;
    TIC_Size:=0;
    While not eof(t2) Do
    Begin
      Readln(t2,s1);                                   { s1 = gesamte Zeile        }
      p:=blankpos(s1);
      If p > 0 Then With hdp^,boxpar^ Do
      Begin
        feld:=lstr(left(s1,p-1));                      { feld = Bezeichner         }
        s2:=trim(mid(s1,p));                           { s2 = Feldinhalt           }
        If feld='area' Then
        Begin
          empfaenger:=MagicBrett+'FILES/'+s2;
          StoreTIC(s1);
          Continue;
        End;
        If feld='origin' Then
        Begin
          absender:='FileScan@'+s2;
          Continue;
        End;
        If feld='file' Then
        Begin
          betreff:=FExpand(GetFileDir(fn)+s2);
          StoreTIC(s1);
          Continue;
        End;
        If feld='desc' Then
        Begin
        { If summary = '' Then summary:=s2 Else keywords:=s2;        }
          StoreTIC(s1);
          Continue;
        End;
        If feld='ldesc' Then
        Begin
          StoreTIC(s1);
        { If summary = '' Then summary:=s2;        }
          Continue;
        End;
        If (feld = 'path') and (blankpos(s2) > 0) Then
        Begin
          pfad:=left(s2,blankpos(s2)-1)+'!'+pfad;
          Continue;
        End;
        If feld = 'date' Then
        Begin
          ld:=(-1);
          s2:=LStr(s2);
          If cpos('a',s2)+cpos('b',s2)+cpos('c',s2)+cpos('d',s2)+
             cpos('e',s2)+cpos('f',s2) > 0 Then
            ld:=hexval(s2)
          Else
            ld:=ival(s2);
          If ld > 0 Then
          Begin
            datum:=UNIX2ZDate(ld);
            s2:=fdat(datum)+' '+ftime(datum);
            StoreTIC('Date '+s2);
          End
            Else StoreTIC(s1);
          Continue;
        End;
      End;
    End;
    Close(t2);
    With hdp^ Do
    Begin
      dellastHuge(pfad);
      If (empfaenger <> '') And (betreff <> '') And exist(betreff) Then
      Begin
        netztyp:=nt_Fido;
        inc(attrib,AttrFile);
        If absender = '' then absender:='???';
        If pfad = '' then pfad:=boxpar^.boxname;
        datum:=zdate;
        inc(count);
        msgid:=datum+'.'+strs(count)+'.Tick@'+boxpar^.boxname;
      { fido_to:=summary;        }
        groesse:=TIC_Size;
        WriteHeader(hdp^,f,nil);
        ok:=CopyTIC(true);      { Body schreiben und Speicher freigeben        }
        ProcessTICfile:=ok;
      End
      else ok:=CopyTIC(false);  { nur Speicher freigeben!        }
    End;
    Dispose(hdp);
    If (mchk<>MemAvail) or not ok Then
      trfehler(2807,30);  { 'Speicherverwaltung zerst”rt'        }
  End;

Begin  { of TestTICFiles        }
  Assign(t,logfile);
  Reset(t);
  tmp:=TempS(16384);
  assign(f,tmp);         { Ausgabepuffer        }
  rewrite(f,1);
  count:=0;
  While Not eof(t) Do              { gepackte TIC-Files auswerten        }
  Begin
    Readln(t,s);
    If (s[1] = '*') And (pos('  rcvd ',lstr(s)) > 0) Then
    Begin
      s:=trim(mid(s,18));
      s:=left(s,cpos(';',s)-1);  { Pfad\Dateiname isolieren        }
      UpString(s);
      If (hexval(left(getfilename(s),8)) <> 0) or (left(getfilename(s),4) = 'TO__')
        Then Begin   { m”gliches TIC-Paket?        }
        at:=ArcType(s);
        If at <> 0 Then
        Begin
          OpenArchive(s,at,ar);
          While Not ar.ende And Not IsTIC(ar.name) Do ArcNext(ar);
          name1:=ar.name;
          CloseArchive(ar);
          If Not ar.ende Then           { .TIC-Files enthalten        }
          Begin
            If Not IsPath(FilePath+'TICK') Then
            Begin
              mkdir(FilePath+'TICK');
              If IOResult <> 0 Then
              Begin
                rfehler1(2123,FExpand(FilePath+'TICK'));   { 'Kann Verzeichnis %s nicht anlegen!'        }
                {goto ende;       }
                Break;
              End;
            End;
            If UniExtract(s,FilePath+'TICK\','*.*') And
               exist(FilePath+'TICK\'+name1) Then
            Begin
              _era(s);
              FindFirst(FilePath+'TICK\*.TIC',ffAnyFile,sr);
              While DOSError = 0 Do   { .TIC-Files verarbeiten        }
              Begin
                If ProcessTICfile(FilePath+'TICK\'+sr.name) Then
                  _era(FilePath+'TICK\'+sr.name)
                Else If not _rename(FilePath+'TICK\'+sr.name,FilePath+sr.name) Then
                  _era(FilePath+'TICK\'+sr.name);
                findnext(sr);
              End;
              Findclose(sr);
            End;
          End;   { of TIC-File vorhanden        }
        End;   { at>0        }
      End;
    End;   { rcvd        }
  End;
  Close(t);

  Findfirst(FilePath+'*.TIC',ffAnyFile,sr);    { ungepackte TIC-Files        }
  While doserror=0 Do
  Begin
    if ProcessTICfile(FilePath+sr.name) then
      _era(FilePath+sr.name);
    findnext(sr);
  End;
  Findclose(sr);

  Close(f);
  If _filesize(tmp) > 0 Then
    PufferEinlesen(tmp,BoxPar^.boxname,true,true,false,false,0);
  _era(tmp);
End;

End.
