{$C-} (* so we can read keystrokes on the fly, and abort if desired *)
Program Klean;
(*
   This is an intelligent file erasing program.  Type "Klean //" for help.
   Original version for IBM PC by Jim Taylor.
   Modified for CP/M 80 only, with improvements, by Steven B. Perkins.
   Copyright 1987.   Version 2.0  9/23/87
*)

TYPE
   String12 = string[12];
   String80 = string[80];
   item = record
            key : String12;
          end;
   Darray = array[1..513] of item;
   FCBarr = array[0..35] of char;

Var
  IOVal, I,j,k, SortResult : integer;
  IOErr : boolean;
  ch : char;
  NoListQuery,EraseReadOnly,HorizontalSort,ShowSystemFiles: boolean;
  TypeNameSort,ZapThemAll: boolean;
  NameX : String12;
  Myx, count : integer;
  DoArray : array[1..513] of integer;
  DirNameStr : String12;
  TempStr : String[15]; (* Room for drive *)
  Mask : FCBarr;
  Dir : DArray;
  TheCommandStr : String80;
  TheFile : file;
  linecount: integer;
  olduser,newuser: integer;


procedure IOCheck;
begin
  IOVal := IOresult;
  IOErr := (IOVal <> 0);
end;

Procedure GetKey;
begin
     while not keypressed do;
     read(kbd,ch);
     ch:=upcase(ch);
end;

procedure QuickShell;
var z,i,j : integer;
    t : item;
    looping: boolean; (* to avoid testing illegal array elements *)
begin
  z:=1;
  repeat
    z:=z*3+1;
  until z>=count;
  repeat
    z:=(z-1) DIV 3;
    if TypeNameSort then for i:=z+1 to count do begin
      j:=i-z;
      t:=dir[i];
      looping:=true;
      while (j>0) and looping do
       if (copy(dir[j].key,10,3) + dir[j].key > copy(t.key,10,3) + t.key) then
        begin
          dir[j+z]:=dir[j];
          j:=j-z;
        end
        else looping:=false;
      dir[j+z]:=t;
    end
    else for i:=z+1 to count do begin
      j:=i-z;
      t:=dir[i];
      while(dir[j].key > t.key) and (j>0) do begin
        dir[j+z]:=dir[j];
        j:=j-z;
      end;
      dir[j+z]:=t;
    end;
  until z=1;
end;

procedure AllDone;
begin
  olduser:=BDOS(32,olduser); (* restore original user *)
  halt;
end;

procedure GetNameX;
var
  NameY, NameExt : String12;
  s,t   : integer;
  wild:boolean;
begin
  NameX:='           ';
  for s:=1 to 11 do NameX[s]:=chr(Mem[$5C+s]);
  if (NameX[1]=' ') or (NameX[1]='/') then NameX:='???????????';
end;

procedure ShowName(ToPrint: integer);
begin
  if ToPrint<=count then begin
      write(ToPrint:3,' ',Dir[ToPrint].key);
      if Dir[ToPrint].key[10]>chr(127) then write('r') else write(' ');
      if Dir[ToPrint].key[11]>chr(127) then write('s') else write(' ');
      if Dir[ToPrint].key[12]>chr(127) then write('a') else write(' ');
  end;
end;

procedure dirlist (s:String12);
var
  M                        : String12;
  DTA                      : array [ 1..128 ] of Byte;
  NamR                     : String12;
  Error, I, Linecount, ToPrint, limit, delta : Integer;

begin { main body of program DirList }
  FillChar(DTA,SizeOf(DTA),0);        { Initialize the DTA buffer }
  FillChar(Mask,SizeOf(Mask),0);      { Initialize the mask }
  FillChar(NamR,SizeOf(NamR),0);      { Initialize the file name }
  FillChar(Dir,SizeOf(Dir),0);        { Initialize the Name array }
  writeln('Klean v2.0  Copyright 1987 by Steven B. Perkins');
  GetNameX;
  move(NameX[1],Mask[1],11);
  Mask[0]:=chr(MEM[$5C]);
  write('  FileName= ');
  if (ord(Mask[0])>0) or (newuser<>255) then begin
    if ord(Mask[0])>0 then write(chr(64+ord(Mask[0])));
    if newuser<>255 then write(newuser);
    write(':');
  end;
  writeln(copy(NameX,1,8),'.',copy(NameX,9,3));
  error:=bdos($1a,addr(DTA));
  error:=bdos($11,addr(mask));

  count:=0;
  if (Error <> 255) then begin
    error:=error*32; (* point to name found *)
    for i:=1 to 8 do
      NamR[I] := Chr(DTA[error+i+1]);
    NamR[9]:='.';
    for i:=10 to 12 do
      NamR[I] := Chr(DTA[error+i]);
    NamR[0]:=chr(12);
    if (DTA[error+11]<127) or ShowSystemFiles then count := 1;
  end;
  if error<>255 then Dir[1].key:=NamR;


  while (Error <> 255) do begin
   error:=bdos($12,addr(mask));

   if (Error <> 255) then begin
    error:=error*32; (* point to name found *)
    for i:=1 to 8 do
      NamR[I] := Chr(DTA[error+i+1]);
    NamR[9]:='.';
    for i:=10 to 12 do
      NamR[i] := Chr(DTA[error+i]);
    NamR[0]:=chr(12);
    Dir[count+1].key:=NamR;
    if (DTA[error+11]<127) or ShowSystemFiles then count:=count+1;
   end;
  end;
  QuickShell;
  linecount:=1;
  ToPrint:=1;
  (* New vertical format *)
  if HorizontalSort then begin
    delta:=1;
    limit:=count;
  end
  else begin
    limit:=(count + 3) div 4;
    delta:=limit;
  end;
  while ToPrint<=limit do
    begin
      ShowName(ToPrint);
      write(' ');
      ShowName(ToPrint+delta);
      write(' ');
      ShowName(ToPrint+delta+delta);
      write(' ');
      ShowName(ToPrint+3*delta);
      (* no space for terminals that do auto crlf at column 80 *)
      writeln;
      
      linecount:=linecount+1;
      if linecount > 22 then begin
        write('More . . .');
        getkey;
        linecount:=1;
        if ch<>chr(27) then for i:=1 to 10 do write(chr(8)) (* clear "More" *)
        else ToPrint:=count; (* <ESC> aborts list *)
        if ch=chr(3) then AllDone; (* allow ^C to abort nicely *)
      end;
      if HorizontalSort then ToPrint:=ToPrint+4
      else ToPrint:=ToPrint+1;
    end;
  writeln;
end;

procedure ChopItUp(S : String80);
var I,II,TempInt2,code,tempint : integer;
    temp,temp2 : String12;

procedure SubChop(t:String12);
var ff:integer;
begin
  if length(temp)<=0 then exit;
  ff:=pos('-',t);
  if ff<>0 then begin
    temp:=copy(t,1,ff-1);
    Val(temp,tempint,code);
    if Length(t)>=ff+1 then begin
      temp2:=copy(t,ff+1,length(t));
      Val(temp2,tempint2,code);
    end
    else tempint2:=count; (* something like 3- *)
    for ii:=tempint to tempint2 do
     if (ii>0) and (ii<=count) then begin
      DoArray[MyX]:=ii;
      MyX:=MyX+1;
     end;
  end
  else begin
    Val(temp,tempint,code);
    if (tempint>0) and (tempint<=count) then begin
      DoArray[MyX]:=tempint;
      MyX:=MyX+1;
    end;
  end;
end;

begin
  MyX:=1; temp:='';
  for I:=1 to length(s) do begin
    if (s[i] <> ',') and (s[i]<>' ') then temp:=temp+s[i]
    else begin
      SubChop(temp);
      temp:='';
    end;
  end;
  if temp > '' then begin
    SubChop(temp);
  end;
  MyX:=MyX-1;
end;

Procedure HelpMessage;
begin
  writeln('            Klean v2.0   An intelligent file erase utility.');
  writeln('                  Copyright 1987 by Steven B. Perkins');
  writeln('           Usage: KLEAN [d[u]:][afn] /[/][A][H][R][S][T][Z]');
  writeln;
  writeln('     Options:  </>=help, include <A>ll files, <H>orizontal sort, erase <R>ead');
  writeln('only without asking, show <S>ystem files, <T>ype/name sort, <Z>ap them all.');
  writeln;
  writeln('     Klean gives a sorted, numbered list of all files matching [afn] and');
  writeln('asks which ones to erase (unless <A> or <Z> is used, then Klean doesn''t ask.');
  writeln('<CR> Aborts, or reply with a list of files to erase such as:  1,4 5 9-10,20-');
  writeln('Klean always shows the files selected and asks for final verification (unless');
  writeln('<Z> is used,) before deleting them all.  If a very large directory is shown,');
  writeln('Klean pauses and prompts:  "More . . ."  Press <ESC> to abort the list early.');
  writeln('</> is needed with options only for no filespec.  Released for non-profit use.');
end;

begin
  DirNameStr:='    ';
  NoListQuery:=False;
  HorizontalSort:=False;
  EraseReadOnly:=False;
  ShowSystemFiles:=False;
  TypeNameSort:=False;
  ZapThemAll:=False;
  DirNameStr:=ParamStr(1);
  if (ParamCount > 1) or (DirNameStr[1]='/') then begin
    DirNameStr:=ParamStr(ParamCount);
    for i:=1 to 6 do begin
      NoListQuery:=((DirNameStr[i]='A') or (DirNameStr[i]='Z') or NoListQuery);
      HorizontalSort:=((DirNameStr[i]='H') or HorizontalSort);
      EraseReadOnly:=((DirNameStr[i]='R') or EraseReadOnly);
      ShowSystemFiles:=((DirNameStr[i]='S') or ShowSystemFiles);
      TypeNameSort:=((DirNameStr[i]='T') or TypeNameSort);
       (* don't let them do:  klean /z,  must do:  klean *.* /z *)
      ZapThemAll:=((DirNameStr[i]='Z') or ZapThemAll) and (ParamCount>1);
    end;
  end;
  if ParamCount > 0 then DirNameStr:=ParamStr(1);
  if (DirNameStr[1]='/') and ((DirNameStr[2]='/') or (Length(DirNameStr)=1))
   then begin
    HelpMessage;
    Halt;
  end;
  olduser:=BDOS(32,$0ff); (* get current user for restore *)
  newuser:=255;
  if MEM[$69]<>MEM[$79] then begin (* zcpr3's different user indication *)
    newuser:=ord(MEM[$69]);
    IOVal:=BDOS(32,newuser);
  end;
  DirList(DirNameStr);
  if Count<=0 then begin
    writeln('No files erased.');
    AllDone;
  end;
  for i:=1 to count do DoArray[i]:=i;
  if (Count>1) and not NoListQuery then begin
    Write('Which ones to erase? ');
    readln(TheCommandStr);
    writeln;
    if TheCommandStr <= ' ' then begin
      writeln('No files erased.');
      AllDone;
    end;
    ChopItUp(TheCommandStr);
    if MyX>0 then writeln('Erase: ');
    for I:=1 to MyX do begin
      write(' ':4,Dir[DoArray[i]].key);
      if (I mod 4) = 0 then writeln;
    end;
  end
  else begin (* only one file shown, or erase <A>ll, so don't ask for list *)
    writeln;
    MyX:=Count;
  end;
  if ZapThemAll then ch:='Y'
  else if MyX>0 then begin
    writeln;
    write('O.K. to erase (y/n)? ');
    getkey;
  end
  else ch:='N';
  writeln;
  writeln;
  if ch = 'Y' then begin
    {$I-}
    for I:=1 to MyX do begin
      (* give them a chance to abort *)
      if KeyPressed then begin
        read(kbd,ch);
        if ch<>chr(27) then begin
          write('To abort press <ESC>: ');
          GetKey;
          writeln;
        end;
        if ch=chr(27) then begin
          writeln('Aborted!');
          Alldone;
        end;
      end;
      ch:='Y';
      IOVal:=0;
      write(' ':4,Dir[DoArray[i]].key,' ');
      if Dir[DoArray[i]].key[10]>chr(128) then begin (* R/O file *)
        if EraseReadOnly then ch:='Y'
        else begin
          write(chr(7),'is Read Only!  Erase? ');
          GetKey;
        end;
        if ch='Y' then begin
          for k:=1 to 8 do Mask[k]:=Dir[DoArray[i]].key[k];
          for k:=9 to 11 do Mask[k]:=Dir[DoArray[i]].key[k+1];
          Mask[9]:=chr(ord(Mask[9]) and $7f); (* clear R/O bit *)
          IOVal:=Bdos(30,ADDR(Mask));
        end;
      end;
      if (ch<>'Y') or (IOVal>16) then writeln('Not Erased')
      else begin
        k:=1;
        if ord(Mask[0])>0 then begin
          TempStr[1]:=chr(64+ord(Mask[0]));
          TempStr[2]:=':';
          k:=3;
        end;
        for j:=1 to 12 do
          if Dir[DoArray[i]].key[j]<>' ' then begin
            TempStr[k]:=Dir[DoArray[i]].key[j];
            k:=k+1;
          end;
        TempStr[0]:=chr(k-1);
        assign(TheFile,TempStr);
        erase(TheFile);
        IoCheck;
        if IOErr then writeln('Error:  not erased ')
        else writeln('Erased');
      end;
    end;
    {$I+}
  end
  else begin
    writeln;
    writeln('No files erased.');
  end;

  AllDone;
end.