Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/DPLUS.ZIP/DIRPLUS.PAS

Pascal/Delphi Source File | 1989-03-17 | 22.4 KB | 592 lines

program DirPlus;
{ DirPlus version 2.0                             }
{ Copyright, Rex Kerr, 1989                       }
{ The comments assume the reader is familiar with }
{ fmisc,fwrite,xwin,and file1, three of my own    }
{ units.                                          }
{ If you do not have them, you cannot recompile   }
{ DirPlus, so do not try.                         }
{ This program may cause snow on "snowy" CGA cards}
{ and it will work on EGA and VGA cards unless    }
{ they have their "large" screen on (more than    }
{ 80 by 25).                                      }

uses crt,dos,fmisc,fwrite,xwin,file1; { Units used }
{$R-}{$V-}                      { Range checking and var-string checking
                                  off }
{$M 8000,0,37000}               { Small memory size so DOS has plenty to
                                  run other programs }
type string40 = string[40];     { Size of string shown on screen }
     string12 = string[12];     { Size of string for holding filename }
var st : string;                { String containing current directory shown }
    std : dirstr;               { "Free" strings (used with FExpand) }
    stn : namestr;
    ste : extstr;
type dirsave = record                  { Record for holding file name and }
                     name : string12;  { the output seen on the screen. }
                     seen : string40;
               end;
     dirarry = array[1..200] of dirsave;  { Array to hold filenames.  112 is
                                            max for dos, but in case it
                                            somehow has more ... }
var ddir : dirarry;       { Directory name array }
    a : integer;          { Current directory length }
    choice : integer;     { Not used integer.  You may delete }
    cha,chb : char;       { Free characters (for ReadKey) }
    lnum,cnum,anum : integer;  { Positions in the array;
                                 anum holds actual position,
                                 lnum holds line number,
                                 and cnum holds column number. }
    sclin : byte;           { Current line on the screen }
    exitnow,mono : boolean; { Mono is for determining monochrome or CGA,
                              exitnow is for signaling when to exit. }

procedure cw3;   { Procedure for calling up window for some commands }
begin
     if existwindow(3) then removewindow(3);  { If it's there, get rid of it }
     gotowindow(1);                           { Make sure you're in window 1 }
     createwindow(3,1,4,80,21,7,7,'','++++++');  { Create the window }
end;  { End of cw3 }

procedure vscroll(lines : shortint);  { Procedure for scrolling screen }
begin
     vramscroll(lines,1,1,80,19,7);   { Scroll the screen }
end;

procedure bioscurshape(x,y : byte);  { Sets the cursor shape }
var regs : registers;                { using BIOS }
begin
     regs.ch := x;        { Top line goes in ch }
     regs.cl := y;        { Bottom line goes in cl }
     regs.ah := $1;       { Function $1 }
     intr($10,regs);      { Call interrupt }
end;

procedure setcuron;     { Set the cursor on }
begin
     if mono then bioscurshape(12,13)   { Monochrome cursors have different }
     else bioscurshape(6,7);            { lines than CGAs do }
end;

procedure setcuroff;  { Turn the cursor off }
begin
     bioscurshape(32,0);
end;

procedure biosgetcur(var x,y : byte);   { Get the cursor shape }
var regs : registers;
begin
     regs.bh := 0;     { Video page 0 (0 is the normal one) }
     regs.ah := $3;    { Function $3 }
     intr($10,regs);   { Call interrupt }
     x := regs.ch;     { Top line is in X }
     y := regs.cl;     { Bottom line is in Y }
end;

function num_st(num : longint) : string;  { Function turning longints to strings }
var st : string;  { function is better than procedure sometimes }
begin
     str(num,st);    { Call a procedure to do the work }
     num_st := st;   { Return the string }
end;

procedure getdir(st : string);   { Procedure to load the files in the
                                   specified directory into the variable
                                   ddir }
var dirinfo : searchrec;         { For FindFirst and FindNext }
    ast,bst,cst : string40;      { Same type as ddir's .seen }
    b : integer;                 { Free integer }
begin
     a := 0;                     { How many files found ? }
     findfirst(st,$30,dirinfo);  { Find the first file }
     while (doserror = 0) do     { While files are still there }
     begin
          inc(a);                { Another file found }
          qfillchar(ddir[a].seen[1],40,$20);  { Fill the array with spaces. }
          ddir[a].seen := dirinfo.name;   { What is shown on the screen
                                            includes the name of the file }
          if dirinfo.attr <> $20 then  { If the file is a directory, mark }
          begin                        { it with << and >> symbols }
               ddir[a].seen := #174+ddir[a].seen+#175;
          end
          else
          begin
               ddir[a].seen[0] := #15;   { If it is a file, add the size }
               ddir[a].seen := ddir[a].seen + num_st(dirinfo.size);
          end;
          ddir[a].name := dirinfo.name;  { And then save the name for later use }
          findnext(dirinfo);   { Find the next file }
     end;
end;

procedure sortdir(Lo,Hi: integer);  { Procedure to alphabetically sort the
                                      filenames. }
{ I have forgotten how this works, so I won't bother putting
  comments in... }

procedure sort(l,r: longint);
var
  i,j : word;
  x : string12;
  y : dirsave;
begin
  i:=l; j:=r; x:=(ddir[((l+r) DIV 2)].name);
  repeat
    while ddir[i].name<x do i:=i+1;
    while x<ddir[j].name do j:=j-1;
    if i<=j then
    begin
      y:=ddir[i]; ddir[i]:=ddir[j]; ddir[j]:=y;
      i:=i+1; j:=j-1;
    end;
  until i>j;
  if l<j then sort(l,j);
  if i<r then sort(i,r);
end; { Sort }
begin { SortDir }
  sort(Lo,Hi);
end;  { SortDir }

procedure fixup(var st : string);  { Fixes up the directory path given }
var pst : pathstr;
    a : byte;
begin
     pst := st;
     st := fexpand(pst);
     a := length(st);
     if (st[a] = '\') then st := st + '*.*';   { Account for wildcards }
end;

procedure writeone(sno : byte; i : integer; attr : byte);
begin  { Writes out one filename }
     if (frac(i/3) > 0.5) then   { Is it the second column? }
     begin
          vramwrit(28,sno,attr,ddir[i].seen);   { Sno is the line }
     end
     else if (frac(i/3) > 0.2) then  { Is it the first one? }
     begin
          vramwrit(1,sno,attr,ddir[i].seen);    { Attr is the attribute }
     end
     else      {If it's not either of those, it must be the third. }
     begin
          vramwrit(53,sno,attr,ddir[i].seen); { ddir[i].seen is the string }
     end;
end;

procedure getnewdir(up : boolean);  { Gets a new directory and writes it
                                      out.  If up is true, then it asks
                                      user for input. }
var pst : pathstr;
procedure writesome;   { Write out as much as you can see at one time }
var b,d : byte;
begin
     for d := 1 to 19 do clrvramline(d,7);  { Clear the screen }
     d := 1; b := 1;                        { Initialize d and b }
     while (b <= a) and (d < 20) do    { Stop if you get to last entry or }
     begin                             { line 19. }
          writeone(d,b,7);             { Write out one filename }
          if (b = 1) then writeone(d,b,112);  { The current place is 1, so
                                                write that one out it
                                                reverse video. }
          inc(b);                    { B holds array # }
          if (b > d*3) then inc(d);  { D holds line # }
     end;
end;
begin { GetNewDir }
     if up then   { If ask user for input }
     begin
          cw3;         { Create a window to write in }
          setcuron;    { Set the cursor on }
          write('Please enter directory or path:');  { Get the input }
          readln(st);
          setcuroff;   { Turn of the cursor }
          fixup(st);   { Fix up the directory path }
     end;
     getdir(st);       { Get the directory's files }
     sortdir(1,a);     { Sort the directory }
     lnum := 1;        { Set everything to the first line }
     cnum := 1;
     anum := 1;
     sclin := 1;
     if up then popwindow;  { If get rid of the window if it was called }
     clrscr;                { Clear the screen for the files }
     writesome;             { Write out the files }
     if a = 0 then getnewdir(true); { If no files are found, do it again }
end;

{ For the next few procedures, I is the array number that holds the
  filename.  It is easier to pass that way that to pass a whole string. }

procedure getdiskdir(i : integer);   { To go into a subdirectory }
var sta : pathstr;
begin
     fsplit(st,std,stn,ste);
     if ddir[i].name = '.' then exit;   { Don't do anything if you go to
                                          the same directory }
     if ddir[i].name = '..' then        { If you go back one, find last directory }
     begin
          repeat   { Go backwards until you hit a \ }
                std[0] := chr(ord(std[0])-1);
          until std[ord(std[0])] = '\';
          sta := std + '*.*';   { And add the wildcard }
     end
     else sta := std + ddir[i].name + '\*.*';  { Going in, just and the
                                                 directory name & wildcard }
     st := sta;                   { Set the directory path string }
     getnewdir(false);         { and get the new directory }
end;

procedure dorenamefile(i : integer);  { Rename a file. }
var sta,stb : pathstr;
    ret : byte;
begin
     cw3;    { User input needed, create a window for that }
     fsplit(st,std,stn,ste);    { Split the directory path and }
     sta := std + ddir[i].name; { add the file name, so now you have }
                                { the file name with the path. }
     setcuron;                  { Set the cursor on }
     write('Rename ',sta,' to: ');  { Get the input }
     readln(stb);
     setcuroff;                 { Turn the cursor off }
     stb := std + stb;          { Add the path to the filename }
     stb := fexpand(stb);       { and expand it }
     renamefile(sta,stb,ret);   { Rename the file }
     if (ret <> 0) then writeln('Error #',ret,' in renaming');
     { If there is an error, write it out. }
     popwindow;   { User's input is done, so get rid of that window; }
     if (ret = 0) then getnewdir(false);  { If the renaming went right,
                                            the file names have changed, so...}
end;

procedure docopyfile(i : integer);  { You can figure this one out }
var sta,stb : pathstr;
    ret : byte;
begin
     cw3;
     fsplit(st,std,stn,ste);
     sta := std + ddir[i].name;
     setcuron;
     write('Copy file ',sta,' to: ');
     readln(stb);
     setcuroff;
     stb := fexpand(stb);
     copyfile(sta,stb,ret);
     if (ret <> 0) then writeln('Error #',ret,' in copying');
     popwindow;
     if ret = 0 then getnewdir(false);
end;

procedure dodeletefile(i : integer);  { And this one. }
var sta : pathstr;       { Just one note:  make sure the user has at least }
    ret : byte;          { one chance to change his mind about deleting }
    ch : char;
begin
     cw3;
     fsplit(st,std,stn,ste);
     sta := std + ddir[i].name;
     setcuron;
     write('Are you sure you want to delete ',sta,'? (Y/N)');
     readln(ch);
     setcuroff;
     ch := upcase(ch);
     if (ch <> 'Y') then
     begin
          popwindow;
          exit;
     end;
     erasefile(sta,ret);
     if (ret <> 0) then writeln('Error #',ret,' in deleting');
     popwindow;
     if ret = 0 then getnewdir(false);
end;

procedure dotypefile(i : integer);  { And you can figure this one out, too. }
var sta : pathstr;  { The window created is typed into, in this case. }
    ret : byte;
begin
     cw3;
     fsplit(st,std,stn,ste);
     sta := std + ddir[i].name;
     typefile(sta,ret);
     if (ret <> 0) then writeln('Error #',ret,' in typing');
     writeln;
     writeln;
     settextattr(112);
     write('Press any key to continue...');
     settextattr(7);
     repeat until keypressed;
     ret := ord(readkey); if ret = 0 then ret := ord(readkey);
     popwindow;
end;

procedure dorunfile(i : integer);  { Run a file }
var sta,stb : pathstr;
begin
     createwindow(4,1,1,80,25,7,7,'','');  { Make a big window to save the others }
     fsplit(st,std,stn,ste);     { Get the name and path }
     sta := std + ddir[i].name;
     setcuron;                   { Set the cursor on }
     write('Enter command line: ');   { Let the user enter the command line }
     readln(stb);
     swapvectors;      { Save interrupt vectors.  This is a standard TP practice }
     exec(sta,stb);    { Run the file }
     swapvectors;      { Get the interrupt vectors back again }
     setcuroff;        { Turn cursor off }
     popwindow;        { Get rid of that big window and recall old ones }
     gotowindow(1);
     getnewdir(false);  { Program may have changed files, so re-get them }
end;

procedure dogetinfo;  { Get informaton about the directory. }
var b,c : longint;    { Such as bytes free and used and files in it }
    sta : string;     { and the default directory. }
begin                 { I'll let you figure this out yourself }
     cw3;
     b := disksize(ord(st[1]) - 64);
     c := diskfree(ord(st[1]) - 64);
     system.getdir(0,sta);
     writeln('Current default directory: ',sta);
     writeln('Number of files: ',a);
     writeln(c,' of ',b,' bytes free.');
     writeln('Disk ',((1 - c/b) * 100):5:2,'% full.');
     write('Press any key to continue...');
     repeat until keypressed;
     b := ord(readkey);
     if (b = 0) then c := ord(readkey);
     popwindow;
end;

procedure dochangedir;  { Change the default directory. }
var x,y : byte;         { See if you can figure this one out! }
    sta : pathstr;
begin
     cw3;
     setcuron;
     write('Enter new default directory: ');
     sta := 'The directory MUST be entered exactly right';
     y := wherey;
     vramwrit(lo(windmin)+1,hi(windmin)+y+1,112,sta);
     readln(sta);
     setcuroff;
     popwindow;
     {$I-}
     chdir(sta);
     {$I+}
     if ioresult <> 0 then exit
     else getnewdir(false);
end;

procedure domakedir;  { Another tricky one to create a subdirectory }
var x,y : byte;
    sta : pathstr;
begin
     cw3;
     setcuron;
     write('Enter directory to create: '); y := wherey;
     sta := 'Enter JUST the name, NOT the path';
     getxy(x,y);
     vramwrit(lo(windmin)+1,y+hi(windmin)+1,112,sta);
     readln(sta);
     setcuroff;
     fsplit(st,std,stn,ste);
     sta := std + sta;
     {$I-}
     mkdir(sta);
     {$I+}
     popwindow;
     if ioresult <> 0 then exit
     else getnewdir(false);
end;

procedure doremovedir(i : integer);  { and remove a subdirectory...}
var sta : pathstr;
begin
     fsplit(st,std,stn,ste);
     sta := std + ddir[i].name;
     {$I-}
     rmdir(sta);
     {$I+}
     if ioresult <> 0 then exit
     else getnewdir(false);
end;

procedure linewrite(lno,i : integer);   { Write out one line of filenames }
var st : string;                        { for scrolling }
    w : word;
begin
     i := ((i-1) * 3) + 1;
     qfillchar(st[1],40,$20);
     st := ddir[i].seen;
     if (i < a) then        { Write the filenames out, checking for the last one }
     begin
          st[0] := #25;
          st := st + '  ' + ddir[i+1].seen;
     end;
     if (i+1 < a) then
     begin
          st[0] := #50;
          st := st + '  ' + ddir[i+2].seen;
     end;
     vramwrit(1,lno,7,st);   { And write the line }
end;

procedure uponeline; { Go up one line on request }
begin
     if (lnum > 1) then   { If not at beginning }
     begin
          writeone(sclin,anum,7);    { Erase old highlight bar }
          dec(lnum);  dec(anum,3);  dec(sclin);  { Dec the 3 affected vars }
          if (sclin < 1) then  { If you have gone of the top of the screen,}
          begin  { Scroll the screen up one, back up the line 1, and write }
               inc(sclin);  vscroll(-1);  linewrite(sclin,lnum);
          end;   { Out the new line that has scrolled on }
          writeone(sclin,anum,112);  { Draw the new highlight bar }
     end;
end;

procedure downoneline;  { Go down 1 line on request }
begin
     if (lnum*3 < a) then  { If you are not at the end }
     begin
          writeone(sclin,anum,7);  { erase the highlight bar }
          inc(lnum);  inc(anum,3);  inc(sclin);  { Inc the vars }
          if (anum > a) then       { If this is past the last one, }
          begin
               anum := a;          { go back to the last one }
               if (frac(anum/3) > 0.5) then cnum := 2  { and set the column }
               else if (frac(anum/3) > 0.2) then cnum := 1;  { number }
          end;
          if sclin > 19 then  { If you've gone off the end of the screen,}
          begin   { scroll up one line }
               dec(sclin);  vscroll(1); linewrite(sclin,lnum);
          end;
          writeone(sclin,anum,112);  { Write out the new highlight bar }
     end;
end;

procedure leftoneline;  { Handle cursor left }
begin
     if (cnum > 1) then   { If no "backwrap" needed }
{ Backwrap is when you are at the far left of the screen and press the
  left arrow key.  You should go up one line and be at the end of the line }
     begin
          writeone(sclin,anum,7);
          dec(cnum); dec(anum);
          writeone(sclin,anum,112);
     end
     else if (anum > 1) then  { If "backwrap" needed }
     begin
          writeone(sclin,anum,7);
          cnum := 3; dec(anum); dec(lnum); dec(sclin);
          if (sclin < 1) then
          begin
               inc(sclin); vscroll(-1); linewrite(sclin,lnum);
          end;
          writeone(sclin,anum,112);
     end;
end;

procedure rightoneline;  { Handle right one }
begin
     if (cnum < 3) and (anum < a) then  { If no "forewrap" needed }
                                        { and not at end }
{ Forewrap is the same thing as backwrap, just forewrap is for going to
  the right.}
     begin
          writeone(sclin,anum,7);
          inc(cnum); inc(anum);
          writeone(sclin,anum,112);
     end
     else if (anum < a) then  { Else if not at end }
     begin
          writeone(sclin,anum,7);
          cnum := 1; inc(anum); inc(lnum); inc(sclin);
          if (sclin > 19) then
          begin
               dec(sclin); vscroll(1); linewrite(sclin,lnum);
          end;
          writeone(sclin,anum,112);
     end;
end;

procedure uptotop;  {Handle PgUp}
begin
     repeat uponeline until lnum = 1;
     if (anum > 1) then repeat leftoneline until anum = 1;
end;

procedure downtobottom; {Handle PgDn}
var ab,ac : integer;
begin
     ab := anum;
     repeat
           downoneline;
           ac := ab;
           ab := anum;
     until (anum = a) or (ab = ac);
     if (ab = ac) then
     begin
          repeat
                rightoneline;
          until (anum = a);
     end;
end;

begin  { DirPlus }
     if vid_mem_start = $B000 then mono := true else mono := false; {is mono?}
     createwindow(1,1,1,80,19,7,7,'','');  { Create window for filenames }
     createwindow(2,1,20,80,25,7,7,' COMMANDS ','******'); { window for commands }
     gotowindow(1);  { go to filenames window }
     repeat  {Should not be a repeat !}  {you can cut it out}
           exitnow := false;  { No exit yet }
           setcuroff;         { turn cursor off }
           gotowindow(2); clrscr;  { write out commands }
           writeln('1 : new directory      2 : rename        3 : copy');
           writeln('DEL : delete           ENTER : type      4 : run');
           writeln('5 : directory info     6 : change dir    7 : make dir');
             write('8 : remove dir         ESC : exit');
           gotowindow(1);    { Go to filenames window }
           getnewdir(true);  { Get filenames and write them out }
           repeat            { Handle commands until done }
                 repeat until keypressed;  { Wait for a key }
                 cha := readkey;           { get it }
                 if ddir[anum].seen[1] = #174 then   { if highlighted fname }
                 begin    { is a subdirectory, 1, and 8 are different from }
                      if cha = '1' then getdiskdir(anum);    { normal }
                      if cha = '8' then doremovedir(anum);
                 end
                 else
                 case cha of    { Only for non-subdirectory files }
                      '1' : getnewdir(true);
                      '2' : dorenamefile(anum);
                      '3' : docopyfile(anum);
                      '4' : dorunfile(anum);
                 end;
                 if cha = '5' then dogetinfo;    { Either is fine }
                 if cha = '6' then dochangedir;
                 if cha = '7' then domakedir;
                 if cha = #13 then             { If enter, type }
                 begin                  { Or go in if subdirectory }
                      if ddir[anum].seen[1] = #174 then getdiskdir(anum)
                      else dotypefile(anum);
                 end;
                 if cha = #27 then exitnow := true;  { ESC is exit }
                 if cha = #0 then      { If extended keycode }
                 begin
                      chb := readkey;  { get the extended key }
                      case chb of
                           #72 : uponeline;     { up }
                           #75 : leftoneline;   { left }
                           #77 : rightoneline;  { right }
                           #80 : downoneline;   { down }
                           #73 : uptotop;       { PgUp }
                           #81 : downtobottom;  { PgDn }
                 {Del deletes a file (or subdir) }
                           #83 : if ddir[anum].seen[1] = #174 then doremovedir(anum)
                                    else dodeletefile(anum);
                      end;
                 end;
           until exitnow;  { repeat unless time to exit (ESC pressed) }
     until exitnow;    { Can be removed, serves no purpose }
     window(1,1,80,25); settextattr(7); clrscr; setcuron;  { Leave }
end.