home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / TPPROC19.ZIP / TREEDIRS.INC < prev    next >
Encoding:
Text File  |  1985-02-06  |  6.2 KB  |  180 lines
  1. (*--------------------------------------------------------------------------*)
  2. (*                         TREEDIRS.INC                                     *)
  3. (* Turbo Pascal routines for tree-structured directories.                   *)
  4. (* Copyright 1984 Michael A. Covington                                      *)
  5. (* Functions:  currentdrive            Procedures:  chdrive                 *)
  6. (*             currentdir                           rmdir                   *)
  7. (*             diskspace                            mkdir                   *)
  8. (*                                                  rename                  *)
  9. (*--------------------------------------------------------------------------*)
  10. TYPE
  11.     pathtype  = STRING[62];
  12.     drivetype = STRING[2];
  13.     rtype     = RECORD
  14.                       ax,bx,cx,dx,bp,si,di,ds,es,flags:INTEGER
  15.                 END;
  16.  
  17. PROCEDURE xxdiskerr(x:drivetype);
  18. BEGIN
  19.      WRITELN('Error -- Invalid disk drive, ''',x,'''');
  20.      HALT
  21. END;
  22.  
  23. PROCEDURE xxpatherr(x:pathtype);
  24. BEGIN
  25.      WRITELN('Error -- Invalid path,''',x,'''');
  26.      HALT
  27. END;
  28.  
  29. FUNCTION currentdrive: drivetype;
  30. (*--------------------------------------------------------------------------*)
  31. (* Returns designator for the default drive, e.g. 'A:'.                     *)
  32. (*--------------------------------------------------------------------------*)
  33. VAR
  34.    w   : drivetype;
  35.    reg : rtype;
  36.  
  37. BEGIN
  38.      reg.ax:=$1900;
  39.      Intr($21,reg);
  40.      w:='A:';
  41.      w[1]:=CHR(ORD(w[1])+Lo(reg.ax));
  42.      currentdrive:=w
  43.      END;
  44.  
  45. PROCEDURE chdrive(x:drivetype);
  46. (*--------------------------------------------------------------------------*)
  47. (* Chooses a new default drive.  Parameters can have the form A: A a: or a. *)
  48. (* Requires XXDISKERR, above                                                *)
  49. (*--------------------------------------------------------------------------*)
  50. VAR
  51.    reg: rtype;
  52.  
  53. BEGIN
  54.      reg.ax := $0E00;
  55.      reg.dx := ORD(UpCase(x[1])) - ORD('A');
  56.      Intr($21,reg);
  57.      IF (reg.dx < 0) OR (Lo(reg.ax) < Lo(reg.dx)) THEN xxdiskerr(x);
  58. END;
  59.  
  60. FUNCTION diskspace(x:drivetype):REAL;
  61. (*--------------------------------------------------------------------------*)
  62. (* Returns number of bytes available on specified disk.  Parameter as for   *)
  63. (* CHDRIVE.  Requires XXDISKERR, above.                                     *)
  64. (*--------------------------------------------------------------------------*)
  65. VAR
  66.    reg: rtype;
  67.  
  68. BEGIN
  69.      reg.ax := $3600;
  70.      reg.dx := 1 + ORD(UpCase(x[1])) - ORD('A');
  71.      Intr($21,reg);
  72.      IF reg.ax = $FFFF THEN
  73.         xxdiskerr(x)
  74.      ELSE
  75.         diskspace := (256.0 * Hi(reg.dx) + Lo(reg.dx)) * reg.ax * reg.cx
  76. END;
  77.  
  78. FUNCTION currentdir(x:drivetype):pathtype;
  79. (*--------------------------------------------------------------------------*)
  80. (* Returns full path to active directory on specified drive, including      *)
  81. (* backslash at beginning, not including drive designator.  Parameters as   *)
  82. (* for CHDRIVE.  Requires XXDISKERR, above.                                 *)
  83. (*--------------------------------------------------------------------------*)
  84. VAR
  85.    w  : pathtype;
  86.    reg: rtype;
  87.    i  : INTEGER;
  88.  
  89. BEGIN (*get current path*)
  90.   reg.ax:=$4700;
  91.   reg.dx:=1 + ORD(UpCase(x[1])) - ORD('A');
  92.   reg.ds:=Seg(w[1]);
  93.   reg.si:=Ofs(w[1]);
  94.   Intr($21,reg);
  95.   IF (reg.flags AND 1) > 0 THEN xxdiskerr(x);
  96.  
  97. (*turn it into a Turbo string*)
  98.        i:=1;
  99.        WHILE w[i]<>CHR(0) DO i:=i+1;
  100.        w[0]:=CHR(i-1);
  101.        FOR i:=1 TO LENGTH(w) DO w[i]:=UpCase(w[i]);
  102.        currentdir := '\'+w
  103. END;
  104.  
  105. PROCEDURE xxdir(x:pathtype; k:INTEGER);
  106. (*--------------------------------------------------------------------------*)
  107. (* Executes CHDIR, MKDIR, RMDIR requests. Requires XXPATHERR,CURRENTDRIVE.  *)
  108. (*--------------------------------------------------------------------------*)
  109. VAR
  110.    w  : pathtype;
  111.    reg: rtype;
  112.  
  113. BEGIN
  114.      w:=x+CHR(0);
  115.      IF w[2] <> ':' THEN (*add drive designator*)
  116.         w:=currentdrive+w;
  117.      reg.ax := k;
  118.      reg.ds := Seg(w[1]);
  119.      reg.dx := Ofs(w[1]);
  120.      Intr($21,reg);
  121.      IF (reg.flags AND 1) > 0 THEN xxpatherr(x)
  122. END;
  123.  
  124. PROCEDURE chdir(x:pathtype);
  125. (*--------------------------------------------------------------------------*)
  126. (* Equivalent to CHDIR in DOS;  requires XXDIR, XXPATHERR, CURRENTDRIVE     *)
  127. (* WARNING:  do not leave a directory if you have files open in it.         *)
  128. (*--------------------------------------------------------------------------*)
  129. BEGIN
  130.     xxdir(x,$3B00)
  131. END;
  132.  
  133. PROCEDURE rmdir(x:pathtype);
  134. (*--------------------------------------------------------------------------*)
  135. (* Equivalent to RMDIR in DOS;  requires XXDIR, XXPATHERR, CURRENTDRIVE     *)
  136. (*--------------------------------------------------------------------------*)
  137. BEGIN
  138.     xxdir(x,$3A00)
  139. END;
  140.  
  141. PROCEDURE mkdir(x:pathtype);
  142. (*--------------------------------------------------------------------------*)
  143. (* Equivalent to MKDIR in DOS;  requires XXDIR, XXPATHERR, CURRENTDRIVE     *)
  144. (*--------------------------------------------------------------------------*)
  145. BEGIN
  146.     xxdir(x,$3900)
  147. END;
  148.  
  149. PROCEDURE Rename(x,y:pathtype);
  150. (*--------------------------------------------------------------------------*)
  151. (* renames a file; unlike the DOS RENAME command, both parameters of this   *)
  152. (* are full paths.  The paths need not be the same, allowing a file to be   *)
  153. (* moved from one directory to another.  First parameter can specify a      *)
  154. (* drive, any drive letter on the second parameter is ignored.              *)
  155. (*--------------------------------------------------------------------------*)
  156. VAR
  157.    wx,wy : pathtype;
  158.    reg   : rtype;
  159.  
  160. BEGIN
  161.      wx := x + CHR(0);
  162.      wy := y + CHR(0);
  163.      IF wx[2]<>':' THEN wx :=currentdrive+wx;
  164.      reg.ax := $5600;
  165.      reg.ds := Seg(wx[1]);
  166.      reg.dx := Ofs(wx[1]);
  167.      reg.es := Seg(wy[1]);
  168.      reg.di := Ofs(wy[1]);
  169.      Intr($21,reg);
  170.      IF (reg.flags AND 1) <> 0 THEN
  171.         BEGIN
  172.              WRITELN;
  173.              WRITELN('Error -- invalid rename request.');
  174.              WRITELN('      -- from: ''',x,'''');
  175.              WRITELN('      -- to:   ''',y,'''');
  176.              HALT
  177.         END
  178. END;
  179.  
  180.