home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1988 / 01 / dirlib / dirdemo3.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-11-09  |  5.0 KB  |  137 lines
  1. PROGRAM DirDemo3;
  2. CONST
  3.   (*$I DIRCONST.PAS *)
  4. TYPE
  5.   (*$I DIRMTTYP.PAS *)                  (* bzw. DIRCPTYP.PAS fuer CP/M 3.0 *)
  6. VAR
  7.   (*$I DIRVAR.PAS *)
  8.   ch   : CHAR;
  9.   path, oldpth  : Dir_Str;
  10.   drive, olddrv : INTEGER;
  11.  
  12. (*$I DIRMT.TUR *)    (* bzw. DIRMT.PSP fuer Atari, DIRCP.TUR fuer CP/M 3.0 *)
  13. (*$I DIRMTDTA.PAS *) (* bzw. DIRCPDTA.PAS fuer CP/M 3.0                    *)
  14. (*$I DIRLIB.PAS *)
  15. (* ----------------------------------------------------------------------- *)
  16. PROCEDURE error;
  17. BEGIN
  18.   WriteLn;  Write('**** ');
  19.   CASE DirResult OF
  20.     DOSfnok  : Write('OK');
  21.     DOSinvfn : Write('ungueltige Funktionsnummer');
  22.     DOSfilnf : Write('Datei nicht gefunden');
  23.     DOSpthnf : Write('Pfad nicht gefunden');
  24.     DOSaccdn : Write('Zugriff abgelehnt');
  25.     DOSnsmem : Write('ungenuegend Speicher');
  26.     DOSedriv : Write('ungueltiges Laufwerk');
  27.     DOSrmcur : Write('aktuelles Verzeichnis kann nicht geloescht werden');
  28.     DOSnsdev : Write('nicht die selbe Einheit');
  29.     DOSnmfil : Write('keine weiteren Dateien');
  30.     ELSE       Write('unbekannter Fehler: ',DirResult);
  31.   END;
  32.   Write(' ****');  WriteLn;
  33. END;
  34. (* ----------------------------------------------------------------------- *)
  35. PROCEDURE ShowAttr (attr: INTEGER);
  36. BEGIN
  37.   Write('Attribute:');
  38.   IF AndInt(attr,DirRO) <> 0 THEN Write('  Read only');
  39.   IF AndInt(attr,DirHid) <> 0 THEN Write('  Hidden');
  40.   IF AndInt(attr,DirSys) <> 0 THEN Write('  System');
  41.   IF AndInt(attr,DirDir) <> 0 THEN Write('  Directory');
  42.   WriteLn;
  43. END;
  44. (* ----------------------------------------------------------------------- *)
  45. PROCEDURE DoDir;
  46. VAR  fname: Dir_Str;  i: INTEGER;
  47. BEGIN
  48.   Write('Suchbegriff: ');  ReadLn(fname);  WriteLn;
  49.   Dir(fname,DirRO+DirHid+DirSys+DirDir,Directory);
  50.   Write('Sortiere...');  SortDir(DirName,Directory);  WriteLn;  WriteLn;
  51.   WITH Directory DO
  52.     FOR i := 1 TO num DO BEGIN
  53.       WITH items[i] DO Write('      ',name,'.',ext);
  54.       IF i MOD 4 = 0 THEN WriteLn;
  55.     END;
  56.   WriteLn;  WriteLn(Directory.num,' Dateien gefunden');  WriteLn;
  57. END;
  58. (* ----------------------------------------------------------------------- *)
  59. FUNCTION answer (prompt: Dir_Str): CHAR;
  60. BEGIN
  61.   Write('  ',prompt,' (j/n) ? ');  ReadLn(ch);  answer := UpCase(ch);
  62. END;
  63. (* ----------------------------------------------------------------------- *)
  64. PROCEDURE DotheRest (command: CHAR);
  65. VAR  dirpath, fname: Dir_Str;  i, nextch, result: INTEGER;  ch: CHAR;
  66.      entry: Dir_Rec;
  67.  
  68.   PROCEDURE DoRename;
  69.   VAR newname: Dir_Str;
  70.   BEGIN
  71.     Write('neuer Name: ');  ReadLn(newname);  RenameFile(fname,newname);
  72.   END;
  73.  
  74.   PROCEDURE DoAttribut;
  75.   VAR AttrStr: Dir_Str;  newattr, i: INTEGER;
  76.   BEGIN
  77.     Write('alte ');  ShowAttr(GetFileAttribut(fname));
  78.     Write('neue Attribute (WRHS): ');  ReadLn(AttrStr);
  79.     newattr := DirRW;  i := 1;
  80.     WHILE i <= Length(AttrStr) DO BEGIN
  81.       CASE UpCase(AttrStr[i]) OF
  82.         'R': newattr := OrInt(newattr,DirRO);
  83.         'H': newattr := OrInt(newattr,DirHid);
  84.         'S': newattr := OrInt(newattr,DirSys);
  85.         ELSE;
  86.       END;
  87.       i := Succ(i);
  88.     END;
  89.     Write('neue ');  ShowAttr(SetFileAttribut(fname,newattr));
  90.   END;
  91.  
  92. BEGIN
  93.   Write('Welche Datei: ');  ReadLn(path);
  94.   FilePath(path,dirpath,nextch);            (* Pfadspezifikation abspalten *)
  95.   Dir(path,DirRO+DirHid+DirSys,Directory);  i := 1;
  96.   WHILE i <= Directory.num DO BEGIN
  97.     DirResult := DOSfnok;  MakeDirFileName(i,Directory,fname);
  98.     fname := Concat(dirpath,fname);
  99.     Write(fname,' (',FileSize(fname):0:0,' Bytes)');
  100.     CASE command OF
  101.       'E': IF answer('loeschen') = 'J' THEN EraseFile(fname);
  102.       'R': IF answer('umbenennen') = 'J' THEN DoRename;
  103.       'A': IF answer('Attribute aendern') = 'J' THEN DoAttribut;
  104.     END;
  105.     IF DirResult <> DOSfnok THEN i := Directory.num;
  106.     i := Succ(i);
  107.   END;
  108. END;
  109. (* ----------------------------------------------------------------------- *)
  110. PROCEDURE DoChDir;
  111. BEGIN  Write('neuer Pfad: ');  ReadLn(path);  ChDir(path);  END;
  112. (* ----------------------------------------------------------------------- *)
  113. PROCEDURE DoChDrive;
  114. BEGIN  Write('neues Laufwerk: ');  ReadLn(ch);  ChDrive(DriveNum(ch));  END;
  115. (* ----------------------------------------------------------------------- *)
  116. BEGIN
  117.   NewDirDTA;                      (* DTA fuer Directory-Funktionen anlegen *)
  118.   olddrv := GetDrive;  GetDir(0, oldpth);
  119.   REPEAT
  120.     GetDir(0, path);
  121.     WriteLn; WriteLn('Laufwerk: ', DriveChar(GetDrive));
  122.     WriteLn('Pfad    : ',path);
  123.     WriteLn('Frei    : ',DiskFree(0):0:0,' Bytes');  WriteLn;
  124.     Write('D)ir  C)hDir  CH)Drive  E)raseFile  R)ename  ',
  125.           'A)ttribute  Q)uit  ? ');
  126.     ReadLn(ch);   ch := UpCase(ch);
  127.     CASE ch OF
  128.       'D' : DoDir;    'C' : DoChDir;   'H' : DoChDrive;
  129.       'E','R','A': DotheRest(ch);
  130.       ELSE;
  131.     END;
  132.     IF ch <> 'Q' THEN error;
  133.   UNTIL ch = 'Q';
  134.   ChDrive(olddrv);  ChDir(oldpth);
  135.   DispDirDTA;                (* eigene DTA wird nicht mehr gebraucht, kann *)
  136. END.                         (* entfallen, da sowieso Programm zu ende!    *)
  137.