home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TURBODIR.ZIP / TURBDIR.PAS
Encoding:
Pascal/Delphi Source File  |  1985-10-13  |  12.8 KB  |  417 lines
  1. (*--------------------------------------------------------------------------*)
  2. (*                                                                          *)
  3. (* Written by Laszlo S. Gonc for Turbo Version 3.0                          *)
  4. (*                                                                          *)
  5. (* Can be contacted via Gene Plantz IBBS                                    *)
  6. (*                      (312) 885-9557 or  (312) 882-4227                   *)
  7. (*                      my user ID is #0537                                 *)
  8. (*                                                                          *)
  9. (* The directory procedure mimics the display of diskette file information  *)
  10. (* as that of the DIR command in PC-DOS.                                    *)
  11. (*                                                                          *)
  12. (* After finding many half-assed routines all over the place for getting    *)
  13. (* a directory from Turbo, I decided to write one myself that actually      *)
  14. (* handled problems like a diskette not having a volume label.              *)
  15. (*                                                                          *)
  16. (* However, no matter how much you strive for perfection, Murphy's law      *)
  17. (* will always hold a firm grip on the programming world. The PRINTDIR      *)
  18. (* procedure will print a directory of your diskette showing filename,      *)
  19. (* size, date, and time.                                                    *)
  20. (*                                                                          *)
  21. (* A MAJOR problem exists in the routine that determines the file creation  *)
  22. (* time, and for the life of me, I cannot figure out what the problem is.   *)
  23. (* The curious aspect is that the correct time is given SOMETIMES.          *)
  24. (*                                                                          *)
  25. (* If anyone can solve this problem, please let me know and upload the      *)
  26. (* edited version to Gene Plantz IBBS. Thanks in advance.                   *)
  27. (*--------------------------------------------------------------------------*)
  28.  
  29. type regPack = record case integer of
  30.                 1 : (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: integer);
  31.                 2 : (AL,AH,BL,BH,CL,CH,DL,DH         : byte   );
  32.                end;
  33.      st80    = string[80];
  34.  
  35. var cursor : integer;
  36.     regs   : regpack;
  37. (*--------------------------------------------------------------------------*)
  38. (* Procedures to turn the cursor on and off.                                *)
  39. (*--------------------------------------------------------------------------*)
  40. procedure cursorOff;
  41. begin
  42.   regs.AX := $0300;
  43.   intr ($10,regs);
  44.   cursor := regs.CX;
  45.   regs.AX := $0100;
  46.   regs.CX := $2000;
  47.   intr ($10,regs)
  48. end;
  49.  
  50. procedure cursorOn;
  51. begin
  52.   regs.AX := $0100;
  53.   regs.CX := cursor;
  54.   intr ($10,regs)
  55. end;
  56.  
  57. (*--------------------------------------------------------------------------*)
  58. (* Procedure to read the keyboard (extended scan codes as well).            *)
  59. (*--------------------------------------------------------------------------*)
  60. procedure get (var ch:char);
  61. begin
  62.   read (kbd,ch);
  63.   if (ch = #27) and keypressed then
  64.   begin
  65.     read (kbd,ch);
  66.     case ch of
  67.       #15 : ch := ^O;     { tab backwards           }
  68.       #72 : ch := ^E;     { cursor up,    control-E }
  69.       #75 : ch := ^S;     { cursor left,  control-S }
  70.       #77 : ch := ^D;     { cursor right, control-D }
  71.       #80 : ch := ^X;     { cursor down,  control-X }
  72.       #82 : ch := ^V;     { insert                  }
  73.       #83 : ch := ^G;     { delete                  }
  74.       else ch := #00;
  75.     end;
  76.   end;
  77. end;
  78.  
  79. (*--------------------------------------------------------------------------*)
  80. (* Procedure to accept input, format (row,column,size,datatype,string,esc)  *)
  81. (*--------------------------------------------------------------------------*)
  82. procedure accept (r,c,l,d:integer; var temp:st80; var esc:boolean);
  83. var x   : integer;
  84.     ch  : char;
  85.     ins : boolean;
  86. procedure println;
  87. begin
  88.   cursorOff;
  89.   gotoxy (c,r);
  90.   write (temp);
  91.   clreol;
  92.   gotoxy (x,r);
  93.   cursorOn;
  94. end;
  95. procedure format;
  96. begin
  97.   if x < c + l - 1 then
  98.   begin
  99.     if ins then
  100.       temp := copy (temp,1,x - c) + ch + copy (temp,x - c + 1,c + l - x - 1)
  101.     else temp := copy (temp,1,x - c) + ch + copy (temp,x - c + 2,c + l - x);
  102.     x := x + 1;
  103.   end
  104.   else begin
  105.          if x = c + l - 1 then
  106.            x := x + 1;
  107.          temp := copy (temp,1,l - 1) + ch;
  108.        end;
  109. end;
  110. begin
  111.   esc := false;
  112.   ins := false;
  113.   x := c;
  114.   println;
  115.   repeat
  116.     get (ch);
  117.     if ch = #27 then
  118.     begin
  119.       esc := true;
  120.       temp := '';
  121.       exit;
  122.     end;
  123.     case ch of
  124.       #4  : if x < c + length (temp) then
  125.               x := x + 1;
  126.       #7  : temp := copy (temp,1,x - c) + copy (temp,x - c + 2,l);
  127.       #8  : if not (x <= c) then
  128.             begin
  129.               delete (temp,x - c,1);
  130.               x := x - 1;
  131.             end;
  132.       #9  : x := c + length (temp);
  133.       #15 : x := c;
  134.       #19 : if x > c then
  135.               x := x - 1;
  136.       #22 : ins := not (ins);
  137.       else if ch <> #13 then
  138.            case d of
  139.            1 : if upcase (ch) in
  140.                [#33,#35..#38,#40..#42,#44..#57,#63..#90,#95,#96,#123,#125]
  141.                then format;
  142.            end;
  143.     end;
  144.     println;
  145.   until ch in [#13];
  146. end;
  147.  
  148. (*--------------------------------------------------------------------------*)
  149. (* Procedure to draw a border in high video at the specified coordinates.   *)
  150. (*--------------------------------------------------------------------------*)
  151. procedure border (ux,uy,lx,ly:integer);
  152. var x : integer;
  153. begin
  154.   cursorOff;
  155.   gotoxy (ux,uy);
  156.   write  (#213);
  157.   for x := ux + 1 to lx - 1 do
  158.     write (#205);
  159.   write  (#184);
  160.   for x := uy + 1 to ly - 1 do
  161.   begin
  162.     gotoxy (ux,x);
  163.     write (#179);
  164.     gotoxy (lx,x);
  165.     write (#179);
  166.   end;
  167.   gotoxy (ux,ly);
  168.   write  (#212);
  169.   for x := ux + 1 to lx - 1 do
  170.     write (#205);
  171.   write  (#190);
  172.   cursorOn;
  173. end;
  174.  
  175. (*--------------------------------------------------------------------------*)
  176. (* Procedure to display 'Press any key to continue...'                      *)
  177. (*--------------------------------------------------------------------------*)
  178. procedure presskey;
  179. begin
  180.   writeln;
  181.   write (' Press any key to continue...');
  182.   repeat until keypressed;
  183. end;
  184.  
  185. (*--------------------------------------------------------------------------*)
  186. (* Procedure to give a directory of a diskette.                             *)
  187. (*--------------------------------------------------------------------------*)
  188. procedure printDir;
  189. type
  190.   info    = record
  191.              filename   : string[20];
  192.              size       : real;
  193.              time       : string[6];
  194.              date       : string[8];
  195.              attribute  : string[2];
  196.             end;
  197.   char80 = array[1..80] of char;
  198. var
  199.   numberFiles,
  200.   DTAseg, DTAofs,
  201.   setDTAseg, setDTAofs,
  202.   error, option,
  203.   x, y, z               : integer;
  204.   r                     : real;
  205.   DTA                   : array[1..43] of byte;
  206.   month, day, hour, min : string[2];
  207.   year                  : string[4];
  208.   field                 : string[12];
  209.   name,temp,cdi         : string[80];
  210.   ch                    : char;
  211.   mask                  : char80;
  212.   entry                 : info;
  213.   flag,esc              : boolean;
  214. procedure setDTA (segment,offset:integer; var error:integer);
  215. begin
  216.   regs.AX := $1A00;
  217.   regs.DS := segment;
  218.   regs.DX := offset;
  219.   msdos (regs);
  220.   error := regs.AX and $FF;
  221. end;
  222. procedure getCurrentDTA (var segment,offset,error:integer);
  223. begin
  224.   regs.AX := $2F00;
  225.   msdos (regs);
  226.   segment := regs.ES;
  227.   offset  := regs.BX;
  228.   error   := regs.AX and $FF;
  229. end;
  230. procedure getEntry (var entry:info; segment,offset,option:integer; var error:integer);
  231. begin
  232.   error := 0;
  233.   getdir (0,cdi);
  234.   if flag then
  235.   begin
  236.     if option = 8 then
  237.       chdir (copy (cdi,1,2) + '\')
  238.     else chdir (cdi);
  239.     regs.AX := $4E00;
  240.     regs.DS := seg (mask);
  241.     regs.DX := ofs (mask);
  242.     regs.CX := option;
  243.   end
  244.   else begin
  245.          regs.AX := $4F00;
  246.          regs.CX := option;
  247.        end;
  248.   msdos (regs);
  249.   error := regs.AX and $FF;
  250.   with entry do
  251.   begin
  252.     attribute := '..';
  253.     x := mem[segment:offset + 21];
  254.     if ((x and 223) = 0) or ((x and 1) = 1) then
  255.       attribute := 'R.';
  256.     if (x and 16) = 16 then
  257.       insert ('D',attribute,2);
  258.  
  259.  
  260. (* Determine the creation time of the file. Works SOMETIMES ?! *)
  261.     x := mem[segment:offset + 23];
  262.     str ((x shr 3):2,hour);
  263.     x := 8 * (x and 3);
  264.     x := x + (mem[segment:offset + 22] shr 5);
  265.     str (x,min);
  266.     if length (min) < 2 then
  267.       min := '0' + min;
  268.     val (hour,y,z);
  269.     case y of
  270.       0      : begin
  271.                  hour := '12';
  272.                  ch := 'a';
  273.                end;
  274.       1..11  : ch := 'a';
  275.       12     : ch := 'p';
  276.       13..23 : begin
  277.                  str (y - 12,hour);
  278.                  ch := 'p';
  279.                end;
  280.     end;
  281.     time := hour + ':' + min + ch;
  282. (* End file creation time determination algorithm. *)
  283.  
  284.     x := mem[segment:offset + 25];
  285.     str ((80 + (x shr 1)):2,year);
  286.     x := 8 * (x and 1);
  287.     x := x + (mem[segment:offset + 24] shr 5);
  288.     str (x:2,month);
  289.     x := mem[segment:offset + 24];
  290.     str ((x and 31),day);
  291.     if length (day) < 2 then
  292.       day := '0' + day;
  293.     date := month + '-' + day + '-' + year;
  294.     size := 0;
  295.     size := mem[segment:offset + 26] +
  296.             mem[segment:offset + 27] * 256.0 +
  297.             mem[segment:offset + 28] * 65536.0 +
  298.             mem[segment:offset + 29] * 16777200.0;
  299.     x := 1;
  300.     repeat
  301.       name[x] := chr (mem[segment:offset + 29 + x ]);
  302.       x := x + 1;
  303.     until (not (name[x-1] in [' '..'~']));
  304.     name[0] := chr (x-1);
  305.     filename := name;
  306.     if option <> 8 then
  307.     begin
  308.       if pos ('.',filename) <> 0 then
  309.       begin
  310.         if (copy (filename,1,1) = '.') or (copy (filename,1,2) = '..') then
  311.         begin
  312.           for x := 1 to 12 - length (filename) do
  313.             filename := filename + ' ';
  314.         end
  315.         else begin
  316.                if pos ('.',filename) < 9 then
  317.                  for x := 1 to 9 - pos ('.',filename) do
  318.                    insert (' ',filename, pos ('.',filename));
  319.                if length (filename) < 12 then
  320.                  for x := 1 to 12 - length (filename) do
  321.                    filename := filename + ' ';
  322.                delete (filename,9,1);
  323.                insert (' ',filename,9);
  324.              end;
  325.       end
  326.       else for x := 1 to 13 - length (filename) do
  327.              filename := filename + ' ';
  328.     end;
  329.   if attribute[2] = 'D' then
  330.     insert ('<DIR>',filename,14);
  331.   end;
  332. end;
  333. procedure initFilename;
  334. begin
  335.   for x := 1 to 21 do
  336.     DTA[x] := 0;
  337.   for x := 1 to 80 do
  338.   begin
  339.     mask[x] := chr (0);
  340.     name[x] := chr (0);
  341.   end;
  342.   name[0] := chr (0);
  343.   getCurrentDTA (DTAseg,DTAofs,error);
  344.   setDTAseg := seg (DTA);
  345.   setDTAofs := ofs (DTA);
  346.   setDTA (setDTAseg,setDTAofs,error);
  347.   error := 0;
  348.   for x := 1 to length (field) do
  349.     mask[x] := field[x];
  350. end;
  351. begin
  352.   gotoxy (2,20);
  353.   write ('Directory mask:');
  354.   temp := '';
  355.   accept (20,18,12,1,temp,esc);
  356.   if esc then exit;
  357.   border (38,1,80,24);
  358.   cursorOff;
  359.   window (39,2,79,23);
  360.   gotoxy (1,1);
  361.   field := '*.*' + chr (0);
  362.   initFilename;
  363.   option := 8;
  364.   flag := true;
  365.   getEntry (entry,setDTAseg,setDTAofs,option,error);
  366.   delete (entry.filename,pos ('.',entry.filename),1);
  367.   write (' Volume in drive ',copy (cdi,1,1));
  368.   if (error = 0) then
  369.     writeln (' is ',entry.filename)
  370.   else writeln (' has no label');
  371.   writeln;
  372.   setDTA (DTAseg,DTAofs,error);
  373.   if temp = '' then
  374.     field := '*.*' + chr (0)
  375.   else field := temp + chr (0);
  376.   numberFiles := 0;
  377.   initFilename;
  378.   option := 16;
  379.   getEntry (entry,setDTAseg,setDTAofs,option,error);
  380.   flag := false;
  381.   with entry do
  382.   begin
  383.     if (error = 0) then
  384.     begin
  385.       if attribute[2] = 'D' then
  386.         writeln (filename:19,date:12,time:8)
  387.       else writeln (filename:14,size:7:0,date:10,time:8);
  388.     end
  389.     else writeln ('  File not found');
  390.     if attribute[1] = 'R' then
  391.       numberFiles := numberFiles + 1;
  392.   end;
  393.   while (error = 0) do
  394.   begin
  395.     getEntry (entry,setDTAseg,setDTAofs,option,error);
  396.     with entry do
  397.     begin
  398.       if (error = 0) then
  399.       begin
  400.         if attribute[1] = 'R' then
  401.           numberFiles := numberFiles + 1;
  402.         if attribute[2] = 'D' then
  403.           writeln (filename:19,date:12,time:8)
  404.         else writeln (filename:14,size:7:0,date:10,time:8);
  405.       end;
  406.     end;
  407.   end;
  408.   setDTA (DTAseg,DTAofs,error);
  409.   regs.AX := $36 shl 8;
  410.   regs.DX := 0;
  411.   msdos (regs);
  412.   r := regs.CX;
  413.   writeln ('  ',numberFiles:3,' file(s)','  ',regs.AX * regs.BX * r:12:0,' bytes free');
  414.   presskey;
  415.   window (1,1,80,25);
  416.   cursorOn;
  417. end;