home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1987 / 11 / dirlib / dirlib.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-08-30  |  15.7 KB  |  310 lines
  1. (* ----------------------------------------------------------------------- *)
  2. (*                              DIRLIB.PAS                                 *)
  3. (*              (c) 1987  Michael Ceol & PASCAL INT.                       *)
  4. (* Betriebssystem- und compilerunabhaengige Routinen der Directory-Biblio- *)
  5. (* thek. Diese rufen wiederum die "low level" Routinen in DIRMT.TUR,       *)
  6. (* DIRMT.PSP bzw. DIRCP.TUR auf, um den eigentlichen Job zu erledigen.     *)
  7.  
  8. (*                       ein bischen Konvertierung:                        *)
  9. (* ----------------------------------------------------------------------- *)
  10. (*    String in eine ASCIIZ-Zeichenfolge konvertieren, wie es von den      *)
  11. (*                     Betriebssystemen benoetigt wird:                    *)
  12. PROCEDURE StrChr (VAR st: Dir_Str; VAR ch: Dir_Chr0);
  13. VAR i : INTEGER;
  14. BEGIN
  15.   FOR i := 1 TO Length(st) DO ch[i] := st[i];
  16.   ch[Succ(Length(st))] := Chr(0);
  17. END;
  18. (* ----------------------------------------------------------------------- *)
  19. (*           ASCIIZ-Zeichenfolge in einen String konvertieren:             *)
  20. PROCEDURE ChrStr (VAR ch: Dir_Chr0;  VAR st: Dir_Str);
  21. VAR i : INTEGER;
  22. BEGIN
  23.   i := 1;  st := '';
  24.   WHILE ch[i] <> Chr(0) DO BEGIN st := Concat(st,ch[i]); i := Succ(i); END;
  25. END;
  26. (* ----------------------------------------------------------------------- *)
  27. (*   Dateinamen aus einem "Dir_Rec" (name[8], ext[3]) in einen gueltigen   *)
  28. (*           Dateinamen des Formats "name.ext" konvertieren:               *)
  29. PROCEDURE MakeFileName (VAR direntry: Dir_Rec; VAR filename: Dir_Str);
  30. VAR i : INTEGER;
  31. BEGIN
  32.   filename := '';
  33.   WITH direntry DO BEGIN
  34.     FOR i := 1 TO 8 DO      (* die aufgefuellten Leerzeichen muessen weg ! *)
  35.       IF name[i] <> ' ' THEN filename := Concat(filename, name[i]);
  36.     IF ext <> '   ' THEN BEGIN       (* gibt's Extension ? (3 Leerzeichen) *)
  37.       filename := Concat(filename, '.');             (* ja, Trennpunkt und *)
  38.       FOR i := 1 TO 3 DO                             (* Extension anfuegen *)
  39.         IF ext[i] <> ' ' THEN filename := Concat(filename, ext[i]);
  40.     END;
  41.   END;
  42. END;
  43. (* ----------------------------------------------------------------------- *)
  44. (*    Das Gleiche fuer den i-ten Eintrag eines eingelesenen Directorys:    *)
  45. PROCEDURE MakeDirFileName (index: INTEGER; VAR directory: Dir_Typ;
  46.                                            VAR filename : Dir_Str);
  47. BEGIN
  48.   WITH directory DO
  49.     IF (index > 0) AND (index <= num) THEN
  50.       MakeFileName(items[index],filename);
  51. END;
  52.  
  53. (*                    nun zu den Directory-Funktionen:                     *)
  54. (* ----------------------------------------------------------------------- *)
  55. (* Wie in DIR??TYP.PAS erwaehnt, muss die DTA dynamisch verwaltet werden.  *)
  56. (* Man muss VOR Gebrauch der folgenden Funktionen mit "NewDTA" eine eigene *)
  57. (* DTA erschaffen, und diese mit "DispDTA" wieder freigeben, wenn nicht    *)
  58. (* mehr benoetigt. Der Zeiger auf diese DTA muss aus dem gleichen Grund in *)
  59. (* einer globalen Variablen gehalten werden:                               *)
  60. PROCEDURE NewDirDTA;
  61. BEGIN  New(DirDTA)  END;
  62.  
  63. PROCEDURE DispDirDTA;
  64. BEGIN  Dispose(DirDTA)  END;
  65. (* ----------------------------------------------------------------------- *)
  66. (* "SetDTA" teilt dem BS eine neue DTA-Adresse mit, "GetDTA" ermittelt die *)
  67. (* gerade vom BS verwendete DTA-Adresse:                                   *)
  68. PROCEDURE SetDTA (DTA: DTA_Ptr);
  69. BEGIN  IF DTA <> NIL THEN FSetDTA(DTA)  END;
  70.  
  71. PROCEDURE GetDTA (VAR DTA: DTA_Ptr);
  72. BEGIN  DTA := FGetDTA;  END;
  73. (* ----------------------------------------------------------------------- *)
  74. (* Den ersten mit der Suchspezifikation "search" (kann auch '*' oder '?'   *)
  75. (* enthalten) und mit dem Attribut uebereinstimmenden Directory-Eintrag    *)
  76. (* suchen. Wird einer gefunden, enthaelt die Variable "DirResult" den Wert *)
  77. (* 0, ansonsten einen Fehlercode (s. DIRCONST.PAS). Bei Erfolg wird der    *)
  78. (* gefundene Eintrag als Dir-Record ausgegeben:                            *)
  79. PROCEDURE DirFirst (search: Dir_Str; attr: INTEGER; VAR entry: Dir_Rec);
  80. VAR oldDTA : DTA_Ptr;  temp : Dir_Chr0;  i : INTEGER;
  81. BEGIN
  82.        (* fuer den Volume-Eintrag eine wirklich exklusive Suche erzwingen: *)
  83.   IF AndInt(attr,DirVol) = DirVol THEN attr := DirVol;
  84.          (* aktuelle DTA sichern und fuer Dir-Funktionen eigene verwenden: *)
  85.   GetDTA(oldDTA);   SetDTA(DirDTA);
  86.   StrChr(search,temp); (* Zeichenfolge der Suchspez. zu eine ASCIIZ-Folge. *)
  87.   DirResult := FSFirst(temp, attr);              (* Betriebssystem-Aufruf. *)
  88.   DTAtoDirEntry(entry);      (* Info aus DTA in unseren Dir-Record bringen *)
  89.   SetDTA(oldDTA);                       (* wieder alte DTA benutzen lassen *)
  90. END;
  91. (* ----------------------------------------------------------------------- *)
  92. (* den naechsten mit der bei "DirFirst" festgelegten Suchspez. ueberein-   *)
  93. (* stimmenden Eintrag suchen. Fuer "DirResult" gilt oben beschriebenes.    *)
  94. PROCEDURE DirNext (VAR entry: Dir_Rec);
  95. VAR oldDTA: DTA_Ptr;
  96. BEGIN
  97.   GetDTA(oldDTA);  SetDTA(DirDTA);  DirResult := FSNext;
  98.   SetDTA(oldDTA);  DTAtoDirEntry(entry);
  99. END;
  100. (* ----------------------------------------------------------------------- *)
  101. (* alle mit Suchspez. uebereinstimmenden Eintraege suchen und in unseren   *)
  102. (* Directory-Puffer in der Reihenfolge des Auftretens eintragen:           *)
  103. PROCEDURE Dir (search: Dir_Str; attr: INTEGER; VAR directory: Dir_Typ);
  104. VAR entry: Dir_Rec;
  105. BEGIN
  106.   WITH directory DO BEGIN
  107.     num := 0;   DirFirst(search, attr, entry);
  108.     WHILE DirResult = DOSfnok DO BEGIN    (* solange kein Fehler auftritt. *)
  109.       num := Succ(num);  items[num] := entry;   DirNext(entry);
  110.     END;
  111.   END;
  112. END;
  113. (* ----------------------------------------------------------------------- *)
  114. (*    gelesenes Verzeichnis nach 'sortkey' sortieren, wobei Unterver-      *)
  115. (*          zeichnisse immer an den Anfang gebracht werden:                *)
  116. PROCEDURE SortDir (sortkey: INTEGER; VAR directory: Dir_Typ);
  117. VAR i, j, p : INTEGER;  help : Dir_Rec;
  118.  
  119. PROCEDURE Swap(i1, i2: INTEGER); (* zwei Eintrage im Directory vertauschen *)
  120.   BEGIN
  121.     WITH directory DO BEGIN
  122.       help := items[i1]; items[i1] := items[i2]; items[i2] := help;
  123.     END;
  124.   END;
  125.  
  126. (*$A+*)                         (* Turbo Pascal: rekursiven Code erzeugen! *)
  127. (*    Vergleichsfunktion fuer die Sortierung durch den verf. Shell-Sort:   *)
  128. FUNCTION lower(sortkey, i1, i2: INTEGER): BOOLEAN;
  129.   VAR tmp: ARRAY [1..3] OF Dir_Str;
  130.   BEGIN
  131.     lower := FALSE;
  132.     IF i2 > 0 THEN
  133.       WITH directory DO BEGIN
  134.                (* Strings (Name, Extension, Datum) von Unterverzeichnissen
  135.                   kleiner als die von Dateien "machen":                    *)
  136.         tmp[1] := '!';  tmp[2] := '!';
  137.         IF items[i1].attr = DirDir THEN tmp[1] := ' ';        (* ' ' < '!' *)
  138.         IF items[i2].attr = DirDir THEN tmp[2] := ' ';
  139.         CASE sortkey OF
  140.           DirDate: BEGIN
  141.                                           (* juengste Eintraege (groesstes
  142.                                              Datum als String) nach vorn:  *)
  143.                      tmp[3] := tmp[1]; tmp[1] := tmp[2]; tmp[2] := tmp[3];
  144.                      tmp[1] := Concat(tmp[1],items[i1].date);
  145.                      tmp[2] := Concat(tmp[2],items[i2].date);
  146.                      lower := tmp[1] > tmp[2];
  147.                                      (* notfalls noch Uhrzeit vergleichen: *)
  148.                      IF tmp[1] = tmp[2] THEN
  149.                        IF items[i1].time > items[i2].time THEN
  150.                          lower := TRUE
  151.                                         (* gut, dann halt noch nach Namen: *)
  152.                        ELSE IF items[i1].time = items[i2].time THEN
  153.                          lower := lower(DirName,i1,i2)
  154.                    END;
  155.           DirSize: BEGIN
  156.                                        (* die groessten Dateien nach vorn: *)
  157.                           (* zwischen Verzeichnis und Datei unterscheiden: *)
  158.                      IF (tmp[1] = ' ') OR (tmp[2] = ' ') THEN
  159.                        lower := items[i1].size < items[i2].size
  160.                      ELSE
  161.                        lower := items[i1].size > items[i2].size;
  162.                      IF items[i1].size = items[i2].size THEN
  163.                        lower := lower(DirName,i1,i2);
  164.                    END;
  165.                                              (* folgendes ist klar, oder ? *)
  166.         DirExt : BEGIN
  167.                      tmp[1] := Concat(tmp[1],items[i1].ext,items[i1].name);
  168.                      tmp[2] := Concat(tmp[2],items[i2].ext,items[i2].name);
  169.                      lower := tmp[1] < tmp[2];
  170.                    END;
  171.           ELSE     BEGIN
  172.                      tmp[1] := Concat(tmp[1],items[i1].name,items[i1].ext);
  173.                      tmp[2] := Concat(tmp[2],items[i2].name,items[i2].ext);
  174.                      lower := tmp[1] < tmp[2];
  175.                    END;
  176.         END;
  177.       END;
  178.   END;
  179. (*$A-*)
  180.  
  181. BEGIN (* verfeinerter Shell-Sort, s. 'Sortieren in Modula 2' *)
  182.   WITH directory DO BEGIN
  183.     p := num;
  184.     WHILE p > 1 DO BEGIN
  185.       p := p DIV 2;
  186.       FOR i := 1 TO num-p DO
  187.         IF lower(sortkey,i+p,i) THEN BEGIN
  188.           Swap(i,i+p);
  189.           j := i;
  190.           WHILE (j >= 1+p) AND lower(sortkey,j,j-p) DO BEGIN
  191.             Swap(j,j-p);  j := j - p;
  192.           END;
  193.         END;
  194.     END;
  195.   END;
  196. END;
  197.  
  198. (*           und der neue Stoff mit ein paar kleinen Schmankerln:          *)
  199. (* ----------------------------------------------------------------------- *)
  200. (* Laufwerknummer als Laufwerkzeichen ausgeben (0 = A, 1 = B, 2 = C usw.): *)
  201. FUNCTION DriveChar (drive: INTEGER): CHAR;
  202. BEGIN  DriveChar := Chr(Ord('A')+drive);  END;
  203.  
  204. (* Laufwerkzeichen als Laufwerknummer ausgeben (A = 0, B = 1, C = 2 usw.): *)
  205. FUNCTION DriveNum (drive: CHAR): INTEGER;
  206. BEGIN  DriveNum := Ord(UpCase(drive)) - Ord('A');  END;
  207. (* ----------------------------------------------------------------------- *)
  208. (* aktuelles (angemeldetes) Laufwerk ermitteln (0 = A, 1 = B, 2 = C usw.): *)
  209. FUNCTION GetDrive: INTEGER;
  210. BEGIN  GetDrive := DGetDrive;  END;
  211.  
  212. (*       Laufwerk selektieren (anmelden) (A = 0, B = 1, C = 2 usw.):       *)
  213. (* existiert das gewuenschte Laufwerk nicht, ist DirResult = DOSedriv,     *)
  214. (* sonst ist DirResult = DOSfnok.                                          *)
  215. PROCEDURE ChDrive (drive: INTEGER);
  216. BEGIN  DirResult := DSetDrive(drive);  END;
  217. (* ----------------------------------------------------------------------- *)
  218. (* Dateinamen z.B. der Form 'a:*.pas' untersuchen. Bei MS-DOS und CP/M     *)
  219. (* wird gleichzeitig der 'DirFCB' initialisiert, was bei TOS entfaellt.    *)
  220. (* nextch zeigt auf das erste, nicht mehr zum Dateinamen gehoerende Zei-   *)
  221. (* chen.
  222. (* Diese Prozedur sollte nicht fuer Dateinamen mit Pfadangabe genutzt wer- *)
  223. (* den!                                                                    *)
  224. (* result = 0 -> fname ok, result = 1 -> fname enthaelt '*' oder '?', re-  *)
  225. (* sult = 255 -> fname fehlerhaft.                                         *)
  226. PROCEDURE ParseFileName (fname: Dir_Str; VAR nextch, result: INTEGER);
  227. VAR temp: Dir_Chr0;
  228. BEGIN  StrChr(fname, temp);  FParsName(temp, nextch, result);  END;
  229.  
  230. (* Pfadspezifikation aus 'fname' extrahieren und in 'fpath' zurueckgeben.  *)
  231. (* nextch zeigt auf das erste Zeichen des dem Pfad folgenden Dateinamens   *)
  232. (* in fname:                                                               *)
  233. PROCEDURE FilePath (fname: Dir_Str; VAR fpath: Dir_Str; VAR nextch: INTEGER);
  234. VAR fn, fp: Dir_Chr0;
  235. BEGIN StrChr(fname, fn); FGetPath(fn, fp, nextch); ChrStr(fp, fpath); END;
  236.  
  237. (*    In fname angegebene Laufwerkspezifikation in 'drive' zurueckgeben:   *)
  238. (*                       (0 = A, 1 = B, 2 = C usw.):                       *)
  239. FUNCTION FileDrive (fname: Dir_Str): INTEGER;
  240. VAR i: INTEGER;
  241. BEGIN
  242.   FileDrive := GetDrive;  FilePath(fname,fname,i);
  243.   IF (Length(fname) > 1) AND (fname[2] = ':') THEN
  244.     FileDrive := DriveNum(fname[1]);
  245. END;
  246. (* ----------------------------------------------------------------------- *)
  247. (*                   aktuelles Verzeichnis ermitteln:                      *)
  248. (* Hier unterscheiden sich MS-DOS und TOS etwas: Pfadnamen werden von MS-  *)
  249. (* DOS ohne den ersten, das Wurzel-(Haupt-) Verzeichnis identifizierenten  *)
  250. (* Backslash "\", von TOS aber mit diesem zurueckgegeben. Wir halten uns   *)
  251. (* hier an TOS und lassen von DGetPath das vorangestellte "\"-Zeichen im-  *)
  252. (* mer zurueckgeben, also auch fuer das Wurzelverzeichnis. Nur im Fehler-  *)
  253. (* fall (ungueltiges Laufwerk) wird eine leere Zeichenfolge erwartet. Fuer *)
  254. (* das Laufwerk gilt: 0 = angemeldetes Laufwerk, 1 = A, 2 = B, 3 = C usw.: *)
  255. (* (Beschreibung fuer die CP/M-Version von DGetPath und den noch folgenden *)
  256. (* Knecht-Prozeduren s. bitte DIRCP.TUR.)                                  *)
  257. PROCEDURE GetDir (drive: INTEGER; VAR path: Dir_Str);
  258. VAR temp: Dir_Chr0;
  259. BEGIN
  260.   temp[1] := Chr(0); DirResult := DGetPath(temp, drive); ChrStr(temp, path);
  261. END;
  262.  
  263. (*                      aktuelles Verzeichnis wechseln:                    *)
  264. (* wieder ein kleiner Unterschied: TOS erlaubt den Verzeichnis-Wechsel nur *)
  265. (* fuer das gerade angemeldete Laufwerk, MS-DOS dagegen fuer alle vorhan-  *)
  266. (* denen Laufwerke (Laufwerksangabe in path enthalten). Wir halten uns an  *)
  267. (* MS-DOS, was fuer DSetPath unter TOS etwas mehr Aufwand bedeutet         *)
  268. (* (s. DIRMT.PSP):                                                         *)
  269. PROCEDURE ChDir (path: Dir_Str);
  270. VAR temp: Dir_Chr0;
  271. BEGIN  StrChr(path, temp);  DirResult := DSetPath(temp);  END;
  272.  
  273. (*                          neues Verzeichnis erzeugen:                    *)
  274. (* hier scheinen MS-DOS und TOS im Einklang zu sein, soweit ich festge-    *)
  275. (* stellt habe:                                                            *)
  276. PROCEDURE MkDir (path: Dir_Str);
  277. VAR temp: Dir_Chr0;
  278. BEGIN  StrChr(path, temp);  DirResult := DCreate(temp);  END;
  279.  
  280. (*                     ein leeres Verzeichnis entfernen:                   *)
  281. (* wieder leichte (?) Diskrepanzen:                                        *)
  282. (* a) TOS mag nur Verzeichnisse der naechsten Ebene loeschen bzw. besteht  *)
  283. (*    auf eine vollstaendige Pfadangabe inklusive Laufwerk. MS-DOS erlaubt *)
  284. (*    dagegen auch Teilpfade von einem Unterverzeichnis aus.               *)
  285. (* b) MS-DOS erlaubt nicht, das gerade aktuelle Verzeichnis zu loeschen,   *)
  286. (*    sei es auch noch so leer. TOS dagegen ist das schnurz, solange das   *)
  287. (*    Verzeichnis leer ist.                                                *)
  288. (* Wir halten uns an MS-DOS, was fuer a) bei TOS durch das Voranstellen    *)
  289. (* der Zeichen ".\" in DDelete vor den Pfad geloesst wird. b) wird dagegen *)
  290. (* fuer TOS noch nicht geloesst, was aber auch keine grosse Beeintraech-   *)
  291. (* tigung der Funktionsfaehigkeit mit sich bringt.                         *)
  292. PROCEDURE RmDir (path: Dir_Str);
  293. VAR temp: Dir_Chr0;
  294. BEGIN  StrChr(path, temp);  DirResult := DDelete(temp);  END;
  295. (* ----------------------------------------------------------------------- *)
  296. (*                freien Disk-Speicherplatz ermitteln:                     *)
  297. (* drive = 0 -> angemeldetes Laufwerk, 1 -> A, 2 -> B usw. MS-DOS und TOS  *)
  298. (* stimmen bei den Ergebnissen von DFree ueberein, CP/M wird davon soft-   *)
  299. (* waremaessig ueberzeugt. Wird ein nicht existierendes Laufwerk ange-     *)
  300. (* sprochen, so sind die Groessen in Info von DFree mit dem Wert -1 zu be- *)
  301. (* legen, wodurch DiskFree einen sinnlosen Wert von -1 liefert!            *)
  302. FUNCTION DiskFree (drive: INTEGER): REAL;
  303. VAR Info: DSK_Info;
  304. BEGIN
  305.   DFree(Info, drive);
  306.   WITH Info DO  DiskFree := SectorSize * ClusterSize * FreeCluster;
  307. END;
  308. (* ----------------------------------------------------------------------- *)
  309. (*                              DIRLIB.PAS                                 *)
  310.