home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / tiftool / ul.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-12-16  |  9.5 KB  |  372 lines
  1.  
  2. PROGRAM UL;
  3. { LISTE DER USES- ANWEISUNGEN }
  4.  
  5.  
  6. USES  TPDOS,TPSTRING,GETPUT;
  7.  
  8.  
  9. VAR   I,J             : WORD;
  10.       S,CMDLIN,CC,PA  : STRING;
  11.       ARR             : ARRAY[1..200] OF STRING;
  12.       AP,TIEFE        : WORD;
  13.       ALLE            : BOOLEAN;
  14.       K1,K2,NS        : BOOLEAN;
  15.  
  16.       F               : FILE;
  17.       BUF             : ARRAY[0..2000] OF CHAR;
  18.       UNITPATH        : ARRAY[1..5] OF STRING;
  19.  
  20.  
  21. FUNCTION ISSCHONDA(VAR NAME:STRING):BOOLEAN;
  22. VAR   I  : WORD;
  23. BEGIN
  24.   ISSCHONDA := TRUE;
  25.   FOR I := 1 TO AP DO BEGIN
  26.     IF NAME = ARR[I] THEN EXIT;
  27.   END;
  28.   ISSCHONDA := FALSE;
  29. END;
  30.  
  31.  
  32. PROCEDURE SPEICHERN(VAR NAME:STRING);
  33. VAR   I  : WORD;
  34. BEGIN
  35.   IF ISSCHONDA(NAME) THEN EXIT;
  36.   INC(AP);
  37.   ARR[AP] := NAME;
  38. END;
  39.  
  40.  
  41. PROCEDURE LISTE(VAR NAME:STRING;INCLUDE:BOOLEAN);
  42. VAR   I,P            : WORD;
  43.       LIN,N,N1,NAM2  : STRING;
  44.       F              : TEXT;
  45.       F1             : FILE;
  46.       FOUND,FF,CK    : BOOLEAN;
  47.       TPUID          : ARRAY[1..4] OF CHAR;
  48.       TPUBUF         : STRING;
  49.       EC             : CHAR;
  50.  
  51. PROCEDURE GETLINE;
  52. VAR   C,CA  : CHAR;
  53. BEGIN
  54.   C   := ' ';
  55.   CA  := ' ';
  56.   LIN := '';
  57.   CC  := '';
  58.   K1  := FALSE;
  59.   K2  := FALSE;
  60.   CK  := FALSE;
  61.   WHILE (NOT EOF(F)) AND (C <> ^J) DO BEGIN
  62.     CA := C;
  63.     READ(F,C);
  64.     CASE C OF
  65.       '$' : BEGIN
  66.               IF (K1 AND (CA = '{')) OR (K2 AND (CA = '*')) THEN BEGIN
  67.                 CK := TRUE;
  68.               END;
  69.             END;
  70.       '{' : K1 := TRUE;
  71.       '*' : BEGIN
  72.               IF CA = '(' THEN BEGIN
  73.                 K2 := TRUE;
  74.                 DELETE(LIN,LENGTH(LIN),1);
  75.               END ELSE IF NOT K1 AND NOT K2 THEN LIN := LIN + C;
  76.             END;
  77.       '}' : BEGIN
  78.               K1 := FALSE;
  79.               CK := FALSE;
  80.             END;
  81.       ')' : BEGIN
  82.               IF K2 THEN BEGIN
  83.                 IF CA = '*' THEN BEGIN
  84.                   K2 := FALSE;
  85.                   CK := FALSE;
  86.                 END;
  87.               END ELSE IF NOT K1 AND NOT K2 THEN LIN := LIN + C;
  88.             END;
  89.        ^M : BEGIN
  90.             END;
  91.        ^J : BEGIN
  92.               IF K1 OR K2 THEN C := ' ';
  93.             END;
  94.     ELSE
  95.       IF K1 OR K2 THEN BEGIN
  96.         IF CK THEN CC := CC + C;
  97.       END ELSE BEGIN
  98.         LIN := LIN + C;
  99.       END;
  100.     END; { CASE C }
  101.   END; { WHILE }
  102.   LIN := STUPCASE(LIN);
  103. END; { GETLINE }
  104.  
  105. FUNCTION GETNAME(LESEN:BOOLEAN):STRING;
  106. VAR   S1  : STRING;
  107.       P   : WORD;
  108. BEGIN
  109.   GETNAME := '';
  110.   S1 := '';
  111.   IF LENGTH(LIN) = 0 THEN BEGIN
  112.     IF NOT LESEN THEN EXIT;
  113.     GETLINE;
  114.     IF (CC <> '') THEN BEGIN
  115.       IF (UPCASE(CC[1]) = 'L') AND (CC[2] = ' ') THEN BEGIN
  116.         DELETE(CC,1,1);
  117.         WRITELN('$L',CC);
  118.       END;
  119.       IF (UPCASE(CC[1]) = 'I') AND (CC[2] = ' ') THEN BEGIN
  120.         DELETE(CC,1,1);
  121.         WRITELN('$I',CC);
  122.       END;
  123.     END;
  124.     P := POS('USES ',LIN);
  125.     IF P > 0 THEN DELETE(LIN,1,P+4);
  126.   END;
  127.   WHILE (LENGTH(LIN) > 0) AND (LIN[1] = ' ') DO DELETE(LIN,1,1);
  128.   WHILE (LENGTH(LIN) > 0) AND (LIN[1] = ',') DO DELETE(LIN,1,1);
  129.  
  130.   IF LIN[1] = ';' THEN BEGIN
  131.     FOUND := TRUE;
  132.     EXIT;
  133.   END;
  134.   WHILE NOT (LIN[1] IN [' ',',',';']) AND NOT (LENGTH(LIN) = 0) DO BEGIN
  135.     S1 := S1 + LIN[1];
  136.     DELETE(LIN,1,1);
  137.   END; { WHILE }
  138.   GETNAME := S1;
  139. END; { GETNAME }
  140.  
  141. PROCEDURE LISTTPU0(VAR NAME:STRING;WEITER:BYTE);
  142. VAR   I  : WORD;
  143. BEGIN
  144.   REPEAT
  145.     FGETW(F1,I);
  146.     FGETS(F1,TPUBUF);
  147.     FGETC(F1,EC);
  148.     FSEEK(F1,FPOS(F1)+WEITER);
  149.     IF (EC = 'Z') AND (TPUBUF <> NAME) AND (TPUBUF <> 'SYSTEM') THEN BEGIN
  150.       INC(TIEFE);
  151.       LISTE(TPUBUF,FALSE);
  152.       DEC(TIEFE);
  153.     END;
  154.   UNTIL EC <> 'Z';
  155. END; { LISTTPU0 }
  156.  
  157. PROCEDURE LISTTPU6(VAR NAME:STRING);
  158. VAR   I  : WORD;
  159. BEGIN
  160.   REPEAT
  161.     FGETW(F1,I);
  162.     FGETC(F1,EC);
  163.     FGETS(F1,TPUBUF);
  164.     FSEEK(F1,FPOS(F1)+8);
  165.     IF (EC = 'Y') AND (TPUBUF <> NAME) AND (TPUBUF <> 'SYSTEM') THEN BEGIN
  166.       INC(TIEFE);
  167.       LISTE(TPUBUF,FALSE);
  168.       DEC(TIEFE);
  169.     END;
  170.   UNTIL EC <> 'Y';
  171. END; { LISTTPU6 }
  172.  
  173. BEGIN { LISTE }
  174. {$I-}
  175.   IF ALLE THEN BEGIN
  176.     FOR I := 1 TO TIEFE DO WRITE('  ');
  177.     IF INCLUDE THEN WRITE('INCLUDE ');
  178.     WRITE(NAME);
  179.   END;
  180.   IF ISSCHONDA(NAME) THEN BEGIN
  181.     IF ALLE THEN WRITELN;
  182.     EXIT;
  183.   END;
  184.  
  185.   IF NOT ALLE THEN BEGIN
  186.     FOR I := 1 TO TIEFE DO WRITE('  ');
  187.     IF INCLUDE THEN WRITE('INCLUDE ');
  188.     WRITE(NAME);
  189.   END;
  190.   SPEICHERN(NAME); { EIGENEN NAMEN MERKEN }
  191.  
  192.   IF POS('.',NAME) > 0 THEN NAM2 := NAME ELSE NAM2 := NAME + '.PAS';
  193.  
  194.   IF NS THEN BEGIN
  195.     N1 := NAM2;
  196.   END ELSE BEGIN
  197.     IF NOT EXISTONPATH(NAM2,N1) THEN N1 := '';
  198.   END;
  199.   IF EXISTFILE(N1) THEN BEGIN
  200.     IF POS('.',NAME) = 0 THEN WRITE('.PAS');
  201.     WRITELN;
  202.     INC(TIEFE);
  203.  
  204.     FOUND := FALSE;
  205.     ASSIGN(F,N1);
  206.     RESET(F);
  207.     REPEAT
  208.       GETLINE;
  209.       IF (CC <> '') THEN BEGIN
  210.         IF (UPCASE(CC[1]) = 'L') AND (CC[2] = ' ') THEN BEGIN
  211.           DELETE(CC,1,1);
  212.           WHILE CC[1] = ' ' DO DELETE(CC,1,1);
  213.           FOR I := 1 TO TIEFE DO WRITE('  ');
  214.           IF POS('.',CC) = 0 THEN WRITELN(CC,'.OBJ') ELSE WRITELN(CC);
  215.         END;
  216.         IF (UPCASE(CC[1]) = 'I') AND (CC[2] = ' ') THEN BEGIN
  217.           DELETE(CC,1,1);
  218.           WHILE CC[1] = ' ' DO DELETE(CC,1,1);
  219.           LISTE(CC,TRUE);
  220.         END;
  221.       END;
  222.       N := GETNAME(FALSE);
  223.       IF N = 'VAR' THEN FOUND := TRUE;
  224.       IF N = 'USES' THEN BEGIN
  225.         REPEAT
  226.           N := GETNAME(TRUE);
  227.           IF N <> '' THEN LISTE(N,FALSE);
  228.         UNTIL FOUND;
  229.       END; { IF POS ('VAR', }
  230.     UNTIL EOF(F) {OR FOUND};
  231.     CLOSE(F);
  232.  
  233.     DEC(TIEFE);
  234.  
  235.   END ELSE BEGIN
  236.     IF NAME = 'OVERLAY' THEN BEGIN
  237.       WRITELN(' : TURBO intern');
  238.       EXIT;
  239.     END;
  240.     IF NAME = 'DOS' THEN BEGIN
  241.       WRITELN(' : TURBO intern');
  242.       EXIT;
  243.     END;
  244.     IF NAME = 'GRAPH' THEN BEGIN
  245.       WRITELN(' : TURBO intern');
  246.       EXIT;
  247.     END;
  248.     IF NAME = 'CRT' THEN BEGIN
  249.       WRITELN(' : TURBO intern');
  250.       EXIT;
  251.     END;
  252.     IF NAME = 'PRINTER' THEN BEGIN
  253.       WRITELN(' : TURBO intern');
  254.       EXIT;
  255.     END;
  256.  
  257.     FF := FALSE;
  258.     IF POS('.',NAME) = 0 THEN BEGIN
  259.  
  260.     IF NS THEN BEGIN
  261.       N1 := NAME + '.TPU';
  262.       FF := EXISTFILE(N1);
  263.     END ELSE BEGIN
  264.       IF EXISTONPATH(NAME+'.TPU',N1) THEN FF := TRUE;
  265.       FOR I := 1 TO 5 DO BEGIN
  266.         IF NOT FF AND (UNITPATH[I] <> '') THEN BEGIN
  267.           IF EXISTONPATH(UNITPATH[I]+'\'+NAME+'.TPU',N1) THEN FF := TRUE;
  268.         END;
  269.       END; { NEXT I }
  270.     END;
  271. (*
  272.       IF EXISTONPATH(NAME+'.TPU',N1) THEN FF := TRUE;
  273.       FOR I := 1 TO 5 DO BEGIN
  274.         IF NOT FF AND (UNITPATH[I] <> '') THEN BEGIN
  275.           IF EXISTONPATH(UNITPATH[I]+'\'+NAME+'.TPU',N1) THEN FF := TRUE;
  276.         END;
  277.       END; { NEXT I }
  278. *)
  279.     END;
  280.  
  281.     IF FF THEN BEGIN
  282.       WRITELN('.TPU');
  283.       FOPENI(F1,N1);
  284.       FGET(F1,@TPUID,4);
  285.       FSEEK(F1,8);
  286.       FGETW(F1,I);
  287.       FSEEK(F1,I);
  288.       IF TPUID = 'TPU0' THEN LISTTPU0(NAME,4);
  289.       IF TPUID = 'TPU5' THEN LISTTPU0(NAME,6);
  290.       IF TPUID = 'TPU6' THEN LISTTPU6(NAME);
  291.       FCLOSE(F1);
  292.     END ELSE BEGIN
  293.       WRITELN('.PAS nicht gefunden');
  294.     END;
  295.   END;
  296. {$I+}
  297. END;
  298.  
  299.  
  300. BEGIN
  301.   WRITELN;
  302.  
  303.   AP    := 0;
  304.   TIEFE := 0;
  305.  
  306.   ALLE := STUPCASE(PARAMSTR(2)) = 'ALL';
  307.   NS   := STUPCASE(PARAMSTR(2)) = '/N';
  308.   CMDLIN := STUPCASE(PARAMSTR(1));
  309.   IF (CMDLIN <> '') AND
  310.      (CMDLIN <> '-?') AND
  311.      (CMDLIN <> '/?') AND
  312.      (CMDLIN <> '?') THEN BEGIN
  313.     PA := JUSTPATHNAME(CMDLIN);
  314.     IF PA <> '' THEN BEGIN
  315.       WRITELN('!!! Eingegebener PATH ''',PA,''' wird ignoriert !!!');
  316.       WRITELN;
  317.     END;
  318.     CMDLIN := JUSTFILENAME(CMDLIN);
  319.     I := POS('.',CMDLIN);
  320.     IF I > 0 THEN DELETE(CMDLIN,I,SUCC(LENGTH(CMDLIN)-I));
  321.  
  322. { EINLESEN UNIT- DIRECTORY AUS TURBO.TP }
  323.     FOR I := 1 TO 5 DO UNITPATH[I] := '';
  324.     IF (NOT NS) AND EXISTONPATH('TURBO.TP',UNITPATH[1]) THEN BEGIN
  325.       ASSIGN(F,UNITPATH[1]);
  326.       RESET(F);
  327.       BLOCKREAD(F,BUF,8,I);
  328.       CLOSE(F);
  329.       UNITPATH[1] := '';
  330.       I := $19C; J := 1;
  331.       WHILE BUF[I] <> #0 DO BEGIN
  332.         IF BUF[I] = ';' THEN INC(J) ELSE UNITPATH[J] := UNITPATH[J] + BUF[I];
  333.         INC(I);
  334.       END; { WHILE }
  335.     END;
  336. {}
  337.  
  338.     IF NOT EXISTONPATH(CMDLIN+'.PAS',S) THEN
  339.       IF NOT EXISTONPATH(CMDLIN+'.TPU',S) THEN S := '';
  340.     S := JUSTPATHNAME(S);
  341.     IF S = '' THEN GETDIR(0,S);
  342.     IF S[LENGTH(S)] <> '\' THEN S := S+ '\';
  343.  
  344.     WRITE('USES- Liste für File : ',S);
  345.     LISTE(CMDLIN,FALSE);
  346.   END ELSE BEGIN
  347.     WRITELN('UL NAME[.PAS|.TPU] [ALL|/N]  listet alle geschachtelten USES- Anweisungen');
  348.     WRITELN('für ein TURBO PASCAL- Programm oder ein *.TPU- File.');
  349.     WRITELN('');
  350.     WRITELN('INCLUDE- Files und mit $L eingebundene *.OBJ- Files werden berücksichtigt.');
  351.     WRITELN('');
  352.     WRITELN('Mehrfach benutzte UNITs werden nur beim 1. USES angezeigt.');
  353.     WRITELN('');
  354.     WRITELN('Wird als 2. Parameter ALL angegeben, werden auch mehrfach benutzte');
  355.     WRITELN('Units gelistet, für diese wird dann aber keine Rekursion mehr ausgeführt.');
  356.     WRITELN('');
  357.     WRITELN('Files werden auf dem PATH gesucht, Pfadnamen im Filename sind nicht möglich.');
  358.     WRITELN('Ist kein *.PAS File zu finden, wird ein *.TPU File gesucht.');
  359.     WRITELN('Es können TPUs Version 4.0, 5.0 und 5.5 verarbeitet werden.');
  360.     WRITELN('');
  361.     WRITELN('Wird TURBO.TP auf dem PATH gefunden, werden die dort gespeicherten UNIT-');
  362.     WRITELN('Directories bei der Suche berücksichtigt.');
  363.     WRITELN('');
  364.     WRITELN('/N als 2. Parameter unterdrückt das Suchen auf dem PATH und in TURBO.TP.');
  365.     WRITELN('');
  366.     WRITELN('Ausgabeumleitung mit ''>'' ist möglich.');
  367.   END;
  368.  
  369. END.
  370.  
  371.  
  372.