PC Online 1996 October/PCO_10.ISO/filesbbs/xphy2201.arj/XPHYDRA.PAS

Pascal/Delphi Source File | 1996-08-28 | 10.3 KB | 447 lines

{ Version 2.201, letzte Änderung am 6.08.96 }

{$A+,B-,D-,E-,F-,G+,I+,L+,N-,O-,R-,S-,V-,X+}
{$M 16384,0,0}

program xphydra;

uses
  dos, crt, xphytool, utimestr, ulog, extract;

const
  hauptversion = '2';
  unterversion = '201';
  alphastatus = ' BETA';
  releasedate = '6.08.96';
  version = hauptversion+'.'+unterversion+alphastatus;
{  line    : word=14400;}
  hydpath : pathstr='hydracom.exe';
  ports   : array[1..4] of string[3]=('3F8','2F8','3E8','2E8');
  mailext : array[1..7] of string[2]=('MO','TU','WE','TH','FR','SA','SU');
  prgpath : pathstr='\';
  logpath : pathstr='\';

var
  lastioresult:integer;

type
  tprogram = object

             screen    : array[1..25,1..80] of word;
             vseg      : word;
             sending   : boolean;
             reqfile   : string[12];
             hydraparams : string[128];
             parpath   : string[12];
             spoolpath : pathstr;
             filespath : pathstr;
             exitcode  : word;
             hydraexitcode: word;

             procedure init;
             procedure run;
             procedure done;

             procedure savescreen;
             procedure restorescreen;
             procedure convertparameters;
             procedure convertparfile;
             procedure convertlogfile;
             procedure endemeldung;

            end;


procedure tprogram.init;

begin
  if (paramcount=0) or (pos('?',paramstr(1))>0) then
  begin
    writeln;
    writeln('XPHydra v'+version+', released '+releasedate+', Copyright '+#39+'95,96 by Jonas v. Poser');
    writeln('XPHydra was designed by Jonas v. Poser, Matthias Eube and Andreas Mutter');
    writeln;
    halt;
  end;
  savescreen;
  window(1,4,80,22);
  clrscr;
  if not exist(hydpath) then hydpath:=back(getenv('xphydra'))+'hydracom.exe';
  prgpath:=getprgpath;
  logpath:=getlogpath('LOGDIR','xpoint.cfg');
  slogfile:=logpath+'xphydra.log';
  sprompt:='[XPHydra] ';
  log('Path to XPHydra version '+version+': '+prgpath);
  writeln('Logfile:'+slogfile);
  convertparameters;
  convertparfile;
  if sending then hydraparams:=hydraparams+' rec hydtemp\ sen '+reqfile
             else hydraparams:=hydraparams+' rec hydtemp\ sen @xphydra.par';
  if sending then log('Starting mailer session batch #1')
             else log('Starting mailer session batch #2');
end;


procedure tprogram.run;

begin
  {$I-}
  if sending and (not exist('HYDTEMP')) then mkdir('HYDTEMP');
  lastioresult:=ioresult; {Die möglich Iofehler zurückzusetzen}
  {$I+}
  if not exist(hydpath) then
    begin
      log('Error: '+hydpath+' not found.');
      exitcode:=13;
      endemeldung;
      halt(exitcode);
    end;
  clrscr;
  writeln;
  log('Executing: '+hydpath+' '+hydraparams);
  swapvectors;
  exec(hydpath,hydraparams);
  hydraexitcode:=dosexitcode;
  swapvectors;
  log('Errorlevel: '+ fstr(hydraexitcode));
end;


procedure tprogram.done;

var
  i:BYTE;
  f:FILE;


procedure movefiles(mask,pathfro,pathto:string;attr:word);

const
  recoveryname='BAD-XFER';

label
  next;

var
  s   : searchrec;
  f   : file;
  test: string;

begin
  findfirst(pathfro+mask,attr,s);
  while doserror=0 do
  begin
    if pos(recoveryname,s.name)<>0 then goto next;
    if exist(pathto+s.name) then
    begin
      assign(f,pathto+s.name);
      test:=s.name;
      test[length(s.name)]:='1';
      while exist(pathto+test) do
      begin
        test[length(s.name)]:=chr(ord(test[length(s.name)])+1);
        if test[length(s.name)] = #58 then test[length(s.name)]:='A';
        if test[length(s.name)] > #90 then halt(99);
      end;
      rename(f,pathto+test);
    end;
  assign(f,pathfro+s.name);
  rename(f,pathto+s.name);
  next:
  findnext(s);
  end;
end;  { of movefiles}

begin
  convertlogfile;
  if not sending then
  begin
    for i:=1 to 7 do
    movefiles('*.'+mailext[i]+'?','HYDTEMP\',spoolpath,anyfile);
    movefiles('*.PKT','HYDTEMP\',spoolpath,anyFile);
    movefiles('*.*','HYDTEMP\',filespath, anyfile and not (directory or volumeid) );
    {$I-}
    rmdir('HydTemp');
    {$I+}
    lastioresult:=ioresult; {Und weg mit eventuellen Fehlermelungen}
    assign(f,'xphydra.par');
    erase(f);
  end;
  case hydraexitcode of
     0   : exitcode:=0;
     1   : exitcode:=1;
     255 : exitcode:=1;
  end;
  if exitcode <> 0 then
  begin
    endemeldung;
    halt(exitcode);
  end;
  endemeldung;
end; { of tprogram.done}


procedure tprogram.savescreen;

var
  bios:word absolute $0040:$0063;

begin
  if bios=$3B4 then vseg:=$B000
               else vseg:=$B800;
  move(ptr(vseg,0)^,screen,25*80*2);
end;


procedure tprogram.restorescreen;

begin
  move(screen,ptr(vseg,0)^,25*80*2);
end;


procedure tprogram.convertparameters;

var
  i,o : byte;
  pa,s: pathstr;

function token(s:string;x:byte):string;

var
  i   : byte;
  tmp : string;

begin
  tmp:='';
  i:=x;
  while (s[i]<>' ') and (s[i]<>',') and (i<=Length(s)) do
  begin
    tmp:=tmp+s[i];
    inc(i);
  end;
  token:=tmp;
end; { of token }


begin
  hydraparams:='res xph~temp.log han hard';
  for o:=1 to paramcount do
  begin
    pa:=paramstr(o);
    if pa[1]='-' then
      case pa[2] of
        'c': begin
               s:=token(pa,3);
               i:=1;
               if Length(s)>1
                   then while (i<5) and (s<>ports[i]) do inc(i)
                   else while (i<5) and (s<>fStr(i)) do inc(i);
               if i=5 then i:=2;
               hydraparams:=hydraparams+' por '+fstr(i);
             end;
        'k': begin
               s:=token(pa,3);
               hydraparams:=hydraparams+' lin '+s;
             end;
        'b': begin
               s:=token(pa,3);
               hydraparams:=hydraparams+' spe '+s;
             end;
        't': begin
             if pa[3] ='l' then
               begin
                 s:=token(pa,4);
                 hydraparams:=hydraparams+' fif '+s;
               end;
             end;
      end else
      case pa[1] of
        'r': sending:=false;
        's': sending:=true;
        '@': parpath:=token(pa,2);
      end; { of case }
  end; { of for slope }
end;


procedure tprogram.convertparfile;

var
  pt,ht : text;
  s     : string;

begin
  log('Converting parameter file: '+parpath);
  assign(pt,parpath);
  if not exist(parpath) then log('Error: '+parpath+' not found');
  reset(pt);
  if sending then
  begin
    assign(ht, 'xphydra.par');
    rewrite(ht);
    while not eof(pt) do
    begin
      readln(pt,s);
      if (pos('.REQ', s)>0) and (s[1]<>';') and
         (s[1]<>'-') and (pos('\',s)=0) then reqfile:=s
                                        else reqfile:='';
      if (s[1]<>';') and (s[1]<>'-') and ( (pos('.REQ',s)=0)) then
      begin
        if pos('\',s)=0 then s:=fexpand(s);
        writeln(ht,s);
      end else filespath:=s;
    end;
    close(ht);
    close(pt);
    end;

  if not sending then
  begin
    assign(pt,parpath);
    reset(pt);
    while not eof(pt) do
    begin
      readln(pt,s);
      if (s[1]<>';') and (s[1]<>'-') and ( pos('.REQ',s)=0 ) and
         (pos('\',s) > 0) then filespath:=s;
      if (pos('-fm:',s)>0) then
      spoolpath:=copy(s,5,length(s)-4);
      if (pos('-fmx:',s)>0) then
      spoolpath:=copy(s,6,length(s)-5);
    end;
    close(pt);
  end;
end;


procedure tprogram.convertlogfile;

var
  pLog,hLog,tLog:text;
  filename,s,ps,temp:string;
  bytes:longint;
  cps, error, secs: integer;


function part(s:string;x:byte):string;
var
  i,o,p: byte;
  t    : string;

begin
  i:=1;
  while s[i]=' ' do inc(i);
  for o:=1 to x-1 do
  begin
    while s[i]<>' ' do inc(i);
    while s[i]=' ' do inc(i);
  end;
  p:=i+1;
  if p>length(s) then
    t:='' else begin
                 while s[p]<>' ' do inc(p);
                 t:=copy(s,i,p-i);
               end;
  part:=t;
end;

begin
  log('Converting log files');
  assign(hlog,'xph~temp.log');
  if not exist('xph~temp.log') then log('Error: xph~temp.log not found');
  reset(hlog);
  assign(plog,'zmtemp.log');
  rewrite(plog);
  assign(tlog,'xptemp.log');
  if sending then
  begin
    rewrite(tlog);
    filespath:='■'; spoolpath:='·';
  end else reset(tLog);
  while not eof(hlog) do
  begin
    readln(hlog,s);
    ps:='';
    if s[1]='H' then ps:='Z ' else
    if s[1]='h' then ps:='z ' else
    if sending then ps:='e ' else ps:='E ';
    filename:=part(s,11);
    if ps[1]='Z' then
                    if copy(filename, Pos('.',filename)+1, 3)='PKT' then
                    filename:=spoolpath+filename
                 else begin
                        cps:=1;
                        while (cps<=7) and (copy(filename, pos('.', filename)+1, 2)<>mailext[cps]) do
                        inc(cps);
                        if cps>7 then filename:=filespath+filename
                                 else filename:=spoolpath+filename;
                      end;

    ps:=ps+Date+' '+Time+'  '+FileName+', ';

    temp:=Part(s,2);
    ps:=ps+temp+' bytes, ';
    Val(temp, bytes, error);

    temp:=Part(s,5);
    Val(temp, cps, error);
    IF (cps=9999) OR (cps=0) THEN
    BEGIN
        secs:=1;
        temp:='0';
    END ELSE secs:=bytes DIV cps;

    ps:=ps+FStr(secs)+' s, '+temp+' cps';
    temp:=Part(s,7);
    IF temp<>'0' THEN
      ps:=ps+', '+temp+' errors';
    IF (ps[1]='Z') AND sending THEN WriteLn(TLog,ps) ELSE WriteLn(PLog,ps);
  END;


  IF NOT sending THEN
    WHILE NOT Eof(TLog) DO
    BEGIN
      ReadLn(TLog,s);
      IF Pos('■',s)>0 THEN
      BEGIN
        Insert(FilesPath,s,Pos('■',s)+1);
        Delete(s, Pos('■',s), 1);
      END ELSE IF Pos('·',s)>0 THEN
      BEGIN
        Insert(SpoolPath,s,Pos('·',s)+1);
        Delete(s, Pos('·',s), 1);
      END;
      WriteLn(PLog,s);
    END;
  Close(HLog);
  Close(PLog);
  Close(TLog);
  Erase(Hlog);
  IF NOT sending THEN Erase(TLog);
END;


procedure tprogram.endemeldung;

const
  status: array[false..true] of string[1]=('2','1');

begin
  restorescreen;
  log('XPHydra '+version+' terminated. Errorlevel: '+fstr(exitcode));
  log('Mailer session batch #'+status[sending]+' terminated.');
  if not sending then log('');
end;


var
  prog:tprogram;

begin
  prog.init;
  prog.run;
  prog.done;
end.