[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]