home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 09 / praxis / qcd.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1979-12-31  |  13.9 KB  |  512 lines
  1. (*-------------------------------------------------------*)
  2. (*             QCD.PAS - Quick Change Dir                *)
  3. (*    Programm zum schnellen Wechseln im Verzeichnisbaum *)
  4. (*   (C) Copyright 1989 by Mario Westphal & TOOLBOX      *)
  5. (*-------------------------------------------------------*)
  6.  
  7. PROGRAM qcd;
  8. USES CRT, DOS;
  9. {$M 19000,30000,30000} {* leider viel Stack für Rekursion! }
  10.  
  11. PROCEDURE quickCD;
  12.  
  13. TYPE
  14.      soundstr = String[4];
  15.      keyword  = String[68];
  16.      PathStr  = String[68];
  17.  
  18. CONST
  19.   max_Stack = 255;          {* maximale Anzahl der Dirs }
  20.  
  21. VAR
  22.   pfad,                        {* für Read_Path }
  23.   aktverz,                     {* momentanes Dir }
  24.   retverz   : PathStr;         {von hier Aufruf von QCD }
  25.  
  26.   fehler    : Byte;            {* für IORESULT }
  27.  
  28.   treefile  : TEXT;                    {* für QCDTREE.DIR }
  29.   puffer    : array[1..2048] of Char;   {* Puffer für TEXT }
  30.  
  31.   dirinfo   : searchrec;             {* für FINDFIRST/NEXT }
  32.  
  33.   verz_stack : array[1..max_Stack] of ^PathStr;
  34.               {* die Pointerorgie für den Verzeichnisstack }
  35.  
  36.   merk_heap : Pointer;               {* für MARK }
  37.   s_anf,
  38.   s_end     : Byte;      {* Zeiger für den Stack }
  39.  
  40.  
  41. PROCEDURE hilfeseite;
  42. BEGIN
  43. WRITELN('SYNTAX     : QCD { /N } { <Laufwerk>:}  { < Pfad',+
  44.         'name > }');
  45. WRITELN;
  46. WRITELN('PARAMETER  : /N erstellt eine neue Verzeichnis',+
  47.         '-Datei im');
  48. WRITELN('             Hauptverzeichnis des momentan',+
  49.         ' gesetzten Laufwerks.');
  50. WRITELN;
  51. WRITELN('<Laufwerk> : geben Sie hier den Kennbuchstaben',+
  52.         ' des Laufwerks an,');
  53. WRITELN('             das Sie als Standardlaufwerk setzen',+
  54.         ' wollen.');
  55. WRITELN;
  56. WRITELN('<Pfadname> : hier können Sie einen vollständigen',+
  57.         ' oder unvollständigen');
  58. WRITELN('             Pfadnamen angeben. Geben Sie kein',+
  59.         ' Laufwerk an, bezieht');
  60. WRITELN('             sich Ihre Angabe auf das momentan',+
  61.         ' gesetzte Laufwerk.');
  62. WRITELN;
  63. WRITELN('BESCHREIBUNG');
  64. WRITELN('             Kann QCD den von Ihnen angegebenen',+
  65.         ' Pfad nicht finden, weil');
  66. WRITELN('             er unvollständig oder fehlerhaft',+
  67.         ' ist, dann versucht QCD,');
  68. WRITELN('             einen ähnlich klingenden Pfadnamen',+
  69.         ' zu finden.');
  70. WRITELN('             QCD gibt Ihnen den Pfad aus und',+
  71.         ' fragt, ob Sie weitersuchen');
  72. WRITELN('             möchten, oder ob Sie im momentan',+
  73.         ' gesetzten Verzeichnis');
  74. WRITELN('             bleiben wollen. Drücken Sie ',+
  75.         '<RETURN>, dann sucht QCD weiter.');
  76. WRITELN('             Kann kein Pfad mehr gefunden werden',+
  77.         ', wird in das');
  78. WRITELN('             Startverzeichnis zurückgewechselt.');
  79. END;
  80.  
  81. FUNCTION FindLastPos(String1,String2:String):Byte;
  82. VAR i,v  : Byte;
  83.     tstr : string;
  84. BEGIN
  85.   v := 0;                                {* initialisieren }
  86.   FOR i := 1 TO LENGTH(string2) DO
  87.    BEGIN
  88.     tstr := COPY(string2,i,LENGTH(string1));
  89.      IF tStr = string1 THEN v := i;   {* Position zuweisen }
  90.    END;
  91.  FindLastPos := v;      {* letzte Position von Str1 in Str2 }
  92. END;
  93.  
  94. PROCEDURE beenden;                       {* zuvor mit MARK }
  95. BEGIN                            {* "gemerkte" Heap-Spitze }
  96.  RELEASE(merk_heap);                   {* wieder freigeben }
  97. END;
  98.  
  99. PROCEDURE LiesBaum(path:PathStr);
  100. VAR dirinfo : searchrec;
  101.  BEGIN
  102.    FINDFIRST(Path+'\*.*',$10,dirinfo);   {* Nur DIR suchen }
  103.  WHILE DOSERROR = 0 DO
  104. BEGIN
  105.   IF (dirinfo.attr AND $10 <> 0) AND (dirinfo.name[1] <> '.')
  106.    THEN
  107.      BEGIN
  108.        WRITELN(treefile,path+'\'+dirinfo.name);
  109.        LiesBaum(Path+'\'+dirinfo.name);
  110.      END;
  111.    FINDNEXT(dirinfo);
  112.   END;
  113. END;
  114.  
  115. PROCEDURE New_Tree;
  116. BEGIN
  117.  ASSIGN(treefile,'\QCDTREE.DIR');
  118.   SETTEXTBUF(treefile,puffer);          {* größerer Puffer }
  119.                                            {* bringt Speed }
  120. {$I-}
  121. REWRITE(treefile);           {* Datei zum Schreiben öffnen }
  122. {$I+}
  123.  
  124. IF IORESULT <> 0 THEN  {* wenn Fehler ! }
  125. BEGIN
  126.  WRITELN(#7,'Verzeichnis-Datei kann nicht erzeugt werden!');
  127.   EXIT;
  128.    END;
  129.  
  130. GETDIR(0,aktverz);
  131.  aktverz := aktverz[1]+':';          {* Root Dir }
  132.   WRITELN(treefile,aktverz+'\');    {* Erster Eintrag }
  133.  liesbaum(aktverz);                 {* Verzeichnis scannen }
  134.  
  135.  CLOSE(treefile);                  {* Datei schließen }
  136.  
  137. END;
  138.  
  139. FUNCTION Read_Tree:Boolean;
  140. VAR pfadname : PathStr;
  141.  
  142. PROCEDURE push_stack;
  143. BEGIN
  144. IF s_anf < Max_Stack THEN
  145.  BEGIN
  146.   NEW(verz_stack[s_anf]);                  {* neu erzeugen }
  147.    verz_stack[s_anf]^ := pfadname;
  148.                              {* Dateieintrag auf den Stack }
  149.     INC(s_anf);                    {* Zeiger aktualisieren }
  150.    INC(s_end);
  151.   END;            {* von s_anf...}
  152. END;
  153.  
  154. BEGIN
  155.  s_anf := 2;       {* initialisieren }
  156.  s_end := 1;
  157.  
  158. ASSIGN(treefile,'\QCDTREE.DIR');
  159.  SETTEXTBUF(treefile,puffer);
  160.  
  161. {$I-}
  162.  RESET(treefile);                      {* zum Lesen öffnen }
  163. {$I+}
  164.  fehler := IORESULT;
  165.  CASE fehler OF
  166. 2 : BEGIN                                {* FILE NOT FOUND }
  167.      WRITELN(#7,'Verzeichnis-Datei QCDTREE.DIR ',+
  168.                'nicht gefunden!');
  169.       WRITELN('Bitte QCD mit der Option /N ',+
  170.               'aufrufen');
  171.        WRITELN;
  172.     END;          {* von fehler = 2 }
  173.  
  174. 0 : fehler := 0;                           {* alles klar...}
  175.  
  176.     ELSE fehler := 2;                 {* Fehler simulieren }
  177.  
  178. END;             {* von case... }
  179.  
  180. IF fehler <> 0 THEN
  181.  BEGIN
  182.   read_tree := FALSE;        {* Funktionsergebnis zuweisen }
  183.    beenden;                              {* Heap freigeben }
  184.   EXIT;                                       {* verlassen }
  185.  END;
  186.  
  187. WHILE NOT EOF(treefile)
  188.    DO BEGIN
  189.     READLN(treefile,pfadname);            {* Eintrag lesen }
  190.      push_stack;                          {* auf den Stack }
  191.    END;           {* von not EOF... }
  192.  
  193.  CLOSE(treefile);   {* Datei schließen }
  194. END;
  195.  
  196. FUNCTION Meldung : BYTE;
  197. VAR choice : Char;
  198. BEGIN
  199.  WRITELN('Neues Verzeichnis ist : ',aktverz);
  200.  WRITELN('Weitersuchen ? [ <──┘ / ESC ]');
  201.  
  202.  REPEAT
  203.   choice := READKEY;
  204.  UNTIL (choice = #13) OR (choice = #27);   {* RETURN/ESC }
  205.  
  206.  IF choice = #13 THEN meldung := 1
  207.    ELSE Meldung := 0;              {* Ergebnis zuweisen }
  208.     WRITELN;
  209.  
  210. END;
  211.  
  212. FUNCTION soundex(W:keyword):soundstr;
  213. CONST
  214. soundkey: ARRAY['A'..'Z'] of Char =('0','1','2','3','2','1',
  215.           '2','0','0','2','2','4','5','5','0','1','2','6',
  216.           '2','3','0','1','0','2','0','2');
  217. VAR
  218.     SWert     : soundstr;
  219.     I,K       : Integer;
  220.     Ch,LastCh : Char;
  221.  
  222. BEGIN
  223. IF LENGTH(W) = 0 THEN SOUNDEX := '0000'
  224. ELSE
  225.  BEGIN
  226.   SWert := W[1];
  227.    LastCh := ' ';
  228.     FOR i := 2 TO LENGTH(W) DO
  229.      BEGIN
  230.       Ch := W[i];
  231.        IF Ch IN ['A'..'Z'] THEN
  232.         IF (soundkey[Ch] <> '0') AND
  233.            (soundkey[Ch] <> LastCh) THEN
  234.            BEGIN
  235.             Swert := Swert + soundkey[Ch];
  236.           LastCh := soundkey[Ch];
  237.         END;
  238.      END;  {* for i...}
  239.  
  240.  IF LENGTH(Swert) > 4 THEN Swert := COPY(Swert,1,4)
  241.   ELSE
  242.    WHILE LENGTH(Swert) < 4 DO Swert := Swert+'0';
  243.    SOUNDEX := Swert;
  244.   END;
  245.  
  246. END;
  247.  
  248. FUNCTION Read_Path: BOOLEAN;
  249. VAR i : Byte;
  250.  
  251. BEGIN
  252. IF PARAMCOUNT = 0 THEN                 {* nichts übergeben }
  253.   BEGIN
  254.    Read_Path := FALSE;                {* Ergebnis zuweisen }
  255.     hilfeseite;                 {* Seite mit Hilfestellung }
  256.   EXIT;                         {* ausgeben }
  257. END
  258.  ELSE               {* ansonsten...}
  259.     BEGIN
  260.      pfad := PARAMSTR(1);
  261.       Read_Path := TRUE;
  262.  
  263. IF (COPY(pfad,1,2) = '/N') OR (COPY(pfad,1,2) = '/n') THEN
  264.   BEGIN
  265.    WRITELN('Verzeichnis-Datei QCDTREE.DIR wird erstellt.');
  266.     WRITELN;
  267.     new_tree;              {* neue Datei anlegen}
  268.       read_path := FALSE;
  269.       CHDIR(retverz);               {* in Startverzeichnis }
  270.      EXIT;
  271.    END;                              {* und dann abbrechen }
  272.  
  273. WHILE (COPY(pfad,LENGTH(pfad),1) = '\') AND
  274.       (LENGTH(pfad) > 1) DO DELETE(pfad,LENGTH(pfad),1);
  275.  
  276.                               {* \\\ ausschalten }
  277.  
  278. FOR i := 1 TO LENGTH(pfad) DO pfad[i] := UPCASE(pfad[i]);
  279.                        {* in Großbuchstaben umwandeln }
  280.  
  281.  END;             {* von ELSE... }
  282.  
  283. END;
  284.  
  285. PROCEDURE such_pfad;
  286. VAR i     : Word;
  287.     vwert,
  288.     swert : SoundStr;
  289.     name  : PathStr;
  290.     found,
  291.     size  : Byte;
  292.  
  293. BEGIN
  294.  size := LENGTH(COPY(pfad,FINDLASTPOS('\',pfad)+1,12));
  295.  found := 0;              {* Länge des Suchnamens }
  296.  
  297.  
  298. FOR i := 1 TO s_end DO                   {* Stack scannen }
  299.  
  300. IF pfad = COPY(verz_stack[i]^,FINDLASTPOS
  301.               ('\',verz_stack[i]^)+1,12)
  302. THEN
  303.  BEGIN
  304.    found := 1;       {* z.B. \XXXXXX }
  305.     {$I-}
  306.      CHDIR(verz_stack[i]^);
  307.     {$I+}
  308.  
  309. IF IORESULT <> 0 THEN
  310.  BEGIN
  311.   WRITELN(#7,'Falscher Eintrag in Verzeichnis-Datei');
  312.    WRITELN('Bitte QCD mit der Option /N aufrufen');
  313.     CHDIR(retverz);
  314.       GETDIR(0,aktverz);
  315.      found := 0;
  316.    EXIT;
  317.  END;                  {* von IORESULT <> 0 }
  318.  
  319. GETDIR(0,aktverz);
  320.  WRITELN;
  321.   WRITELN('Neues Verzeichnis ist : ',aktverz);
  322.  EXIT;
  323.  
  324. END;
  325.  
  326.  
  327. swert := soundex(COPY(pfad,FINDLASTPOS('\',pfad)+1,size));
  328.  
  329. FOR i := 1 TO s_end DO                    {* Stack scannen }
  330. BEGIN
  331. name := COPY(verz_stack[i]^,FINDLASTPOS
  332.             ('\',verz_stack[i]^)+1,size);
  333.  
  334. vwert:=Soundex(name);           {* Soundex-Wert errechnen }
  335.  
  336. IF swert = vwert THEN              {* Soundex-Werte gleich }
  337. BEGIN
  338.  found := 3;
  339.   {$I-}
  340.    CHDIR(verz_stack[i]^);
  341.   {$I+}
  342.    IF IORESULT <> 0 THEN
  343.     BEGIN
  344.       WRITELN(#7,'Falscher Eintrag in Verzeichnis-Datei');
  345.         WRITELN('Bitte QCD mit der Option /N aufrufen');
  346.        found := 0;
  347.       CHDIR(retverz);
  348.      EXIT;
  349.     END;                        {* von IORESULT <> 0 }
  350.  
  351. GETDIR(0,aktverz);
  352.  
  353. IF meldung = 0 THEN
  354.   BEGIN
  355.    WRITELN;
  356.     WRITELN('Neues Verzeichnis ist : ',aktverz);
  357.     EXIT;
  358.   END
  359.  ELSE found := 4;     {* weitersuchen }
  360.  
  361. END;   {* von swert = vwert...}
  362.  
  363. END;   {* von FOR i... }
  364.  
  365.  
  366. IF found = 0 THEN  {* nichts gefunden ==> Anfangsbuchstabe }
  367.  
  368. FOR i := 1 TO s_end DO
  369. IF pfad[1] = COPY(verz_stack[i]^,FINDLASTPOS
  370.                  ('\',verz_stack[i]^)+1,1)
  371. THEN
  372. BEGIN
  373.  found := 3;
  374.   {$I-}
  375.    CHDIR(verz_stack[i]^);
  376.   {$I+}
  377.    IF IORESULT <> 0 THEN
  378.     BEGIN
  379.       WRITELN(#7,'Falscher Eintrag in Verzeichnis-Datei');
  380.        WRITELN('Bitte QCD mit der Option /N aufrufen');
  381.         found := 0;
  382.        CHDIR(retverz);
  383.       EXIT;
  384.      END;               {* von IORESULT <> 0...}
  385.  
  386. GETDIR(0,aktverz);
  387.  IF meldung = 0 THEN
  388.    BEGIN
  389.     WRITELN;
  390.      WRITELN('Neues Verzeichnis ist : ',aktverz);
  391.      EXIT
  392.    END
  393.     ELSE found := 4;   {* gefunden, aber J gedrückt}
  394.                        {* also weitersuchen }
  395. END;    {* von FOR i... }
  396.  
  397.  
  398. IF found = 3 THEN                       {* Weiter gedrückt }
  399.  IF meldung = 1 THEN BEGIN END;           {* Name ausgeben }
  400.  
  401. IF found = 0 THEN                       {* Nichts gefunden }
  402.  BEGIN
  403.    CHDIR(retverz);                 {* zurück in Startverz. }
  404.    WRITELN(#7,'Pfad nicht gefunden');
  405.  EXIT;
  406. END;
  407.  
  408. IF found = 4 THEN               {* J gedrückt, aber nichts }
  409.  BEGIN                          {* mehr gefunden }
  410.   CHDIR(retverz);
  411.    WRITELN;
  412.     WRITELN('Kein weiteres Verzeichnis gefunden!');
  413.      WRITELN;
  414.     WRITELN('Startverzeichnis ',retverz,' wieder gesetzt.');
  415.   EXIT;
  416.  END;         {* von found = 4 }
  417.  
  418. END;       {* von such_pfad }
  419.  
  420. BEGIN
  421.  
  422. WRITELN;
  423. WRITELN('QCD - Quick Change Dir, Version 1.1,',+
  424.      '  (C) Copyright 1989 by Mario M. Westphal');
  425. WRITELN;
  426.             {* sonst funktioniert das Programm nicht !!! }
  427.  
  428. GETDIR(0,retverz);              {* Startverzeichnis merken }
  429.  
  430. IF NOT read_path THEN EXIT;            {* nichts übergeben }
  431.                                          {* also abbrechen }
  432. MARK(merk_heap);                     {* Heap-Spitze merken }
  433.  
  434.  
  435.  
  436. IF (pfad[2] = ':') AND (LENGTH(pfad)=2)
  437.   THEN pfad := pfad+'\';                     {* C: ==> C:\ }
  438.  
  439. {$I-}
  440.  CHDIR(pfad);                          {* normal versuchen }
  441. {$I+}
  442.  
  443. fehler := IORESULT;
  444.  
  445.  IF fehler = 3 THEN
  446.   BEGIN                           {* Backslash voranstellen }
  447.    IF pfad[1] <> '\' THEN pfad := '\'+pfad;
  448.     {$I-}
  449.      CHDIR(pfad);                 {* noch einmal versuchen }
  450.     {$I+}
  451.     fehler := IORESULT;
  452.   IF pfad[1] = '\' THEN DELETE(pfad,1,1);
  453.  END;                                    {* von Fehler = 3 }
  454.  
  455. CASE fehler OF          {* FEHLER ABFANGEN }
  456. 0 : BEGIN
  457.      GETDIR(0,aktverz);
  458.       WRITELN('Neues Verzeichnis ist : ',aktverz);
  459.      EXIT;
  460.     END;
  461.                    {* Ungültige Laufwerksbezeichnung }
  462. 15 : BEGIN
  463.       WRITELN(#7,'Falsche Laufwerksbezeichnung!');
  464.     WRITELN('Startverzeichnis ',retverz,' wieder gesetzt.');
  465.       CHDIR(retverz);              {* zurück ins Startverz }
  466.      beenden;                            {* Heap freigeben }
  467.     EXIT;                                    {* aussteigen }
  468.    END;
  469.                      {* Laufwerk nicht bereit }
  470. 152 : BEGIN
  471.     WRITELN(#7,'Laufwerk ',pfad[1]+': nicht bereit!');
  472.     WRITELN('Startverzeichnis ',retverz,' wieder gesetzt.');
  473.         CHDIR(retverz);
  474.        beenden;
  475.       EXIT;
  476.     END;
  477.                     {* Hardware Fehler }
  478. 162 : BEGIN
  479.     WRITELN(#7,'Fehler am Laufwerk ',UPCASE(pfad[1])+': !');
  480.     WRITELN('Startverzeichnis ',retverz,' wieder gesetzt.');
  481.       CHDIR(retverz);
  482.         beenden;
  483.       EXIT;
  484.    END;
  485.                      {* Pfad nicht gefunden }
  486. 3 : BEGIN
  487.      IF NOT read_tree THEN           {* Fehler bei Readtree }
  488.        BEGIN
  489.      CHDIR(retverz);
  490.     WRITELN('Startverzeichnis ',retverz,' wieder gesetzt.');
  491.      beenden;
  492.       EXIT;
  493.        END                            {* ...not Read-Tree }
  494.       ELSE
  495.       such_pfad;                          {* Verzeichnis suchen }
  496.     END;              {* von fehler = 3 }
  497. ELSE          {* Jeder andere Fehler }
  498.  BEGIN
  499.   WRITELN(#7,'Nicht näher bestimmbarer Fehler!');
  500.   HALT(fehler);
  501.  END;
  502.  
  503. END;    {* von CASE...}
  504.  
  505. beenden;                                 {* Heap freigeben }
  506.  
  507. END;   {* von QuickCD }
  508.  
  509. BEGIN
  510.  quickcd;
  511. END.
  512.