Mini Kabibi Habibi
#define MAXDEPTH 50
#define SPECIFYDIR_LOC "You must supply the name of the Documenting Wizard target directory."
#define ACTIVATEWIN_LOC "You must activate an edit window first."
#define GETDIRPROMPT_LOC "Doc Wizard Output Folder?"
#DEFINE FOUND_IN_LOC " found in "
#DEFINE NOT_FOUND_LOC " not found"
#DEFINE RECURSION_LOC " (recursion)"
para m1,m2
set exact off
set conf on
PUBLIC mdir
if type("m1") = 'C'
mdir=m.m1
ELSE
mdir=GETDIR(sys(2003)+"out",GETDIRPROMPT_LOC)
ENDIF
IF EMPTY(m.mdir) OR !FILE(mdir+"fdxref.dbf") OR !FILE(mdir+"files.dbf")
MESSAGEBOX(SPECIFYDIR_LOC,16)
RETURN .f.
ENDIF
IF USED("fdxref")
SELECT fdxref
ELSE
USE (mdir+"fdxref") EXCLUSIVE
ENDIF
IF !ISEXCL()
USE (DBF()) EXCLUSIVE
ENDIF
set order to symbol
IF !USED("symbols")
SELECT upper(symbol) as symbol,count(*) as count ;
FROM fdxref INTO CURSOR symbols order by 1 group by 1
ENDIF
SELECT symbols
LOCATE
do form jump
PROC tex
para mm && Definition Reference Next Back Goto
publ mwinname,mwinpos,seekmode,m.symbol
SELECT fdxref
set order to symbol
seekmode=m.mm
do setlibr
if m.seekmode='G'
IF EMPTY(filename)
RETURN
ENDIF
IF RIGHT(UPPER(ALLTRIM(filename)),4)$".VCX.SCX.DBC"
IF USED("snipfile")
USE IN snipfile
ENDIF
USE (ALLTRIM(fdxref.filename)) AGAIN IN 0 ALIAS snipfile
GO (fdxref.sniprecno) IN snipfile
IF !EMPTY(fdxref.snipfld)
MODI MEMO ("snipfile."+fdxref.snipfld) nowait noedit
Gotorec()
ENDIF
ELSE
modi comm (filename) nowait noedit
Gotorec()
ENDIF
SET LIBR TO
return
endif
IF type("fdstack[1]")='U'
PUBLIC fdstack[1,1],FDSP
fdsp=0
ENDIF
IF m.seekmode='B'
IF m.fdsp>0
mwinname=fdstack[fdsp,1]
mwinpos=fdstack[fdsp,2]
=CurPos("S")
fdsp=m.fdsp-1
IF m.fdsp>0
DIMENSION fdstack[fdsp,2]
ENDIF
ELSE
ENDIF
set libr to
RETURN
ENDIF
IF m.seekmode$"DR"
IF TYPE("_screen.activeform.caption")#'C'
=CurPos("G")
ELSE
=MessageBox(ACTIVATEWIN_LOC,16)
RETURN
ENDIF
ENDIF
* show wind fdxref refresh
if m.seekmode$"DR"
=examine(seekmode) &&see what's under cursor
endif
do exam &&get cursor word into m.symbol
set libr to
RETURN
PROC exam
*called by examine()... m.symbol ="" if not found
PRIVATE str
SELECT fdxref
if m.seekmode='T'
set orde to
skip
IF eof()
GO BOTT
ENDIF
else
if empty(set("order"))
SET ORDER TO symbol
ENDIF
str=PADR(UPPER(m.symbol),LEN(symbol))
IF m.seekmode$"DR"
SEEK str+m.seekmode
IF m.seekmode='D' AND !FOUND()
SEEK str+'V'
ENDIF
IF m.seekmode='R' AND !FOUND()
SEEK str
ENDIF
ELSE
IF !EOF()
SKIP
ENDIF
ENDIF
ENDIF
IF m.seekmode#'T' and (EMPTY(m.symbol) OR UPPER(symbol)#UPPER(m.symbol) OR EOF())
WAIT WINDOW NOWAIT m.seekmode+' '+m.symbol+NOT_FOUND_LOC
m.symbol=""
ELSE
IF RIGHT(UPPER(ALLTRIM(filename)),4)$".VCX.SCX.DBC"
IF USED("snipfile")
USE IN snipfile
ENDIF
USE (ALLTRIM(fdxref.filename)) AGAIN IN 0 ALIAS snipfile
GO (fdxref.sniprecno) IN snipfile
IF !EMPTY(fdxref.snipfld)
MODI MEMO ("snipfile."+fdxref.snipfld) nowait noedit
ENDIF
ELSE
modi comm (filename) nowait noedit
ENDIF
IF RIGHT(TRIM(filename),3)$"PRG MPR SPR"
SCATTER MEMVAR
m.lineno=INT(m.lineno)
if m.seekmode$"DR"
fdsp=m.fdsp+1
DIMENSION fdstack[fdsp,2]
fdstack[fdsp,1]=mwinname
fdstack[fdsp,2]=mwinpos
ENDIF
ELSE
m.symbol=""
ENDIF
=Gotorec()
WAIT WINDOW NOWAIT ALLTRIM(m.symbol)+" "+flag+FOUND_IN_LOC+ALLTRIM(fdxref.Filename)+' '+STR(lineno,5) &&+" SP="+str(fdsp,2) &&&&showsp
ENDIF
RETURN
proc setlibr
set libr to (IIF(file("fd3fll\fd3.fll"),;
"fd3fll\fd3.fll",;
LOCFILE(sys(2004)+"wizards\fd3.fll")))
IF "fd3"$SET("LIBR")
RETURN .T.
ENDIF
return .f.
proc tre
PARAMETER nmode,ol
*- ol is a TreeControl
PRIVATE lvl,cnt,err,i
ol.nodes.clear && clear all nodes
IF !USED("files")
use (mdir+"files") EXCL in 0
ENDIF
select files
IF !ISEXCL()
USE (DBF()) EXCL ALIAS files
ENDIF
go 1
mtop=JustStem(file)
select fdxref
lvl=0
m.cnt=0
m.err=.f.
mvar1="procname"
mvar2="symbol"
m.allowdup=.t.
set talk off
ol.visible=.f. &&debug
DO CASE
CASE nMode=1 && calling tree
do treediag
CASE nMode=3 && Class Hierarchy
ON ERROR m.err=.t.
SET ORDER TO classes
IF m.err
index on upper(procname) for flag$"BC" tag classes
ENDIF
ON ERROR
SELECT DISTINCT procname FROM fdxref;
WHERE flag$"BC";
ORDER BY 1;
INTO CURSOR obj
SCAN
myrec=recno()
MTOP=UPPER(ALLTRIM(Procname))
SELECT fdxref
DO showit WITH mtop
SELECT obj
go myrec
ENDSCAN
USE IN obj
SELECT fdxref
CASE nMode=2 && Derived class hierarchy
do classdiag
ENDCASE
ol.visible=.t.
RETURN
PROCEDURE JustStem
PARAMETERS mfile
IF AT('\',m.mfile)>0
mfile=SUBSTR(m.mfile,RAT('\',m.mfile)+1)
ENDIF && AT('/',m.mfile)>0
IF AT(".",m.mfile)>0
mfile=LEFT(m.mfile,AT(".",m.mfile)-1)
ENDIF && AT(".",m.mfile)>0
RETURN m.mfile
*EOP JustStem
PROC ClassDiag
LOCAL mr, lcKey, loNode
PRIVATE lvl,cCollate
cCollate=SET("collate")
SET COLLATE TO "machine"
SELECT symbol,procname,flag,filename,' ' AS done;
FROM fdxref ;
WHERE flag$"CB" AND;
UPPER(symbol) # UPPER(procname);
INTO CURSOR classd1
USE DBF("classd1") EXCL AGAIN IN 0 ALIAS classd
SELECT classd
USE IN classd1
INDEX ON done+flag+UPPER(procname) TAG dprocname
INDEX ON UPPER(procname) TAG procname
INDEX ON UPPER(symbol) TAG symbol
m.lvl=0
m.cnt=0
DO WHILE SEEK(' ',"classd","dprocname")
mr=RECNO()
DO WHILE SEEK(UPPER(procname)),"classd","symbol")
mr=RECNO()
ENDDO
GO mr
m.lvl=1
loNode = ol.Nodes.Add(,,,ALLTRIM(procname),,)
m.cnt=m.cnt+1
DO showclas WITH UPPER(ALLTRIM(procname)), loNode
SET ORDER TO symbol
ENDDO
USE IN classd
SET COLLATE TO (m.cCollate)
RETURN
PROC showclas
PARA m.procname, poNode
LOCAL mr, loNode
m.lvl=m.lvl+1
IF SEEK(' C'+m.procname+' ',"classd","dprocname")
SET ORDER TO procname
SCAN WHILE UPPER(ALLTRIM(procname))+' ' = m.procname+' '
REPLACE done WITH 'Y'
IF m.lvl>1
mr=recno()
mparent=UPPER(procname)
SKIP
GO m.mr
ENDIF
loNode = ol.Nodes.Add(poNode,4,,ALLTRIM(symbol),,)
m.cnt=m.cnt+1
mr=recno()
DO showclas WITH UPPER(ALLTRIM(symbol)), loNode && recursive call
GO m.mr
SET ORDER TO procname
ENDSCAN
ENDIF
m.lvl=m.lvl-1
RETURN
proc treediag
PRIVATE lvl,cnt,err
PRIVATE aLev
PRIVATE mindent,mparent
PRIVATE cActionChars
PRIVATE track
PRIVATE mtop
local msetexact,mr, loNode
DIMENSION track[MAXDEPTH]
track=""
msetexact=set("exact")
set exact on
CREATE CURSOR did (proc c(len(fdxref.symbol)))
INDEX ON upper(proc) TAG proc
select files
LOCA
IF EOF()
RETURN .f.
ENDIF
m.cnt=0
go 1
*- mtop=PADR(JustStem(file),LEN(fdxref.procname)) &&bugbug
mtop=PADR(JustStem(file),LEN(did.proc))
select fdxref
lvl=1
m.cnt=1
m.err=.t.
DO WHILE !EMPTY(TAG(m.cnt))
IF tag(m.cnt)="PROCEDURE"
m.err=.f.
EXIT
ENDIF
m.cnt=m.cnt+1
ENDDO
IF m.err
index on upper(procname) for flag$'DF' tag procedure
ELSE
SET ORDER TO procedure
ENDIF
m.cnt=0
track=""
loNode = ol.Nodes.Add(,2,,ALLTRIM(m.mtop),,) && next top-level
m.cnt=m.cnt+1
DO showit WITH mtop, loNode
*now find all missing subtrees
SELECT fdxref
SCAN for flag='D'
MR=recno()
*find top of subtree
m.mtop=fdxref.symbol
DO WHILE SEEK(UPPER(m.mtop)+'F',"fdxref","symbol") AND !"."$fdxref.procname AND ;
UPPER(ALLTRIM(fdxref.symbol)) # UPPER(ALLTRIM(fdxref.procname))
m.mtop=PADR(fdxref.procname,LEN(fdxref.symbol))
ENDDO
m.mtop=PADR(m.mtop,LEN(did.proc))
IF !SEEK(UPPER(m.mtop),"did")
m.lvl=1
loNode = ol.Nodes.Add(,2,,ALLTRIM(m.mtop),,) && next top-level
m.cnt=m.cnt+1
DO showit WITH PADR(fdxref.symbol,LEN(fdxref.procname)), loNode
ENDIF
GO m.MR
ENDSCAN
USE IN did
SET ORDER TO
set exact &msetexact
RETURN
PROC showit
Para prg, poNode
priv mr,i
LOCAL loNode
INSERT INTO did VALUES (UPPER(m.prg))
seek UPPER(m.prg)
IF !FOUND() OR m.lvl>=MAXDEPTH
RETURN
ENDIF
lvl=m.lvl+1
scan while upper(procname) = UPPER(m.prg)
if flag #'D'
IF m.lvl>1
mr=recno()
mparent=UPPER(procname)
SKIP
GO m.mr
ENDIF
IF VARTYPE(poNode) # 'O' OR ISNULL(poNode)
loNode = ol.Nodes.Add(,,,ALLTRIM(symbol),,) && top-level
ELSE
loNode = ol.Nodes.Add(poNode,4,,ALLTRIM(symbol),,)
ENDIF
m.cnt=m.cnt+1
I = ASCAN(track,UPPER(TRIM(symbol)))
IF m.i>0
loNode.Text = loNode.Text + RECURSION_LOC && indicate recursion, but don't add new item
ELSE
mr=recno()
track[m.lvl]=UPPER(trim(symbol))
do showit with PADR(symbol,LEN(fdxref.procname)), loNode
track[m.lvl]=""
go mr
ENDIF
endif
ENDsc
lvl=m.lvl-1
RETURN
proc gotorec
proc curpos
proc examine