home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1987 / 11 / dirlib / dirmt.psp < prev    next >
Encoding:
Text File  |  1987-08-30  |  12.4 KB  |  256 lines
  1. (* ----------------------------------------------------------------------- *)
  2. (*                             DIRMT.PSP                                   *)
  3. (*              (c) 1987  Michael Ceol & PASCAL INT.                       *)
  4. (*  System- und Compiler-spezifischer Teil der Directory-Bibliothek fuer   *)
  5. (*                    ATARI TOS in Pascal ST Plus                          *)
  6. (*       programmiert und getestet auf einem ST 1040 mit ROM-BS            *)
  7. (* ----------------------------------------------------------------------- *)
  8. (*       neue DTA-Adresse setzen bzw. aktuelle DTA-Adresse holen:          *)
  9. PROCEDURE FSetDTA (DTA: DTA_Ptr); GEMDOS($1A);
  10. FUNCTION FGetDTA: DTA_Ptr; GEMDOS($2F);
  11. (* ----------------------------------------------------------------------- *)
  12. (*             ersten Directory-Eintrag bzw. naechsten suchen:             *)
  13. FUNCTION FSFirst (VAR search: Dir_Chr0; attr: INTEGER): INTEGER; GEMDOS($4E);
  14. FUNCTION FSNext: INTEGER; GEMDOS($4F);
  15. (* ----------------------------------------------------------------------- *)
  16. (* ----------------------------------------------------------------------- *)
  17. (*              drei Compiler-abhaengige Bit-Funktionen:                   *)
  18. (* Die Bits von "value" um "n" Stellen nach rechts shiften (verschieben):  *)
  19. FUNCTION ShiftR (value, n: INTEGER): INTEGER;
  20. BEGIN  ShiftR := SHR(value,n)  END;
  21. (*         Die Bits von "value" um "n" Stellen nach links shiften:         *)
  22. FUNCTION ShiftL (value, n: INTEGER): INTEGER;
  23. BEGIN  ShiftL := SHL(value,n)  END;
  24. (*              Die Bits von "val1" und "val2" undieren:                   *)
  25. FUNCTION AndInt (val1, val2: INTEGER): INTEGER;
  26. BEGIN  AndInt := val1 & val2  END;
  27. (* ----------------------------------------------------------------------- *)
  28. (*     nochmal zwei eventuell anzupassende Routinen, die hier aber fuer    *)
  29. (*              Turbo Pascal und Pascal ST Plus gleich sind:               *)
  30. (* Integer-Wert zu einer 'n'-stelligen Zeichenkette mit fuehrenden Nullen: *)
  31. PROCEDURE IntStr (value, n: INTEGER; VAR s: Dir_Str);
  32. VAR i : INTEGER;  Ch: CHAR;
  33. BEGIN
  34.   s := '';
  35.   FOR i := 1 TO n DO BEGIN
  36.     s := Concat(Chr((value MOD 10)+Ord('0')),s);  value := value DIV 10;
  37.   END;
  38. END;
  39. (* wg. negativen Integer-Werten bei grossen Dateigroessen selbigen Wert zu *)
  40. (*                 einem positiven Real-Wert konvertieren:                 *)
  41. FUNCTION IntCard (i: INTEGER): REAL;
  42. BEGIN IF i < 0 THEN IntCard := 65536.0 + i ELSE IntCard := i; END;
  43. (* ----------------------------------------------------------------------- *)
  44. (*          Pascal ST Plus kennt die UpCase-Funktion nicht:                *)
  45. FUNCTION UpCase (ch: CHAR): CHAR;
  46. BEGIN UpCase := ch; IF ch IN ['a'..'z'] THEN UpCase := Chr(Ord(ch)-32);  END;
  47. (* ----------------------------------------------------------------------- *)
  48. (* ----------------------------------------------------------------------- *)
  49. (* liefert einen Bitvektor, der durch 16 Bits die angemeldeten Laufwerke   *)
  50. (* repraesentiert. Bit 0 = Laufwerk A, Bit 1 = Laufwerk B usw. Entsp. Bit  *)
  51. (* gesetzt -> Laufwerk vorhanden, sonst nicht.                             *)
  52. FUNCTION DrvMap: INTEGER;
  53.   (* TOS liefert einen 32-Bit-Vektor, der einfach auf 16 Bit gekuerzt wird *)
  54.   FUNCTION DoDrvMap: LONG_INTEGER; BIOS(10);
  55. BEGIN  DrvMap := Trunc(DoDrvMap * 1.0);  END;
  56. (* ----------------------------------------------------------------------- *)
  57. (*         aktuelles Laufwerk ermitteln (0 = A, 1 = B, 2 = C usw.):        *)
  58. FUNCTION DGetDrive: INTEGER; GEMDOS($19);
  59.  
  60. (*            neues Laufwerk setzen (0 = A, 1 = B, 2 = C usw.):            *)
  61. FUNCTION DSetDrive (drive: INTEGER): INTEGER;
  62.               (* BS-Funktion, gibt das zuvor angemeldete Laufwerk zurueck: *)
  63.   FUNCTION DoSetDrive (drive: INTEGER): INTEGER; GEMDOS($0E);
  64. BEGIN
  65.               (* wenn Laufwerk nicht vorhanden, dann Fehler zurueckmelden: *)
  66.   IF AndInt(DrvMap,ShiftL(1,drive)) = 0 THEN DSetDrive := DOSedriv
  67.   ELSE BEGIN  DSetDrive := DoSetDrive(drive);  DSetDrive := DOSfnok;  END;
  68. END;
  69. (* ----------------------------------------------------------------------- *)
  70. (* Pfadspezifikation aus fspec extrahieren und in fpath zurueckgeben. Da-  *)
  71. (* bei findet keine Ueberpruefung auf Korrektheit des Pfades statt!. next- *)
  72. (* ch zeigt auf das erste, dem Pfad folgende Zeichen des Dateinamens.      *)
  73. PROCEDURE FGetPath (VAR fspec, fpath: Dir_Chr0; VAR nextch: INTEGER);
  74. VAR cont: BOOLEAN;
  75. BEGIN
  76.   nextch := 0;  cont := TRUE;
  77.   REPEAT
  78.     nextch := Succ(nextch);  fpath[nextch] := UpCase(fspec[nextch]);
  79.   UNTIL fspec[nextch] = Chr(0);
  80.   WHILE cont DO BEGIN
  81.     cont := NOT (fpath[nextch] IN [':','\']);
  82.     IF cont THEN BEGIN
  83.       fpath[nextch] := Chr(0); nextch := Pred(nextch); cont := nextch > 0;
  84.     END;
  85.   END;
  86.   nextch := Succ(nextch);
  87. END;
  88.  
  89. (* Dateinamen wie z.B. "A:*.pas" untersuchen und in der Form "1????????PAS"*)
  90. (* im File Control Block "DirFCB" eintragen sowie weitere Initialisier-    *)
  91. (* ungen in selbigem treffen. result = 0 -> fname war ok, result = 1 ->    *)
  92. (* fname enthaelt "*" oder "?", result = 255 -> fname fehlerhaft. nextch   *)
  93. (* zeigt auf das erste, nicht mehr zum Dateinamen gehoerende Zeichen.      *)
  94. (* Diese Prozedur sollte fuer Dateispez. mit Pfad nicht benutzt werden!!!  *)
  95. PROCEDURE FParsName (VAR fname: Dir_Chr0; VAR nextch, result: INTEGER);
  96. LABEL 999;
  97. VAR i: INTEGER;  delimiters: SET OF CHAR;  fstr: Dir_Str;
  98.  
  99.   PROCEDURE fpart;         (* einen Teil (Laufwerk, Dateiname...) abteilen *)
  100.   BEGIN
  101.     fstr := '';  nextch := Succ(nextch);
  102.     WHILE (NOT (fname[nextch] IN delimiters)) AND (fname[nextch] <> Chr(0))
  103.     DO BEGIN
  104.       IF fname[nextch] IN ['*','?'] THEN result := 1;
  105.       fstr := Concat(fstr,UpCase(fname[nextch]));  nextch := Succ(nextch);
  106.     END;
  107.   END;
  108.  
  109. BEGIN
  110.   delimiters := [];
  111.   FOR i := 1 TO 32 DO delimiters := delimiters + [Chr(i)];
  112.   delimiters := delimiters + [';', '=', '+', '.', ':', ','];
  113.   result := 0;
  114.   nextch := 1;                        (* fuehrende Trennzeichen entfernen: *)
  115.   WHILE (fname[nextch] IN delimiters) AND (fname[nextch] <> Chr(0)) DO
  116.     nextch := Succ(nextch);
  117.   nextch := Pred(nextch);
  118.   fpart;                            (* ersten Teil des Dateinamens trennen *)
  119.   delimiters := delimiters + ['<', '>', '[', ']', '|', '/', '\', '"'];
  120.   IF (fname[nextch] = ':') AND (Length(fstr) = 1) THEN (* Laufwerksangabe? *)
  121.     IF fstr[1] IN ['A'..'P'] THEN fpart    (* ja. Naechsten Teil abtrennen *)
  122.     ELSE BEGIN  result := 255; GOTO 999;  END;     (* ungueltiges Laufwerk!*)
  123.   IF Length(fstr) <= 8 THEN                    (* ordentlicher Dateiname ? *)
  124.     BEGIN
  125.       IF fname[nextch] = '.' THEN              (* kommt noch Erweiterung ? *)
  126.         BEGIN
  127.           fpart;
  128.           IF Length(fstr) > 3 THEN result := 255;
  129.         END;
  130.     END
  131.   ELSE result := 255;
  132.   IF fname[nextch] = Chr(0) THEN nextch := 0;
  133. 999:
  134. END;
  135. (* ----------------------------------------------------------------------- *)
  136. (*       Konvertierung des MS-DOS/TOS Datums in einen Date_Str:            *)
  137. (*     Datum - Bits: 0..4: Tag,  5..8: Monat,    9..15: Jahr-1980          *)
  138. PROCEDURE DOSDateStr (DOSDate: INTEGER; VAR Date: Date_Str);
  139. VAR temp: Dir_Str;
  140. BEGIN
  141.   IntStr(ShiftR(DOSDate, 9) + 1980, 4, temp);                      (* Jahr *)
  142.   Date := temp;
  143.   IntStr(AndInt(ShiftR(DOSDate, 5), 15), 2, temp);                (* Monat *)
  144.   Date := Concat(Date, temp);
  145.   IntStr(AndInt(DOSDate, 31), 2, temp);                             (* Tag *)
  146.   Date := Concat(Date, temp);
  147. END;
  148.  
  149. (*       Konvertierung der MS-DOS/TOS Zeit in einen Time_Str:              *)
  150. (* Zeit  - Bits:                                                           *)
  151. (*   0..4: Sek. im 2-Sekunden-Intervall, 5..10: Minuten, 11..15: Stunden   *)
  152. PROCEDURE DOSTimeStr (DOSTime: INTEGER; VAR Time: Time_Str);
  153. VAR temp: Dir_Str;
  154. BEGIN
  155.   IntStr(ShiftR(DOSTime, 11), 2, temp);                         (* Stunden *)
  156.   Time := temp;
  157.   IntStr(AndInt(ShiftR(DOSTime, 5),63), 2, temp);               (* Minuten *)
  158.   Time := Concat(Time, temp);
  159.   IntStr(AndInt(DOSTime, 31)*2, 2, temp);                      (* Sekunden *)
  160.   Time := Concat(Time, temp);
  161. END;
  162. (* ----------------------------------------------------------------------- *)
  163. (*  Dateigroesse eines mit FSFirst gefundenen Dateieintrages "errechnen":  *)
  164. FUNCTION CompFSize: REAL;
  165. BEGIN
  166.   WITH DirDTA^ DO CompFSize := IntCard(szhi) * 65536.0 + IntCard(szlo);
  167. END;
  168. (* ----------------------------------------------------------------------- *)
  169. (* Die TOS-"Pfad"-Funktionen mussten teilweise modifiziert werden, um ein  *)
  170. (*               gleiches Verhalten wie MS-DOS zu erlangen!                *)
  171. (*                       aktuellen Pfad ermitteln:                         *)
  172. FUNCTION DGetPath (VAR path: Dir_Chr0; drive: INTEGER): INTEGER;
  173. VAR temp: Dir_Chr0;  i: INTEGER;
  174.                                                 (* endgueltiger BS-Aufruf: *)
  175.   FUNCTION DoDGetPath (VAR path: Dir_Chr0; drive: INTEGER): INTEGER;
  176.     GEMDOS($47);
  177. BEGIN
  178.   path[1] := Chr(0);                                    (* fuer Fehlerfall *)
  179.   i := DoDGetPath(temp,drive);                (* BS-Funktion aufrufen      *)
  180.   DGetPath := i;                              (* und Fehlercode auswerten. *)
  181.   IF i = DOSfnok THEN BEGIN
  182.                        (* falls Wurzelverzeichnis Backslash zurueck geben: *)
  183.     IF temp[1] = Chr(0) THEN BEGIN temp[1] := '\'; temp[2] := Chr(0); END;
  184.     i := 0;               (* Ergebnis von DoDGetPath in path zurueckgeben: *)
  185.     REPEAT  i := Succ(i);  path[i] := temp[i];  UNTIL temp[i] = Chr(0);
  186.   END;
  187. END;
  188.  
  189. FUNCTION DSetPath (VAR path: Dir_Chr0): INTEGER;      (* neuen Pfad setzen *)
  190. VAR olddrv, err: INTEGER;
  191.                                                 (* endgueltiger BS-Aufruf: *)
  192.   FUNCTION DoDSetPath (VAR pth: Dir_Chr0): INTEGER;
  193.     GEMDOS($3B);
  194. BEGIN
  195.   DSetPath := DOSpthnf;                     (* Pfad vorerst nicht gefunden *)
  196.   IF path[1] <> Chr(0) THEN
  197.                                               (* kein Laufwerk angegeben ? *)
  198.     IF path[2] <> ':' THEN DSetPath := DoDSetPath(path)          (* ja, ok *)
  199.     ELSE IF path[3] <> Chr(0) THEN BEGIN
  200.       olddrv := DGetDrive;       (* sonst kurzzeitig das Laufwerk wechseln *)
  201.       IF DSetDrive(Ord(UpCase(path[1]))-Ord('A')) = DOSfnok THEN BEGIN
  202.         DSetPath := DoDSetPath(path);  err := DSetDrive(olddrv);
  203.       END;
  204.     END;
  205. END;
  206.  
  207. FUNCTION DCreate (VAR path: Dir_Chr0): INTEGER;  (* neues Verzeichnis erz. *)
  208. GEMDOS($39);
  209.  
  210. FUNCTION DDelete (VAR path: Dir_Chr0): INTEGER;    (* Verzeichnis loeschen *)
  211. VAR temp: Dir_Chr0;  i, j: INTEGER;
  212.                                                 (* endgueltiger BS-Aufruf: *)
  213.   FUNCTION DoDDelete (VAR path: Dir_Chr0): INTEGER;
  214.     GEMDOS($3A);
  215. BEGIN
  216.   IF path[1] = Chr(0) THEN DDelete := DOSpthnf
  217.   ELSE BEGIN
  218.     i := 0;  j := 0;
  219.     IF path[1] = '\' THEN                    (* Pfad ab Wurzel angegeben ? *)
  220.                                         (* ja, akt. Laufwerk davor setzen: *)
  221.       BEGIN temp[1] := Chr(DGetDrive + Ord('A')); temp[2] := ':'; i := 2; END
  222.     ELSE IF path[2] <> ':' THEN               (* kein Laufwerk angegeben ? *)
  223.                     (* Referenz des aktuellen Verzeichnisses davor setzen: *)
  224.       BEGIN  temp[1] := '.';  temp[2] := '\';  i := 2;  END;
  225.     REPEAT  i := Succ(i);  j := Succ(j);  temp[i] := path[j];
  226.     UNTIL path[j] = Chr(0);
  227.     DDelete := DoDDelete(temp);
  228.   END;
  229. END;
  230. (* ----------------------------------------------------------------------- *)
  231. (*                freien Disk-Speicherplatz ermitteln:                     *)
  232. PROCEDURE DFree (VAR info: DSK_Info; drive: INTEGER);
  233. TYPE DInfo = ARRAY[1..4] OF LONG_INTEGER;
  234. VAR  buf: DInfo;
  235.                                                 (* endgueltiger BS-Aufruf: *)
  236.   PROCEDURE DoDFree (VAR buf: DInfo; drive: INTEGER);
  237.     GEMDOS($36);
  238. BEGIN
  239.   DirResult := DOSfnok;
  240.   WITH info DO BEGIN
  241.     IF drive <> 0 THEN
  242.       IF AndInt(DrvMap,ShiftL(1,Pred(drive))) = 0 THEN BEGIN
  243.         DirResult := DOSedriv;  FreeCluster := -1.0;  TotalCluster := -1.0;
  244.         SectorSize := -1.0;     ClusterSize := -1.0;
  245.       END;
  246.     IF DirResult = DOSfnok THEN BEGIN
  247.       DoDFree(buf,drive);
  248.       FreeCluster := buf[1];  TotalCluster := buf[2];
  249.       SectorSize  := buf[3];  ClusterSize  := buf[4];
  250.     END;
  251.   END;
  252. END;
  253. (* ----------------------------------------------------------------------- *)
  254. (*                             DIRMT.PSP                                   *)
  255.  
  256.