Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TURBO_TK.ZIP/DIRTTT.PAS

Pascal/Delphi Source File | 1988-02-01 | 19.4 KB | 613 lines

{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
{         TechnoJocks Turbo Toolkit v4.00            Released: Feb 1, 1988    }
{                                                                             }
{         Module: DirTTT    --   a directory listing unit a la Sidekick       }
{                                                                             }
{                       Copyright R. D. Ainsbury (c) 1986                     }
{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}

Unit DirTTT;

Interface

Uses CRT, FastTTT, DOS, KeyTTT, WinTTT;

Function Display_Directory(var PathName:string; FileMask:string): string;
Procedure Default_Settings;

Type
   DirDisplay = record
                     TopX    : byte;
                     TopY    : Byte;
                     Cols    : byte;
                     Rows    : byte;
                     DateTime: boolean;
                     CDir    : boolean;
                     Attrib  : byte;
                     BoxType : byte;
                     BoxCol  : byte;
                     BacCol  : byte;
                     NorCol  : byte;
                     DirCol  : byte;
                     HiFCol  : byte;
                     HiBCol  : byte;
                     AllowEsc : boolean;
                 end;

Var
   D : DirDisplay;

Implementation

Procedure Default_Settings;
begin
    With  D  do
    begin
        TopX    := 15;
        TopY    := 5;
        Cols    := 4;
        Rows    := 15;
        DateTime:= true;
        CDir    := true;
        AllowEsc := true;
        Attrib := AnyFile;
        BoxType := 1;      {single lined box}
        If BaseOfScreen = $b000 then
        begin
            BoxCol := white;
            BacCol := black;
            NorCol := white;
            DirCol := lightgray;
            HiFcol := black;
            HiBcol := lightgray;
        end
        else
        begin
            BoxCol := red;
            BacCol := lightgray;
            NorCol := black;
            DirCol := yellow;
            HiFcol := white;
            HiBcol := blue;
        end;
    end; {with}
end;

Function Display_Directory(var PathName:string; FileMask:string): string;

Const
Mcols = 6;       {lower these settings to reduce the amount of}
Mrows = 23;      {memory used - if necessary}
Lchar = #16;
Rchar = #17;
Null  = #0;
HomeKey = #199;   EndKey = #207;   Esc = #027;   Enter = #13;
Cursup  = #200;   CursDown = #208; CursLeft = #203; CursRight = #205;
PgDn    = #209;   PgUp     = #201;

Type
Filerecord = record
               Name : string[12];
               Size : LongInt;
               Time : LongInt;
               Attr : byte;
             end;
DirBox =  array[1..Mcols,1..Mrows] of ^Filerecord;
DirectoryData = record
                   CurrEntry : byte; { the number of the highlighted file }
                   TotFiles  : byte; { the total number of files in cur. box }
                   CurrPage  : integer; { current directory page number}
                   FileData  : DirBox;  { name and attrib info }
                   MoreFiles : boolean; { true if not end of directory }
                end;
Var
Dbox : DirectoryData;        {array of files and attributes}
X2 : byte;                   {right hand box coord}
I,J : integer;               {misc}

{\\\\\\\\\\\\\\\\\\\\\\    Miscellaneous procedures   \\\\\\\\\\\\\\\\\\\\\}

FUNCTION Copies (ch:char; n:integer) : String;
begin
InLine (   $16 /$07 /$8B /$4E /$04 /$88 /$4E /$08 /$8B
       /$46 /$06 /$8D /$7E /$09 /$FC /$F3 /$AA );
end;  { Copies }


Function Left(S : string;Size : byte; Pad : char):string;
var temp : string;
begin
    Fillchar(Temp[1],Size,Pad);
    Temp[0] := chr(Size);
    If Length(S) <= Size then
       Move(S[1],Temp[1],length(S))
    else
       Move(S[1],Temp[1],size);
    Left := Temp;
end;

Function Center(S : string;Size : byte; Pad : char):string;
var
  temp : string;
  L : byte;
begin
    Fillchar(Temp[1],Size,Pad);
    Temp[0] := chr(Size);
    L := length(S);
    If L <= Size then
       Move(S[1],Temp[((Size - L) div 2) + 1],L)
    else
       Move(S[((L - Size) div 2) + 1],Temp[1],Size);
    Center := temp;
end; {center}

Function Int_to_Str(I : Longint):string;
var S : string[11];
begin
    Str(I,S);
    Int_to_Str := S;
end;

Function CalcCol(Entry : byte) : byte;
{ returns the display column of the file}
begin
    CalcCol := Succ(Pred(Entry) MOD D.cols);
end;

Function CalcRow(Entry : byte) : byte;
{ returns the display row of the file}
begin
    CalcRow := Pred(Entry + D.cols) DIV D.cols;
end;

Function Subdirectory(Attrib:byte): boolean;
begin
    Subdirectory := ((Attrib and 16) = 16);
end;

Function ValidPathName:Boolean;
begin
    If PathName[Length(PathName)] <> '\' then
       PathName := PathName + '\';
    {$I-}
    If (length(PathName) = 3) and (PathName[2] = ':') then
       Chdir(PathName)
    else
       ChDir(copy(Pathname,1,length(Pathname) - 1));
    {$I+}
    ValidPathName := (IoResult = 0);
end;  {ValidPathName}

Function FileDetails(F:FileRecord):string;
var
  DT : DateTime;
  Str: string;
begin
    UnPackTime(F.Time,DT);
    Str := Int_to_Str(F.Size)+'  '
           +Int_to_Str(DT.Month)+'-'+Int_to_Str(DT.Day)+'-'
           +copy(Int_to_Str(DT.Year),3,2)
           +'  '+Int_To_Str(DT.Hour)+':'+Int_to_Str(DT.Min);
    FileDetails := Str;
end;

Function ExtractPrevDir(Path : string): string;
begin
 Repeat
  Delete(Path,length(Path),1);
 Until ( copy(Path,length(Path),1) = '\') or (length(Path) = 0);
 Delete(Path,length(Path),1);
 If length(Path) > 2 then
  ExtractPrevDir := Path
 else
  ExtractPrevDir := Path + '\';
end; {ExtractPrevDir}

{\\\\\\\\\\\\\\\\\\\\\\   Screen drawing procedures   \\\\\\\\\\\\\\\\\\\\\}

Procedure Determine_Box_Location;
var Xtra : byte;
begin
    If D.DateTime then
       Xtra := 1
    else
       Xtra := 0;
    If D.DateTime and (D.cols < 4) then D.cols := 4;
    If (D.cols < 1) or (D.cols > 6)  then D.cols := 6;
    If (D.Rows < 1) or (D.Rows + xtra > 23) then D.Rows := 23 - xtra;
    If (D.TopX < 1) or (D.TopX > (79 - D.cols*13)) then
    If D.cols =  6 then D.TopX := 1 else
       D.TopX := 40  - ( (D.cols*13) + 2 ) div 2;
    If D.TopX < 1 then D.TopX := 1;
    If (D.TopY < 1) or (D.TopY > (24 - D.Rows - Xtra)) then
    If D.Rows - Xtra = 23 then D.TopY := 1 else
       D.TopY := ( 23 - D.Rows - xtra) div 2;
    If D.TopY < 1 then D.TopY := 1;
end; {Proc Determine_Box_Location}

Procedure Draw_Box;
var
  Y2,Xtra: byte;
begin
    If D.DateTime then
       Xtra := 1
    else
       Xtra := 0;
    X2 := D.TopX + 2 + 13*D.cols;
    Y2 := D.TopY + 1 + D.Rows + Xtra;
    FBox(D.TopX,D.TopY,X2,Y2,D.boxcol,D.Baccol,1);
end; {Proc Draw_Box}

Procedure LoDisplayFileName(Entry :byte; DPage : DirectoryData);
var C,R,X1,Y1,Color : byte;
begin
    C := CalcCol(Entry);
    R := CalcRow(Entry);
    X1 := D.TopX + 1 + (13 * pred(C));
    If D.DateTime then
       Y1 := D.TopY + R +1
    else
       Y1 := D.TopY + R;
    If Subdirectory(Dpage.FileData[C,R]^.attr) then
       Color := D.Dircol
    else
       Color := D.NorCol;
    Fastwrite(X1,Y1,attr(Color,D.BacCol),
             ' '+left(Dpage.FileData[C,R]^.name,13,' '));
end; {LoDisplayFileName}

Procedure HiDisplayFileName(Entry :byte; DPage : DirectoryData);
var C,R,X1,Y1,color : byte;
    text : string;
begin
    C := CalcCol(Entry);
    R := CalcRow(Entry);
    X1 := D.TopX + 1 + (13 * pred(C));
    If D.DateTime then
       Y1 := D.TopY + R +1
    else
       Y1 := D.TopY + R;
    If Subdirectory(DPage.Filedata[C,R]^.attr) then
       color := D.DirCol
    else
       color := D.HiFCol;
    If DPage.TotFiles > 0 then
    begin
        Text := #16 + Dpage.FileData[C,R]^.name  ;  {place arrows at each end}
        Text := Left(Text,13,' ') + #17;
        Fastwrite(X1,Y1,attr(Color,D.HiBCol),text);
        If D.DateTime then
           If SubDirectory(DPage.FileData[C,R]^.attr) then
           begin
               If Dpage.FileData[C,R]^.name = '..' then
                  Text := 'Directory '+ ExtractPrevDir(Pathname)
               else
                  Text := 'Directory '+ Pathname + Dpage.FileData[C,R]^.name;
           Text := Center(Text,X2-D.TopX-2,' ');
           Fastwrite(D.TopX+1,D.TopY+1,attr(Color,D.BacCol),Text);
       end
       else   {must be a file}
       begin
           Text := Dpage.Filedata[C,R]^.Name+'  '+
                   FileDetails(DPage.FileData[C,R]^);
           Text := Center(Text,X2-D.TopX-2,' ');
           Fastwrite(D.TopX+1,D.TopY+1,attr(Color,D.BacCol),Text);
       end;
    end
    else    {no files}
    begin
        Text := Center('No File(s)',X2-D.TopX-2,' ');
        Fastwrite(D.TopX+1,D.TopY+1,attr(Color,D.BacCol),Text);
    end;
end; {HiDisplayFileName}

Procedure DisplayDirPage(var DPage : DirectoryData);
var I : integer;
begin
    For I := 1 to Dpage.Totfiles do
        LoDisplayFileName(I,Dpage);
    If (Dpage.TotFiles > 1) and (length(PathName) > 3) and D.Cdir then
       DPage.CurrEntry := 2
    else
       DPage.CurrEntry := 1;
    HiDisplayFileName(DPage.CurrEntry,DPage);
end; {DisplayDirPage}

{\\\\\\\\\\\\\\\\\\\\\\  Array filling  procedures   \\\\\\\\\\\\\\\\\\\\\\}

procedure ReadDirPage(var DPage : DirectoryData; NewPage : byte);
const
ReadMessage = 'Reading Directory...';

var
  Y1,Counter : byte;
  Msg : string;
  I,J : integer;

     Procedure ReadNextDirPage(var DPage : DirectoryData);
     Const
         CurrFile : SearchRec= (Fill:(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
                                Attr:0;Time:0;Size:0;Name:'');
     Var
       FirstFileRead : boolean;
     begin
         FirstFileRead := False;
         with DPage do
         begin
             TotFiles := 0;
             repeat
                  with FileData[CalcCol(Succ(TotFiles)),
                                CalcRow(Succ(TotFiles))]^ do
                  begin
                      if (CurrPage = 1) and (TotFiles = 0)
                      and not FirstFileRead              then
                      begin
                          FindFirst(PathName + FileMask,D.Attrib,CurrFile);
                          FirstFileRead := True;
                      end;
                      Name := CurrFile.Name;
                      Attr := CurrFile.Attr;
                      Size := CurrFile.Size;
                      Time := CurrFile.Time;
                      FindNext(CurrFile);
                      if  (Name <> '.') then
                         TotFiles := Succ(TotFiles);
                  end; { with }
             until (TotFiles = (D.Rows * D.cols)) or (DOSError = 18);
             MoreFiles := (DOSError <> 18);
         end; { with }
     end; { ReadNextDirPage }


begin { ReadDirPage }
    Draw_Box;
    Fastwrite(D.TopX+1,D.TopY,attr(D.DirCol,D.BacCol),ReadMessage);
    with DPage do
    begin
        For I := 1 to Mcols do
            for J := 1 to MRows do
                FillChar(FileData[I,J]^, SizeOf(FileData[I,J]^), 0);
        if NewPage < CurrPage then
        begin
            CurrPage := 1;
            for Counter := 1 to Pred(NewPage) do
            begin
                ReadNextDirPage(DPage);
                CurrPage := Succ(CurrPage);
            end;
        end;
        CurrPage := NewPage;
        ReadNextDirPage(DPage);                   { Read current directory page }
        Fastwrite(D.TopX+1,D.TopY,attr(D.BoxCol,D.BacCol),
                  left('',length(ReadMessage),#205));
        If (length(Pathname) + 1 + length(FileMask)) < X2 - D.TopX then
           Fastwrite(D.TopX+1,D.TopY,attr(D.BoxCol,D.BacCol),
                     ' Directory '+Pathname+Filemask+' ')
        else
           Fastwrite(D.TopX+1,D.TopY,attr(D.BoxCol,D.BacCol),' '+Filemask+' ');
        DisplayDirPage(DPage);
        {now add the messages}
        Msg := ' Esc-quit';
        If ToTFiles > 0 then
           Msg := Msg + '  '+#17+#217+' to select ';
        If CurrPage > 1 then
           Msg := Msg + '  PgUp ';
        If MoreFiles then
           Msg := Msg + '  PgDn ';
        Y1 := D.TopY + D.Rows + 1;
        If D.DateTime then Y1 := succ(Y1);
        If length(Msg) <  X2 - D.TopX then
           Fastwrite(D.TopX+1,Y1,attr(D.BoxCol,D.BacCol),Msg);
    end; { with }
end; { ReadDirPage }


{\\\\\\\\\\\\\\\\\\\\\\  Cursor Movement Procs   \\\\\\\\\\\\\\\\\\\\\\}
Function SelectFile(var Dpage : DirectoryData):string;
var ChS : char;

         Procedure ProcessUp;
         var Choice : integer;
         begin
             With Dpage do
             begin
                 LoDisplayFilename(CurrEntry,Dpage);
                 If CurrEntry <= D.cols then {Top Row}
                 begin
                     If CurrEntry = 1 then
                        Choice := D.cols * D.Rows
                     else
                        Choice := (pred(D.Rows) * D.cols) + Pred(CurrEntry);
                     While Choice > TotFiles do
                           Choice := Choice - D.cols;
                     If Choice = 0 then Choice := TotFiles;
                 end
                 else
                   Choice := Currentry - D.cols;
                 CurrEntry := Choice;
                 HiDisplayFilename(CurrEntry,Dpage);
             end;  {with}
         end;  {ProcessUp}

         Procedure MouseUp;
         begin
             With Dpage do
             begin
                 If CurrEntry > D.cols then {below Top Row}
                 begin
                     LoDisplayFilename(CurrEntry,Dpage);
                     CurrEntry :=  Currentry - D.cols;
                     HiDisplayFilename(CurrEntry,Dpage);
                 end;
             end;  {with}
         end;

         Procedure ProcessDown;
         var Choice : integer;
         begin
             With Dpage do
             begin
                 LoDisplayFilename(CurrEntry,Dpage);
                 If CurrEntry + D.cols > TotFiles then {bottom row}
                 begin
                     If (CurrEntry MOD D.cols) = 0 then
                        Choice := 1
                     else
                        Choice := (Pred(CurrEntry) MOD D.cols) + 2;
                     If Choice > TotFiles then
                        Choice := 1;
                 end
                 else
                    Choice := CurrEntry + D.cols;
                 CurrEntry := Choice;
                 HiDisplayFileName(CurrEntry,Dpage);
             end; {With}
         end; {ProcessDown}

         Procedure MouseDown;
         begin
             With Dpage do
             begin
                 If CurrEntry + D.cols <= TotFiles then {not bottom row}
                 begin
                     LoDisplayFilename(CurrEntry,Dpage);
                     CurrEntry := CurrEntry + D.cols;
                     HiDisplayFileName(CurrEntry,Dpage);
                 end;
             end; {With}
         end;

         Procedure ProcessLeft;
         begin
             With Dpage do
             begin
                 LoDisplayFilename(CurrEntry,Dpage);
                 If CurrEntry = 1 then
                    CurrEntry := TotFiles
                 else
                    CurrEntry := Pred(CurrEntry);
                 HiDisplayFileName(CurrEntry,Dpage);
             end; {with}
         end; {ProcessLeft}

         Procedure MouseLeft;
         begin
             With Dpage do
             begin
                 If CurrEntry Mod D.cols <> 1 then
                 begin
                     LoDisplayFilename(CurrEntry,Dpage);
                     CurrEntry := Pred(CurrEntry);
                     HiDisplayFileName(CurrEntry,Dpage);
                 end;
             end; {with}
         end; {ProcessLeft}

         Procedure ProcessRight;
         begin
             With Dpage do
             begin
                 LoDisplayFilename(CurrEntry,Dpage);
                 If CurrEntry = TotFiles then
                    CurrEntry := 1
                 else
                    CurrEntry := Succ(CurrEntry);
                 HiDisplayFileName(CurrEntry,Dpage);
             end; {with}
         end; {ProcessRight}

         Procedure MouseRight;
         begin
             With Dpage do
             begin
                 If (CurrEntry Mod D.cols <> 0) and (CurrEntry < TotFiles) then
                 begin
                     LoDisplayFilename(CurrEntry,Dpage);
                     CurrEntry := Succ(CurrEntry);
                     HiDisplayFileName(CurrEntry,Dpage);
                 end;
             end; {with}
         end; {ProcessLeft}

         Function ProcessCR: string;
         begin
             With Dpage do
             begin
                 With FileData[CalcCol(CurrEntry),CalcRow(CurrEntry)]^ do
                 begin
                     If Subdirectory(Attr) then
                     begin
                         ChDir(Name);
                         GetDir(0,PathName);
                         If Pathname[Length(PathName)] <> '\' then
                         PathName := PathName + '\';
                         FileMask := '*.*';
                         Draw_Box;
                         ReadDirPage(Dpage,1);
                         ChS := ' ';
                         ProcessCr := '';
                     end
                     else {Not a sub-directory}
                        ProcessCr := Name;          {Could include path if desired}
                 end; {With}
             end; {with}
         end; {ProcessCR}

begin
    With Dpage do
    begin
        Repeat
             ChS := Getkey;
             If TotFiles > 0 then
             begin
                 Case upcase(Chs) of
                 CursUp   : ProcessUp;
                 #128     : MouseUp;
                 CursDown : ProcessDown;
                 #129     : MouseDown;
                 CursLeft : ProcessLeft;
                 #130     : MouseLeft;
                 CursRight: ProcessRight;
                 #131     : MouseRight;
                 PgUp     : If CurrPage > 1 then
                                ReadDirPage(Dpage,Pred(CurrPage));
                 PgDn     : If MoreFiles then
                               ReadDirPage(Dpage, Succ(CurrPage));
                 #133,
                 Enter    : SelectFile := ProcessCr;
                 #132,
                 Esc      : If D.AllowEsc then
                               SelectFile := Esc;
                 end;  {case}
             end
             else
                SelectFile := Esc;
        Until (ChS in [Enter,#133])
           or ((ChS in [Esc,#132]) and D.AllowEsc);
    end;  {with Dpage}
end;  {SelectFile}


begin   {Main function Display_Directory}
    If ValidPathname  and (MemAvail >= SizeOf(DBox.FileData[1,1]^)*Mcols*Mrows) then
    begin
        For I := 1 to Mcols do
            for J := 1 to MRows do
                GetMem(DBox.FileData[I,J],sizeof(DBox.FileData[I,J]^));
        Determine_Box_Location;
        Draw_Box;
        Dbox.CurrPage := 1;
        ReadDirPage(Dbox,1);
        Display_Directory := SelectFile(Dbox);
        For I := 1 to Mcols do
            for J := 1 to MRows do
                FreeMem(DBox.FileData[I,J],sizeof(DBox.FileData[I,J]^));
    end
    else
        Display_Directory := '';
end;

begin   {auto execute proc}
   Default_Settings;
   Horiz_Sensitivity := 3;
end.