home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / tp_util / ul.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-05-24  |  8.9 KB  |  346 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  : STRING;
  11.       ARR          : ARRAY[1..200] OF STRING;
  12.       AP,TIEFE     : WORD;
  13.       ALLE         : BOOLEAN;
  14.       K1,K2        : 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.   IF EXISTONPATH(NAM2,N1) THEN BEGIN
  194.     IF POS('.',NAME) = 0 THEN WRITE('.PAS');
  195.     WRITELN;
  196.     INC(TIEFE);
  197.  
  198.     FOUND := FALSE;
  199.     ASSIGN(F,N1);
  200.     RESET(F);
  201.     REPEAT
  202.       GETLINE;
  203.       IF (CC <> '') THEN BEGIN
  204.         IF (UPCASE(CC[1]) = 'L') AND (CC[2] = ' ') THEN BEGIN
  205.           DELETE(CC,1,1);
  206.           WHILE CC[1] = ' ' DO DELETE(CC,1,1);
  207.           FOR I := 1 TO TIEFE DO WRITE('  ');
  208.           IF POS('.',CC) = 0 THEN WRITELN(CC,'.OBJ') ELSE WRITELN(CC);
  209.         END;
  210.         IF (UPCASE(CC[1]) = 'I') AND (CC[2] = ' ') THEN BEGIN
  211.           DELETE(CC,1,1);
  212.           WHILE CC[1] = ' ' DO DELETE(CC,1,1);
  213.           LISTE(CC,TRUE);
  214.         END;
  215.       END;
  216.       N := GETNAME(FALSE);
  217.       IF N = 'VAR' THEN FOUND := TRUE;
  218.       IF N = 'USES' THEN BEGIN
  219.         REPEAT
  220.           N := GETNAME(TRUE);
  221.           IF N <> '' THEN LISTE(N,FALSE);
  222.         UNTIL FOUND;
  223.       END; { IF POS ('VAR', }
  224.     UNTIL EOF(F) {OR FOUND};
  225.     CLOSE(F);
  226.  
  227.     DEC(TIEFE);
  228.  
  229.   END ELSE BEGIN
  230.     IF NAME = 'OVERLAY' THEN BEGIN
  231.       WRITELN(' : TURBO intern');
  232.       EXIT;
  233.     END;
  234.     IF NAME = 'DOS' THEN BEGIN
  235.       WRITELN(' : TURBO intern');
  236.       EXIT;
  237.     END;
  238.     IF NAME = 'GRAPH' THEN BEGIN
  239.       WRITELN(' : TURBO intern');
  240.       EXIT;
  241.     END;
  242.     IF NAME = 'CRT' THEN BEGIN
  243.       WRITELN(' : TURBO intern');
  244.       EXIT;
  245.     END;
  246.     IF NAME = 'PRINTER' THEN BEGIN
  247.       WRITELN(' : TURBO intern');
  248.       EXIT;
  249.     END;
  250.  
  251.     FF := FALSE;
  252.     IF POS('.',NAME) = 0 THEN BEGIN
  253.       IF EXISTONPATH(NAME+'.TPU',N1) THEN FF := TRUE;
  254.       FOR I := 1 TO 5 DO BEGIN
  255.         IF NOT FF AND (UNITPATH[I] <> '') THEN BEGIN
  256.           IF EXISTONPATH(UNITPATH[I]+'\'+NAME+'.TPU',N1) THEN FF := TRUE;
  257.         END;
  258.       END; { NEXT I }
  259.     END;
  260.  
  261.     IF FF THEN BEGIN
  262.       WRITELN('.TPU');
  263.       FOPENI(F1,N1);
  264.       FGET(F1,@TPUID,4);
  265.       FSEEK(F1,8);
  266.       FGETW(F1,I);
  267.       FSEEK(F1,I);
  268.       IF TPUID = 'TPU0' THEN LISTTPU0(NAME,4);
  269.       IF TPUID = 'TPU5' THEN LISTTPU0(NAME,6);
  270.       IF TPUID = 'TPU6' THEN LISTTPU6(NAME);
  271.       FCLOSE(F1);
  272.     END ELSE BEGIN
  273.       WRITELN('.PAS nicht gefunden');
  274.     END;
  275.   END;
  276. {$I+}
  277. END;
  278.  
  279.  
  280. BEGIN
  281.   WRITELN;
  282.  
  283.   AP    := 0;
  284.   TIEFE := 0;
  285.  
  286.   ALLE := STUPCASE(PARAMSTR(2)) = 'ALLE';
  287.   CMDLIN := STUPCASE(PARAMSTR(1));
  288.   IF (CMDLIN <> '') AND
  289.      (CMDLIN <> '-?') AND
  290.      (CMDLIN <> '/?') AND
  291.      (CMDLIN <> '?') THEN BEGIN
  292.     CMDLIN := JUSTFILENAME(CMDLIN);
  293.     I := POS('.',CMDLIN);
  294.     IF I > 0 THEN DELETE(CMDLIN,I,SUCC(LENGTH(CMDLIN)-I));
  295.  
  296. { EINLESEN UNIT- DIRECTORY AUS TURBO.TP }
  297.     FOR I := 1 TO 5 DO UNITPATH[I] := '';
  298.     IF EXISTONPATH('TURBO.TP',UNITPATH[1]) THEN BEGIN
  299.       ASSIGN(F,UNITPATH[1]);
  300.       RESET(F);
  301.       BLOCKREAD(F,BUF,8,I);
  302.       CLOSE(F);
  303.       UNITPATH[1] := '';
  304.       I := $19C; J := 1;
  305.       WHILE BUF[I] <> #0 DO BEGIN
  306.         IF BUF[I] = ';' THEN INC(J) ELSE UNITPATH[J] := UNITPATH[J] + BUF[I];
  307.         INC(I);
  308.       END; { WHILE }
  309.     END;
  310. {}
  311.  
  312.     IF NOT EXISTONPATH(CMDLIN+'.PAS',S) THEN
  313.       IF NOT EXISTONPATH(CMDLIN+'.TPU',S) THEN S := '';
  314.     S := JUSTPATHNAME(S);
  315.     IF S = '' THEN GETDIR(0,S);
  316.     IF S[LENGTH(S)] <> '\' THEN S := S+ '\';
  317.  
  318.     WRITE('USES- Liste für File : ',S);
  319.     LISTE(CMDLIN,FALSE);
  320.   END ELSE BEGIN
  321.     WRITELN('UL PROGRAMMNAME listet alle geschachtelten USES- Anweisungen für ein ');
  322.     WRITELN('PASCAL- Programm oder ein *.TPU- File (.PAS muß nicht angegeben werden)');
  323.     WRITELN('');
  324.     WRITELN('Die vorliegende Version ist etwas langsam bei großen Programmen, zeigt');
  325.     WRITELN('dafür aber auch die INCLUDE- Files (rekursiv) und die mit $L eingebundenen');
  326.     WRITELN('*.OBJ- Files an.');
  327.     WRITELN('');
  328.     WRITELN('Mehrfach benutzte UNITs werden nur beim 1. USES angezeigt.');
  329.     WRITELN('');
  330.     WRITELN('Wird als 2. Parameter ALLE angegeben, werden auch mehrfach benutzte');
  331.     WRITELN('Units gelistet, für diese wird dann aber keine Rekursion mehr ausgeführt.');
  332.     WRITELN('');
  333.     WRITELN('Files werden auf dem PATH gesucht, Pfadnamen im Filename sind nicht möglich.');
  334.     WRITELN('Ist kein *.PAS File zu finden, wird ein *.TPU File gesucht.');
  335.     WRITELN('Es können TPUs Version 4.0, 5.0 und 5.5 verarbeitet werden.');
  336.     WRITELN('');
  337.     WRITELN('Wird TURBO.TP auf dem PATH gefunden, werden die dort gespeicherten UNIT-');
  338.     WRITELN('Directories bei der Suche berücksichtigt.');
  339.     WRITELN('');
  340.     WRITELN('Ausgabeumleitung mit ''>'' ist möglich.');
  341.   END;
  342.  
  343. END.
  344.  
  345.  
  346.