FIDIZ - BBS listing generator from FILE_ID.DIZ contents

fidiz.pas

{
FIDIZ! The New Generation FILE_ID.DIZ extractor...

18th Feb 1997 - 19:44 - 2.00 olayi..
}

uses Objects,Dos,Crt;

type

 TArchiver=record
   Ext      : string[3];
   Cmd      : FNameStr;
   Params   : FnameStr;
   Counter  : longint;
   Ready    : boolean;
 end;

const

  cDIZAdded = LightBlue;

  fVersion = '2.00 alpha';

  maxunpackers = 4;
  unpackers : array[1..maxunpackers] of TArchiver =
  ((Ext:'ZIP';Cmd:'PKUNZIP.EXE' ;Params:'-o @1 @2 @3' ;Counter:0; Ready:false),
   (Ext:'ARJ';Cmd:'ARJ.EXE'     ;Params:'e -y @1 @3 @2'  ;Counter:0; Ready:false),
   (Ext:'LZH';Cmd:'LHA.EXE'     ;Params:'e @1 @3 @2'  ;Counter:0; Ready:false),
   (Ext:'RAR';Cmd:'RAR.EXE'     ;Params:'e -o+ @1 @2 @3'  ;Counter:0; Ready:false));
              {1=archive name, 2=filespec, 3=dest path}

  AttrMask = AnyFile and Not VolumeId;
  TmpDir             : string = '';
  listfile           : string = '';
  searchDrive        : string = '';

  searched           : longint = 0;
  found              : longint = 0;

  lwx                : boolean = false; {default WinCat}
  includepaths       : boolean = false; {default no path info}
  addall             : boolean = false;
  recurse            : boolean = true;
  append             : boolean = false;
  usingnonstdtempdir : boolean = false;

  stdtempdir         = 'C:\FIDIZ.TMP';

  Canceled           : boolean = false;

var

  timer : longint absolute $0:$46c;
  start : longint;
  Interpreter : string;

var

  Out : Text;

function Exist(const AName:String):Boolean;
var
  T : SearchRec;
begin
  FindFirst(AName,AttrMask,T);
  Exist := DosError = 0;
end;

function DelFile(Const AName:String):Boolean;
var
  F : File;
begin
    Assign(F,AName);
    Erase(F);
    DelFile := IOResult = 0;
end;

procedure DestroyDir(s:string);
var
  F:File;
  dirinfo:SearchRec;
begin
  FindFirst(TmpDir+'*.*',readonly+archive+hidden+sysfile,dirinfo);
  while DosError = 0 do begin
    Assign(F,tmpDir+dirinfo.name);
    Erase(F);
    FIndNext(dirinfo);
  end;
  dec(byte(tmpdir[0]));
  RmDir(TmpDir);
end;

procedure abort(msg:string);
begin
  textcolor(lightred);
  write(#13#10+msg);
  textcolor(lightgray);
  writeln;
  if usingnonstdtempdir then DestroyDir(TmpDir);
  halt(1);
end;

function Fix(s:String; len:byte):string;
begin
  while length(s) < len do begin
    inc(byte(s[0]));
    s[length(s)] := #32;
  end;
  Fix := s;
end;

function l2s(l:longint):string;
var
  s:string;
begin
  Str(l,s);
  l2s := s;
end;

function rfix(s:string; len:byte):string;
begin
  while length(s) < len do Insert(#32,s,1);
  RFix := s;
end;

function z2s(l:longint; len:byte):string;
var
  s:string;
begin
  Str(l,s);
  while length(s) < len do Insert('0',s,1);
  z2s := s;
end;

function getdate(l:longint):string;
var
  date:DateTime;
begin
  UnPackTime(l,date);
  with date do getdate := z2s(day,2)+'-'+z2s(month,2)+'-'+z2s(year-1900,2);
end;

procedure distill(var s:string);
var
  b:byte;
begin
  b := pos('@X',s);
  while b > 0 do begin
    if b > 0 then Delete(s,b,4);
    b := pos('@X',s);
  end;
  for b:=1 to length(s) do if (s[b] > #127) or (s[b] < #32) then s[b] := #32;
end;

procedure strip(var s:string);
begin
  while (length(s) > 0) and (s[length(s)] in [#32,#255]) do dec(byte(s[0]));
  while (length(s) > 0) and (s[1] in [#32,#255]) do Delete(s,1,1);
end;

procedure fastupper(var s:string);
var
  b:byte;
begin
  for b:=1 to length(s) do s[b] := upcase(s[b]);
end;

function upper(s:string):string;
begin
  FastUpper(s);
  upper := s;
end;

function XIsParam(s:string):integer;
var
  temp:string;
  n:integer;
begin
  XisParam := 0;
  FastUpper(s);
  for n:=1 to paramcount do begin
    temp := upper(paramStr(n));
    if (temp[1] in ['/','-']) and (copy(temp,2,length(temp))=s) then begin
      XisParam := n;
      exit;
    end;
  end;
end;

procedure WriteOut(s:string);
var
  temp:string;
begin
  Distill(s);
  temp := s;
  Strip(temp);
  if temp <> '' then Writeln(out,s);
end;

function prepdesc(s:string):string;
begin
  if lwx then prepdesc := Fix('',31)+'| '+s
         else prepdesc := Fix('',17)+s;
  Distill(s);
  Strip(s);
  if s = '' then prepdesc := '';
end;

procedure writeheader(var dirinfo:SearchRec; descline:string);
begin
  if lwx then begin
    if descline = '' then descline := '  (description not available)';
    WriteOut(Fix(dirinfo.Name,12)+' '+
                       RFix(l2s(dirinfo.Size),8)+'  '+
                       getdate(dirinfo.Time)+'  '+descline);
  end else WriteOut(' '+Fix(dirinfo.Name,14)+'  '+descline);
end;

function AddFile(where:FnameStr; var dirinfo:SearchRec):Boolean;
var
  T : Text;
  S : string;
begin
  AddFile := False;
  Assign(T,tmpDir+'\FILE_ID.DIZ');
  Reset(T);
  if IOResult <> 0 then begin
    Close(T);
    exit;
  end;
  repeat
    Readln(T,s);
  until (eof(T)) or (s <> '');
  if eof(t) then begin
    WriteHeader(dirinfo,'');
    Close(T);
    AddFile := true;
    exit;
  end;
  WriteHEader(dirinfo,s);
  while Not EOF(T) do begin
    Readln(T,S);
    if IOResult <> 0 then exit;
    WriteOut(prepdesc(s));
    if IOResult <> 0 then exit;
  end;
  if includepaths then WriteOut(prepdesc('('+where+')'));
  Close(T);
  AddFile := True;
end;

procedure DeleteWild(afilespec:FnameStr);
var
  dirinfo:SearchRec;
  F:File;
  dir:dirstr;
  name:namestr;
  ext:extstr;
begin
  FSplit(afilespec,dir,name,ext);
  FindFirst(afilespec,ReadOnly+Hidden+SysFile+Archive,dirinfo);
  while DosError = 0 do begin
    Assign(F,dir+dirinfo.name);
    SetFAttr(F,0);
    Erase(F);
    FindNext(dirinfo);
  end;
end;

procedure AdamEt(var cmd:string; p1,p2,p3:FNameStr);
  procedure replace(src,dst:FnameStr);
  var
    b:byte;
  begin
    b := pos(src,cmd);
    if b=0 then exit;
    Delete(cmd,b,length(src));
    Insert(dst,cmd,b);
  end;
begin
  replace('@1',p1);
  replace('@2',p2);
  replace('@3',p3);
end;

function WrtPaths(where:string; var dirinfo:Searchrec; var rec:TArchiver):Boolean;
var
  Cmdline : String;
  Xdir: dirstr;
  Xname:namestr;
  Xext:extstr;
begin
  WrtPaths := True;
  cmdline := rec.Cmd+' '+rec.Params+'>NUL';
  AdamEt(cmdline,where+dirinfo.name,'*.diz',tmpdir);
  write('analyzing '+Fix(dirinfo.Name,14));
  DeleteWild(tmpdir+'\FILE_ID.DIZ');
  swapvectors;
  Exec(Interpreter,'/C ' + CmdLine);
  swapvectors;
  inc(searched);
  write(#13+'analyzed  '+Fix(dirinfo.Name,14));
  if DosError = 0 then begin
    if Exist(TmpDir+'\FILE_ID.DIZ') then begin
      AddFile(where,dirinfo);
      inc(found);
      TextColor(cDIZAdded);
      writeln('DIZ added');
      TextColor(LightGray);
    end else begin
      if addall then WriteHeader(dirinfo,'');
      writeln('no DIZ found');
    end;
  end else writeln('exec error!');
  if keypressed then if readkey = #27 then begin
    Close(out);
    abort('user abort!');
  end;
end;

procedure Search(Path:String);
var
  T : SearchRec;
  n:integer;
begin
  writeln('- searching path: '+path);
  findFirst(Path+'*.*',AttrMask,T);
  while (DosError = 0) and Not Canceled do begin
    if T.Attr and Directory > 0 then begin
      if recurse then if T.Name[1] <> '.' then Search(Path+T.name+'\');
    end else begin
      for n:=1 to maxunpackers do if pos('.'+unpackers[n].Ext,T.name) > 0 then begin
        inc(unpackers[n].counter);
        Canceled := not WrtPaths(path,t,unpackers[n]);
        if not canceled then if keypressed then canceled := readkey = #27;
        break;
      end;
    end;
    FindNext(T);
  end;
end; {proc}

procedure Report(s:string);
begin
  TextColor(lightgreen);
  write(#254+' ');
  TextColor(lightgray);
  writeln(s);
end;

procedure DetectArchivers;
var
  b:byte;
  procedure Detect(var rec:TArchiver);
  var
    temp:FnameStr;
  begin
    temp := FSearch(rec.Cmd,GetEnv('PATH'));
    if temp = '' then exit;
    rec.Ready := true;
    rec.Cmd := temp;
    Report(rec.Ext+' detected: '+rec.Cmd);
  end;
begin
  for b:=1 to maxunpackers do Detect(unpackers[b]);
end;

function GetTmpDir:string;
var
  s:string;
  dirinfo:SearchRec;
begin
  s := GetEnv('TEMP');
  if s[length(s)] = '\' then dec(byte(s[0]));
  FindFirst(s,directory,dirinfo);
  if DosError <> 0 then begin
    Report('invalid TEMP variable. Creating own');
    MkDir(stdtempdir);
    usingnonstdtempdir := true;
    if IOResult <> 0 then ;
    s := stdtempdir;
  end;
  GetTmpDir := s + '\';
end;

procedure Init;
var
  dirinfo:SearchRec;
  s:string;
begin
  lwx := XIsParam('LWX') <> 0;
  includepaths := XIsParam('DIR') <> 0;
  addall       := XisParam('ALL') <> 0;
  recurse      := XisParam('NOSUB') = 0;
  append       := XisParam('APPEND') <> 0;
  TmpDir := GetTmpDir;
  DetectArchivers;
  Interpreter := GetEnv('COMSPEC');
  Report('Command line interpreter: '+interpreter);
  if lwx then Report('Using ultimate ListWorx(TM) format')
         else Report('Using WinCat format');
end;

procedure DumpStats;
var
  n:integer;
begin
  writeln('Total archives searched  : ',searched);
  writeln('DIZ''s found in archives  : ',found);
  writeln;
  for n:=1 to maxunpackers do writeln(unpackers[n].ext,'''s searched           : ',unpackers[n].counter);
  writeln;
  writeln('Elapsed time             : ',(timer-start) div 18,' secs');
end;

procedure Usage;
begin
  writeln('Usage: FIDIZ searchpath listfile [-dir] [-lwx] [-all] [-nosub] [-append]');
  writeln;
  writeln('-dir     append full path to file''s description');
  writeln('-lwx     use ListWorx(TM) format instead of WinCat format');
  writeln('-all     include archives without file_id.diz''s');
  writeln('-nosub   do not recurse subdirectories');
  writeln('-append  append to existing list file');
  writeln;
  writeln('example: FIDIZ d: c:\temp\list.txt');
  halt;
end;

var
  hebe:fnamestr;
begin
  writeln('FIDIZ! '+fVersion+' - The Ultimate DIZ Extractor! - (c) 1996 SSG & FatalicA'#13#10);
  if paramcount < 2 then Usage;
  listfile := paramstr(2);
  searchDrive := paramStr(1);
  start := timer;
  Init;
  writeln;
  Assign(Out,listfile);
  if append then begin
    System.Append(Out);
    if IOResult <> 0 then Abort('file not found');
  end else begin
    ReWrite(Out);
    writeln(Out,'* Created by FIDIZ v'+fVersion+' * (c) 1996 SSG & FatalicA *'#13#10);
  end;
  hebe := paramstr(1);
  if hebe[length(hebe)] <> '\' then hebe := hebe+'\';
  Search(hebe);
  Close(Out);
  writeln;
  DumpStats;
  TextColor(Lightred+blink);
  Abort('SSG Operation complete');
end.