home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1987 / 10 / dosfunc / dircp.tur < prev    next >
Encoding:
Text File  |  1987-08-25  |  17.2 KB  |  361 lines
  1. (* ----------------------------------------------------------------------- *)
  2. (*                               DIRCP.TUR                                 *)
  3. (*              (c) 1987  Michael Ceol & PASCAL INT.                       *)
  4. (*  System- und Compiler-spezifischer Teil der DIRECTORY-Bibliothek fuer   *)
  5. (*                   CP/M 2.x & 3.x in Turbo Pascal                        *)
  6. (*   programmiert und getestet auf einem Schneider Joyce CP/M 3.0-System   *)
  7. (*             sowie einem Schneider CPC 6128 CP/M 2.2-System              *)
  8. (* Der hier durch die CP/M-Versionsunterscheidung zur Laufzeit erzeugte    *)
  9. (* Code kann verringert werden, in dem                                     *)
  10. (*   a) strickt an die gewuenschte CP/M-Version angepasst wird             *)
  11. (*   b) die CP/M 3.0-Features durch die entsprechenden Pascal-Loesungen    *)
  12. (*      ersetzt werden                                                     *)
  13. (* durch beide Massnahmen kann die Versionsunterscheidung mit den ent-     *)
  14. (* sprechend auszufuehrenden Code-Alternativen entfallen. Hier wurde da-   *)
  15. (* rauf verzichtet, um beide Varianten aufzuzeigen.                        *)
  16. (* ----------------------------------------------------------------------- *)
  17.  
  18. (* CP/M 2.x verraet nicht die aktuelle DTA. Da diese aber beim Programm-   *)
  19. (* start immer auf $80 gesetzt ist, koennen wir sie uns immer selbst mer-  *)
  20. (* ken, wenn brav die Prozedur "FSetDTA" benutzt wird. "FGetDTA" liefert   *)
  21. (* dann auch fuer CP/M 2.x immer die wirklich benutzte DTA!                *)
  22.  
  23. CONST CPM_2x_DTA : INTEGER = $80;
  24.  
  25. (* ----------------------------------------------------------------------- *)
  26. (*   CP/M Versionsnummer ermitteln: $20-$2F: CP/M 2.x, $30-$3F: CP/M 3.x   *)
  27. FUNCTION DVersion: INTEGER;
  28. BEGIN  DVersion := Lo(BDosHL($0C))  END;
  29. (* ----------------------------------------------------------------------- *)
  30. (*     ein Byte aus dem System Control Block lesen (nur CP/M 3.0 !!):      *)
  31. FUNCTION GetSCBByte (SCBOfs: BYTE): BYTE;
  32. VAR scbpb: RECORD ofs, com : BYTE; value : INTEGER; END;
  33. BEGIN
  34.   scbpb.ofs := SCBOfs; scbpb.com := 0; GetSCBByte := BDos($31,Addr(scbpb));
  35. END;
  36.  
  37. (*     ein Word aus dem System Control Block lesen (nur CP/M 3.0 !!):      *)
  38. FUNCTION GetSCBWord (SCBOfs: BYTE): INTEGER;
  39. VAR scbpb: RECORD ofs, com : BYTE; value : INTEGER; END;
  40. BEGIN
  41.   scbpb.ofs := SCBOfs; scbpb.com := 0; GetSCBWord := BDosHL($31,Addr(scbpb));
  42. END;
  43.  
  44. (*   ein Byte in den System Control Block schreiben (nur CP/M 3.0 !!):     *)
  45. PROCEDURE SetSCBByte (SCBOfs, newvalue: BYTE);
  46. VAR scbpb: RECORD ofs, com : BYTE; value : INTEGER; END;
  47. BEGIN
  48.   scbpb.ofs := SCBOfs;      scbpb.com := $FF;
  49.   scbpb.value := newvalue;  BDos($31,Addr(scbpb));
  50. END;
  51.  
  52. (*   ein Word in den System Control Block schreiben (nur CP/M 3.0 !!):     *)
  53. PROCEDURE SetSCBWord (SCBOfs: BYTE; newvalue: INTEGER);
  54. VAR scbpb: RECORD ofs, com : BYTE; value : INTEGER; END;
  55. BEGIN
  56.   scbpb.ofs := SCBOfs;      scbpb.com := $FE;
  57.   scbpb.value := newvalue;  BDos($31,Addr(scbpb));
  58. END;
  59. (* ----------------------------------------------------------------------- *)
  60. (*         aktuellen BDOS-Fehlermodus ermitteln (nur CP/M 3.0 !!):         *)
  61. FUNCTION GetDosErrMode: INTEGER;
  62. CONST ErrMode = $4B;
  63. BEGIN GetDosErrMode := GetSCBByte(ErrMode); END;
  64.  
  65. (*             neuen BDOS-Fehlermodus setzen (nur CP/M 3.0 !!):            *)
  66. PROCEDURE SetDosErrMode (ErrMode: INTEGER);
  67. BEGIN  BDos($2D, ErrMode)  END;
  68. (* ----------------------------------------------------------------------- *)
  69. PROCEDURE FSetDTA (DTA: DTA_Ptr);               (* neue DTA-Adresse setzen *)
  70. BEGIN
  71.   BDos($1A, Ord(DTA));              (* bei CP/M 2.x die DTA selbst merken: *)
  72.   IF NOT (DVersion IN [$30..$3F]) THEN CPM_2x_DTA := Ord(DTA);
  73. END;
  74.  
  75. FUNCTION FGetDTA: DTA_Ptr;               (* aktuelle DTA-Adresse ermitteln *)
  76. CONST CurDTA = $3C;
  77. BEGIN
  78.   IF DVersion IN [$30..$3F] THEN  FGetDTA := Ptr(GetSCBWord(CurDTA))
  79.   ELSE  FGetDTA := Ptr(CPM_2x_DTA);                          (* CP/M 2.x ! *)
  80. END;
  81. (* ----------------------------------------------------------------------- *)
  82. FUNCTION DGetDrive: INTEGER;               (* aktuelles Laufwerk ermitteln *)
  83. BEGIN  DGetDrive := BDos($19)  END;
  84.  
  85. FUNCTION DSetDrive (drive: INTEGER): INTEGER;     (* neues Laufwerk setzen *)
  86. VAR olderrmode, errcode: INTEGER;
  87. BEGIN
  88.   DSetDrive := DOSedriv;                   (* Funktion erstmal fehlerhaft! *)
  89.   IF drive IN [0..15] THEN BEGIN
  90.                           (* keinen Fehlerabbruch durch CP/M 3.0 zulassen: *)
  91.     IF DVersion IN [$30..$3F] THEN BEGIN
  92.       olderrmode := GetDosErrMode;  SetDosErrMode($FF);
  93.     END;
  94.     errcode := BDos($0E, drive);
  95.                       (* wieder alten Fehlermodus von CP/M 3.0 herstellen: *)
  96.     IF DVersion IN [$30..$3F] THEN SetDosErrMode(olderrmode);
  97.     IF errcode = 0 THEN DSetDrive := DOSfnok;          (* hat's geklappt ? *)
  98.   END;
  99. END;
  100. (* ----------------------------------------------------------------------- *)
  101. FUNCTION DGetUser: INTEGER;           (* aktuelle Benutzernummer ermitteln *)
  102. BEGIN  DGetUser := BDos($20,$FF);  END;
  103.  
  104. PROCEDURE DSetUser (user: INTEGER);          (* neue Benutzernummer setzen *)
  105. BEGIN  BDos($20,user);  END;
  106. (* ----------------------------------------------------------------------- *)
  107. (*     aktuellen Pfad (MS-DOS-Simulation) = Benutzernummer ermitteln:      *)
  108. FUNCTION DGetPath (VAR path: Dir_Chr0; dummydrive: INTEGER): INTEGER;
  109. VAR  i: INTEGER;  temp: STRING[3];
  110. BEGIN
  111.   i := DGetUser;  Str(i,temp);
  112.   FOR i := 1 TO Length(temp) DO path[i] := temp[i];
  113.   path[Length(temp)+1] := ':';  path[Length(temp)+2] := Chr(0);
  114.   DGetPath := DOSfnok;
  115. END;
  116.  
  117. (* Pfadspezifikation aus fspec extrahieren und in fpath zurueckgeben. Da-  *)
  118. (* bei findet keine Ueberpruefung auf Korrektheit des Pfades statt!. next- *)
  119. (* ch zeigt auf das erste, dem Pfad folgende Zeichen des Dateinamens.      *)
  120. PROCEDURE FGetPath (VAR fspec, fpath: Dir_Chr0; VAR nextch: INTEGER);
  121. VAR i:INTEGER;
  122. BEGIN
  123.   nextch := 0;
  124.   REPEAT nextch := Succ(nextch);  fpath[nextch] := UpCase(fspec[nextch]);
  125.   UNTIL (fspec[nextch] = ':') OR (fspec[nextch] = Chr(0));
  126.   IF fspec[nextch] = ':' THEN  nextch := Succ(nextch)  ELSE  nextch := 1;
  127.   fpath[nextch] := Chr(0);
  128. END;
  129.  
  130. (*         neuen Pfad (MS-DOS-Simulation) = Benutzernummer setzen:         *)
  131. FUNCTION DSetPath (VAR path: Dir_Chr0): INTEGER;
  132. VAR i, j, n, nextch, Usr: INTEGER;  temp: Dir_Chr0;
  133. BEGIN
  134.   DSetPath := DOSfnok;
  135.   FGetPath(path, temp, nextch);             (* Pfad ueberhaupt angegeben ? *)
  136.   IF nextch > 1 THEN BEGIN                                        (* ja... *)
  137.     i := DOSfnok;  n := 1;  nextch := nextch-2;
  138.     j := Ord(temp[1])-Ord('A');                    (* Laufwerk angegeben ? *)
  139.     IF j IN [0..15] THEN BEGIN  i := DSetDrive(j);  n := 2;  END;   (* ja! *)
  140.     IF i = DOSfnok THEN BEGIN
  141.       IF nextch >= n THEN BEGIN     (* User-Nummer (Directory) angegeben ? *)
  142.         j := 1;  Usr := 0;
  143.         FOR i := n TO nextch DO
  144.           IF temp[i] IN ['0'..'9'] THEN BEGIN
  145.             Usr := Usr * j + Ord(path[i])-Ord('0');  j := j*10;
  146.            END
  147.           ELSE  DSetPath := DOSpthnf;
  148.         DSetUser(Usr);
  149.       END;
  150.      END
  151.     ELSE DSetPath := DOSpthnf
  152.   END;
  153. END;
  154. (* ----------------------------------------------------------------------- *)
  155. (* Dateinamen wie z.B. "a:*.pas" untersuchen und in der Form "1????????PAS"*)
  156. (* im File Control Block "DirFCB" eintragen sowie weitere Vorbereitungen   *)
  157. (* im "DirFCB" zur Suche treffen. Diese Funktion existiert erst ab CP/M    *)
  158. (* 3.0. Fuer CP/M 2.x die in "FPARSCP2.PAS" angegebene alternative verwen- *)
  159. (* den! Die Funktion wurde an die Konventionen der MS-DOS-Funktion 29 an-  *)
  160. (* gepasst: result=0 -> fname war ok, result=1 -> fname enthaelt "*" oder  *)
  161. (* "?", result = 255 -> fname fehlerhaft (z.B. illegales Laufwerk). next-  *)
  162. (* ch zeigt auf das erste, nicht mehr zum Dateiname gehoerende Zeichen.    *)
  163. PROCEDURE FParsName (VAR fname: Dir_Chr0; VAR nextch, result: INTEGER);
  164. VAR pfcb: RECORD fname_adr, FCB_adr : INTEGER; END;  temp: INTEGER;
  165. BEGIN
  166.   pfcb.fname_adr := Addr(fname);  pfcb.FCB_adr := Addr(DirFCB);
  167.   temp := BDosHL($98,Addr(pfcb)); result := 0; nextch := 0;
  168.   IF temp = $FFFF THEN result := 255
  169.   ELSE IF temp <> 0 THEN nextch := Succ(temp-Addr(fname));
  170.   FOR temp := 1 TO 11 DO IF DirFCB.name[temp] = '?' THEN result := 1;
  171. END;
  172. (* ----------------------------------------------------------------------- *)
  173. (*         Die CP/M-Dateiattribute an die von MS-DOS/TOS anpassen:         *)
  174. FUNCTION GetDEAttr(DTAInx: INTEGER): INTEGER;
  175. VAR attr: INTEGER;
  176. BEGIN
  177.   attr := 0;
  178.   IF DirDTA^[DTAInx].fname[9]  > Chr(127) THEN attr := attr + DirRO;
  179.   IF DirDTA^[DTAInx].fname[10] > Chr(127) THEN attr := attr + DirSys;
  180.   IF DirDTA^[DTAInx].fname[11] < Chr(128) THEN attr := attr + DirBak;
  181.   GetDEAttr := attr;
  182. END;
  183. (* ----------------------------------------------------------------------- *)
  184. (*         ersten Directory-Eintrag nach MS-DOS-Manier suchen:             *)
  185. FUNCTION FSFirst (VAR search: Dir_Chr0; attr: INTEGER): INTEGER;
  186. VAR i, j, nextch, voldrive, olddrive, oldusr: INTEGER;
  187.     found: BOOLEAN;  path: Dir_Chr0;
  188. BEGIN
  189.   DirFCB.DirUsr := 0;  DirFCB.DirAtr := attr;
  190.   FGetPath(search, path, nextch);                      (* Pfad angegeben ? *)
  191.   IF nextch = 1 THEN  i := DGetPath(path,0)          (* nein, also default *)
  192.   ELSE BEGIN                                (* ja, aus 'search' entfernen! *)
  193.     i := 0;  nextch := Pred(nextch);
  194.     IF path[1] IN ['A'..'P'] THEN BEGIN  (* Laufwerk wird im FCB gebraucht *)
  195.       i := 2;  search[i] := ':';
  196.     END;
  197.     REPEAT
  198.       nextch := Succ(nextch);  i := Succ(i);  search[i] := search[nextch];
  199.     UNTIL search[nextch] = Chr(0);
  200.   END;
  201.   found := FALSE;  FSFirst := DOSnmfil;
  202.   oldusr := DGetUser;                              (* aktuelle User-Nummer *)
  203.   olddrive := DGetDrive;                           (*  und Laufwerk merken *)
  204.   IF DSetPath(path) = DOSfnok THEN BEGIN (* Laufw. u. User fuer Dir setzen *)
  205.     FParsName(search,i,j);
  206.     IF j <> 255 THEN BEGIN                        (* gueltiger Dateiname ? *)
  207.       DirFCB.DirUsr := DGetUser;   (* User-Nummer und Laufwerk fuer FSNext *)
  208.       DirFCB.DirDrv := DGetDrive;  (* im erweiterten FCB uebergeben.       *)
  209.       IF attr = DirVol THEN BEGIN  (* Directory-Label(Volume) gewuenscht ? *)
  210.         DirFCB.drive := Ord('?');    (* ja, alle Eintraege nach Directory- *)
  211.                                      (* Label durchsuchen....              *)
  212.         i := BDos($11,Addr(DirFCB));              (* ersten Eintrag suchen *)
  213.         WHILE (i <> 255) AND NOT found DO
  214.           IF DirDTA^[i].dircod = 32 THEN BEGIN            (* gefunden? Ja! *)
  215.               DirFCB.DTAInx := i;  found := TRUE;  FSFirst := DOSfnok;
  216.             END
  217.           ELSE i := BDos($12);                 (* nein, naechsten Eintrag. *)
  218.       END
  219.       ELSE BEGIN                            (* normale Suche nach Dateien: *)
  220.         i := BDos($11,Addr(DirFCB));              (* ersten Eintrag suchen *)
  221.         REPEAT
  222.           IF i <> 255 THEN BEGIN
  223.             j := GetDEAttr(i) AND 223;            (* besondere Attribute ? *)
  224.             IF j > 0 THEN IF (j AND DirFCB.DirAtr) > 0 THEN j := 0;
  225.             IF j = 0 THEN BEGIN   (* Eintrag stimmt mit Suchspez. ueberein *)
  226.               DirFCB.DTAInx := i; FSFirst := DOSfnok; found := TRUE;
  227.              END
  228.             ELSE i := BDos($12)   (* sonst mit dem Naechsten weiter machen *)
  229.           END;
  230.         UNTIL (i = 255) OR found;  (* bis gefunden oder kein Eintrag mehr. *)
  231.       END;
  232.     END;
  233.     DSetUser(oldusr);  i := DSetDrive(olddrive);
  234.   END;
  235. END;
  236.  
  237. (*              naechsten Eintrag nach MS-DOS-Manier suchen:               *)
  238. FUNCTION FSNext: INTEGER;
  239. VAR  i,j,oldusr,olddrive: INTEGER;  found: BOOLEAN;
  240. BEGIN
  241.   IF DirFCB.DirAtr <> DirVol THEN BEGIN (* DirVol ist eine exklusive Suche *)
  242.     oldusr := DGetUser;     DSetUser(DirFCB.DirUsr);
  243.     olddrive := DGetDrive;  i := DSetDrive(DirFCB.DirDrv);
  244.     FSNext := DOSfilnf;  found := FALSE;
  245.     REPEAT
  246.       i := BDos($12);
  247.       IF i <> 255 THEN BEGIN                                 (* s. FSFirst *)
  248.         j := GetDEAttr(i) AND 223;
  249.         IF j > 0 THEN IF (j AND DirFCB.DirAtr) > 0 THEN j := 0;
  250.         IF j = 0 THEN BEGIN
  251.           DirFCB.DTAInx := i;  FSNext := DOSfnok;  found := TRUE;
  252.         END;
  253.       END;
  254.     UNTIL (i = 255) OR found;
  255.     DSetUser(oldusr);  i := DSetDrive(olddrive);
  256.   END;
  257. END;
  258. (* ----------------------------------------------------------------------- *)
  259. (* ----------------------------------------------------------------------- *)
  260. (*       zwei Bit-Funktionen, die Compiler-abhaengig sind:                 *)
  261. (*  Die Bits von "value" um "n" Stellen nach rechts shiften (verschieben): *)
  262. FUNCTION ShiftR (value, n: INTEGER): INTEGER;
  263. BEGIN  ShiftR := value SHR n  END;
  264. (*              Die Bits von "val1" und "val2" undieren:                   *)
  265. FUNCTION AndInt (val1, val2: INTEGER): INTEGER;
  266. BEGIN  AndInt := val1 AND val2  END;
  267. (* ----------------------------------------------------------------------- *)
  268. (*           nochmal zwei eventuell anzupassende Routinen:                 *)
  269. (* Integer-Wert zu einer 'n'-stelligen Zeichenkette mit fuehrenden Nullen: *)
  270. PROCEDURE IntStr (value, n: INTEGER; VAR s: Dir_Str);
  271. VAR i : INTEGER;  Ch: CHAR;
  272. BEGIN
  273.   s := '';
  274.   FOR i := 1 TO n DO BEGIN
  275.     s := Concat(Chr((value MOD 10)+Ord('0')),s);  value := value DIV 10;
  276.   END;
  277. END;
  278. (* wg. negativen Integer-Werten bei grossen Dateigroessen selbigen Wert zu *)
  279. (*               einem positiven Real-Wert konvertieren:                   *)
  280. FUNCTION IntCard (i: INTEGER): REAL;
  281. BEGIN IF i < 0 THEN IntCard := 65536.0 + i ELSE IntCard := i; END;
  282. (* ----------------------------------------------------------------------- *)
  283. (* ----------------------------------------------------------------------- *)
  284. (* Konvertierung eines CP/M 3.x Datums. Das CP/M-Datum ist die Anzahl von  *)
  285. (*   seit dem 1.1.1978 vergangenen Tagen (etwas seltsam, oder nicht ?):    *)
  286. PROCEDURE DOSDateStr (DOSDate: INTEGER; VAR Date: Date_Str);
  287. CONST monate: ARRAY[0..12] OF INTEGER =
  288.                 (0,31,59,90,120,151,181,212,243,273,304,334,365);
  289. VAR j, schalt, lfdtag, tag, monat, jahr: INTEGER;  temp: Dir_Str;
  290. BEGIN
  291.   j := (DOSDate+364) MOD 1461;  schalt := 0;  monat := 0;
  292.   IF j > 1095 THEN schalt := 1;
  293.   jahr := ((DOSDate+364) DIV 1461) * 4 + (j-schalt) DIV 365 + 1977;
  294.   IF j = 1460 THEN BEGIN  tag := 31;  monat := 12;  END
  295.   ELSE BEGIN
  296.     lfdtag := j MOD 365;
  297.     IF (schalt = 1) AND (lfdtag = 59) THEN
  298.       BEGIN  tag := 29;  monat := 2; END
  299.     ELSE BEGIN
  300.       REPEAT
  301.         IF (schalt = 1) AND (monat > 1) THEN j := 1  ELSE  j := 0;
  302.         monat := Succ(monat);
  303.       UNTIL (lfdtag < monate[monat+j]) OR (monat = 12);
  304.       tag := lfdtag - monate[Pred(monat)] - j + 1;
  305.     END;
  306.   END;
  307.   IntStr(jahr,4,temp);   Date := temp;
  308.   IntStr(monat,2,temp);  Date := Concat(Date,temp);
  309.   IntStr(tag,2,temp);    Date := Concat(Date,temp);
  310. END;
  311.  
  312. (* Konvertierung der CP/M 3.0-Zeit. Stunde und Minute sind in DOSTime BCD- *)
  313. (*                              codiert:                                   *)
  314. PROCEDURE DOSTimeStr (DOSTime: INTEGER; VAR Time: Time_Str);
  315.       (* Byte mit zwei BCD-Ziffern zu einen 2-Zeichen-String konvertieren: *)
  316.   FUNCTION BCDtoStr (i: INTEGER): Time_Str;
  317.   VAR j: INTEGER;
  318.   BEGIN
  319.     j := i SHR 4 + Ord('0');  i := i AND 15 + Ord('0');
  320.     BCDtoStr := Concat(Chr(j),Chr(i));
  321.   END;
  322.  
  323. BEGIN (* DOSTimeStr *)
  324.   Time := BCDtoStr(DOSTime MOD 256);                            (* Stunden *)
  325.   Time := Concat(Time,BCDtoStr(DOSTime DIV 256));               (* Minuten *)
  326.   Time := Concat(Time,'00');                             (* keine Sekunden *)
  327. END;
  328. (* ----------------------------------------------------------------------- *)
  329. (* BS-Funktion zur Ermittlung der Dateigroesse mit initial. FCB aufrufen:  *)
  330. (* CP/M gibt die Anzahl von 128-Byte-Records in 'ranrec' des FCBs zurueck. *)
  331. FUNCTION CompFSize: REAL;
  332. BEGIN
  333.   WITH DirFCB DO BEGIN
  334.     BDos($23, Addr(DirFCB));
  335.     CompFSize := (ranrec[2]*65536.0+ranrec[1]*256.0+ranrec[0])*128.0;
  336.   END;
  337. END;
  338.  
  339. (* Da CP/M Dateigroessen nicht mit den Dir-Suchfunktionen liefert, wird    *)
  340. (* diese fuer ein gelesenes Directory hier mittels der entspr. BS-Funktion *)
  341. (* ermittelt. Dies kann nicht waehrend des Lesens des Directorys geschehen,*)
  342. (* da zwischen FSFirst und FSNext keine anderen Directory-bezogenen Funk-  *)
  343. (* tionen ausgefuehrt werden duerfen! Diese Vorgehensweise benoetigt aller-*)
  344. (* dings entspr. Zeit. Wenn auf die Groesse verzichtet werden kann, ist    *)
  345. (* der Aufruf dieser Prozedur in "Dir" (s. DIRLIB.PAS) zu entfernen!       *)
  346. PROCEDURE FDirSize;
  347. VAR i, j, oldusr, olddrive: INTEGER;
  348. BEGIN
  349.   oldusr := DGetUser;     DSetUser(DirFCB.DirUsr);
  350.   olddrive := DGetDrive;  i := DSetDrive(DirFCB.DirDrv);
  351.   FOR i := 1 TO Directory.num DO
  352.     WITH Directory.items[i] DO BEGIN
  353.       FOR j := 1 TO 8 DO DirFCB.name[j] := name[j];
  354.       FOR j := 1 TO 3 DO DirFCB.name[j+8] := ext[j];
  355.       DirFCB.drive := 0;  size := CompFSize;
  356.     END;
  357.   DSetUser(oldusr);  i := DSetDrive(olddrive);
  358. END;
  359. (* ----------------------------------------------------------------------- *)
  360. (*                               DIRCP.TUR                                 *)
  361.