program PF;
(***********************************************************)
(*                                                         *)
(*  Howdy.  I wrote this because I did not like FM.COM...  *)
(*  On small screens I think it important to get as much   *)
(*  "real" data as possible, as opposed to extraneous      *)
(*  lines and other dither. I was also curious as how much *)
(*  of a DOS machine the Portfolio is.  I am impressed.    *)
(*  It also takes me back to the good old days (which were *)
(*  never so good after all--what programmer these days    *)
(*  would dream of coding sheets and keypunches and one    *)
(*  day turnarounds--when small was not only better, but   *)
(*  essential.  Enjoy adding your functions....            *)
(*                                                         *)
(*           charlie cook 71370,1025                       *)
(*                                                         *)
(***********************************************************)

(*******************************)
(*                             *)
(* Revisions 1.1               *)
(*   added alt-letter commands *)
(*   changed ifs to case       *)
(*   enhanced copy function    *)
(*   added move,mark           *)
(*   major code revisions      *)
(*                             *)
(*******************************)

uses
  Dos;
const
  MAXFILES =64;
  VERSION  ='1.1';
  BUFFSIZE =4096;

type
  FileRecType = record
    Name : string[8];
    Ext  : string[3];
    Size : string[6];
    Date : string[8];
    Mark : char;
  end;

var
  DirData   : Searchrec;
  Tab       : array[1..MAXFILES] of FileRecType;
  NameIndex : integer;
  NameMax   : integer;
  I         : integer;
  J         : integer;
  DT        : DateTime;
  Field     : string;
  FPoint    : integer;
  OffSet    : integer;
  OffEnd    : integer;
  OldOff    : integer;
  OldPoint  : integer;
  Arrow     : string[4];
  Path      : string[32];
  Done      : boolean;
  Buffer    : array[1..Buffsize] of char;
  MarkCount : integer;

  Drive     : integer;
  FPath     : Pathstr;
  FDir      : DirStr;
  FName     : NameStr;
  FExt      : ExtStr;

procedure clrscr;
var
  Regs : registers;
begin
  Regs.ah:=6;     (* scroll or init window *)
  Regs.al:=0;     (* clear screen          *)
  Regs.bh:=7;     (* attribute             *)
  Regs.ch:=0;     (* y coord top left      *)
  Regs.cl:=0;     (* x coord top left      *)
  Regs.dh:=7;     (* y coord bottom right  *)
  Regs.dl:=39;    (* x coord bottom right  *)
  intr($10,Regs); (* use bios              *)
end;

procedure gotoxy(x:integer; y:integer);
var
  Regs : registers;
begin
  Regs.ah:=2;     (* command to set cursor *)
  Regs.bh:=0;     (* page 0                *)
  Regs.dh:=y;     (* set y coord           *)
  Regs.dl:=x;     (* set x coord           *)
  intr($10,Regs); (* use bios              *)
end;

procedure LoadFiles;
var I,J:integer;
begin
  NameIndex :=0;
  NameMax   :=0;
  MarkCount :=0;

  findfirst(Path+'*.*',0,DirData);

  while (DosError=0) and (NameMax<MAXFILES) do
    begin
      inc(NameMax);
      NameIndex:=NameMax;
      while (NameIndex>1) and (DirData.Name<Tab[NameIndex-1].Name) do
        begin
          Tab[NameIndex]:=Tab[NameIndex-1]; (* a little insertion sort *)
          dec(NameIndex);
        end;

      FSplit(DirData.Name,FPath,FName,FExt);
      Tab[NameIndex].Name:=FName;
      delete(Fext,1,1);
      Tab[NameIndex].Ext:=FExt;

      str(DirData.Size:6,Tab[NameIndex].Size);

      Unpacktime(DirData.Time,DT);  (* all this to format the date *)
      str(DT.Month:2,Field);
      Tab[NameIndex].Date:=Field+'/';
      str(DT.Day:2,Field);
      Tab[NameIndex].Date:=Tab[NameIndex].Date+Field+'/';
      str(DT.Year:4,Field);
      delete(Field,1,2);
      Tab[NameIndex].Date:=Tab[NameIndex].Date+Field;
      for J:=1 to 12 do
       if Tab[Nameindex].Date[J]=' ' then
         Tab[NameIndex].Date[J]:='0';

      Tab[NameIndex].Mark:=' ';

      findnext(DirData);
    end;
  if NameMax=0 then
    write('No Files... ');
end;

procedure DoHelp;
var
  Regs : registers;
begin
  clrscr;
  gotoxy(0,0);
  write('        Portfolio Filer '+Version);
  gotoxy(0,1);
  write('                                        ');
  gotoxy(0,2);
  write('Use the Cursor keys to scroll file names');
  gotoxy(0,3);
  write('up and down.  To delete, point and press');
  gotoxy(0,4);
  write('DELETE. ESCAPE will exit or abort. RIGHT');
  gotoxy(0,5);
  write('arrow will copy, LEFT will move.  RETURN');
  gotoxy(0,6);
  write('to list.  Alt-C,L,D,M and H may be used ');
  gotoxy(0,7);
  write('as well.            .....press any key'+#7);
  Regs.ah:=8;
  msdos(regs);
  OldOff:=0;
end;

procedure CopyIt;
var
  IFile   : file;
  OFile   : file;
  InNum   : word;
  OutNum  : word;
  C       : char;
  Regs    : registers;
  FCount  : integer;
  NewPath : PathStr;

begin
  OldOff:=0;
  Field:='';
  repeat
    Regs.ah:=1;
    msdos(Regs);
    C:=chr(Regs.al);
    if (C>='.') and (C<='z') then
      Field:=Field+C;
    if C=#27 then
      begin
        Field:='';
        exit;
      end;
    if (C=#8) and (Field[0]>#0) then
      begin
        write(' '+#8);
        dec(Field[0]);
      end;
  until C=#13;

  FSplit(Field,NewPath,FName,FExt);
  if Newpath='' then
    getdir(0,NewPath);
  if NewPath[length(NewPath)]<>'\' then
    Newpath:=NewPath+'\';

  if (NewPath=Path) and ((MarkCount>0) or (FName='')) then
    begin
      Field:='';
      exit;
    end;

  if (MarkCount=0) and (FName='') then
    Field:=NewPath+Tab[FPoint].Name+'.'+Tab[FPoint].Ext;

  FCount:=MarkCount;
  I:=0;
  repeat
    if FCount>0 then
      begin
        inc(I);
        while Tab[I].Mark<>'*' do
          inc(I);
        FPoint:=I;
        assign(OFile,Field+Tab[FPoint].Name+'.'+Tab[FPoint].Ext);
        dec(FCount);
      end
    else
      assign(OFile,Field);
    rewrite(OFile,1);
    assign(IFile,Path+Tab[FPoint].Name+'.'+Tab[FPoint].Ext);
    reset(IFile,1);
    repeat
      blockread(IFile,Buffer,BuffSize,InNum);
      blockwrite(OFile,Buffer,InNum,OutNum);
      write('.');
    until (InNum<Buffsize) or (OutNum<InNum);
    close(OFile);
    close(IFile);
  until FCount<1;
end;

procedure DoCopy;
begin
  clrscr;
  gotoxy(0,0);
  write('Copy to?');
  CopyIt;
  if MarkCount>0 then
    begin
      MarkCount:=0;
      for I:=1 to NameMax do
        if Tab[I].Mark='*' then
          Tab[I].Mark:=' ';
    end;
end;

procedure Eraseit;
var
  F     : file;
begin
  assign(F,Path+Tab[FPoint].Name+'.'+Tab[FPoint].Ext);
  erase(F);
  dec(NameMax);
  for I:=FPoint to NameMax do
    Tab[I]:=Tab[I+1];
end;

procedure DoDelete;
var
  I     : integer;
  Regs  : registers;
begin
  OldOff:=0;
  if MarkCount=0 then
    begin
     gotoxy(0,FPoint-Offset);
     write('???'+#7);           (* confirm delete *)
     Regs.ah:=8;
     msdos(regs);
     if (chr(Regs.al)='Y') or (chr(Regs.al)='y') then
      EraseIt;
    end
  else
    repeat
      I:=1;
      while Tab[I].Mark<>'*' do
        inc(I);
      FPoint:=I;
      EraseIt;
      dec(MarkCount);
    until MarkCount<1;
end;

procedure DoMove;
begin
  clrscr;
  gotoxy(0,0);
  write('Move to?');
  CopyIt;
  if Field='' then
    exit;
  DoDelete;
end;

procedure DoList;
label Break;
var
  F        : file of char;
  FCh      : char;
  Regs     : registers;
begin
  assign(F,Path+Tab[FPoint].Name+'.'+Tab[FPoint].Ext);
  reset(F);
  gotoxy(0,0);
  clrscr;
  while not eof(F) do
    begin
      Regs.ah:=6;
      Regs.dl:=255;
      msdos(regs);
      if (Regs.Flags and FZero)=0 then
        begin
          if Regs.al=27 then
            goto Break;
          Regs.ah:=8;
          msdos(regs);
        end;
      read(F,FCh);
      if (FCh<#10) or (FCh>'~') then
        FCh:='.';
      write(FCh);
    end;
  Regs.ah:=8;
  msdos(regs);
Break:
  close(F);
  OldOff:=0;
end;

procedure ProcessCommands;
var
  GotIt    : boolean;
  Regs     : registers;
  Ch       : char;

begin
  GotIt:=false;        (* process the commands *)
  repeat
    Regs.ah:=8;
    msdos(regs);
    Ch:=chr(Regs.al);
    if Regs.al=0 then
      begin
        GotIt:=true;
        Regs.ah:=8;
        msdos(regs);
        case Regs.al of
          46:DoCopy;           (* alt-C *)
          32:DoDelete;         (* alt-D *)
          35:DoHelp;           (* alt-H *)
          38:DoList;           (* alt-L *)
          50:DoMove;           (* alt-M *)
          75:DoMove;           (* left key *)
          77:DoCopy;           (* right key *)
          72:dec(FPoint);      (* up key *)
          80:inc(FPoint);      (* down key *)
          73:FPoint:=FPoint-6; (* page up *)
          81:FPoint:=FPoint+6; (* page down *)
          71:FPoint:=1;        (* home *)
          79:FPoint:=NameMax;  (* end *)
          83:DoDelete;         (* delete *)
          59:OldOff:=0;        (* F1 Key *)
          60:DoHelp;           (* F2 Key *)
        end;
      end;

    if (Ch=' ') then
      begin
        if Tab[FPoint].Mark=' ' then
          begin
            inc(MarkCount);
            Tab[FPoint].Mark:='*';
          end
        else
          begin
            Tab[FPoint].Mark:=' ';
            dec(MarkCount);
          end;
        gotoxy(17,FPoint-Offset);
        write(Tab[FPoint].Mark);
        inc(FPoint);
        GotIt:=true;
      end
    else if (Ch>='0') then
      begin
        Ch:=upcase(Ch);
        FPoint:=1;
        while ((FPoint<NameMax) and (Ch>Tab[FPoint].Name[1])) do
          inc(FPoint);
        GotIt:=true;
      end
    else if Ch=#27 then                (* escape *)
      begin
        Done:=true;
        GotIt:=true;
      end
    else if (Ch=#13) or (Ch=#10) then  (* return *)
      begin
        DoList;
        GotIt:=true;
      end;
  until GotIt;
end;

procedure DoFiles;
var J : integer;
begin
  FPoint:=1;
  OffSet:=1;
  Done:=false;
  OldOff:=0;
  OldPoint:=0;

  repeat
    if FPoint>NameMax then
      FPoint:=NameMax;
    if FPoint<1 then
      FPoint:=1;

    if FPoint<Offset then
      Offset:=FPoint-2;
    if FPoint>OffEnd then
      Offset:=FPoint-2;
    if Offset<1 then
      Offset:=1;
    OffEnd:=OffSet+7;
    if OffEnd>NameMax then
      OffEnd:=NameMax;
    if (Offend=NameMax) and (Offset=Offend-7) then
      Offset:=Offend-6;

    if Offset=OldOff then
      begin
        gotoxy(0,OldPoint-Offset);
        write('   ');
        gotoxy(0,FPoint-Offset);
        write(Arrow);
      end
    else
      begin
        clrscr;
        for I:=OffSet to OffEnd do
          begin
            J:=I-Offset;
            gotoxy(4,J);
            write(Tab[I].Name);
            gotoxy(13,J);
            write(Tab[I].Ext);
            gotoxy(19,J);
            write(Tab[I].Date);
            gotoxy(17,J);
            write(Tab[I].Mark);
            gotoxy(30,J);
            write(Tab[I].Size);
            OldOff:=Offset;
          end;
        gotoxy(0,FPoint-Offset);
        write(Arrow);
        if J<7 then
          begin
            gotoxy(8,7);
            write(DiskFree(Drive),' Bytes Free on Disk '+Path[1]);
          end;
      end;

    OldPoint:=FPoint;

    ProcessCommands;
  until Done;
end;

(************************)
(*** ye olde mainline ***)
(************************)
begin
  Path:='';
  if paramcount>0 then
    Path:=paramstr(1)
  else
    getdir(0,Path);

  Drive:=0;
  if (length(Path)>1) and (Path[2]=':') then
    begin
      Drive:=ord(upcase(Path[1]))-ord('A')+1;
      if length(Path)=2 then
        getdir(Drive,Path);
    end;
  if Path[length(Path)]<>'\' then
    Path:=Path+'\';

  clrscr;
  Arrow:=chr(205)+chr(205)+'>';
  LoadFiles;
  if NameMax=0 then
    exit;
  DoFiles;
  clrscr;
end.