Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/TREEDIR.ZIP/TREEDIR.PAS

Pascal/Delphi Source File | 1985-12-28 | 4.9 KB | 187 lines

{ routine for tree-structure directory }

{ requires MS-DOS 2.0 or higher. }

{ All the routines require these type definitions.          }
{ However, except as noted, they do not require each other. }

type pathtype  = string[63];
     drivetype = string[2];
     rtype     = record
                   ax,bx,cx,dx,bp,si,di,ds,es,flags:integer
                 end;

procedure xxdiskerr(x:drivetype);
begin
  writeln('Error -- Invalid disk drive, ''',x,'''');
  halt;
end;

procedure xxpatherr(x:pathtype);
begin
  writeln('Error -- Invalid path, ''',x,'''');
  halt;
end;

function currentdrive: drivetype;

{ Returns designator for current default drive, e.g., 'A:'. }
{ Works under DOS version 1.x }

var w:   drivetype;
    reg: rtype;
begin
  reg.ax:=$1900;
  intr($21,reg);
  w:='A:';
  w[1]:=chr(ord(w[1])+lo(reg.ax));
  currentdrive:=w;
end;

procedure chdrive(x:drivetype);
  { Chooses a new default drive. }
  { Parameter can have the form 'A:', 'A', 'a:', or 'a'.     }
  { Works under DOS version 1.x.  Requires XXDISKERR, above. }
var reg: rtype;

begin
  reg.ax:=$0E00;
  reg.dx:=ord(upcase(x[1])) - ord('A');
  intr($21,reg);
  if (reg.dx < 0) or (lo(reg.ax) < lo(reg.dx)) then xxdiskerr(x);
end;

function diskspace(x:drivetype): real;
  { Returns number of bytes available on specified disk.  }
  { Parameter as for CHDRIVE.  Requires XXDISKERR, above. }
var reg: rtype;

begin
  reg.ax:=$3600;
  reg.dx:=1 + ord(upcase(x[1])) - ord('A');
  intr($21,reg);
  if reg.ax = $FFFF then xxdiskerr(x)
  else diskspace := (256.0*hi(reg.bx) + lo(reg.bx)) * reg.cx * reg.ax;
end;

function currentdir(x:drivetype): pathtype;
  { Returns full path to active directory on specified drive.        }
  { including backslah at beginning, not including drive designator. }
  { Parameter as for CHDIVE.   }
  { Requires XXDISKERR, above. }
var w:   pathtype;
    reg: rtype;
    i:   integer;

begin
  { Get current path }
  reg.ax:=$4700;
  reg.dx:=1 + ord(upcase(x[1])) - ord('A');
  reg.ds:=seg(w[1]);
  reg.si:=ofs(w[1]);
  intr($21,reg);
  if (reg.flags and 1) > 0 then xxdiskerr(x);

  { Turn it into a Turbo string }
  i:=1;
  while w[i]<>chr(0) do i:=i+1;
  w[0]:=chr(i-1);
  for i:=1 to length(w) do w[i]:=upcase(w[i]);

  currentdir:='\' + w;
end;

procedure xxdir(x:pathtype; k:integer);
  { Executes CHDIR, MKDIR, RMDIR requests.      }
  { Requires XXPATHERR and CURRENTDRIVE, above. }
var w:   pathtype;
    reg: rtype;

begin
  w:=x + chr(0);
  if w[2] <> ':' then w:=currentdrive + w;  { add drive designator }
  reg.ax:=k;
  reg.ds:=seg(w[1]);
  reg.dx:=ofs(w[1]);
  intr($21,reg);
  if (reg.flags and 1) > 0 then xxpatherr(x);
end;

procedure chdir(x:pathtype);
  { Equivalent to CHDIR command in DOS.                 }
  { Requires XXDIR, XXPATHERR, and CURRENTDRIVE, above. }
  { Caution!  Do NOT leave a directory if you have files in it open. }

begin
  xxdir(x,$3B00);
end;

procedure rmdir(x:pathtype);
  { Equivalent to RMDIR command in DOS.                 }
  { Requires XXDIR, XXPATHERR, and CURRENTDRIVE, above. }

begin
  xxdir(x,$3A00);
end;

procedure mkdir(x:pathtype);
  { Equivalent to MKDIR command in DOS.                 }
  { Requires XXDIR, XXPATHERR, and CURRENTDRIVE, above. }

begin
  xxdir(x,$3900);
end;

procedure rename(x,y:pathtype);
  { Renames a file; unlike the DOS RENAME command,       }
  { both parameters of this command are full paths.      }
  { The paths need not be the same, allowing a file      }
  { to be moved from one directory to another.           }
  { First parameter can specify a drive;                 }
  { any drive letter on the second parameter is ignored. }
var wx, wy: pathtype;
    reg:    rtype;
begin
  wx:=x + chr(0);
  wy:=y + chr(0);
  if wx[2] <> ':' then wx:=currentdrive + wx;
  reg.ax:=$5600;
  reg.ds:=seg(wx[1]);
  reg.dx:=ofs(wx[1]);
  reg.es:=seg(wy[1]);
  reg.di:=ofs(wy[1]);
  if (reg.flags and 1) <> 0 then
    begin
      writeln('Error -- Invalid rename request');
      writeln('      -- From: ''',x,'''');
      writeln('      -- To:   ''',y,'''');
      halt;
    end;
end;

{ sample program that uses the above subroutines
begin
  writeln('Current drive is ',currentdrive);
  chdrive('A:');
  writeln('Drive changed to ',currentdrive);
  writeln;
  writeln(diskspace(currentdrive):10:0,' bytes free on drive ',currentdrive);
  chdrive('B:');
  writeln;
  writeln('Drive changed to ',currentdrive);
  writeln;
  writeln(diskspace(currentdrive):10:0,' bytes free on drive ',currentdrive);
  writeln('Current Path is ',currentdrive,currentdir(currentdrive));
  writeln;
  mkdir('\test');
  chdir('\test');
  writeln('Path changed to ',currentdrive,currentdir(currentdrive));
  writeln;
  chdir('\');
  writeln('Path changed to ',currentdrive,currentdir(currentdrive));
  writeln;
  rmdir('\test');

end.
  }