[Back to UNITINFO SWAG index] [Back to Main SWAG index] [Original]

    {
    Purpose: bpxref is a ms-dos program that prints the
    dependencies (cross reference) of Turbo Pascal units by
    parsing import (uses) lists of the sources.
    Run bpxref with no parameters to display the calling syntax.
    Output to stdout (for piping).
    With source. I think little effort is necessary to extend
    it to Delphi sources (in addition you have to parse the .dpr file).

    Installation:
    files: bpxref.exe (executable binary)
           bpxref.pas (the source)
           readme.txt (what you're just reading)
    Extract the desired file(s). Ready.

    Status of the Program: Freeware.

    Distribution status: freely;

    Author: Uwe Maeder, university of wuerzburg, germany
            tuze001@rzbox.uni-wuerzburg.de

    }
    PROGRAM bpxref;
    {$M 32000,0,255360 }
    {    ^  stack size (recursion!) }

    { Borland Pascal Cross Reference Lister. Short description see main }
    { uwe maeder, wuerzburg, germany }
    { 10/88: BP4.0, at this time no oop, sorry! }
    { 10/97: BP7.0, Version: 1.0 }
    { thanks to Prof. N. Wirth: Compilerbau }
    USES crt,dos;

    TYPE NameStr = string[64];
         TimeStr = string[20];

    { ==== defs for the mini parser ===========}
    TYPE symbol = (NulSym,EOFSym,ident,number,literal,
                   IntfSym,UsesSym,ImplSym,Comma);

          SymSet = SET OF Symbol;

    CONST NoKW = 3;
    CONST KWtbl: ARRAY[0..NoKW] OF NameStr =
                ('',
                 'USES','INTERFACE','IMPLEMENTATION');

          wsym: ARRAY[1..NoKW] OF symbol =
                 (UsesSym,IntfSym,ImplSym);

    { === structure to hold information: tree and list==== }
    TYPE tpUseNode = ^tUseNode;
         tUseNode  = RECORD
                     name: NameStr;
                     next: tpUseNode
                    END;
         tpNode    = ^tNode;
         tNode     = RECORD
                      Name: NameStr;
                      dirx: word; { Index of Dir in DirList }
                      time,size: LONGINT;
                      left,right: tpNode;
                      pUseList: tpUseNode;
                    END;

    VAR Root: tpNode;

    CONST PLAST = 32;

    VAR DirList: ARRAY[1..PLAST] OF STRING[50];
        DirCnt: WORD;
        SourceSize: LONGINT;
        SourceCount: WORD;
        stdout: text;
        verboose: boolean;

    { =============misc routines==================== }
    function UpperCase(s: string): string;
    var i: integer;
    begin
     for i:=1 to length(s) do
      s[i]:=upcase(s[i]);
     UpperCase:=s;
    end; { UpperCase }

    FUNCTION Trim(s: STRING): STRING;
    VAR p1,p2: integer;
    BEGIN
     p2:=length(s);
     WHILE (p2>0) and (s[p2]=' ') DO
      dec(p2);
     if p2=0 then
      trim:=''
     else
     begin
      p1:=1;
      WHILE s[p1]=' ' DO
       inc(p1);
      trim:=copy(s,p1,p2-p1+1);
     END;
    END; {trim}

    FUNCTION Piece(CONST s: STRING; delim: CHAR; n: WORD): STRING; ASSEMBLER;
    { gets the n-th element of the list s, separator delim  }
    ASM
     PUSH DS
     LDS  SI,s              { DS:SI String }
     LES  DI,@result        { ES:DI Result }
     PUSH DI                { merken }
     MOV  BX,n              { BH = nummer n }
     XCHG BL,BH
     MOV  BL,delim          { trenner }
     CLD                    { aufw„rts geht's }
     XOR CX,CX
     XOR DL,DL              { Counter Result }
     MOV CL,DS:[SI]         { L„nge s }
     CMP CL,0
     JZ @ready              { leer: raus }
     MOV AH,1               { result default: TRUE }
     INC SI                 { Begin  1 weiter }
     DEC BH                 { copy ab n-1 }
     JZ @copy               { n=1: sofort kopieren }
    @loop:
     LODSB
     CMP AL,BL              { trenner? }
     JNZ @lend
     DEC BH                 { gefunden: DEC no }
     JZ @copy0              { =0: jetzt copy }
    @lend:
     LOOP @loop
     { Hier L„nge erreicht }
     JMP @ready
    @copy0:
     DEC CL                { 1- wegen keine LOOP }
     JZ @ready
    @copy:
     INC DI                { ziel }
    @cloop:
     LODSB
     CMP AL,BL             { trenner }
     JZ @ready             { ja: fertig }
     STOSB                 { Store und INC DI }
     INC DL                { L„nge }
     LOOP @cloop
    @ready:
     POP DI                 { ES:DI -> Result }
     MOV ES:[DI],DL         { l„nge Ziel }
     POP DS
    END; { piece }

    FUNCTION AdStr(s: STRING; len: BYTE): STRING; ASSEMBLER;
    { format string s}
    ASM
     PUSH DS
     LDS SI,s
     LES DI,@result
     CLD          { aufw„rts gehts }
     MOV AL,len
     STOSB        { new len }
     CMP AL,0
     JZ @ready
     MOV BL,AL    { BL : len }
     LODSB        { al = len(s) }
     XOR CH,CH
     MOV CL,AL    { cx len(s) }
     MOV BH,AL    { bh: length(s)  }
     JCXZ @cont   { nothin to move }
     REP MOVSB    { move string s }
     SUB BL,BH    { len - length(s) }
     JBE @ready   { result <= 0: ready }
    @cont:
     MOV CL,BL    { BL bytes Blank }
     MOV AL,' '
     REP STOSB
    @ready:
     POP DS
    END; { AdStr }

    FUNCTION DateTimeStr(time: longint): TimeStr; { german format }
    VAR   dt: DateTime;
          s,s0: TimeStr;
          i: word;
    BEGIN
      UnpackTime(time,dt);
      with dt do
      begin
       str(day  :2,s0); s:=s0+'.';
       str(month:2,s0); s:=s+s0+'.';
       str(year :4,s0); s:=s+s0;
       str(hour :2,s0); s:=s+':'+s0+'.';
       str(min  :2,s0); s:=s+s0+'.';
       str(sec  :2,s0); s:=s+s0;
      end;
      FOR i:=1 TO length(s) DO
       if s[i]=' ' then s[i]:='0';
      DateTimeStr:=s;
    END; (* DateTimeStr *)

    { ========== dir list load ================ }
    PROCEDURE EnterDir(dir: DirStr);
    VAR i: WORD;
    BEGIN
     if DirCnt>=PLAST then exit;
     dir:=UpperCase(dir);
     if dir[length(dir)]<>'\' then dir:=dir+'\';
     i:=DirCnt;
     WHILE (i>0) AND (dir<>DirList[i]) DO DEC(i);
     IF i=0 THEN
     BEGIN
      INC(DirCnt); DirList[DirCnt]:=dir;
     END;
    END; { EnterDir }

    PROCEDURE LoadDirList(const path: string);
    var f: text;
        s: string;
        dir: DirStr;
        i: integer;
    BEGIN
     DirCnt:=0;
     assign(f,path);
     {$I-} reset(f); {$I+}
     if IOresult=0 then
     begin
      while not eof(f) do
      begin
       ReadLn(f,s);
       i:=1; dir:=trim(piece(s,';',i));
       while dir<>'' do
       begin
        EnterDir(dir);
        inc(i); dir:=piece(s,';',i);
       end;
      end;
      close(f);
     end;
    end;  { LoadDirList }

    { ================ file search in DirList =================  }

    PROCEDURE FindDir(uname: NameStr; VAR dirx: word; VAR time,size: LONGINT);
    VAR i: INTEGER;
        s: SearchRec;
    BEGIN
     dirx:=0; time:=0; size:=0;
     i:=0;
     {$I-}
     REPEAT
      INC(i);
      dos.FindFirst(DirList[i]+uname+'.PAS',Archive,s);
      if DosError=0 then
       dirx:=i;
     UNTIL (dirx>0) OR (i>=DirCnt);
     {$I+}
     IF dirx>0 THEN
     BEGIN
      time:=s.time;
      size:=s.size;
     END;
    END; { FindDir }

    { ============ list routines ===================}

    FUNCTION search(const id: NameStr; VAR p: tpNode): tpNode;
    BEGIN
     IF p=NIL THEN
     BEGIN
      NEW(p);
      WITH p^ DO
      BEGIN
       name:=id; dirx:=0; time:=0;
       pUseList:=NIL; left:=NIL; right:=NIL;
       search:=p;
      END;
     END ELSE
      IF id<p^.name THEN search:=search(id,p^.left)
     ELSE
      IF id>p^.name THEN search:=search(id,p^.right)
     ELSE search:=p;
    END; { search }

    FUNCTION Used(id: NameStr; p: tpUseNode): BOOLEAN;
    VAR q: tpUseNode;
    BEGIN
     q:=p;
     WHILE (q<>NIL) AND (q^.name<>id) DO q:=q^.next;
     Used:=q<>NIL;
    END; { Used }

    PROCEDURE UsedBy(const uname: string);
    { prints all units that import unit uname }
    var l: word;

     PROCEDURE PrUsedBy(p: tpNode);
     BEGIN
      IF p<>NIL THEN
      WITH p^ DO
      BEGIN
       PrUsedBy(left);
       IF Used(uname,pUseList) THEN
       BEGIN
        IF l>69 THEN
        begin
         WriteLn(stdout);
         l:=0;
        end;
        Write(stdout,Name,'':10-Length(Name)); inc(l,10);
       END;
       PrUsedBy(right);
      END;
     END; { PrUsed }

    BEGIN
     IF root=NIL THEN EXIT;
     WriteLn(stdout,uname,' USED by:'); l:=0;
     PrUsedBy(root);
     WriteLn(stdout);
    END; { UsedBy }

    procedure PrintPaths;

     procedure traverse(p: tpNode);
     begin
      if p<>nil then
       with p^ do
       begin
        traverse(p^.left);
        if dirx<>0 then
         WriteLn(stdout,AdStr(DirList[dirx]+name+'.PAS',50),
                        ' ',size:6,' ',DateTimeStr(time));
        traverse(p^.right);
       end;
     end; { traverse }

    begin { PrintPaths }
     IF root=NIL THEN EXIT;
     WriteLn(stdout,'All Files:');
     traverse(root);
    end; { PrintPaths }

    { ======= recursively collect all uses lists ============= }
    PROCEDURE GetStructure(VAR UName: NameStr; VAR p: tpNode; Level: WORD);
    CONST EOFch = #31;
          EOLch = #13;
    VAR ref: tpNode;
        up,p1,p2: tpUseNode;
        F: TEXT;
        udirx: word;
        ch0,ch: char;
        sym: symbol;
        id: NameStr;
        str: string;

     { mini parser. it seems to be enough to skip comments and
        to recognize
         INTERFACE, IMPLEMENTATION and USES
        GetNumber and GetLiteral may be omitted.
        Source must be syntactical correct!
        Parser doesn't know about compiler directives, i.e. in
         uses (*$IFDEF debug*) debug, (*$ENDIF*),gbase;
        the unit debug is included! }

       PROCEDURE getsym;
       VAR j: integer;

        PROCEDURE  getch;
        BEGIN
         IF EOF(F) THEN
          ch0:=EOFch
         ELSE
         IF EOLn(F) THEN
         BEGIN
          ReadLn(F); ch0:=EOLch;
         END ELSE
          read(F,ch0);
         ch:=UpCase(ch0);
        END; { GetCh }

        PROCEDURE GetId;
        BEGIN
          id:='';
          REPEAT id:=id+ch; getch UNTIL not (ch IN ['A'..'Z','0'..'9','_']);
        END; { GetId }

        PROCEDURE GetNumber; { result as string in str }
        BEGIN
          str:='';
          REPEAT str:=str+ch; getch UNTIL not (ch IN ['0'..'9','.']);
        END; { GetNumber }

        function GetLiteral: boolean; { result in str }
        var stop: boolean;
        begin
         str:='';
         GetCh; stop:=false;
         while not (ch in [EOFch,EOLch]) and not stop do
         begin
          if ch='''' then     { check for "''" -> "'" }
          begin
           GetCh;
           if ch='''' then
           begin
            str:=str+ch;
            GetCh;
           end
           else
            stop:=true;
          end
          else
          begin
           str:=str+ch0;
           GetCh;
          end;
         end;
         GetLiteral:=stop;
        end; { GetLiteral }

        PROCEDURE Comment1;
        BEGIN
         REPEAT
          GetCh;
         UNTIL ch IN ['}',EOFch];
         GetCh;
        END; { Comment1 }

        PROCEDURE Comment2;
        BEGIN
         REPEAT
          WHILE NOT (ch IN ['*',EOFCh]) DO GetCh;
          GetCh;
         UNTIL ch IN [')',EOFCh];
         GetCh;
        END; { Comment2 }

      BEGIN (* getsym *)
       WHILE ch in [' ',#13] DO getch;
       CASE ch OF
        'A'..'Z': BEGIN
                   GetId;
                   KWtbl[0]:=id; j:=NoKW;
                   WHILE id<>KWtbl[j] DO dec(j);
                   IF j>0 THEN sym:=wsym[j] ELSE sym:=ident;
                  END;
        '0'..'9': begin GetNumber; sym:=number end;
        ''''    : if GetLiteral then
                   sym:=literal
                  else
                  begin
                   WriteLn(stdout,'Error in literal');
                   sym:=EOFsym;
                  end;
        ',':     BEGIN sym:=comma; GetCh; END;
        '{': begin
              Comment1;
              GetSym;
             end;
        '(': BEGIN
              GetCh;
              IF ch='*' THEN
              BEGIN
               GetCh; Comment2; GetSym;
              END ELSE sym:=NulSym;
             END;
        EOFch:   sym:=EOFSym;
        ELSE     BEGIN sym:=NulSym; GetCh; END;
       END;
      END; { GetSym }

     procedure ParseUseList;
     begin
      GetSym; { USES }
      p1:=up;
      WHILE sym=ident DO
      BEGIN
       p1^.name:=COPY(id,1,8);
       if verboose then WriteLn(stdout,'':(level+1),id);
       NEW(p2); p1^.next:=p2;
       WITH p2^ DO
       BEGIN
        next:=NIL;
        name:='';
       END;
       p1:=p2;
       GetSym; IF sym=comma THEN GetSym;
      END;
     end; { ParseUseList }

    BEGIN { GetStructure }
     INC(Level);
     ref:=search(UName,root);
     IF ref^.pUseList<>NIL THEN EXIT; { schon da }
     FindDir(UName,udirx,ref^.time,ref^.size);
     IF udirx=0 THEN EXIT;
     if verboose then
      WriteLn(stdout,'Scanning ',DirList[udirx]+uname,' ... ');
     INC(SourceCount); SourceSize:=SourceSize+ref^.size;
     ref^.dirx:=udirx;
     NEW(up);
     WITH up^ DO
     BEGIN
      Name:='';
      next:=NIL;
     END;
     ASSIGN(F,DirList[udirx]+UName+'.PAS'); RESET(F);
     ch:=' ';
     GetSym;
     { collect the USES lists }
     WHILE NOT (sym IN [EOFSym,IntfSym,UsesSym]) DO GetSym;
     if sym=IntfSym then
     begin
      if verboose then WriteLn(stdout,'':(level+1),'interface uses:');
      GetSym;
      if sym=UsesSym then
       ParseUseList;
      WHILE NOT (sym IN [EOFSym,ImplSym]) DO GetSym;
      if sym=ImplSym then
      begin
       if verboose then WriteLn(stdout,'':(level+1),'implementation uses:');
       GetSym;
       if sym=UsesSym then
        ParseUseList;
      end;
     end
     else     { no INTERFACE }
     if sym=UsesSym then
     begin
      if verboose then WriteLn(stdout,'program uses:');
      ParseUseList;
     end;
     CLOSE(F);
     { Parse the files in pUseList recursively }
     ref^.pUseList:=up;
     p1:=up;
     WHILE (p1^.name<>'') DO
     BEGIN
      GetStructure(p1^.name,root,level);
      p1:=p1^.next;
     END;
    END; { GetStructure }

    PROCEDURE OutputStructure(r: tpNode);
    var lc: WORD;
        line: string;

      PROCEDURE PrintStructure(r: tpNode);
      VAR p: tpUseNode;

        PROCEDURE PrintUseList(p: tpUseNode);
        VAR q: tpUseNode;
            empty: BOOLEAN;
        BEGIN
         q:=p;   empty:=TRUE;
         WHILE (q<>NIL) AND (q^.name<>'') DO
         BEGIN
          empty:=FALSE;
          IF length(line)>74 THEN
          BEGIN
           WriteLn(stdout,line);
           line:=AdStr(' ',16);
           INC(lc);
          END;
          line:=line+AdStr(q^.name,10);
          q:=q^.next;
         END;
         IF empty THEN
         BEGIN
          line:=line+'-';
         END;
        END; { PrintUseList }

      BEGIN { PrintStructure }
       IF r<>NIL THEN
       WITH r^ DO
       BEGIN
        PrintStructure(left);
        line:=AdStr(name,10)+' USES ';
        IF dirx<>0 THEN
         PrintUseList(pUseList)
        ELSE
         line:=line+'No PAS-file';
        WriteLn(stdout,line); line:='';
        INC(lc);
        PrintStructure(right)
       END;
      END; { PrintStructure }

    BEGIN { OutputStructure }
     IF r=NIL THEN EXIT;
     lc:=0;
     line:='';
     PrintStructure(r);
    END; { OutputStructure }

    PROCEDURE DisposeStructure(VAR p: tpNode);

     PROCEDURE DisposeUseList(VAR u: tpUseNode);
     BEGIN
      IF u=NIL THEN EXIT;
      WHILE u^.next<>NIL DO DisposeUseList(u^.next);
      DISPOSE(u); u:=NIL;
     END;

    BEGIN
     IF p=NIL THEN EXIT;
     IF p^.left<>NIL THEN DisposeStructure(p^.left);
     IF p^.right<>NIL THEN DisposeStructure(p^.right);
     DisposeUseList(p^.pUseList);
     Dispose(p); p:=NIL;
    END; { DisposeStructure }

    PROCEDURE ScanUnits(const SelPath: string);
    VAR dir: DirStr;
        name: NameStr;
        ext: ExtStr;
        mdirx : word;
        dummy: LONGINT;
    BEGIN
     fsplit(SelPath,dir,name,ext);
     EnterDir(dir);
     FindDir(Name,mdirx,dummy,dummy);
     if mdirx<>0 then
      GetStructure(Name,root,0)
     else
      WriteLn(stdout,'File not found');
     WriteLn(stdout,SourceCount,' PAS-File(s)');
     WriteLn(stdout,'Size: ',SourceSize DIV 1024,' KByte');
    END; { ScanUnits }

    var pcnt,i: word;
        options: string;
    begin { main }
     if ParamCount<2 then
     begin
      WriteLn('bpxref dirs path[.pas] [units] [/v] [/p] [/x]');
      WriteLn('prints dependencies of Turbo Pascal units');
      WriteLn('by scanning the uses lists of the source files.');
      WriteLn('Output to stdout.');
      WriteLn('dirs    : file containing the dirs, separated by semicola');
      WriteLn('          example: \pas;\db;\graphic');
      WriteLn('path    : path of unit or program');
      WriteLn('units   : unit list, prints all units uses by the elements');
      WriteLn('/v      : verboose, prints scanning information');
      WriteLn('/x      : print x-reference list');
      WriteLn('/p      : print paths of all units');
      Writeln('Example : bpxref \bin\bpdirs.txt \db\myprog gbase hex /p > myprog.xrf');
     end
     else
     begin
      assign(stdout,''); rewrite(stdout);
      pcnt:=ParamCount;
      while pos('/',ParamStr(pcnt))>0 do dec(pcnt);
      options:='';
      for i:=pcnt+1 to ParamCount do
       options:=options+UpperCase(ParamStr(i));
      verboose:=pos('/V',options)>0;
      LoadDirList(ParamStr(1));
      if DirCnt=0 then WriteLn(stdout,'No DirList');
      verboose:=UpperCase(ParamStr(pcnt))='/V';
      if verboose then dec(pcnt);
      root:=nil;
      SourceSize:=0; SourceCount:=0;
      ScanUnits(UpperCase(ParamStr(2)));
      WriteLn(stdout,'Start-File: ',ParamStr(2));
      if pos('/X',options)>0 then OutputStructure(root);
      for i:=3 to pcnt do
       UsedBy(UpperCase(ParamStr(i)));
      if pos('/P',options)>0 then PrintPaths;
      DisposeStructure(root);
      close(stdout);
     end;
    END.

[Back to UNITINFO SWAG index] [Back to Main SWAG index] [Original]