Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : FCT1_11.ZIP
Filename : FC_LIST.PRG

#pragma stack-, range-
#output
#output Force Source Code Lister Version 1.0 By Pr

#include fileio.hdr
#include fct1.hdr

#define cf_array 400 && number of elements

vardef
logical strip = .f. && strip comments
logical include_file = .f. && list include files

uint func_cap = 2 && 0 = All, 1 = First letter, 2 = Lower
uint comm_cap = 2 && 0 = All, 1 = First letter, 2 = Lower
uint var_cap = 2 && 0 = All, 1 = First letter, 2 = Lower
uint tab_size = 3 && Tab size
uint curr_tab = 0 && current tab
uint tab_flag = 0 && tab command

logical prn_line_no = .f. && print line numbers
uint line_no = 0 && line count
ulong file_no = 0 && line number source
uint page_no = 0 && page number
uint page_len = 66 && page line

char buf && line buffer
file fs && file stream

char(15) force_comm[&cf_array]
char(15) force_func[&cf_array]

uint(1) force_comm_tab[&cf_array]
* 1 = Tab in
* 2 = Tab out
* 3 = Tab out, Tab in
* 4 = Tab in, Tab out

char null && Zero byte
enddef

* initialise the language arrays
procedure init_language
params char path

vardef
int cnt && local counter
enddef

* command array
if .not. f_open(fs, path + 'commands.txt', &f_read)
? 'no command set present'
_quit 2
endif

cnt = 0
do while .not. f_eof(fs)
if .not. f_getln(fs, buf)
? 'error reading file command.txt'
_quit 3
endif

if cnt >= &cf_array
? 'To many commands in text file'
_quit 4
endif

if numtoken(buf, ",") = 0
force_comm[cnt] = lower(alltrim(buf))
else
force_comm[cnt] = lower(alltrim(token(buf, ",", 1)))
force_comm_tab[cnt] = i_val(token(buf, ",", 2))
if force_comm_tab[cnt] < 0 .OR. force_comm_tab[cnt] > 4
? 'illegal tab command in commands.txt ' + force_comm[cnt]
_quit 5
endif
endif
cnt = cnt + 1
enddo
f_close(fs)

* function array
if .not. f_open(fs, path + 'function.txt', &f_read)
? 'no function set present'
_quit 2
endif

cnt = 0
do while .not. f_eof(fs)
if .not. f_getln(fs, buf)
? 'error reading file function.txt'
_quit 3
endif

if cnt >= &cf_array
? 'To many functions in text file'
_quit 4
endif

force_func[cnt] = lower(alltrim(buf)) + "("
cnt = cnt + 1
enddo
f_close(fs)
endpro

* forward declaration
*
procedure read_source prototype
params const char

* change the case of a token
*
procedure change_case
params char ret_buf, const char s_token, uint cap

vardef
char temp
uint i
enddef

if cap = 0
ret_buf = strtran(ret_buf, s_token, upper(s_token), 1, 99)
else
if cap = 2
ret_buf = strtran(ret_buf, s_token, lower(s_token), 1, 99)
else
if cap = 1
temp = upper(substr(s_token, 1, 1))
if at("_", s_token) <> 0 .or. at("[", s_token) <> 0
for i = 2 to len(s_token)
if substr(s_token, i, 1) <> "_" .and. substr(s_token, i, 1) <> "["
temp = temp + substr(s_token, i, 1)
else
temp = temp + upper(substr(s_token, i, 2))
i = i + 1
endif
next
else
temp = temp + substr(s_token, 2, len(s_token))
endif
ret_buf = strtran(ret_buf, s_token, temp, 1, 99)
endif
endif
endif
endpro

#Define max_str 20

* add tab's
*
procedure add_tab
params char ret_buf

if tab_flag = 2 .or. tab_flag = 3
if curr_tab >= tab_size
curr_tab = curr_tab - tab_size
endif
endif

if tab_flag = 4
curr_tab = curr_tab + tab_size
endif

if curr_tab > 0
ret_buf = space(curr_tab) + ret_buf
endif

if tab_flag = 4
if curr_tab >= tab_size
curr_tab = curr_tab - tab_size
endif
endif

if tab_flag = 1 .or. tab_flag = 3
curr_tab = curr_tab + tab_size
endif

tab_flag = 0

endpro

* manipulate a source line
*
procedure parse_source_line
params char ret_buf

vardef
logical f_flag
uint i, j, k, x, y
int l
uint tokens
char work_buf, func_buf

uint start[&max_str], eind[&max_str]
char str[&max_str]
enddef

if substr(ret_buf, 1, 1) = "*" .or. substr(ret_buf, 1, 2) = '&&'
if strip
ret_buf = null
else
add_tab(ret_buf)
endif
return
endif

if strip
i = rat('&&', ret_buf)
if i <> 0
if at("'", substr(ret_buf, i, len(ret_buf))) = 0
if at(chr(34), substr(ret_buf, i, len(ret_buf))) = 0
ret_buf = substr(ret_buf, 1, i - 1)
endif
endif
endif
j = rat("*", ret_buf)
if j <> 0
if at("'", substr(ret_buf, j, len(ret_buf))) = 0
if at(chr(34), substr(ret_buf, j, len(ret_buf))) = 0
ret_buf = substr(ret_buf, 1, j - 1)
endif
endif
endif
endif

* remove strings
for i = 0 to &max_str - 1
start[i] = 0
eind[i] = 0
str[i] = null
next

for j = 0 to &max_str - 1
if at(chr(39), ret_buf) = 0
exit
endif
x = atnum(chr(39), ret_buf, 1)
y = atnum(chr(39), ret_buf, 2)
start[j] = x
eind[j] = y
str[j] = substr(ret_buf, x, y - x + 1)
ret_buf = stuff(ret_buf, x, y - x + 1, null)
next

for k = j to &max_str - 1
if at(chr(34), ret_buf) = 0
exit
endif
x = atnum(chr(34), ret_buf, 1)
y = atnum(chr(34), ret_buf, 2)
start[k] = x
eind[k] = y
str[k] = substr(ret_buf, x, y - x + 1)
ret_buf = stuff(ret_buf, x, y - x + 1, null)
next

if .not. strip
* temp strip
if at('&&', ret_buf) <> 0
start[k] = at('&&', ret_buf) - 1
if start[k] = 0
start[k] = 1
endif
eind[k] = len(ret_buf)
str[k] = substr(ret_buf, start[k], eind[k])
ret_buf = substr(ret_buf, 1, start[k])
k = k + 1
endif
if at("*", ret_buf) <> 0
start[k] = at("*", ret_buf) - 1
if start[k] = 0
start[k] = 1
endif
eind[k] = len(ret_buf)
str[k] = substr(ret_buf, start[k], eind[k])
ret_buf = substr(ret_buf, 1, start[k])
endif
endif

* test line on command, function's and var's
tokens = numtoken(ret_buf, " ")
for i = 0 to tokens
if tokens > 1
work_buf = token(ret_buf, " ", i + 1)
if at(work_buf, ret_buf) = 0
exit
endif
else
work_buf = ret_buf
endif
work_buf = alltrim(work_buf)

if .not. empty_str(work_buf)
f_flag = .f.

* search command / function
for j = 0 to &cf_array - 1
if force_comm[j] <> null
if lower(work_buf) = force_comm[j]
if force_comm_tab[j] <> 0
if at('prototype', lower(ret_buf)) = 0
tab_flag = force_comm_tab[j]
endif
endif
change_case(ret_buf, work_buf, comm_cap)
f_flag = .t.
exit
endif
endif
next

if .not. f_flag
for j = 0 to numtoken(work_buf, "(")
func_buf = token(work_buf, "(", j)
if len(func_buf) <> 0
func_buf = func_buf + "("
for k = 0 to &cf_array - 1
if force_func[k] <> null
if func_buf = force_func[k]
change_case(ret_buf, func_buf, func_cap)
f_flag = .t.
exit
endif
endif
next
endif
next

* found, test voor var's
if f_flag
j = rat("(", work_buf)
if j <> 0
k = at(")", work_buf)
if k = 0
k = len(work_buf) + 1
endif
func_buf = substr(work_buf, j + 1, k - 1)
change_case(ret_buf, func_buf, var_cap)
f_flag = .t.
endif
endif
endif

* non found, assume var
if .not. f_flag
change_case(ret_buf, work_buf, var_cap)
endif
endif
next

* put strings back
for l = &max_str - 1 downto 0
if start[l] <> 0
ret_buf = stuff(ret_buf, start[l], 0, str[l])
endif
next

add_tab(ret_buf)

endpro

* read the source file
procedure read_source
params const char file_name

vardef
file fs
char file_name_path
char buf
char work_buf
char work_file
enddef

if .not. f_open(fs, file_name, &f_read)
file_name_path = getenv('FORCE.HDR') + file_name
if .not. f_open(fs, file_name_path, &f_read)
? "Can't open input file " + file_name
_quit 1
endif
endif

line_no = page_len
do while .not. f_eof(fs)
if .not. f_getln(fs, buf)
? 'problem reading ' + file_name
_quit 6
endif

if prn_line_no
line_no = line_no + 1
file_no = file_no + 1
if line_no >= page_len
page_no = page_no + 1
? chr(12)
? file_name + ' Page ' + i_str(page_no)
line_no = 2
endif
endif

buf = AllTrim(buf)
if .not. empty_str(buf) .and. substr(buf, 1, 1) <> chr(13)
parse_source_line(buf)
endif

if prn_line_no
buf = i_str(file_no) + ': ' + buf
endif
? buf

* include file recursive
work_buf = alltrim(lower(buf))
if substr(alltrim(work_buf), 1, 8) = '#include' .and. include_file
work_buf = alltrim(substr(work_buf, 10, len(work_buf)))
if at('&&', work_buf) <> 0
work_buf = alltrim(substr(work_buf, 1, at('&&', work_buf)))
endif
if at("*", work_buf) <> 0
work_buf = alltrim(substr(work_buf, 1, at("*", work_buf)))
endif
read_source(work_buf)
endif

enddo
f_close(fs)
if prn_line_no
? chr(12)
endif
endpro

* set options
*
procedure init_options
params char opt_str

vardef
uint i
char(3) s_token
enddef

for i = 2 to numtoken(opt_str, "/")
s_token = token(opt_str, "/", i)
do case
case substr(s_token, 1, 1) = "s"
strip = .t.
case substr(s_token, 1, 1) = "i"
include_file = .t.
case substr(s_token, 1, 1) = "p"
prn_line_no = .t.
page_len = i_val(substr(s_token, 2, 2))
if page_len = 0
page_len = 66
endif
case substr(s_token, 1, 1) = "f"
func_cap = i_val(substr(s_token, 2, 1))
case substr(s_token, 1, 1) = "c"
comm_cap = i_val(substr(s_token, 2, 1))
case substr(s_token, 1, 1) = "v"
var_cap = i_val(substr(s_token, 2, 1))
case substr(s_token, 1, 1) = "t"
tab_size = i_val(substr(s_token, 2, 2))
endcase
next
endpro

* main procedure
*
procedure force_main
params const char cmdlin

vardef
char opt_str
char path
enddef

path = alltrim(exename())
key_dos
scrn_dos

opt_str = lower(alltrim(cmdlin))
if empty_str(opt_str) .or. at('/h', opt_str) <> 0
? 'fc_list - Force Program Lister / formatter V1.0 (c) 1990 by Pr'
? 'usage : fc_list '
?
? ' Options summary'
? ' /H - Show this help screen'
? ' /I - List Include files'
? ' /Px - Enable page/line numbers, x = page len (standard 66 lines)'
? ' /S - Strip Comments'
? ' /Tx - Set tabsize (standard 3)'
?
? ' /Cx - Set commands case, x = case setting'
? ' /Fx - Set function case, x = case setting'
? ' /Vx - Set variables case, x = case setting'
?
? ' Valid case settings are :'
? ' 0 = Convert to uppercase'
? ' 1 = Only convert first letter to uppercase'
? ' 2 = Convert to lowercase'
? ' 3 = Just as it is'
?
quit
endif

if .not. empty_str(path)
path = substr(path, 1, rat("\", path))
endif

init_language(path)
init_options(opt_str)
read_source(token(cmdlin, " ", 2))

endpro