home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / TDIR.PAS < prev    next >
Pascal/Delphi Source File  |  2000-06-30  |  11KB  |  358 lines
  1. {
  2.   CP/M-80 directory program written in Turbo Pascal 2.0.
  3.   Based loosely on wildcard.pas, author and compiler unknown.
  4.   Accepts ambiguous file names and displays sorted directory.
  5.     File sizes rounded to next 1k increment.
  6.   Steve Fox - Albuquerque RCP/M  (505)299-5974
  7.   Version 1.0     29 Mar 1985
  8.  
  9. >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  10.  
  11.   Revised 23 Apr 85 by : William L. Mabee, CRNA Followin attributes added
  12.   Functions  :
  13.    Centered
  14.    Dash
  15.    ConstStr
  16.   Procedures :
  17.    PutItUp
  18.  
  19.   Changed Code to allow automatic display of logged DU directory will allow
  20.   code to be included in Turbo Pascal Program or chaining from main turbo
  21.   routine.
  22.  
  23.   Added prompt for which drive change source for your own system
  24.   if you have more than two drives add something like ['A..P']; and
  25.   change appropriate prompt.
  26.  
  27.   Added code to display total amount disk space used.
  28.  
  29.   Added header.
  30.  
  31. }
  32.  
  33. Program dir;
  34. label start;
  35. const
  36.   columns   = 4;
  37.   fence     = ' | ';
  38.   header    = 'File     Ext Size   File     Ext Size   File     Ext Size   File     Ext Size';
  39. type
  40.   CharSet   = set of char;
  41.   FileName  = string[14];                   { d:filename.ext }
  42.   str80     = string[80];
  43.   StrStd    = string[127];
  44.   FilePtr   = ^FileDescr;
  45.   FileDescr =
  46.     record
  47.       fname: FileName;                      { Name of a matching file }
  48.       fsize: integer;                       { Size of file }
  49.       Next: FilePtr;                        { Points to next name on linked list }
  50.     end;
  51.   FileBlock =
  52.     record
  53.       case boolean of
  54.         true:
  55.           (drive: byte;                     { Byte code }
  56.            fname: array[1..11] of char;     { File name }
  57.            extent,                          { Current extent }
  58.            s1, s2, reccount: byte;          { Used to compute file size }
  59.            dn: array[16..31] of byte);
  60.         false:
  61.           (init: array[1..32] of byte);
  62.     end;
  63.  
  64. var
  65.   CH : Char;
  66.   entries: integer;                         { Count of directory entries }
  67.   prototype: FileName;                      { Directory mask }
  68.   first: FilePtr;                           { Start of linked list }
  69.   searchblk: FileBlock;                     { Block for search }
  70.   CtrPrg: File;
  71.  
  72. Function ConstStr(C : Char; N : Integer) : Str80;
  73. var
  74.   S : string[80];
  75. begin
  76.   if N < 0 then
  77.     N := 0;
  78.   S[0] := Chr(N);
  79.   FillChar(S[1],N,C);
  80.   ConstStr := S;
  81. end;
  82.  
  83. Function Centered(TheString:Str80):Str80;
  84. begin
  85.   Centered := ConstStr(' ',((80 - Length(TheString)) Div 2)) +
  86.   TheString;
  87. end;
  88.  
  89. Function Dash(Spaces : Integer) : Str80;
  90. var
  91.   Column : Integer;
  92.   Temp   : Str80;
  93. begin
  94.   Temp :='';
  95.   For Column := 1 to Spaces do
  96.   begin
  97.     Temp := Temp + '-';
  98.     Dash := Temp;
  99.   end;
  100. end;
  101.  
  102. Function Tab(Spaces : Integer) : Str80;
  103. var
  104.   Column : Integer;
  105.   Temp   : Str80;
  106. begin
  107.   Temp :='';
  108.   For Column := 1 to Spaces do
  109.   begin
  110.     Temp := Temp + '-';
  111.     Dash := Temp;
  112.   end;
  113. end;
  114.  
  115. Procedure Choice(    Prompt : Str80;
  116.                      Term   : CharSet;
  117.                  var TC     : Char    );
  118. var
  119.   Ch : Char;
  120. begin
  121.   GotoXY(1,23); Write(Prompt); ClrEol;
  122.   repeat
  123.     Read(Kbd,Ch);
  124.     TC := Upcase(Ch);
  125.     if not (TC in Term) then
  126.       write(^G);
  127.   until TC in Term;
  128.   Write(Ch);
  129. end;
  130.  
  131. Procedure ClearFrame;
  132. var
  133.   I : Integer;
  134. begin
  135.   for I := 20 downto 3  do
  136.   begin
  137.     GotoXY(1,I + 1); ClrEol ;
  138.   end;
  139. end;
  140.  
  141.   procedure GetMask(var prototype: FileName);
  142.   { Get ambiguous file name and expand into directory mask (prototype) }
  143.     var
  144.       i, j: integer;
  145.       line: StrStd;
  146.  
  147.     function trim(st: StrStd): StrStd;
  148.     { Trim leading and trailing blanks }
  149.       var
  150.        i, j: integer;
  151.       begin
  152.         i := 1;
  153.         j := length(st);
  154.         while (st[i] = ' ') and (i <= j) do
  155.           i := succ(i);
  156.         while (st[j] = ' ') and (j >= i) do
  157.           j := pred(j);
  158.         trim := copy(st, i, j - i + 1)
  159.       end;
  160.  
  161.     function pad(line: StrStd; i: integer): StrStd;
  162.     { Pad line with spaces to length of i }
  163.       begin
  164.         while length(line) < i do
  165.           line := line + ' ';
  166.         pad := line
  167.       end;
  168.  
  169.     begin
  170.       repeat
  171.         Choice('Directory for which drive ( A or B ) ? ',['A','B'],Ch);
  172.       until Ch <> '';
  173.       ClearFrame;
  174.       line := Ch+':*.*';
  175.       line := trim(line);
  176.       for i := 1 to length(line) do
  177.         line[i] := UpCase(line[i]);
  178.       if line = ''
  179.         then line := '*.*';
  180.       line := pad(line, 14);
  181.       prototype := copy(line, 1, 14);
  182.       FillChar(searchblk.init, 32, 0);
  183.       with searchblk do
  184.         begin
  185.           if prototype[2] = ':'
  186.             then
  187.               begin
  188.                 drive := succ(ord(prototype[1]) - ord('A'));
  189.                 i := 3
  190.               end
  191.             else
  192.               begin
  193.                 drive := 0;
  194.                 i := 1
  195.               end;
  196.           fname := '           ';
  197.           j := 1;
  198.           repeat
  199.             begin
  200.               if prototype[i] = '*'
  201.                 then while j <= 8 do
  202.                   begin
  203.                     fname[j] := '?';
  204.                     j := succ(j)
  205.                   end
  206.                 else
  207.                   begin
  208.                     fname[j] := prototype[i];
  209.                     j := succ(j)
  210.                   end
  211.             end;
  212.             i := succ(i)
  213.           until (j > 8) or (prototype[i] = '.');
  214.  
  215.           while (prototype[i] <> '.') and (prototype[i] <> ' ') do
  216.             i := succ(i);
  217.  
  218.           i := succ(i);
  219.           j := 9;
  220.           repeat
  221.             begin
  222.               if prototype[i] = '*'
  223.                 then while j <= 11 do
  224.                   begin
  225.                     fname[j] := '?';
  226.                     j := succ(j)
  227.                   end
  228.                 else
  229.                   begin
  230.                     fname[j] := prototype[i];
  231.                     j := succ(j)
  232.                   end
  233.             end;
  234.             i := succ(i)
  235.           until (j > 11) or (prototype[i] = '.');
  236.           extent := ord('?');
  237.           s1     := ord('?');
  238.           s2     := ord('?')
  239.         end
  240.     end;
  241.  
  242.   procedure ReadDir(prototype: filename; var entries: integer; var first: FilePtr);
  243.   { Create an alphabetized list of files which match the prototype }
  244.     const
  245.       findfirst = 17;                       { BDOS function - search for first file }
  246.       findnext  = 18;                       { BDOS function - search for next file}
  247.       setdma    = 26;                       { BDOS function - set dma buffer address }
  248.       fcb       = $80;                      { Default dma buffer address }
  249.     type
  250.       dirblock  = array [0..3] of FileBlock;
  251.       fileblptr = ^FileBlock;
  252.     var
  253.       off: integer;                         { dir entry offset or end flag }
  254.       fn: FileName;
  255.       answerblk: dirblock;                  { block to receive file name }
  256.  
  257.     procedure insertfile(fn: FileName; fs: integer; var entries: integer; var first: FilePtr);
  258.     { Insert a new file name in the alphabetic list }
  259.       var
  260.         f,                                  { file name entry being created }
  261.         this, previous: FilePtr;            { followers for insertion }
  262.       begin
  263.         previous := nil;
  264.         this := first;
  265.         while (this <> nil) and (this^.fname < fn) do
  266.           begin
  267.             previous := this;
  268.             this := this^.next
  269.           end;
  270.         if this^.fname <> fn
  271.           then
  272.             begin
  273.               entries := succ(entries);
  274.               new(f);
  275.               f^.fname := fn;
  276.               f^.fsize := fs;
  277.               f^.next  := this;
  278.               if previous = nil
  279.                 then first := f
  280.                 else previous^.next := f
  281.             end
  282.           else if this^.fsize < fs
  283.                  then this^.fsize := fs
  284.       end;
  285.  
  286.     begin { ReadDir }
  287.       entries := 0;
  288.       first := nil;
  289.       BDOS(setdma, addr(answerblk));
  290.       off := BDOS(findfirst, addr(searchblk));
  291.       while off <> 255 do
  292.         begin
  293.           with answerblk[off] do
  294.             if (ord(fname[10]) and $80) = 0 { Non-system? }
  295.               then
  296.                 begin
  297.                   drive := 11;              { File name length }
  298.                   move(drive, fn, 12);      { File name }
  299.                   insert('.', fn, 9);
  300.                   insertfile(fn, reccount + (extent + (s2 shl 5)) shl 7, entries, first)
  301.                 end;
  302.           off := BDOS(findnext, addr(searchblk));
  303.         end;
  304.       BDOS(setdma, fcb)                     { Restore DMA buffer }
  305.     end;
  306.  
  307.   procedure DispDir(entries: integer; first: FilePtr);
  308.   { Display directory list }
  309.     var
  310.       i, size,totsize: integer;
  311.       OldName: FilePtr;
  312.     begin
  313.       i := 0;
  314.       totsize := 0;
  315.       GotoXY(1,6);
  316.       WriteLn(Header); WriteLn;
  317.       while first <> nil do
  318.         begin                               { Scan the whole list }
  319.           size := first^.fsize shr 3;
  320.           totsize := totsize + size;
  321.           if 0 <> (first^.fsize mod 8)
  322.             then size := succ(size);
  323.           write(first^.fname, size:4, 'k');
  324.           i := succ(i);
  325.           Oldname := first;
  326.           first := first^.Next;             { Go to next on chain }
  327.           dispose(Oldname);                 { Reclaim space }
  328.           if i < columns
  329.             then write(fence)
  330.             else
  331.               begin
  332.                 writeln;
  333.                 i := 0
  334.               end
  335.         end;
  336.         WriteLn;
  337.         WriteLn;
  338.         write('Total number of Files : ',entries);
  339.         writeln('              Using a total of : ',totsize,' K');
  340.     end;
  341.  
  342.   begin { main }
  343.     ClrScr;
  344.     GotoXY(1,1); Writeln(ConstStr('-',79)); WriteLn; Write(ConstStr('-',79));
  345.     GotoXY(1,2); Write(Centered('Disk Directory Routine'));
  346.     GotoXY(1,22); Writeln(ConstStr('-',79)); WriteLn; Write(ConstStr('-',79));
  347.     start :
  348.     clearFrame;
  349.     GetMask(prototype);                     { Read mask }
  350.     ReadDir(prototype, entries, first);     { Read directory }
  351.     DispDir(entries, first);                { Display directory }
  352.     repeat
  353.       Choice('Do directory on another drive ( Y or N ) : ',['Y','N'],CH);
  354.       if Ch = 'Y' then goto start;
  355.     until Ch = 'N';
  356.     ClrScr;
  357.   end.
  358.