home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TM40.ZIP / DIRECT.INC < prev    next >
Encoding:
Text File  |  1985-07-20  |  11.3 KB  |  336 lines
  1. (****************************************************************************)
  2. (*                         GET DEFAULT DRIVE LETTER                         *)
  3. (****************************************************************************)
  4.    function
  5.       default_drive : char;
  6.    begin
  7.       regs.AX := $1900;
  8.       msdos( regs );
  9.       default_drive := chr(ord('A')+lo(regs.AX));
  10.    end;
  11.  
  12. (****************************************************************************)
  13. (*                          CHANGE DEFAULT DRIVE                            *)
  14. (****************************************************************************)
  15.    procedure
  16.       change_drive(dr : char);
  17.    begin
  18.       regs.AX := $0E00;
  19.       regs.DX := ord(upcase(dr)) - ord('A');
  20.       msdos( regs );
  21.    end;
  22.  
  23. (****************************************************************************)
  24. (*                          DISK SPACE AVAILABLE                            *)
  25. (****************************************************************************)
  26.    function
  27.       diskspace(dr : char) : integer;
  28.    var
  29.       r            : real;
  30.    begin
  31.       regs.AX := $3600;
  32.       regs.DX := ord(upcase(dr)) - pred(ord('A'));
  33.       msdos( regs );
  34.       r := ((regs.AX * regs.CX * 1.0) * regs.BX);
  35.       diskspace := round( r / 1024.0);
  36.    end;
  37.  
  38. (****************************************************************************)
  39. (*                           TIME SERVICE ROUTINES                          *)
  40. (****************************************************************************)
  41.    function
  42.       time       : string20;
  43.    var
  44.       h,m,s,w    : string10;
  45.       i          : integer;
  46.    begin
  47.       regs.AX := $2C00;
  48.       intr($21,regs);
  49.       str(hi(regs.CX):2,h);
  50.       str(lo(regs.CX):2,m);
  51.       str(hi(regs.DX):2,s);
  52.       w := h + ':' + m + ':' + s;
  53.       for i:=2 to 8 do if w[i]=' ' then w[i]:='0';
  54.       time:=w;
  55.    end;
  56.    function
  57.       delta_time(t1,t2 : string20) : string20;
  58.    var
  59.       h,m,s       : integer;
  60.       th,tm,ts,tw : string10;
  61.    begin
  62.       h:=bval(copy(t2,1,3)) - bval(copy(t1,1,3));
  63.       m:=bval(copy(t2,4,3)) - bval(copy(t1,4,3));
  64.       s:=bval(copy(t2,7,3)) - bval(copy(t1,7,3));
  65.       if s<0 then begin
  66.          s:=s+60;
  67.          m:=pred(m);
  68.       end;
  69.       if m<0 then begin
  70.          m:=m+60;
  71.          h:=pred(h);
  72.       end;
  73.       if h<0 then h:=h+24;
  74.       str(h:2,th);
  75.       str(m:2,tm);
  76.       str(s:2,ts);
  77.       tw:=th+':'+tm+':'+ts;
  78.       for s:=2 to 8 do if tw[s]=' ' then tw[s]:='0';
  79.       delta_time := tw;
  80.    end;
  81.  
  82. (****************************************************************************)
  83. (*                     DISPLAY CURRENT DRIVE\DIRECTORY                      *)
  84. (****************************************************************************)
  85.    procedure
  86.       displ_curr_dr;
  87.    var
  88.       curdir       : string40;
  89.       dn           : integer;
  90.       ch           : char;
  91.    begin
  92.       ch := default_drive;
  93.       dn := ord(ch) - pred(ord('A'));
  94.       getdir(dn,curdir);
  95.       writeln(' Current Drive\Directory: ',curdir);
  96.    end;
  97.  
  98. (****************************************************************************)
  99. (*                            FILE COPY ROUTINE                             *)
  100. (****************************************************************************)
  101.    procedure
  102.       copy_file;
  103.    type
  104.       buffer_pointer = ^buffer_type;
  105.       buffer_type    = array[ 1..128 ] of byte;
  106.    var
  107.       source, dest   : file;
  108.       sourcename     : string40;
  109.       destname       : string40;
  110.       recsread       : integer;
  111.       buff_pointer   : buffer_pointer;
  112.    begin
  113.       mkwin(10,3,71,11,'File Copy');
  114.       writeln;
  115.       displ_curr_dr;
  116.       writeln;
  117.       repeat
  118.          write(' Copy from: ');
  119.          readln(sourcename);
  120.          if length(sourcename)=0 then begin
  121.             rmwin;
  122.             exit;
  123.          end;
  124.          assign(source,sourcename);
  125.          {$I-}
  126.          reset(source);
  127.          {$I+}
  128.          ok := (ioresult=0);
  129.          if not ok then
  130.             writeln(' Cannot find file: ',sourcename);
  131.       until ok;
  132.       repeat
  133.          write(' Copy to  : ');
  134.          readln(destname);
  135.          if length(destname)=0 then begin
  136.             close( source );
  137.             rmwin;
  138.             exit;
  139.          end;
  140.          assign(dest,destname);
  141.          {$I-}
  142.          rewrite(dest);
  143.          {$I+}
  144.          ok := (ioresult=0);
  145.          if not ok then
  146.             writeln(' Cannot create file: ',destname);
  147.       until ok;
  148.       new( buff_pointer );
  149.       repeat
  150.          blockread(source,buff_pointer^,1,recsread);
  151.          blockwrite(dest,buff_pointer^,1);
  152.       until recsread=0;
  153.       close( dest );
  154.       close( source );
  155.       dispose( buff_pointer );
  156.       rmwin;
  157.    end;
  158.  
  159. (****************************************************************************)
  160. (*                          DISK DIRECTORY HANDLERS                         *)
  161. (****************************************************************************)
  162.    type
  163.       Char40arr       = array [ 1..40 ] of Char;
  164. (****************************************************************************)
  165. (*  SetDTA resets the current DTA to the new address specified in the       *)
  166. (*  parameters 'SEGMENT' and 'OFFSET'.                                      *)
  167. (****************************************************************************)
  168.       procedure
  169.          SetDTA( Segment, Offset : Integer; var Error : Integer );
  170.       begin
  171.          Regs.AX := $1A00;
  172.          Regs.DS := Segment;
  173.          Regs.DX := Offset;
  174.          MSDos( Regs );
  175.          Error := Regs.AX and $FF;
  176.       end;
  177.  
  178. (****************************************************************************)
  179. (*  GetCurrentDTA is used to get the current Disk Transfer Area ( DTA )     *)
  180. (*  address.  A function code of $2F is stored in the high Byte of the AX   *)
  181. (*  register and a call to the predefined procedure MSDos is made.  This    *)
  182. (*  can also be accomplished by using the "Intr" procedure with the same    *)
  183. (*  register record and a $21 specification for the interrupt.              *)
  184. (****************************************************************************)
  185.       procedure
  186.           GetCurrentDTA( var Segment, Offset : Integer;
  187.                          var Error : Integer );
  188.       begin
  189.          Regs.AX := $2F00;
  190.          MSDos( Regs );
  191.          Segment := Regs.ES;
  192.          Offset := Regs.BX;
  193.          Error := Regs.AX and $FF;
  194.       end;
  195.  
  196. (****************************************************************************)
  197. (*  GetFirst gets the first directory entry of a particular file Mask.  The *)
  198. (*  Mask is passed as a parameter 'Mask'.                                   *)
  199. (****************************************************************************)
  200.       procedure
  201.          GetFirst( Mask : Char40arr; var NamR : String40;
  202.                    Segment, Offset : Integer; Option : Integer;
  203.                    var Error : Integer );
  204.       var
  205.          I : Integer;
  206.       begin
  207.          Error := 0;
  208.          Regs.AX := $4E00;
  209.          Regs.DS := Seg( Mask );
  210.          Regs.DX := Ofs( Mask );
  211.          Regs.CX := Option;
  212.          MSDos( Regs );
  213.          Error := Regs.AX and $FF;
  214.          I := 1;
  215.          repeat
  216.             NamR[ I ] := Chr( mem[ Segment : Offset + 29 + I ] );
  217.             I := succ(I);
  218.          until ( not ( NamR[ pred(I) ] in [ ' '..'~' ] ));
  219.          NamR[ 0 ] := Chr( pred(I) );
  220.       end;
  221.  
  222. (****************************************************************************)
  223. (*  GetNextEntry uses the first bytes of the DTA for the file Mask, and     *)
  224. (*  returns the next file entry on disk corresponding to the file Mask.     *)
  225. (****************************************************************************)
  226.       procedure
  227.          GetNextEntry( var NamR : String40; Segment, Offset : Integer;
  228.                        Option : Integer; var Error : Integer );
  229.       var
  230.          I : Integer;
  231.       begin
  232.          Error := 0;
  233.          Regs.AX := $4F00;
  234.          Regs.CX := Option;
  235.          MSDos( Regs );
  236.          Error := Regs.AX and $FF;
  237.          I := 1;
  238.          repeat
  239.             NamR[ I ] := Chr( mem[ Segment : Offset + 29 + I ] );
  240.             I := succ(I);
  241.          until ( not ( NamR[ pred(I) ] in [ ' '..'~' ] ));
  242.          NamR[ 0 ] := Chr( pred(I) );
  243.       end;
  244.  
  245.    var
  246.       mask                : char40arr;
  247.       dtaseg,dtaofs,error : integer;
  248.       setdtaseg,setdtaofs : integer;
  249.       dta                 : record
  250.                                dta_dos      : array[1..26] of byte;
  251.                                lo_file_s1   : byte;
  252.                                lo_file_s2   : byte;
  253.                                hi_file_s1   : byte;
  254.                                hi_file_s2   : byte;
  255.                                dta_fname    : array[1..13] of byte;
  256.                             end;
  257.       namr                : string40;
  258.  
  259.    procedure
  260.       dir_list;
  261.  
  262.    {$I-}
  263.  
  264.    var
  265.       i,j,option   : Integer;
  266.       Buffer       : string40;
  267.       horz_tab     : byte;
  268.  
  269. (****************************************************************************)
  270. (*                        LIST DIRECTORY OF DISK                            *)
  271. (****************************************************************************)
  272.    begin
  273.       mkwin(1,1,80,24,'Disk Directory');
  274.       horz_tab := 4;
  275.       for I := 1 to 40 do begin
  276.          Mask[ I ] := Chr( 0 );
  277.          NamR[ I ] := Chr( 0 );
  278.       end;
  279.       NamR[ 0 ] := Chr( 0 );
  280.       GetCurrentDTA( DTAseg, DTAofs, Error );
  281.       if ( Error <> 0 ) then begin
  282.          WriteLn( 'Unable to get current DTA' );
  283.          WriteLn( 'Program aborting.' );
  284.          Halt;
  285.       end;
  286.       SetDTAseg := Seg( DTA );
  287.       SetDTAofs := Ofs( DTA );
  288.       SetDTA( SetDTAseg, SetDTAofs, Error );
  289.       if ( Error <> 0 ) then begin
  290.          WriteLn( 'Cannot reset DTA' );
  291.          WriteLn( 'Program aborting.' );
  292.          Halt;
  293.       end;
  294.       Error := 0;
  295.       Buffer := '';
  296.       Option:=16;
  297.       displ_curr_dr;
  298.       Write('                Dir Mask: ' );
  299.       ReadLn( Buffer );
  300.       WriteLn;
  301.       if ( length( Buffer ) = 0 ) then
  302.          Buffer := '*.*';
  303.       for I := 1 to length( Buffer ) do
  304.          Mask[ I ] := Buffer[ I ];
  305.       GetFirst( Mask, NamR, SetDTAseg, SetDTAofs, Option, Error );
  306.       if ( Error = 0 ) then begin
  307.          gotoxy(horz_tab,wherey);
  308.          Write( NamR );
  309.          horz_tab := horz_tab + 15;
  310.       end
  311.       else
  312.          WriteLn( '   File ''', Buffer, ''' not found.' );
  313.       while ( Error = 0 ) do begin
  314.          GetNextEntry( NamR, SetDTAseg, SetDTAofs, Option, Error );
  315.          if ( Error = 0 ) then begin
  316.             gotoxy(horz_tab,wherey);
  317.             Write( NamR );
  318.             horz_tab := horz_tab + 15;
  319.             if horz_tab > 70 then begin
  320.                horz_tab := 4;
  321.                writeln;
  322.             end;
  323.          end;
  324.       end;
  325.       SetDTA( DTAseg, DTAofs, Error );
  326.       if horz_tab > 4 then
  327.          writeln;
  328.       writeln;
  329.       writeln('   Bytes Available: ',diskspace(default_drive),'k');
  330.       write('  ');
  331.       wait_for_key;
  332.       rmwin;
  333.    end;
  334.  
  335.    {$I+}
  336.