home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / dtx9303 / dup / dup.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  30.4 KB  |  779 lines
  1. {$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-,X+}
  2. {$IFDEF Ver70} {$P-,Q-,T-,Y-} {$ENDIF}
  3. {$M 16384, 16384, 655360}
  4. (*========================================================*)
  5. (*                        DUP.PAS                         *)
  6. (*  Copyright (c) 1993  Karsten Gieselmann & DMV-Verlag   *)
  7. (*  Turbo/Borland Pascal ab 6.0, Stony Brook Pascal+ 6.0  *)
  8. (*                      DOS ab 3.30                       *)
  9. (*========================================================*)
  10. PROGRAM Dup;
  11.  
  12. USES
  13.   Crt, Dos,     (* benötigte Units aus dem Runtime-System *)
  14.   DupUtil;      (* ausgelagerte allgemeine Hilfsroutinen  *)
  15.  
  16. CONST
  17.   Version    = '1.0a';
  18.   BufferSize = $4000;      (* Puffer für Dateivergleich   *)
  19.  
  20. CONST                      (* Return-Codes:               *)
  21.   Ok              =   0;   (* Programm normal beendet     *)
  22.   NoFilesFound    =   1;   (* keine Dateien gefunden      *)
  23.   HelpCalled      =   8;   (* Programmende mit Hilfe      *)
  24.   UserAbort       =   9;   (* Abbruch durch Benutzer      *)
  25.   InvalidParams   =  10;   (* unerlaubter/ungültig. Param *)
  26.   InsufficientMem =  20;   (* zu wenig Hauptspeicher      *)
  27.   FaultOnIO       =  30;   (* Fehler bei Dateiein/ausgabe *)
  28.   WrongDos        = 200;   (* DOS-Version < 3.30          *)
  29.   InternalError   = 250;   (* interner Fehler             *)
  30.  
  31. CONST
  32.   StdErrHandle    = 2;     (* Handle für StdErr-Device    *)
  33.  
  34. TYPE
  35.   tDriveStr = STRING[27];           (* Buchstabenfolge    *)
  36.                                     (* der Laufwerksliste *)
  37. CONST
  38.   EqualContent   : BOOLEAN = TRUE;  (* Inhalt prüfen?     *)
  39.   EqualName      : BOOLEAN = FALSE; (* gl. Namen prüfen?  *)
  40.   EqualNameExt   : BOOLEAN = FALSE; (* Test Name+Suffix?  *)
  41.   LoggedDrives   : BOOLEAN = FALSE; (* alle Laufwerke?    *)
  42.   RemoteDrives   : BOOLEAN = FALSE; (* Netzwerklaufwerke? *)
  43.   FileNamesOnly  : BOOLEAN = FALSE; (* nur Dateinamen?    *)
  44.   SuppressSummary: BOOLEAN = FALSE; (* Statistik-Report?  *)
  45.   QuietSearch    : BOOLEAN = FALSE; (* keine Pfadangabe?  *)
  46.   DriveList      : tDriveStr = '';  (* Suchlaufwerke      *)
  47.   TotalFileCount : LongInt = 0;     (* Dateizähler        *)
  48.   DuplicateCount : LongInt = 0;     (* Duplikatzähler     *)
  49.   TotalFileSize  : LongInt = 0;     (* Dateigröße         *)
  50.   DuplicateSize  : LongInt = 0;     (* Duplikatgröße      *)
  51.  
  52. (*--------------------------------------------------------*)
  53. (*            Deklaration für Pool-Strukturen             *)
  54.  
  55. CONST
  56.   MaxFile   = 1023;        (* maximaler Hashcode Filepool *)
  57.   MaxName   =  512;        (* maximaler Hashcode Namepool *)
  58.  
  59. TYPE
  60.   tFileIndex = 0..MaxFile;(* Wertebereich Filepool Indizes*)
  61.   tNameIndex = 0..MaxName;(* Wertebereich Namepool Indizes*)
  62.   fsFileName = STRING[12];(* Stringtyp für Dateinamen     *)
  63.   tStringPtr = ^STRING;   (* Zeigertyp auf Dateinamen     *)
  64.  
  65. TYPE
  66.   tFileDescPtr = ^tFileDesc;  (* Zeiger auf Filepool Elem.*)
  67.   tFileDesc    = RECORD       (* Beschreibung Filepool El.*)
  68.     DirPtr     : tStringPtr;  (* Verweis auf Namepool     *)
  69.     Name       : fsFileName;  (* Dateiname                *)
  70.     NameExt    : fsFileName;  (* Dateiname und -endung    *)
  71.     Size       : LongInt;     (* Dateigröße in Bytes      *)
  72.     Time       : LongInt;     (* Datum-/Zeitstempel       *)
  73.     Prev, Next : tFileDescPtr;(* Nachbarn in Koll.-Liste  *)
  74.   END;
  75.  
  76.   tNameDescPtr = ^tNameDesc;  (* Zeiger auf Namepool-Elem.*)
  77.   tNameDesc    = RECORD       (* Beschreibung Namepool-El.*)
  78.     HashKey    : WORD;        (* 16-Bit Hashschlüssel     *)
  79.     NamePtr    : tStringPtr;  (* Verweis auf DIR-Namen    *)
  80.     Prev, Next : tNameDescPtr;(* Nachbarn in Koll.-liste  *)
  81.   END;
  82.  
  83. VAR
  84.   FilePool: ARRAY[tFileIndex] OF tFileDescPtr;
  85.                                   (* Hashtabelle Filepool *)
  86.   NamePool: ARRAY[tNameIndex] OF tNameDescPtr;
  87.                                   (* Hashtabelle Namepool *)
  88.  
  89. (*--------------------------------------------------------*)
  90. (*                  allgemeine Variablen                  *)
  91.  
  92. VAR
  93.   FileSpec    : PathStr;    (* Suchmaske für Rekursion    *)
  94.   Buf1, Buf2  : ARRAY[1..BufferSize] OF CHAR;
  95.                             (* Puffer für Dateivergleich  *)
  96.   CollectTime : LongInt;    (* Zeit für Suche auf Platte  *)
  97.   CompareTime : LongInt;    (* Zeit für Suche in Hashtab. *)
  98.   StdErr      : Text;       (* Gerät für Fehlermeldungen  *)
  99.   rc          : WORD;       (* letzter I/O-Returncode     *)
  100.  
  101. PROCEDURE OpenStdErr;
  102. (* Öffnet das StdErr-Device für die Ausgabe von Fehler-   *)
  103. (* meldungen                                              *)
  104. BEGIN
  105.   Assign(StdErr, ''); Rewrite(StdErr);
  106.   IF IOResult = 0 THEN BEGIN
  107.    (* Handle eintragen und zeichenweise Ausgabe erzwingen *)
  108.     TextRec(StdErr).Handle  := StdErrHandle;
  109.     TextRec(StdErr).BufSize := 1;
  110.   END ELSE BEGIN
  111.     WriteLn('Error opening standard error device');
  112.     Halt(FaultOnIO);
  113.   END;
  114. END;
  115.  
  116. PROCEDURE OpenStdOut;
  117. (* Bildschirmausgaben über StdOut, um Umlenkung zu er-    *)
  118. (* möglichen                                              *)
  119. BEGIN
  120.   Assign(Output, ''); Rewrite(Output);
  121. END;
  122.  
  123. PROCEDURE OpenCrtOut;
  124. (* Bildschirmausgaben über Crt, um die Ausgabe zu         *)
  125. (* beschleunigen                                          *)
  126. BEGIN
  127.   AssignCrt(Output); Rewrite(Output);
  128. END;
  129.  
  130. FUNCTION UserBreak: BOOLEAN;
  131. (* Überprüft, ob zwischenzeitlich eine Abbruchtaste ge-   *)
  132. (* drückt wurde                                           *)
  133. VAR
  134.   ch: CHAR;
  135. BEGIN
  136.   UserBreak := FALSE;
  137.   WHILE KeyPressed DO BEGIN
  138.     ch := ReadKey;
  139.     CASE ch OF
  140.       ^@:     UserBreak := (ReadKey = ^@); (* ^Break      *)
  141.       ^[, ^C: UserBreak := TRUE;           (* ^C oder Esc *)
  142.     END;
  143.   END;
  144. END;
  145.  
  146. (*--------------------------------------------------------*)
  147. (*                    Fehlerbehandlung                    *)
  148.  
  149. FUNCTION RunErrorMsg(ErrorCode: WORD): STRING;
  150. (* Liefert Klartextmeldung zu einer Turbo-Pascal-Fehler-  *)
  151. (* Nummer                                                 *)
  152. BEGIN
  153.   CASE ErrorCode OF
  154.     0 : RunErrorMsg := '';
  155.     1 : RunErrorMsg := 'Invalid DOS function call number';
  156.     2 : RunErrorMsg := 'File not found';
  157.     3 : RunErrorMsg := 'Path not found';
  158.     4 : RunErrorMsg := 'Too many open files';
  159.     5 : RunErrorMsg := 'File access denied';
  160.     6 : RunErrorMsg := 'Invalid file handle';
  161.     8 : RunErrorMsg := 'Insufficient memory';
  162.    12 : RunErrorMsg := 'Invalid file access mode';
  163.    15 : RunErrorMsg := 'Invalid drive number';
  164.    16 : RunErrorMsg := 'Cannot remove current directory';
  165.    17 : RunErrorMsg := 'Cannot rename across drives';
  166.    18 : RunErrorMsg := 'No more files';
  167.   100 : RunErrorMsg := 'Disk read error';
  168.   101 : RunErrorMsg := 'Disk write error';
  169.   102 : RunErrorMsg := 'File not assigned';
  170.   103 : RunErrorMsg := 'File not open';
  171.   104 : RunErrorMsg := 'File not open for input';
  172.   105 : RunErrorMsg := 'File not open for output';
  173.   106 : RunErrorMsg := 'Invalid numeric format';
  174.   150 : RunErrorMsg := 'Disk is write protected';
  175.   151 : RunErrorMsg := 'Bad drive request structure length';
  176.   152 : RunErrorMsg := 'Drive not ready';
  177.   154 : RunErrorMsg := 'CRC error in data';
  178.   156 : RunErrorMsg := 'Disk seek error';
  179.   157 : RunErrorMsg := 'Unknown media type';
  180.   158 : RunErrorMsg := 'Sector not found';
  181.   159 : RunErrorMsg := 'Printer out of paper';
  182.   160 : RunErrorMsg := 'Device write fault';
  183.   161 : RunErrorMsg := 'Device read fault';
  184.   162 : RunErrorMsg := 'Hardware failure';
  185.   ELSE  RunErrorMsg := 'I/O Error #' + Long2Str(ErrorCode);
  186.   END;
  187. END;
  188.  
  189. PROCEDURE Abort(ErrorMsg: STRING; ExitCode: WORD);
  190. (* Programmabbruch bei einem folgenschweren Fehler; falls *)
  191. (* das Fehlverhalten auf eine I/O-Operation zurückzufüh-  *)
  192. (* ren ist, wird die Fehlermeldung um einen erklärenden   *)
  193. (* Text bezüglich der Fehlerursache ergänzt.              *)
  194. BEGIN
  195.   DelLine;
  196.   IF (ExitCode = FaultOnIO) AND (rc <> 0) THEN
  197.     (* vom Betriebsystem gemeldeter Ein/Ausgabefehler     *)
  198.     WriteLn(StdErr, ^M, ErrorMsg, ', ', RunErrorMsg(rc))
  199.   ELSE IF ExitCode = InternalError THEN
  200.     (* interner Fehler, sollte normal nicht vorkommen     *)
  201.     WriteLn(StdErr, ^M'Internal error: ', ErrorMsg)
  202.   ELSE
  203.     WriteLn(StdErr, ^M^J, ErrorMsg);      (* alles andere *)
  204.   Halt(ExitCode);
  205. END;
  206.  
  207. PROCEDURE Attention(Warning: STRING);
  208. (* Ausgabe einer Warnung, das Programm wird fortgeführt   *)
  209. BEGIN
  210.   WriteLn(StdErr, '*Warning: ', Warning);
  211. END;
  212.  
  213. FUNCTION CheckIO: BOOLEAN;
  214. (* Überprüft die letzte I/O-Operation auf mögliche Fehler *)
  215. BEGIN
  216.   rc := IOResult;(* System-Fehlercode holen und auswerten *)
  217.   IF DosError >= 150 THEN rc := DosError; (* krit. Fehler *)
  218.   CheckIO := (rc = 0);
  219. END;
  220.  
  221. FUNCTION HeapOverflow(Request: WORD): INTEGER; FAR;
  222. (* Eigene Heapüberlauf-Behandlung, bricht das Programm ab *)
  223. BEGIN
  224.   IF Request <> 0 THEN
  225.     Abort('Insufficient memory', InsufficientMem);
  226. END;
  227.  
  228. (*--------------------------------------------------------*)
  229. (*         Initialisierung, Vor- und Nachbereitung        *)
  230.  
  231. PROCEDURE InstallErrorHandler;
  232. (* Installiert die programmeigene Fehlerbehandlung        *)
  233. BEGIN
  234.   OpenStdErr;  (* Ausgabekanal für Fehlermeldungen öffnen *)
  235.   HeapError := @HeapOverflow;(* Heapüberlaufrout. install.*)
  236. END;
  237.  
  238. PROCEDURE DosVersionCheck;
  239. (* Das Programm bricht bei einer DOS-Version < 3.30 ab.   *)
  240. BEGIN
  241.   IF (Lo(DosVersion) < 3) OR                  (* DOS 2.XX *)
  242.     ((Lo(DosVersion) = 3) AND (Hi(DosVersion) < $1E)) THEN
  243.                                        (* DOS 3.0 .. 3.21 *)
  244.     Abort('Incorrect DOS version', WrongDos);
  245. END;
  246.  
  247. PROCEDURE SignOn;
  248. (* Programm- und Versionsmeldung, Hilfsbildschirm         *)
  249. BEGIN
  250.   OpenStdOut;
  251.   IF Pos('?', ParamStr(1)) <> 0 THEN BEGIN
  252.     WriteLn(^M^J'Find duplicate files. Version ', Version,
  253.          ^M^J'(C) 1993  Karsten Gieselmann & DMV-Verlag'^J +
  254.          ^M^J'Usage:  DUP [drive(s):] [options] [>output]' +
  255.          ^M^J'Options are:'                                +
  256.          ^M^J'  -c    Search for files with equal content' +
  257.              ' (default)'                                  +
  258.          ^M^J'  -n    Search for files with equal names',
  259.          ^M^J'  -e    Search for files with equal names '  +
  260.              ' and extensions'                             +
  261.          ^M^J'  -d    Search all logged drives (A:..Z:)'   +
  262.          ^M^J'  -r    Include remote drives in default'    +
  263.              ' drive search list'                          +
  264.          ^M^J'  -f    Display file names only (for piping)'+
  265.          ^M^J'  -s    Suppress search summary',
  266.          ^M^J'  -q    Quiet, don''t display path names'    +
  267.              ' during search'^J                            +
  268.          ^M^J'Default drive search list is all local hard' +
  269.              ' disk drives.'^J,
  270.          ^M^J'Example DUP commands:'                       +
  271.          ^M^J'  DUP cde:       Search drives C:, D: and'   +
  272.              ' E: for files with equal content.',
  273.          ^M^J'  DUP a: -n -s   Search drive A: for files ' +
  274.              'with equal names, no summary.'               +
  275.          ^M^J'  DUP -e -d      Search all drives for files'+
  276.              ' with equal names and extensions.',
  277.          ^M^J'  DUP -r         Search all local and '      +
  278.              'remote hard disk drives for files with'^M^J  +
  279.              '                 equal content.');
  280.     Halt(HelpCalled);
  281.   END;
  282. END;
  283.  
  284. PROCEDURE OS2Message;
  285. (* Ausgabe einer Meldung, falls OS/2 als Betriebssystem   *)
  286. (* verwendet wird, da dort Dateien vom Betriebssystem     *)
  287. (* oder von anderen Tasks verwendet sind / sein können.   *)
  288. (*   OS/2 1.X = Lo(DosVersion) = 10                       *)
  289. (*   OS/2 2.X = Lo(DosVersion) = 20                       *)
  290. (*   Windows N(ot)T(here) (=> OS/2 3.0) ist dann wohl zur *)
  291. (*   Abgrenzung Lo(DosVersion) = 30 ?????                 *)
  292. BEGIN
  293.   IF Lo(DosVersion) IN [10..20] THEN
  294.     WriteLn(StdErr, ^M^J'Attention: ',
  295.                     'You are using DUP in an OS/2 ',
  296.                     Lo(DosVersion) DIV 10, '.',
  297.                     Hi(DosVersion), ' DOS Box,'
  298.                   + ^M^J'files locked by other tasks cannot'
  299.                   + ' be accessed!'^M^J'Warnings will be '
  300.                   + 'displayed when checking such files.'^J)
  301. END;
  302.  
  303. PROCEDURE GetParameters;   (* Auswerten der Kommandozeile *)
  304. CONST
  305.   Options  = 'CDEFNRSQ';   (* erlaubte Optionssymbole     *)
  306.   Switches = 'CDEFNRSQ';   (* erlaubte Schaltersymbole    *)
  307.   Prefixes = '/-';         (* erlaubte Einleitungssymbole *)
  308. VAR
  309.   Param  : ComStr;  (* aktueller Kommandozeilenparameter  *)
  310.   Option : CHAR;    (* zu bearbeitendes Optionssymbol     *)
  311.   Count  : BYTE;    (* Zähler für Kommandozeilenparameter *)
  312. BEGIN
  313.   Count := 1;
  314.   WHILE Count <= ParamCount DO BEGIN
  315.     Param := ParamStr(Count);
  316.     IF (Length(Param) >= 2)          AND
  317.        (Pos(Param[1], Prefixes) > 0) AND
  318.        (Pos(UpCase(Param[2]), Options) > 0) THEN BEGIN
  319.       Option := UpCase(Param[2]);   (* erlaubte Direktive *)
  320.       IF Length(Param) = 2 THEN BEGIN
  321.         IF Pos(Option, Switches) = 0 THEN BEGIN
  322.           (* kein Schalter, nächsten Parameter als        *)
  323.           (* Argument holen                               *)
  324.           Inc(Count);
  325.           IF Count > ParamCount THEN
  326.             Abort('Argument expected: ' + Param + '???',
  327.                   InvalidParams);
  328.           Param := ParamStr(Count);
  329.         END
  330.       END ELSE BEGIN
  331.         IF Pos(Option, Switches) > 0 THEN
  332.           (* direkt hinter einem Schalter darf sonst      *)
  333.           (* nichts mehr stehen!                          *)
  334.           Abort('Invalid use of a switch option: ' + Param,
  335.                 InvalidParams);
  336.       END;
  337.       (* benötigte Aktion entsprechend analysierter       *)
  338.       (* Direktive ausführen:                             *)
  339.       CASE Option OF
  340.         'C', 'E', 'N':
  341.              BEGIN
  342.                EqualContent := (Option = 'C');
  343.                EqualName    := (Option = 'N');
  344.                EqualNameExt := (Option = 'E');
  345.              END;
  346.         'D': LoggedDrives    := TRUE;
  347.         'F': FileNamesOnly   := TRUE;
  348.         'R': RemoteDrives    := TRUE;
  349.         'S': SuppressSummary := TRUE;
  350.         'Q': QuietSearch     := TRUE;
  351.         ELSE
  352.           Abort('Option handling missing (/' + Option + ')',
  353.                 InternalError);
  354.       END;
  355.     END ELSE
  356.       IF (Pos(Param[1], Prefixes) = 0) AND
  357.          (Param[Length(Param)] = ':')      THEN
  358.                             (* Laufwerksangabe übernehmen *)
  359.         DriveList := To_Upper(Copy(Param, 1,
  360.                               Pred(Length(Param))))
  361.       ELSE
  362.         Abort('Invalid option: ' + Copy(Param, 1, 2),
  363.               InvalidParams);
  364.     Inc(Count);
  365.   END;
  366. END;
  367.  
  368. PROCEDURE Initialize;
  369. (* Initialisieren der Datenstrukturen                     *)
  370. VAR
  371.   h     : WORD;
  372.   Drive : CHAR;
  373.   d, p  : BYTE;
  374. BEGIN
  375.   DosError := 0;        (* Work-Around für Bug in Turbo 6 *)
  376.   CheckBreak := FALSE;  (* Abbruch über Crt verbieten     *)
  377.                         (* Hashtabellen initialisieren:   *)
  378.   FOR h := 0 TO MaxFile DO FilePool[h] := NIL;
  379.   FOR h := 0 TO MaxName DO NamePool[h] := NIL;
  380.   IF DriveList = '' THEN  (* Laufwerksliste aufbauen:     *)
  381.     (* Suchlaufwerke automatisch bestimmen, falls nicht   *)
  382.     (* explizit angegeben                                 *)
  383.     FOR Drive := 'A' TO 'Z' DO BEGIN
  384.       d := BYTE(Drive) - 64;                   (* 'A' - 1 *)
  385.       (* Zugriff war ok, Laufwerk mit in Liste aufnehmen: *)
  386.       IF (LoggedDrives     AND (DiskSize(d) > 0)) OR
  387.          (HardDiskDrive(d) AND (LocalDrive(d)     OR
  388.                                    RemoteDrives)) THEN
  389.         IF CheckIO THEN DriveList := DriveList + Drive;
  390.       (* den evtl. von DiskSize noch vorhandenen Fehler   *)
  391.       (* code löschen:                                    *)
  392.       CheckIO;
  393.     END
  394.   ELSE BEGIN
  395.    (* angegebene Laufwerksliste auf Gültigkeit überprüfen *)
  396.     FOR p := 1 TO Length(DriveList) DO BEGIN
  397.       d := Succ(Ord(DriveList[p]) - Ord('A'));
  398.       IF NOT (DriveList[p] IN ['A'..'Z']) THEN
  399.         Abort('Invalid drive letter ' +
  400.               UpCase(DriveList[p]) +  ':', InvalidParams)
  401.       ELSE IF (DiskSize(d) < 0) THEN        (* ungültiges *)
  402.         Abort('Cannot access drive ' +      (* Laufwerk   *)
  403.               UpCase(DriveList[p]) + ':', FaultOnIO);
  404.     END;
  405.   END;
  406. END;
  407.  
  408. (*--------------------------------------------------------*)
  409. (*          Hashschlüssel-Berechnung für Strings          *)
  410.  
  411. FUNCTION ComputeHash(VAR s: STRING): WORD; ASSEMBLER;
  412. (* Hashschlüssel (= Summe aller ASCII-Codes im String)    *)
  413. (* berechnen                                              *)
  414. ASM
  415.   MOV    DX, DS  (* Datensegment-Register sichern         *)
  416.   LDS    SI, s   (* DS:SI ==> s                           *)
  417.   CLD            (* Inkrementierender Stringzugriff       *)
  418.   XOR    BX, BX  (* Hashschlüssel in BX akkumulieren      *)
  419.   XOR    AX, AX  (* AH darf Berechnung nicht beeinflussen *)
  420.   LODSB          (* Längenbyte holen ...                  *)
  421.   MOV    CX, AX  (* und als Schleifenzähler speichern     *)
  422.   OR     AX, AX  (* Falls Leerstring, dann schon fertig   *)
  423.   JZ     @Done   (* ... und tschüß                        *)
  424. @Next:
  425.   LODSB          (* nächstes Zeichen holen ...            *)
  426.   ADD    BX, AX  (* ASCII-Code zum Hashschlüssel addieren *)
  427.   LOOPNZ @Next   (* ... sooft bis alle Zeichen dran waren *)
  428. @Done:
  429.   MOV    DS, DX  (* Datensegment-Register restaurieren    *)
  430.   MOV    AX, BX  (* Funktionswert in AX zurückgeben       *)
  431. END;
  432.  
  433. (*--------------------------------------------------------*)
  434. (*                 Zugriff auf Namepool                   *)
  435.  
  436. FUNCTION EnterNamePool(PathName: STRING): tStringPtr;
  437. (* Trägt einen Verzeichnisnamen im Namepool ein bzw.     *)
  438. (* liefert einen Verweis auf ein bereits existierendes    *)
  439. (* Duplikat zurück                                        *)
  440. VAR
  441.   h    : WORD;          (* 16-Bit Hashschlüssel           *)
  442.   Slot : tNameIndex;    (* Hashtabellen-Slot für Namepool *)
  443.   n    : tNameDescPtr;  (* Verweis auf Pooleintrag        *)
  444. BEGIN
  445.             (* Hashschlüssel berechnen und Slot ermitteln *)
  446.   h    := ComputeHash(PathName);
  447.   Slot := h MOD (Succ(MaxName));
  448.                 (* Kollisionsliste nach Namen durchsuchen *)
  449.   n := NamePool[Slot];
  450.   WHILE (n <> NIL) AND NOT ((n^.HashKey = h)
  451.                    AND (n^.NamePtr^ = PathName)) DO
  452.     n := n^.Next;
  453.   IF n = NIL THEN BEGIN
  454.     New(n);        (* neuen Eintrag anlegen und verankern *)
  455.     WITH n^ DO BEGIN
  456.       HashKey := h;
  457.       Next    := NamePool[Slot];
  458.       Prev    := NIL;
  459.       GetMem(NamePtr, Succ(Length(PathName)));
  460.       Move(PathName, NamePtr^, Length(PathName) + 1);
  461.     END;
  462.     NamePool[Slot] := n;
  463.   END;
  464.                (* Verweis auf Pool-Eintrag zurückliefern: *)
  465.   EnterNamePool := n^.NamePtr;
  466. END;
  467.  
  468. (*--------------------------------------------------------*)
  469. (*                  Zugriff auf Filepool                  *)
  470.  
  471. PROCEDURE EnterFilePool(VAR Path    : PathStr;
  472.                         VAR DirEntry: SearchRec);
  473. (* Legt einen neuen Filepool Eintrag an und verankert ihn *)
  474. (* entsprechend                                           *)
  475. VAR
  476.   Key  : LongInt;       (* 32-Bit Hashschlüssel           *)
  477.   Slot : tFileIndex;    (* Hashtabellen-Slot für Filepool *)
  478.   f    : tFileDescPtr;  (* Verweis auf neuen Pooleintrag  *)
  479.  
  480.   FUNCTION StripExtension(NameExt: fsFileName): fsFileName;
  481.   (* bereinigt einen Dateinamen um die Dateiendung        *)
  482.   VAR
  483.     p: BYTE;
  484.   BEGIN
  485.     p := Pos('.', NameExt);
  486.     IF p > 0 THEN
  487.       StripExtension := Copy(NameExt, 1, Pred(p))
  488.     ELSE
  489.       StripExtension := NameExt;
  490.   END;
  491.  
  492. BEGIN
  493.   (* Filepool Eintrag anlegen und Komponenten versorgen   *)
  494.   New(f);
  495.   WITH f^ DO BEGIN
  496.     DirPtr  := EnterNamePool(To_Lower(Path));
  497.     NameExt := To_Lower(DirEntry.Name);
  498.     Name    := StripExtension(NameExt);
  499.     Size    := DirEntry.Size;
  500.     Time    := DirEntry.Time;
  501.     Prev    := NIL;
  502.     Next    := NIL;
  503.     Inc(TotalFileCount);           (* Zähler akkumulieren *)
  504.     Inc(TotalFileSize, Size);
  505.     IF EqualContent THEN
  506.       Key := Size (* Schlüssel berechnen                  *)
  507.                   (* Schlüssel ist einfach die Dateigröße *)
  508. (* strict Var-String-Check muß ausgeschaltet sein         *)
  509. {$IFOPT V+} {$DEFINE V_ON} {$V-} {$ENDIF}
  510.     ELSE IF EqualName THEN Key := ComputeHash(Name)
  511.       (* alle im Dateinamen vorkommenden Zeichencodes     *)
  512.       (* aufaddieren                                      *)
  513.                       ELSE Key := ComputeHash(NameExt);
  514. (* Falls vorher an, strict Var-String-Check einschalten:  *)
  515. {$IFDEF V_ON} {$V+} {$UNDEF V_ON} {$ENDIF}
  516.                          (* Element in Filepool eintragen *)
  517.     Slot := Key MOD (Succ(MaxFile));
  518.     IF FilePool[Slot] = NIL THEN FilePool[Slot] := f
  519.     (* Kollisionsliste für diesen Slot ist noch nicht     *)
  520.     (* vorhanden                                          *)
  521.     ELSE BEGIN
  522.       (* neues Element als erstes vor der bestehenden     *)
  523.       (* Liste einhängen                                  *)
  524.       Next           := FilePool[Slot];
  525.       Next^.Prev     := f;
  526.       FilePool[Slot] := f;
  527.     END;
  528.   END;
  529. END;
  530.  
  531. (*--------------------------------------------------------*)
  532. (*    Absuchen der Laufwerke und Aufbau des Dateibaums    *)
  533.  
  534. PROCEDURE ScanDir(Path: PathStr);
  535. (* Rekursives Absuchen von »Path« und zugehörigen SubDirs *)
  536. CONST
  537.   FilesOnly = ReadOnly + Hidden + SysFile + Archive;
  538. VAR
  539.   DirEntry: SearchRec;              (* Verzeichniseintrag *)
  540. BEGIN
  541.   IF NOT QuietSearch THEN BEGIN     (* wo sind wir denn   *)
  542.     Write(^M'Searching ', Path);    (* jetzt gerade?      *)
  543.     ClrEoL;
  544.   END;
  545.   FileSpec := Path + '*.*';
  546.   WITH DirEntry DO BEGIN
  547.     (* zunächst alle Dateien im Verzeichnis bearbeiten ...*)
  548.     FindFirst(FileSpec, FilesOnly, DirEntry);
  549.     WHILE DosError = 0 DO BEGIN
  550.       IF (Name[1] <> '.') THEN (* '.' und '..' ignorieren *)
  551.          EnterFilePool(Path, DirEntry);
  552.       FindNext(DirEntry);
  553.     END;
  554.     (* ... dann erst Unterverzeichnisse rekursiv abackern *)
  555.     FindFirst(FileSpec, Directory, DirEntry);
  556.     WHILE DosError = 0 DO BEGIN
  557.       IF UserBreak THEN    (* Programmabbruch ermöglichen *)
  558.         Abort('Aborted by user', UserAbort);
  559.       IF Attr AND Directory = Directory THEN
  560.         IF (Name[1] <> '.') THEN   (* '.' und '..' ignor. *)
  561.           ScanDir(Path + Name + '\');   (* DIR bearbeiten *)
  562.       FindNext(DirEntry);
  563.     END;
  564.   END;
  565. END;
  566.  
  567. PROCEDURE ScanDrives(Drives: tDriveStr);
  568. (* Steuerungsroutine, um alle angegebenen Laufwerke abzu- *)
  569. (* suchen                                                 *)
  570. VAR
  571.   d           : BYTE;       (* Index für Laufwerksliste   *)
  572.   Start, Stop : LongInt;    (* Marken für Laufzeitmessung *)
  573. BEGIN
  574.   OpenCrtOut;
  575.   Start := GetTimerTicks;
  576.   FOR d := 1 TO Length(Drives) DO
  577.     ScanDir(UpCase(Drives[d]) + ':\');
  578.   Write(^M);
  579.   ClrEoL;
  580.   Stop := GetTimerTicks;
  581.   CollectTime := Stop - Start;
  582. END;
  583.  
  584. (*--------------------------------------------------------*)
  585. (* Auswerten der im Filepool akkumulierten Informationen  *)
  586.  
  587. FUNCTION SameFile(a, b: tFileDescPtr): BOOLEAN;
  588. (* Überprüft, ob zwei gegebene Dateien inhaltlich gleich  *)
  589. (* sind; bei einem Lesefehler wird Verschiedenheit der    *)
  590. (* Dateien angenommen. Diese Routine verbraucht den       *)
  591. (* Hauptteil der Laufzeit beim Suchen nach Dateien glei-  *)
  592. (* chen Inhalts. Um unterschiedliche Dateien möglichst    *)
  593. (* schnell identifizieren zu können, wird zunächst nur    *)
  594. (* der erste Sektor zum Vergleich herangezogen. An-       *)
  595. (* schließend wird  mit einer deutlich höheren Blockgröße *)
  596. (* gearbeitet, um den Datendurchsatz von der Platte zu    *)
  597. (* erhöhen.                                               *)
  598. CONST
  599.   InitialBlockSize = 512;   (* Blockgröße bei Erstzugriff *)
  600.   OpenReadShared   = $20;   (* Datei-Öffnungsmodus        *)
  601. VAR
  602.   fa, fb      : FILE;       (* Kontrollblöcke für Dateien *)
  603.   aName, bName: PathStr;    (* Dateinamen                 *)
  604.   aResult, bResult,         (* Kontrollzähler für Zugriff *)
  605.   BlockSize   : WORD;       (* Blockgröße für Dateizugr.  *)
  606.   MisMatch    : BOOLEAN;    (* Flag für Dateivergleich    *)
  607.  
  608. BEGIN
  609.   SameFile := FALSE;    (* Default: keine Übereinstimmung *)
  610.   aName := a^.DirPtr^ + a^.NameExt; (* Dateinamen wieder  *)
  611.   bName := b^.DirPtr^ + b^.NameExt; (* zusammensetzen     *)
  612.   (* beide Dateien mit Satzlänge 1 Byte zum Lesen öffnen  *)
  613.   Assign(fa, aName);
  614.   FileMode := OpenReadShared;
  615.   Reset(fa, 1);
  616.   IF NOT CheckIO THEN BEGIN
  617.     Attention('Cannot open ' + aName + ', skipping file');
  618.     Exit;
  619.   END;
  620.   Assign(fb, bName);
  621.   FileMode := OpenReadShared;
  622.   Reset(fb, 1);
  623.   IF NOT CheckIO THEN BEGIN
  624.     Attention('Cannot open ' + bName + ', skipping file');
  625.     Exit;
  626.   END;
  627.  
  628.   (* ok, jetzt stückweise einlesen und vergleichen        *)
  629.   BlockSize := InitialBlockSize;
  630.   REPEAT
  631.     BlockRead(fa, Buf1, BlockSize, aResult);
  632.     BlockRead(fb, Buf2, BlockSize, bResult);
  633.     IF aResult <> bResult THEN BEGIN
  634.       Attention('Error reading ' + aName + ' and ' + bName
  635.                 + ', skipping files');
  636.       Exit;
  637.     END;
  638.     MisMatch  := NOT SameBytes(Buf1, Buf2, aResult);
  639.     BlockSize := SizeOf(Buf1);
  640.   UNTIL MisMatch OR (aResult = 0);
  641.   Close(fa); Close(fb);     (* Dateien wieder schließen   *)
  642.   SameFile := NOT MisMatch; (* Funktionsresultat besetzen *)
  643. END;
  644.  
  645. PROCEDURE DisplayFile(f: tFileDescPtr);
  646. (* Zeigt den Namen bzw. Directoryinformationen der gege-  *)
  647. (* benen Datei an                                         *)
  648. VAR
  649.   p : DirStr;                        (* Verzeichnisname   *)
  650.   n : NameStr;                       (* Dateiname         *)
  651.   e : ExtStr;                        (* Dateisuffix       *)
  652.   t : DateTime;                      (* Datum/Zeitstempel *)
  653. BEGIN
  654.   WITH f^ DO BEGIN
  655.     IF FileNamesOnly THEN WriteLn(DirPtr^, NameExt)
  656.     ELSE BEGIN
  657.       FSplit(NameExt, p, n, e);
  658.       UnPackTime(Time, t);
  659.       WriteLn(' ', Pad(n, 8), Pad(e, 4), Size: 9,
  660.               t.Day: 4, '.',  PadNumZero(t.Month), '.',
  661.               Copy(PadNumZero(t.Year), 3, 2),
  662.               t.Hour: 4, ':', PadNumZero(t.Min),  '  ',
  663.               DirPtr^);
  664.     END;
  665.   END;
  666. END;
  667.  
  668. PROCEDURE SearchDuplicates;
  669. (* Durchsucht den Filepool nach gleichartigen/gleichnami- *)
  670. (* gen Dateien                                            *)
  671. VAR
  672.   h      : tFileIndex;   (* Index für Hashtabellenzugriff *)
  673.   a, b   : tFileDescPtr; (* Laufvariablen                 *)
  674.   Match,                 (* Flag für Dateivergleich       *)
  675.   NewItem: BOOLEAN;      (* Neuer Dateigruppen-Abschnitt? *)
  676.   Start,
  677.   Stop   : LongInt;      (* Marken für Laufzeitmessung    *)
  678. BEGIN
  679.   OpenStdOut; (* Umlenkung für Ausgabe wieder ermöglichen *)
  680.   Start := GetTimerTicks;
  681.   (* alle Slots der Filepool Hashtabelle der Reihe nach   *)
  682.   (* abklappern                                           *)
  683.   FOR h := 0 TO MaxFile DO BEGIN
  684.     a := FilePool[h];
  685.     WHILE a <> NIL DO BEGIN
  686.       NewItem := TRUE;
  687.       b       := a^.Next;
  688.       WHILE b <> NIL DO BEGIN
  689.         (* Elemente »a« und »b« gegeneinander prüfen      *)
  690.         IF (EqualContent AND (a^.Size = b^.Size) AND
  691.            SameFile(a, b)) OR (EqualName         AND
  692.            (a^.Name = b^.Name)) OR (EqualNameExt AND
  693.            (a^.NameExt = b^.NameExt))            THEN BEGIN
  694.           (* Dateien als Duplikate behandeln ==>          *)
  695.           (* Namen ausgeben                               *)
  696.           Inc(DuplicateCount);
  697.           Inc(DuplicateSize, a^.Size);
  698.           IF NewItem THEN BEGIN
  699.             Inc(DuplicateCount);
  700.             WriteLn;
  701.             DisplayFile(a);
  702.             NewItem := FALSE;
  703.           END;
  704.           DisplayFile(b);
  705.           (* als Duplikat erkannte Datei aus der Liste    *)
  706.           (* streichen:                                   *)
  707.           WITH b^ DO BEGIN
  708.             IF Prev <> NIL THEN Prev^.Next := Next;
  709.             IF Next <> NIL THEN Next^.Prev := Prev;
  710.           END;
  711.         END;
  712.         IF UserBreak THEN  (* Programmabbruch ermöglichen *)
  713.           Abort('Aborted by user', UserAbort);
  714.         b := b^.Next;
  715.       END;
  716.       a := a^.Next;
  717.     END;
  718.   END;
  719.   Stop := GetTimerTicks;
  720.   CompareTime := Stop - Start;
  721. END;
  722.  
  723. (*--------------------------------------------------------*)
  724. (*               Zusammenfassung & Statistik              *)
  725.  
  726. PROCEDURE DisplaySummary;
  727. (* Ausgabe von Statistikinformationen                     *)
  728. CONST
  729.   Plural: ARRAY[BOOLEAN] OF STRING[1] = ('', 's');
  730. CONST
  731.   t = 12;       (* Spaltennummer zur Ausrichtung          *)
  732. VAR
  733.   p, z : BYTE;  (* Indizes zur Ausgabe der Laufwerksliste *)
  734. BEGIN
  735.   IF NOT SuppressSummary THEN BEGIN
  736.     z := Length(DriveList);
  737.     Write(^M^J^J'===================== DUP SEARCH SUMMARY'
  738.         + ': ====================='^M^J^J'           '
  739.         + '  Searching drive', Plural[z > 1], ' ');
  740.     FOR p := 1 TO Pred(z) DO Write(DriveList[p], ':,');
  741.     WriteLn(DriveList[z], ':');
  742.     Write('           ^  for files with equal ');
  743.     IF EqualContent THEN Write('content.');
  744.     IF EqualName    THEN Write('names.');
  745.     IF EqualNameExt THEN Write('names and extensions.');
  746.     WriteLn(^M^J^J, DuplicateCount: t,
  747.             ' Duplicates found within'^M^J,
  748.             TotalFileCount: t, ' Files in total.'^M^J^J,
  749.             DuplicateSize: t,
  750.             ' Bytes allocated by duplicate files,'^M^J,
  751.             TotalFileSize: t,
  752.             ' Bytes allocated by files on searched drive',
  753.             Plural[z > 1], '.'^M^J^J,
  754.             CollectTime / 18.2: t: 2,
  755.             ' Seconds needed to collect files,'^M^J,
  756.             CompareTime / 18.2: t: 2,
  757.             ' Seconds needed to compare files.'^J);
  758.   END;
  759. END;
  760.  
  761. (*--------------------------------------------------------*)
  762. (*                      Hauptprogramm                     *)
  763. (*--------------------------------------------------------*)
  764.  
  765. BEGIN
  766.   InstallErrorHandler;  (* Fehlerbehandlung installieren  *)
  767.   DosVersionCheck;      (* Abbruch bei Version < DOS 3.30 *)
  768.   SignOn;               (* Hilfebildschirm, Meldungen     *)
  769.   OS2Message;           (* Meldung für die OS/2 DOS-Box   *)
  770.   GetParameters;        (* Kommandozeile auswerten        *)
  771.   Initialize;           (* Datenstrukturen initialisieren *)
  772.   ScanDrives(DriveList);(* Filepool aufbauen              *)
  773.   SearchDuplicates;     (* Filepool durchsuchen           *)
  774.   DisplaySummary;       (* Statistik ausgeben             *)
  775. END.
  776.  
  777. (*========================================================*)
  778. (*                    Ende von DUP.PAS                    *)
  779.