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 / TKERMIT.LBR / KDIR.PQS / KDIR.PAS
Pascal/Delphi Source File  |  2000-06-30  |  7KB  |  192 lines
  1.  
  2.     procedure adjust_fn(fileref : string15; var drive : string1;
  3.                         var filename : string15; var filetype : string3);
  4.  
  5.       (* This procedure converts a string into the standard CP/M format
  6.          for processing. This format is all upper case, and inserts ?'s
  7.          into the string if the wildcards ? or * are found in the string.
  8.          Finally, the string is expanded so spaces are placed in any
  9.          unfilled positions in the name.  these are placed in the middle of
  10.          the filename, i.e.  abc.de is converted to 'abc     . de'.
  11.       *)
  12.  
  13.       var
  14.         insert_pos, count : integer;
  15.  
  16.       begin
  17.         for count := 1 to length(fileref) do (* convert to upper case *)
  18.           if (fileref[count] in ['a'..'z']) then
  19.             fileref[count] := chr(ord(fileref[count]) and $df);
  20.         if pos('.', fileref) <> 0 then (* separate the file name and type *)
  21.           begin
  22.             filename := copy(fileref, 1, pos('.', fileref) - 1);
  23.             filetype := copy(fileref, pos('.', fileref) + 1, 3);
  24.           end
  25.         else
  26.           begin
  27.             filename := fileref;
  28.             filetype := ''; (* no file type in this case *)
  29.           end;
  30.         if pos(':', filename) <> 0 then (* check for drive spec *)
  31.           begin
  32.             drive := copy(filename, 1, pos(':', filename) - 1);
  33.             delete(filename, 1, pos(':', filename));
  34.             if filename = '' then
  35.               begin
  36.                 filename := '*';
  37.                 filetype := '*';
  38.               end;
  39.           end
  40.         else
  41.           drive := '!'; (* dummy value for param *)
  42.  
  43.         while (pos('*',filename) <> 0) do (* find any '*' wildcards *)
  44.           begin
  45.           insert_pos := pos('*', filename); (* find the spot *)
  46.           delete(filename, insert_pos, 1);  (* get rid of * *)
  47.           while (length(filename) < 8) do
  48.             (* insert ?'s until filename is filled. Note that the first '*'
  49.                will fill the string, so any other *'s in the name will be
  50.                deleted and replaced with a single '?'.  '*k*' will be
  51.                converted to '??????k?'
  52.             *)
  53.             insert('?', filename, insert_pos);
  54.         end;
  55.         while pos('*',filetype) <> 0 do (* do the same for the filetype *)
  56.           begin
  57.             insert_pos := pos('*', filetype);
  58.             delete(filetype, insert_pos, 1);
  59.             while (length(filetype) < 3) do
  60.               insert('?', filetype, insert_pos);
  61.           end;
  62.         while length(filename) < 8 do (* fill out the filename with spaces *)
  63.           filename := filename + ' ';
  64.         while length(filetype) < 3 do (* do the same for the filetype *)
  65.           filetype := filetype + ' ';
  66.       end; (* adjust_fn *)
  67.  
  68.     procedure init_fcb(infile : string15);
  69.  
  70.       (* initialize an fcb with a filename and filetype for use with BDOS
  71.          calls
  72.       *)
  73.  
  74.       var
  75.         count : integer;
  76.         drive : string1;
  77.         filename : string[15];
  78.         filetype : string[3];
  79.  
  80.       begin
  81.  
  82.         adjust_fn(infile, drive, filename, filetype); (* put filespec in proper form *)
  83.         if drive in ['A'..'P'] then
  84.           fcb[1] := ord(drive) - 64 (* store the drive spec *)
  85.         else
  86.           fcb[1] := 0; (* use default drive *)
  87.         for count := 1 to 8 do (* put in the filename. Array operation, not string *)
  88.           fcb[1 + count] := ord(filename[count]);
  89.         for count := 1 to 3 do (* same for filetype. Must be integers here *)
  90.           fcb[9 + count] := ord(filetype[count]);
  91.         for count := 13 to 36 do (* rest of FCB is 0's *)
  92.           fcb[count] := 0;
  93.       end;
  94.  
  95.     procedure searchfirst(var result : integer);
  96.  
  97.       (* search for first BDOS call.  Result is position in DMA buffer of
  98.          filespec, or 255 if no file is found *)
  99.  
  100.       begin
  101.         result := bdos($11, addr(fcb));
  102.       end;
  103.  
  104.     procedure searchnext(var result : integer);
  105.  
  106.       (* search for next BDOS call. Result is same as above *)
  107.  
  108.       begin
  109.         result := bdos($12, addr(fcb));
  110.       end;
  111.  
  112.   procedure dir; (* generate directory listing *)
  113.  
  114.     (* generate a directory listing.  This is a CP/M dependent procedure and
  115.        would have to be changed for other operating systems.  No size
  116.        information is printed
  117.     *)
  118.  
  119.     var
  120.       filename : string[15];
  121.       filetype : string[3];
  122.       index, count, result : integer;
  123.  
  124.   begin
  125.     if arg1 = '' then
  126.       arg1 := '*.*'; (* we'll read all the filenames *)
  127.     init_fcb(arg1);  (* set up the FCB *)
  128.     bdos($1a, addr(dma)); (* set up the dma address *)
  129.     searchfirst(result);  (* look for the first directory entry *)
  130.     count := 0; (* cont for formatting output into 4 per line *)
  131.     if result <> 255 then (* write the first filename *)
  132.       begin
  133.         writeln;
  134.         writeln('Directory listing for ', arg1);
  135.         writeln;
  136.         for index := ((result * 32) + 1) to ((result * 32) + 9) do
  137.           write(chr(dma[index]));
  138.         write('.');
  139.         for index := ((result * 32) + 10) to ((result * 32) + 12) do
  140.             write(chr(dma[index]));
  141.         write(' : ');
  142.         count := count + 1;
  143.       end
  144.     else
  145.       writeln('no file'); (* guess it doen't exist *)
  146.     while (result <> 255) do
  147.       begin
  148.         searchnext(result); (* keep looking *)
  149.         if result <> 255 then
  150.           begin
  151.             count := count + 1; (* bump the display counter *)
  152.             for index := (result * 32) + 1 to ((result * 32) + 9) do
  153.               write(chr(dma[index]));
  154.             write('.');
  155.             for index := ((result * 32) + 10) to ((result * 32) + 12) do
  156.               write(chr(dma[index]));
  157.             if ((count mod 5) = 0) then
  158.               writeln
  159.             else
  160.               write(' : ');
  161.         end;
  162.     end;
  163.     writeln;
  164.   end;
  165.  
  166.   procedure delfile; (* delete the selected files *)
  167.  
  168.     var
  169.       result : integer;
  170.       fileref : string15;
  171.  
  172.     procedure deletefile(var result : integer);
  173.  
  174.       begin
  175.         result := bdos($13, addr(fcb));
  176.       end;
  177.  
  178.     begin (* delfile *)
  179.       if arg1 = '' then
  180.         begin
  181.           writeln;
  182.           write('Enter file(s) to erase: ');
  183.           readln(arg1);
  184.         end;
  185.       init_fcb(arg1);
  186.       deletefile(result);
  187.       if result in [0..3] then
  188.         writeln('File(s) deleted.')
  189.       else
  190.         writeln('File(s) not found.');
  191.       writeln;
  192.     end; (* delfile *)