home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 07_08 / tricks / tree.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1991-02-25  |  13.5 KB  |  439 lines
  1. (* ------------------------------------------------------ *)
  2. (*                     TREE.PAS                           *)
  3. (*           (c) 1991 Michael Reiter & TOOLBOX            *)
  4. (* ------------------------------------------------------ *)
  5. {$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
  6. {$M 65512,0,655360}                { STACK wegen Rekursion }
  7. PROGRAM Tree;
  8.  
  9. USES
  10.   Crt, Dos, Scroll;         { Unit SCROLL aus Toolbox 1/89 }
  11.  
  12. CONST
  13.   MaxLines     = 512;
  14.   Version      = ' TREE (c) 1991 M.Reiter & TOOLBOX';
  15.   TreeFileName = 'TREE-';
  16.   TreeFileExt  = '.DTA';
  17.   xFullPath    : BYTE     = 20;
  18.   WriteFile    : ShortInt =  0;
  19.                        { -1=NICHT schreiben / +1=SCHREIBEN }
  20.                        {  0= nur schreiben,wenn File fehlt }
  21. TYPE
  22.   Str16        = STRING[16];
  23.   EntryTypePtr = ^EntryType;
  24.   EntryType    = RECORD
  25.                    Name    : Str16;
  26.                    Level   : BYTE;
  27.                    Counter : WORD;
  28.                    Back    : EntryTypePtr;
  29.                    Next    : EntryTypePtr
  30.                  END;
  31.   LineType     = ARRAY [1..MaxLines] OF ^STRING;
  32.  
  33. VAR
  34.   Root         : EntryType;
  35.   TreeFPath,
  36.   AktPath,
  37.   OldPath      : STRING;
  38.   Level, Drive : BYTE;
  39.   EntryPtr     : EntryTypePtr;
  40.   Lines        : LineType;
  41.   Counter, Key : WORD;
  42.   TreeFile     : FILE OF EntryType;
  43.  
  44.  
  45.   PROCEDURE Help;
  46.   BEGIN
  47.     TextAttr := $07;
  48.     WriteLn
  49.   ('                                                     ');
  50.     WriteLn
  51.   (' ChangeSubdir: Cursorgesteuerter Verzeichniswechsel  ');
  52.     WriteLn
  53.   ('                mit Hilfe eines Verzeichnisbaums.    ');
  54.     WriteLn
  55.   ('                                                     ');
  56.     WriteLn
  57.   (' Aufruf: TREE [LW:][?][/I±]                          ');
  58.     WriteLn
  59.   ('     LW: Laufwerkangabe (a:, C:, ...)                ');
  60.     WriteLn
  61.   ('         Bei fehlender Angabe => aktuelles Laufwerk  ');
  62.     WriteLn
  63.   ('      ?: Diese Hilfe                                 ');
  64.     WriteLn
  65.   ('    /I+: Neues Baumfile erzeugen und abspeichern     ');
  66.     WriteLn
  67.   ('    /I-: KEIN  Baumfile abspeichern                  ');
  68.     WriteLn
  69.   ('                                                     ');
  70.     WriteLn
  71.   (' Steuerung des Auswahlbalken mit den Cursortasten.   ');
  72.     WriteLn
  73.   (' [Enter]: Wechsel in gewähltes Verzeichnis.          ');
  74.     WriteLn
  75.   (' [Esc]:   Abbruch ohne Verzeichniswechsel.           ');
  76.     WriteLn;
  77.     Halt(0);
  78.   END;
  79.  
  80.   PROCEDURE ErrorMsg(Abbruch : BOOLEAN; Msg : STRING);
  81.   VAR
  82.     TA : BYTE;
  83.   BEGIN
  84.     Window(1, 1, 80, 25);
  85.     TA := TextAttr;  TextAttr := $70;
  86.     WriteLn(Version);
  87.     Write(#7#7#7,' *** TREE: ',Msg,' ! ');
  88.     TextAttr := $07; WriteLn;
  89.     IF Abbruch THEN Halt(1)
  90.                ELSE Delay(5000);
  91.     TextAttr := TA;
  92.   END;
  93.  
  94.   PROCEDURE GetParameter;
  95.   VAR
  96.     FN, s : STRING;
  97.     b     : BYTE;
  98.     SR    : SearchRec;
  99.   BEGIN
  100.     TextAttr := $07; Window(1,1,80,25); ClrScr;
  101.     TextAttr := $0F; WriteLn (Version); TextAttr := $07;
  102.     GetDir(0, OldPath);
  103.     Drive := Ord(OldPath[1]) - 64;
  104.     IF ParamCount = 0 THEN
  105.       Drive := 0
  106.     ELSE
  107.       FOR b := 1 TO ParamCount DO BEGIN
  108.         s := ParamStr(b);
  109.         IF Pos('?', s) <> 0 THEN Help;
  110.         IF (UpCase(s[1]) >='A') AND
  111.            (UpCase(s[1]) <='Z') THEN
  112.           Drive := Ord(UpCase (s[1])) - 64;
  113.         IF (s[1] = '/') AND (UpCase(s[2])= 'I') THEN
  114.           CASE s[3] OF
  115.             '-' : WriteFile := -1;
  116.             '+' : WriteFile := +1;
  117.           ELSE WriteFile :=  0
  118.         END;
  119.       END;
  120.     GetDir(Drive, s);
  121.     ChDir(s[1] + ':\');
  122.     IF IOResult <> 0 THEN
  123.       ErrorMsg(TRUE, 'falsche LW-Angabe');
  124.     GetDir(Drive, s);
  125.     FN := TreeFileName + s[1] + TreeFileExt;
  126.     TreeFPath := s[1] + ':\' + FN;
  127.                        { Volume-Name holen, wenn vorhanden }
  128.     FindFirst(s + '*.*', VolumeID, SR);
  129.     IF DosError = 0 THEN s := s + ' ' + SR.Name;
  130.     WITH Root DO BEGIN
  131.       Name    := s;
  132.       Level   := 0;
  133.       Counter := 1;
  134.       Back    := NIL;
  135.       Next    := NIL;
  136.     END;
  137.     EntryPtr := @Root;
  138.     Level    := 0;
  139.     Counter  := 1;
  140.   END;
  141.  
  142.   PROCEDURE Anhaengen (s : Str16; l : BYTE; VAR c : WORD);
  143.   { Einhängen eines Elements in doppelt verkettete Liste. }
  144.   VAR
  145.     TempEntry : EntryTypePtr;
  146.   BEGIN
  147.     IF MaxAvail <= SizeOf (EntryType) THEN
  148.       ErrorMsg(TRUE, 'Zu wenig freier Speicher');
  149.     New(TempEntry);
  150.     INC(c);
  151.     WITH TempEntry^ DO BEGIN
  152.       Name    := s;
  153.       Level   := l;
  154.       Counter := c;
  155.       Back    := EntryPtr;
  156.       Next    := NIL;
  157.     END;
  158.     EntryPtr^.Next := TempEntry;
  159.     EntryPtr := TempEntry;
  160.   END;
  161.  
  162.   PROCEDURE ScanDirectory(AktPath : STRING; Le : BYTE);
  163.   VAR
  164.     SR : SearchRec;
  165.   BEGIN
  166.     FindFirst(AktPath + '\*.*', Directory, SR);
  167.     WHILE DosError = 0 DO BEGIN
  168.       IF (SR.Attr AND Directory <> 0) THEN
  169.         IF (SR.Name[1] <> '.') THEN BEGIN
  170.           GotoXY(5,12);
  171.           Write(Copy(AktPath + '\' + SR.Name, 1, 74));
  172.           ClrEol;
  173.           { Nur akt. Subdir. merken, nicht ganzen Pfad ! }
  174.           Anhaengen(SR.Name, Le, Counter);
  175.           ScanDirectory(AktPath + '\' + SR.Name, Succ(Le));
  176.         END;
  177.       FindNext(SR);
  178.     END;
  179.   END;
  180.  
  181.   FUNCTION ReadTreeFile : BOOLEAN;
  182.   VAR
  183.     Element : EntryType;
  184.   BEGIN
  185.     Assign(TreeFile, TreeFPath);  Reset(TreeFile);
  186.     IF IOResult <> 0 THEN BEGIN
  187.       ErrorMsg(FALSE, 'Fehler beim Öffnen der Baumdatei');
  188.       ReadTreeFile := FALSE; EXIT;
  189.     END;
  190.     Seek(TreeFile, 0);
  191.     WHILE (NOT EoF (TreeFile)) AND (IOResult = 0) DO BEGIN
  192.       Read(TreeFile, Element);
  193.       Anhaengen(Element.Name, Element.Level, Counter);
  194.     END;
  195.     IF (IOResult <> 0) AND (NOT EoF (TreeFile)) THEN BEGIN
  196.       ErrorMsg(FALSE, 'Fehler beim Einlesen der Baumdatei');
  197.       ReadTreeFile := FALSE; EXIT;
  198.     END;
  199.     Close(TreeFile);
  200.     ReadTreeFile := TRUE;
  201.   END;
  202.  
  203.   PROCEDURE WriteTreeFile;
  204.   VAR
  205.     EPtr : EntryTypePtr;
  206.     Cnt  : WORD;
  207.     Err  : INTEGER;
  208.   BEGIN
  209.     IF (WriteFile = -1) THEN Exit;
  210.     Assign(TreeFile, TreeFPath); Rewrite(TreeFile);
  211.     IF IOResult <> 0 THEN
  212.       ErrorMsg(FALSE, 'Fehler beim Öffnen der Baumdatei');
  213.     EPtr := Root.Next;
  214.     FOR Cnt := 1 TO Counter DO BEGIN
  215.       IF EPtr <> NIL THEN BEGIN
  216.         Write(TreeFile, EPtr^); EPtr := EPtr^.Next
  217.       END;
  218.       Err := IOResult;
  219.       IF Err <> 0 THEN Cnt := Counter
  220.     END;
  221.     IF Err <> 0 THEN
  222.      ErrorMsg(FALSE, 'Fehler beim Schreiben der Baumdatei');
  223.     Close(TreeFile);
  224.   END;
  225.  
  226.   FUNCTION TreeFileFound : BOOLEAN;
  227.    { Gibt TRUE zurück, wenn TREE-File im Root-Verz. steht }
  228.   VAR
  229.     SR : SearchRec;
  230.   BEGIN
  231.     FindFirst(TreeFPath, AnyFile, SR);
  232.     TreeFileFound := (DosError = 0);
  233.   END;
  234.  
  235.   PROCEDURE MakeSubDirList;
  236.      { Diese Routine stellt die Baumstruktur zu Verfügung. }
  237.      { Wenn das TREE-File gefunden wird, werden diesem die }
  238.      { Informationen entnommen, ansonsten wird der Verz.-  }
  239.      { baum gescannt und das TREE-File abgespeichert (oder }
  240.      { auch nicht) => Parameter                            }
  241.   BEGIN
  242.     TextAttr := $0F;
  243.     IF (WriteFile = +1) OR (NOT TreeFileFound) THEN BEGIN
  244.       GotoXY(5,10);
  245.       Write('Scannen der Unterverzeichnisse ... ');
  246.       TextAttr := $07;
  247.       ScanDirectory(Copy(Root.Name, 1, 2), 1);
  248.       WriteTreeFile;
  249.     END ELSE BEGIN
  250.       IF NOT ReadTreeFile THEN BEGIN
  251.         GotoXY(5,10);
  252.         Write('Scannen der Unterverzeichnisse ... ');
  253.         TextAttr := $07;
  254.         ScanDirectory(Copy(Root.Name, 1, 2), 1)
  255.       END;
  256.     END;
  257.     ClrScr;
  258.   END;
  259.  
  260.   PROCEDURE InitLines;
  261.   VAR
  262.     Cnt : WORD;
  263.   BEGIN
  264.     IF Counter > MaxLines THEN Counter := MaxLines;
  265.     FOR Cnt := 1 TO Counter DO Lines[Cnt] := NIL;
  266.   END;
  267.  
  268.   FUNCTION LastDirIn(Le   : WORD;
  269.                      Step : EntryTypePtr) : BOOLEAN;
  270.   { Gibt TRUE zurück, wenn das akt. Verzeichnis das letzte }
  271.   { Unterverz. dieses Levels in diesem Ast ist.            }
  272.   VAR
  273.     Cut, EqualDirFound : BOOLEAN;
  274.   BEGIN
  275.     EqualDirFound := FALSE; Cut := FALSE;
  276.     REPEAT
  277.       Step := Step^.Next;
  278.       IF Step^.Level < Le THEN Cut           := TRUE;
  279.       IF Step^.Level = Le THEN EqualDirFound := TRUE
  280.     UNTIL (Step = NIL) OR
  281.           (Step^.Counter = Counter) OR EqualDirFound OR Cut;
  282.     IF Cut OR (NOT EqualDirFound) THEN LastDirIn := TRUE
  283.                                   ELSE LastDirIn := FALSE;
  284.   END;
  285.  
  286.   PROCEDURE BuildLines;
  287.         { Erstellung der später "sichtbaren" Baumstruktur. }
  288.         { Auf die Zeilen des Baums wird über ein Pointer-  }
  289.         { Array zugegriffen => siehe auch SCROLL-Unit      }
  290.   VAR
  291.     Line, Space   : STRING;
  292.     CurrLevel, w,
  293.     Cnt           : WORD;
  294.     Connect       : ARRAY [1..25] OF BOOLEAN;
  295.   BEGIN
  296.     InitLines;
  297.     FillChar(Connect, SizeOf(Connect), #0);
  298.     FillChar(Space, 255, #32); Space[0] := #255;
  299.     IF MaxAvail <= 80 THEN
  300.       ErrorMsg(TRUE, 'Zu wenig freier Speicherplatz');
  301.     GetMem(Lines[1], 80);
  302.     Move(Space, Lines[1]^, 255);
  303.     Line         := #32 + Root.Name + #32;
  304.     Lines[1]^    := Line;
  305.     Lines[1]^[0] := #79;
  306.     EntryPtr     := Root.Next;
  307.     FOR Cnt := 2 TO Succ (Counter) DO BEGIN
  308.       Line      := EntryPtr^.Name;
  309.       CurrLevel := EntryPtr^.Level;
  310.       IF LastDirIn(CurrLevel, EntryPtr) THEN BEGIN
  311.         Line := '└─' + Line; Connect[CurrLevel] := FALSE;
  312.       END ELSE BEGIN
  313.         Line := '├─' + Line; Connect[CurrLevel] := TRUE;
  314.       END;
  315.       FOR w := CurrLevel DOWNTO 1 DO BEGIN
  316.         IF (w <> CurrLevel) THEN BEGIN
  317.           IF Connect[w] THEN Line := '│ ' + Line
  318.                         ELSE Line := '  ' + Line;
  319.         END;
  320.       END;
  321.       Line := #32 + Line;
  322.       IF Succ(Length(Line)) > xFullPath THEN
  323.         INC(xFullPath, 5);
  324.       IF MaxAvail <= (Length(Line) + 2) THEN
  325.         ErrorMsg(TRUE, 'Zu wenig freier Speicherplatz');
  326.       GetMem(Lines[Cnt], Length(Line) + 2);
  327.       Move(Space, Lines[Cnt]^, Length(Line) + 2);
  328.       Lines[Cnt]^    := Line;
  329.       Lines[Cnt]^[0] := Chr (Succ(Length(Line)));
  330.       EntryPtr       := EntryPtr^.Next;
  331.     END;
  332.   END;
  333.  
  334. { Die beiden nächsten Routinen werden von der Unit SCROLL  }
  335. { aufgerufen und müssen unbedingt im FAR-Modus eingebunden }
  336. { werden !!!                                               }
  337.  
  338. {$F+}
  339.   PROCEDURE NormalWrite(Col, Row : BYTE; Index : LongInt);
  340.                   { Normal-Ausgabe-Routine der Unit SCROLL }
  341.   BEGIN
  342.     GotoXY (Col, Row);    TextAttr := $07;
  343.     Write(Lines[Index]^); ClrEol
  344.   END;
  345.  
  346.   PROCEDURE SelectWrite(Col, Row : BYTE; Index : LongInt);
  347.   { Diese Routine wird von der Unit SCROLL benutzt und     }
  348.   { stellt das momentan angewählte Verzeichnis invers dar. }
  349.   { Ferner ermittelt die Routine den kompletten Pfadnamen  }
  350.   { und bringt ihn ganz oder teilweise, auf den Bildschirm }
  351.   VAR
  352.     Start, Stop : BYTE;
  353.     AktZeile    : STRING;
  354.     EPtr        : EntryTypePtr;
  355.  
  356.     FUNCTION GetFullPath(EP : EntryTypePtr) : STRING;
  357.     VAR
  358.       sTemp : STRING;
  359.       eTemp : WORD;
  360.       Stop  : BOOLEAN;
  361.     BEGIN
  362.       sTemp := EP^.Name;     Stop := FALSE;
  363.       WHILE (NOT Stop) AND (EP^.Back <> @Root) DO BEGIN
  364.         eTemp := EP^.Level;
  365.         REPEAT
  366.           EP := EP^.Back
  367.         UNTIL (EP = NIL) OR (Pred(eTemp) = EP^.Level);
  368.         IF EP <> @Root THEN sTemp := EP^.Name + '\' + sTemp
  369.                        ELSE Stop := TRUE;
  370.       END;
  371.       sTemp := Copy(Root.Name, 1, 3) + sTemp;
  372.       GetFullPath := sTemp;
  373.     END;
  374.  
  375.   BEGIN
  376.     AktZeile := Lines[Index]^;  Stop := Length(AktZeile);
  377.     WHILE (Stop>0) AND (AktZeile[Stop] = ' ') DO DEC(Stop);
  378.     Start := Stop; INC(Stop);
  379.     WHILE (Start > 0) AND (AktZeile[Start] <> '─') DO
  380.       DEC(Start);
  381.     IF Start = 0 THEN Start := 1;
  382.     TextAttr := $07;
  383.     GotoXY(Col, Row); Write(AktZeile); ClrEol;
  384.     TextAttr := $70;  GotoXY(Start, Row); Write (' ');
  385.     GotoXY(Start+1, Row);
  386.     Write(Copy(AktZeile, Start+1, Stop-Start));
  387.     IF Index = 1 THEN AktPath := Copy(Root.Name, 1, 3)
  388.                  ELSE BEGIN
  389.       EPtr := Root.Next;
  390.       WHILE(EPtr^.Next <> NIL) AND
  391.            (EPtr^.Counter <> Index) DO EPtr:=EPtr^.Next;
  392.       AktPath := GetFullPath(EPtr)
  393.     END;
  394.     IF Length(AktPath) < (79 - xFullPath) THEN
  395.       AktZeile := AktPath
  396.     ELSE IF (xFullPath < 64) THEN BEGIN
  397.       AktZeile := Copy(AktPath, 1, 3);
  398.       AktZeile := AktZeile + '...';
  399.       Stop     := Length(AktPath);
  400.       Start    := Stop - (72 - xFullPath);
  401.       WHILE (Start < Stop) AND (AktPath[Start] <> '\') DO
  402.         INC(Start);
  403.       AktZeile := AktZeile +
  404.                   Copy(AktPath, Start, Succ(Stop-Start));
  405.     END;
  406.     IF (xFullPath < 64) THEN BEGIN
  407.       GotoXY(xFullPath, WhereY);
  408.       Write(' ', AktZeile); ClrEol;
  409.     END;
  410.   END;
  411. {$F-}
  412.  
  413.  
  414. FUNCTION GetScanCode : WORD;     INLINE ($31/$C0/$CD/$16);
  415.  
  416. BEGIN
  417.   GetParameter;
  418.   MakeSubDirList;
  419.   BuildLines;
  420.   SetUpScrollArea(Counter, @NormalWrite, @SelectWrite);
  421.   Key := $4700;                               { Key = Home }
  422.   RedrawScrollArea;
  423.   REPEAT
  424.     Key := GetScanCode;
  425.     ScrollResponse(Key);
  426.   UNTIL (Key = $011B) OR (Key = $1C0D);     { Enter o. ESC }
  427.   HeapPtr := HeapOrg;                      { aufräumen ... }
  428.   IF Key = $1C0D THEN   ChDir (AktPath)    { Enter ....    }
  429.                  ELSE   ChDir (OldPath);   {  ESC  ....    }
  430.   IF IOResult <> 0 THEN
  431.     ErrorMsg(TRUE,'Verzeichnisname ungültig oder zu lang!');
  432.   TextAttr := $0F;   ClrScr;     WriteLn (Version);
  433.   TextAttr := $07;
  434.   WriteLn('  ',Counter,' Verzeichnisse gefunden. ')
  435. END.
  436. (* ------------------------------------------------------ *)
  437. (*               Ende von TREE.PAS                        *)
  438.  
  439.