public close_pf_hnd()
public dbgen_delete()
public dbgen_update()
public dbgen_find()
public open_pf_hnd()
public put_find()
public put_form()
global calc_value()
global get_fld()
global pf_hdr()
global fct_hdr()
global fct_tail()
global fld_name()
global put_selection()
global put_radio()
global gen_db()
global get_gen_db_param()
global make_array()
global make_sort_str()
global extract_coords()
global out_html()
global quotes() XS()
global $cgi_exe
global put_html_hdr()
external substr1() get_choice() open_file() open_f_error() split_pfe2()
external check_path()
public $$advr $$dirsep $$fct
global $pfhdr
main
"@(#)dbgen.pf3 3.2 - 96/10/08" ' SID
$pfhdr = "' Automatically generated project file for use with CGI server"
if $$advr=0
clearerror
execute path(syspath)|"loadalib.rf0" in-memory
if lerror
exit main
end if
end if
if $$fct<>"loadlib"
gen_db()
end if
end main
' ************************************************************
function put_form($title,#hnd,#pf,#want_val,$button,$obj_id,$task)
' ************************************************************
local #fld_num $fld $str #ct
local $items[1] #r1 #r2 #c1 #c2
local #lr1 #lr2 #lc1 #lc2 #items $type
local #table_row
local #fixed_font
if not(make_array(arrayptr($items[1]),varptr(#items),$task))
return 0
end if
if len($title)
out_html(#hnd, #pf, ""|$title|"" )
out_html(#hnd, #pf, "")
out_html(#hnd, #pf, "
"|$title|"
")
end if
out_html(#hnd, #pf, quotes("") )
' Relies on Server to datafile to key
'FIND NEXT
out_html(#hnd, #pf ,quotes("") )
'FIND PREVIOUS
out_html(#hnd, #pf ,quotes("") )
otherwise
out_html(#hnd, #pf, quotes("") )
out_html(#hnd, #pf, quotes("") )
out_html(#hnd, #pf, quotes("") )
end case
end function
' ****************************************************************************
function make_array(AP_items,VP_items,$task)
' ****************************************************************************
local #init_size #a_ct #fld_ct
local #r1 #r2 #c1 #c2 $type
local #row #pos $str $text
local #row_ct
local $table $last_table
if group(sysvar($_irev),2)<"95/10/17"
' DBTEXTINFO is not available
#init_size = dbinfo(db_fields)
else
#init_size = dbinfo(db_fields) + dbinfo(db_num_tables)*10 + dbinfo(db_text_items)+10
end if
arrayresize(AP_items, #init_size)
#a_ct = 0
for #fld_ct = 1 to dbinfo(db_fields)
if $task = "E" ' Entry form
if dbfldinfo(#fld_ct,dbf_attrib)=1 or \
dbfldinfo(#fld_ct,dbf_attrib)=3 ' READ ONLY
continue for
elseif dbfldinfo(#fld_ct,dbf_calctype)=1 or \
dbfldinfo(#fld_ct,dbf_calctype)=2 ' Calculated
continue for
end if
end if
#r1 = dbfldinfo(#fld_ct,dbf_relstartrow)
#c1 = dbfldinfo(#fld_ct,dbf_relstartcol)
#r2 = dbfldinfo(#fld_ct,dbf_relendrow)
#c2 = dbfldinfo(#fld_ct,dbf_relendcol)
if dbfldinfo(#fld_ct,dbf_ontable)
if dbfldinfo(#fld_ct,dbf_filenum)=128
continue for
' Must ignore view only fields on tables
end if
$table = dbfldinfo(#fld_ct,dbf_table)
if $table<>$last_table
' Put Table Title
if arraysize(AP_items,1)<#a_ct+1
arrayresize(AP_items,#a_ct+20)
end if
#a_ct = #a_ct + 1
writeptr(AP_items,#a_ct,\
make_sort_str(#r1-1,#c1,#r1,#c1+len($table) ) & \
"3-Note" & "0" & $table&" ")
end if
$last_table = $table
for #row_ct = #r1 to #r2
#a_ct = #a_ct + 1
if arraysize(AP_items,1)<#a_ct+1
arrayresize(AP_items,#a_ct+20)
end if
writeptr(AP_items,#a_ct,\
make_sort_str(#row_ct,#c1,#row_ct,#c2)&\
"1-Fld" &\
str(#fld_ct) &\
str(#row_ct - #r1 + 1) )
end for
else
#a_ct = #a_ct + 1
if arraysize(AP_items,1)<#a_ct+1
arrayresize(AP_items,#a_ct+20)
end if
writeptr(AP_items,#a_ct,\
make_sort_str(#r1,#c1,#r2,#c2)&\
"1-Fld" &\
str(#fld_ct) )
end if
end for
if group(sysvar($_irev),2)>="95/10/17"
for #fld_ct = 1 to dbinfo(db_text_items)
#r1 = dbtextinfo(#fld_ct,dbt_top)
#c1 = dbtextinfo(#fld_ct,dbt_left)
#r2 = dbtextinfo(#fld_ct,dbt_bottom)
#c2 = dbtextinfo(#fld_ct,dbt_right)
$type = case dbtextinfo(#fld_ct,dbt_type) (1,"3-Note") (2,"2-Single") else "2-Double"
if $type = "3-Note"
$str = dbtextinfo(#fld_ct,dbt_text)
for #row = #r1 to #r2
#pos = match($str,"~")
if #pos
$text = left($str,#pos-1)
$str = mid($str,#pos+1)
else
$text = $str
end if
#a_ct = #a_ct + 1
if arraysize(AP_items,1)<#a_ct+1
arrayresize(AP_items,#a_ct+20)
end if
writeptr(AP_items,#a_ct,\
make_sort_str(#row,#c1,#row,#c2) & \
$type & str(#fld_ct) & $text)
end for
else
if #r1 = #r2 and #c2-#c1>60 ' A big horizontal line
if arraysize(AP_items,1)<#a_ct+1
arrayresize(AP_items,#a_ct+20)
end if
#a_ct = #a_ct + 1
writeptr(AP_items,#a_ct,\
make_sort_str(#r1,#c1,#r2,#c2)&\
$type & str(#fld_ct) & "")
end if
end if
end for
end if
writeptr(VP_items,#a_ct)
arrayresize(AP_items,#a_ct)
arraysort(AP_items,1)
return 1
end function
' ****************************************************************************
function make_sort_str(#r1,#c1,#r2,#c2)
' ****************************************************************************
return right(repeat("0",6)|str(#r1),6)|right(repeat("0",6)|str(#c1),6)| \
right(repeat("0",6)|str(#r2),6)|right(repeat("0",6)|str(#c2),6)
end function
' ****************************************************************************
function extract_coords($str,VP_#r1,VP_#c1,VP_#r2,VP_#c2)
' ****************************************************************************
writeptr(VP_#r1,val(left($str,6)))
writeptr(VP_#c1,val(mid($str,7,6)))
writeptr(VP_#r2,val(mid($str,13,6)))
writeptr(VP_#c2,val(mid($str,19,6)))
end function
' ****************************************************************************
function put_radio(#hnd,#pf,#fld_ct,$fld,#r1,#c1,#r2,#c2,#want_val,#row)
' ****************************************************************************
local $ch $chstr #chct $str #wid
$chstr = dbfldinfo(#fld_ct,dbf_menuchoices)
while true
#chct = #chct +1
$ch = group($chstr,#chct)
if len($ch)=0
exit while
end if
$str = ""& $ch
#wid = #wid +len($ch)+2
if #wid>#c2-#c1+1
#wid = len($ch)+2
$str = $str & " "
end if
out_html(#hnd, #pf, $str)
end while
end function
' ****************************************************************************
function calc_value(#want_val,$fld,#strip_tilde,#row)
' ****************************************************************************
return quotes("VALUE='")|get_fld(#want_val,$fld,#strip_tilde,#row)|quotes("'")
end function
' ****************************************************************************
function fld_name($fld,#row)
' ****************************************************************************
if #row = 0
return $fld
end if
return str(#row)|"-"|$fld
end function
' ****************************************************************************
function get_fld(#want_val,$fld,#strip_tilde,#row)
' ****************************************************************************
' GETS A FIELD
' #want_val = 0 ' NADA
' #want_val = 1 ' Returns value in current record
' #want_val = 2 ' Returns expression to include in PF to get value
' #want_val = 3 ' Returns expression to include without ~(~ ~)~
' ****************************************************************************
local $str #need_str
local #db $db $key_val $key_fld #type
if #want_val = 0
return ""
end if
#type = dbfldinfo("["|$fld|"]",dbf_type)
if #type>=3
#need_str = 1
end if
if #row = 0
$fld = "["|apinfo(ap_file)|"."|$fld|"]"
if #want_val = 1
$fld = dbget($fld)
if #need_str
$fld = str($fld)
end if
if #strip_tilde
$fld = replacestr($fld,"~"," ")
end if
elseif #want_val >= 2
if #need_str
$fld = "str("|$fld|")"
end if
if #strip_tilde and #need_str
$fld = "replacestr("|$fld|"),~~_~~,~~ ~~)"
end if
end if
else
#db = dbfldinfo("["|$fld|"]",dbf_filenum)
if #db=128 ' View only field
' $fld = replacestr(dbfldinfo("["|$fld|"]",dbf_calculation),chr(34),"~~")
' won't work because table record fields won't be correct
$fld = "~~~"
else
$db = dbinfo(db_driven+#db-1)
$key_fld = dbinfo(db_dvnlinks+#db)
if #want_val = 1
message "I Wasn't expecting this"
' $key_val = get_fld(1, dbinfo(db_dvrlinks+#db), #strip_tilde , 0)
' get_table($db, $key_val, $key_fld, #row, $fld)
elseif #want_val >= 2
$key_val = get_fld(3, dbinfo(db_dvrlinks+#db), #strip_tilde , 0)
$fld = "get_table_val(~~"|$db|"~~, "|$key_val|", ~~"|$key_fld|"~~, "|str(#row)|")"
' get_table_val($db,$key_val,$key_fld,#row,$fld)
end if
end if
end if
if #want_val = 1
$str = $fld
elseif #want_val = 2
$str = "~(~" & $fld & " ~)~"
elseif #want_val = 3
$str = $fld
end if
return $str
end function
' ****************************************************************************
function put_selection(#hnd,#pf,#fld_ct,$fld,#want_val,#row)
' ****************************************************************************
local $str #ct $ch $chstr #pos
out_html(#hnd, #pf, quotes("")
end function
' ****************************************************************************
function open_pf_hnd($vw_path,$vw_file)
' ****************************************************************************
local #pf_hnd $file #exists
local $str
$file = check_path($vw_path)|$vw_file|".pf3"
if file($file)
#exists = 1
end if
#pf_hnd = open_file($vw_path,$vw_file|".pf3",rw_mode)
if #pf_hnd<=0
open_f_error($vw_path,$vw_file|".pf3",#pf_hnd)
return 0
end if
if #exists
fread #pf_hnd into $str
if $str<>$pfhdr
while true
case get_choice(substr1("SPL file %s already exists.",$file),"Overwrite?","","","Yes"&"No",4)
when 1 ' Yes
exit while
when 2 ' No
fclose #pf_hnd
return 0
end case
end while
end if
end if
pf_hdr(#pf_hnd)
ftruncate #pf_hnd
return #pf_hnd
end function
' ****************************************************************************
function close_pf_hnd($vw_path,$vw_file,#pf_hnd)
' ****************************************************************************
clearerror
ftruncate #pf_hnd
fclose #pf_hnd
remember tools compile debug $vw_path|$$dirsep|$vw_file|".pf3"
return not(lerror)
end function
' ****************************************************************************
function gen_db()
' ****************************************************************************
local $doc_path $doc_base $title
local #comb #enter #find #update #delete
local #hnd $vw_path $vw_file $vw_ext
local $pfe $obj_id
local #pf_hnd
$pfe = apinfo(ap_filep)
split_pfe2($pfe,varptr($vw_path),varptr($vw_file),varptr($vw_ext))
$doc_path="/usr/local/etc/httpd/htdocs"
$doc_base=left($vw_file,7)
$title="%s"
' GET PARAMETERS
if get_gen_db_param(\
varptr($doc_path),\
varptr($doc_base),\
varptr($vw_path),\
varptr($vw_file),\
varptr($title),\
varptr(#comb),\
varptr(#enter),\
varptr(#find),\
varptr(#update),\
varptr(#delete) ) = 0
return 0
end if
$cgi_exe = "/cgi-bin/smrtpipe?-c+-H+-1+%s"
if $vw_path=""
$vw_path="."
end if
$obj_id = $vw_path|$$dirsep|"*"|$vw_file
if #comb
#hnd = open_file($doc_path,$doc_base|".htm",rw_mode)
if #hnd<=0
open_f_error($doc_path,$doc_base|".htm",#hnd)
return 0
end if
put_html_hdr(#hnd,substr1($title,"Commands"))
end if
if #find or #delete or #update
#pf_hnd = open_pf_hnd($vw_path,$vw_file)
if #pf_hnd=0
return 0
end if
end if
if #enter
if not(#comb)
#hnd = open_file($doc_path,left($doc_base,7)|"e.htm",rw_mode)
if #hnd<=0
open_f_error($doc_path,left($doc_base,7)|"e.htm",#hnd)
return 0
end if
put_html_hdr(#hnd,substr1($title,"Add"))
else
out_html(#hnd, 0, "
"|substr1($title,"Send a Record")|"
")
end if
put_form(substr1($title,"Send Record"),#hnd,0,0,"Send Record",$obj_id,"E")
if not(#comb)
ftruncate #hnd
fclose #hnd
end if
end if
if #find
if #comb
out_html(#hnd, 0, "
"|substr1($title,"Find a Record")|"
")
end if
dbgen_find(#comb, #hnd, #pf_hnd, $title, $doc_path, $doc_base, $vw_file)
end if
if #update
if #comb
out_html(#hnd, 0, "
"|substr1($title,"Change a Record")|"
")
end if
dbgen_update(#comb, #hnd, #pf_hnd, $title, $doc_path, $doc_base, $vw_file)
end if
if #delete
if #comb
out_html(#hnd, 0, "
"|substr1($title,"Delete a Record")|"
")
end if
dbgen_delete(#comb, #hnd, #pf_hnd, $title, $doc_path, $doc_base, $vw_file)
end if
if #comb
ftruncate #hnd
fclose #hnd
end if
if #find or #delete or #update
close_pf_hnd($vw_path,$vw_file,#pf_hnd)
end if
end function
' ************************************************************
function dbgen_find(#comb, #hnd, #pf_hnd, $title, $doc_path, $doc_base, $vw_file)
' ************************************************************
if not(#comb)
#hnd = open_file($doc_path,left($doc_base,7)|"f.htm",rw_mode)
if #hnd<=0
open_f_error($doc_path,left($doc_base,7)|"f.htm",#hnd)
return 0
end if
put_html_hdr(#hnd,substr1($title,"Find"))
end if
if #hnd>0
put_find($title,#hnd,"Find",$vw_file,"F")
end if
if #pf_hnd>0
fct_hdr(#pf_hnd,$vw_file,"F")
put_form(substr1($title,"Record Found"),#pf_hnd,1,2,"Find Next",$vw_file,"F")
fct_tail(#pf_hnd,$vw_file,"F")
end if
if not(#comb)
ftruncate #hnd
fclose #hnd
end if
end function
' ************************************************************
function dbgen_update(#comb, #hnd, #pf_hnd, $title, $doc_path, $doc_base, $vw_file)
' ************************************************************
if not(#comb)
#hnd = open_file($doc_path,left($doc_base,7)|"u.htm",rw_mode)
if #hnd<=0
open_f_error($doc_path,left($doc_base,7)|"u.htm",#hnd)
return 0
end if
put_html_hdr(#hnd,substr1($title,"Update"))
end if
if #hnd>0
put_find($title,#hnd,"Update",$vw_file,"U1")
end if
if #pf_hnd>0
fct_hdr(#pf_hnd,$vw_file,"U")
put_form(substr1($title,"Change Record"),#pf_hnd,1,2,"Update",$vw_file,"U")
fct_tail(#pf_hnd,$vw_file,"U")
end if
if not(#comb)
ftruncate #hnd
fclose #hnd
end if
end function
' ************************************************************
function dbgen_delete(#comb, #hnd, #pf_hnd, $title, $doc_path, $doc_base, $vw_file)
' ************************************************************
if not(#comb)
#hnd = open_file($doc_path,left($doc_base,7)|"d.htm",rw_mode)
if #hnd<=0
open_f_error($doc_path,left($doc_base,7)|"d.htm",#hnd)
return 0
end if
put_html_hdr(#hnd,substr1($title,"Delete"))
end if
if #hnd>0
put_find($title,#hnd,"Delete",$vw_file,"D1")
end if
if #pf_hnd>0
fct_hdr(#pf_hnd,$vw_file,"D")
put_form(substr1($title,"Delete Record"),#pf_hnd,1,2,"Delete",$vw_file,"D")
fct_tail(#pf_hnd,$vw_file,"D")
end if
if not(#comb)
ftruncate #hnd
fclose #hnd
end if
end function
' ************************************************************
function put_html_hdr(#genhnd,$title)
' ************************************************************
fwrite #genhnd from quotes("")
fwrite #genhnd from ""|$title|""
fwrite #genhnd from ""
end function
' ************************************************************
function put_find($title,#hnd,$button,$obj_id,$task)
' ************************************************************
local #ct #key_ct #key #def_key #max #w
local $keys[15]
for #ct = 1 to dbinfo(db_fields)
if dbfldinfo(#ct,dbf_iskey)
#key_ct = #key_ct + 1
$keys[#key_ct] = dbfldinfo(#ct,dbf_name)
end if
end for
#def_key = 1
if dbinfo(db_order)=1
for #ct = 1 to #key_ct
if $keys[#ct] == dbinfo(db_orderfld)
#def_key = #ct
exit for
end if
end for
end if
fwrite #hnd from quotes("")
end function
' ************************************************************
function pf_hdr(#hnd)
' ************************************************************
fwrite #hnd from $pfhdr
fwrite #hnd from ""
fwrite #hnd from "external cgi_send_line()"
fwrite #hnd from "external get_table_val()"
fwrite #hnd from ""
end function
' ************************************************************
function fct_hdr(#hnd,$view,$action)
' ************************************************************
local $function
$function = $view|"_"|$action
fwrite #hnd from ""
fwrite #hnd from "public "|$function|"(2)"
fwrite #hnd from ""
fwrite #hnd from "function "|$function|"(#srv_id,#pid)"
end function
' ************************************************************
function out_html(#hnd,#pf,$str)
' ************************************************************
if #pf
' Change "'s to be CHR(34)'s with required contcatenation
$str = replacestr($str,chr(34),chr(34)|"|chr(34)|"|chr(34))
' ~(~ and ~)~ surround expresions which must be eval'd at run time
$str = replacestr($str,"~(~",chr(34)|"|")
$str = replacestr($str,"~)~","|"|chr(34))
' Change ~~ to "'s
$str = replacestr($str,"~~",chr(34))
' Change ~_~ to ~'s
$str = replacestr($str,"~_~","~")
' Remove redundent null's
$str = replacestr($str,"|"|chr(34)|chr(34),"")
$str = replacestr($str,chr(34)|chr(34)|"|","")
fwrite #hnd from " cgi_send_line(#srv_id,#pid,"|chr(34)|$str|chr(34)|")"
else
fwrite #hnd from $str
end if
end function
' ************************************************************
function fct_tail(#hnd,$view,$action)
' ************************************************************
fwrite #hnd from "end function"
end function
' ************************************************************
' DIALOG BOX INCLUDE STUFF
' Generalize format for Add functions:
' DialogAdd(AP_dlg,#id,#r1,#c1,[width|max_c|c2|r2 c2],\
' $#val,others,\
' $fld_title)
external DialogAddButton()
external DialogAddFieldPrompt()
external DialogAddFilePrompt()
external DialogAddDirPrompt()
external DialogAddFld()
external DialogAddHelp()
external DialogAddMenu()
external DialogAddPop()
external DialogAddPrompt()
external DialogAddStdButton()
external DialogAddTextFile()
external DialogAddText()
external DialogAddTitle()
external DialogDrawAll()
external DialogExit()
external DialogInit()
external DialogGetVal()
external DialogSetVal()
external DialogHide()
external DialogLocate()
external DialogFree()
external DialogJustify()
external DialogRun()
external DialogSize()
external DialogStdCB()
' ************************************************************
function get_gen_db_param(VP_$p,VP_$f,VP_$vp,VP_$vf,VP_$title,VP_#comb,VP_#enter,VP_#find,VP_#update,VP_#delete)
' ************************************************************
local $dialog[70,30] AP_dlg #row
local $p
AP_dlg = arrayptr($dialog[1,1])
#row = 1
DialogInit(AP_dlg)
DialogAddTitle(AP_dlg,"HTML Form Generation")
' Document Path (ID 1)
DialogAddDirPrompt(AP_dlg,1,#row,1,40,readptr(VP_$p),\
"Path of HTML files:")
' File Name (ID 2)
#row = #row + 1
DialogAddPrompt(AP_dlg,2,#row,1,60,readptr(VP_$f),7,"txt",\
"Base HTML file name:")
' View Path (ID 10)
#row = #row + 1
DialogAddDirPrompt(AP_dlg,10,#row,1,40,readptr(VP_$vp),\
"Path of view file (on server)")
' File Name (ID 11)
#row = #row + 1
DialogAddPrompt(AP_dlg,11,#row,1,60,readptr(VP_$vf),8,"txt",\
"Name of view file (on server):")
' Combine (ID 3)
#row = #row + 1
DialogAddMenu(AP_dlg, 3, #row,1,0,0, 1, \
2, "Yes"&"No",\
"Combine into one page?" )
' Title (ID 4)
#row = #row + 1
DialogAddPrompt(AP_dlg,4,#row,1,60,readptr(VP_$title),70,"txt",\
"Title: (use a %s)")
' Add (5)
#row = #row + 1
DialogAddMenu(AP_dlg, 5, #row,1,0,0, 1, \
2, "Yes"&"No",\
"Generate Add Record?" )
' Find (6)
#row = #row + 1
DialogAddMenu(AP_dlg, 6, #row,1,0,0, 1, \
2, "Yes"&"No",\
"Generate Find Record?" )
' Update (7)
#row = #row + 1
DialogAddMenu(AP_dlg, 7, #row,1,0,0, 1, \
2, "Yes"&"No",\
"Generate Update Record?" )
' Delete (8)
#row = #row + 1
DialogAddMenu(AP_dlg, 8, #row,1,0,0, 1, \
2, "Yes"&"No",\
"Generate Delete Record?" )
' DialogAddHelp( AP_dlg, $$advr|"netapgen.hlp" )
DialogAddStdButton( AP_dlg )
DialogLocate( AP_dlg, 1 )
while true
if DialogRun( AP_dlg, "", "", "" ,"","")
$p = DialogGetVal(AP_dlg,1)
if right($p,1)=$$dirsep
$p = left($p,len($p)-1)
end if
if fileinfo($p,f_type)<>2
if get_choice("Missing directory."&"Create?","","","",\
"Yes"&"No",3)=1
tools directory make $p
if fileinfo($p,f_type)<>2
continue
end if
else
continue
end if
end if
writeptr(VP_$p,$p)
writeptr(VP_$f,DialogGetVal(AP_dlg,2))
writeptr(VP_$title,DialogGetVal(AP_dlg,4))
$p = DialogGetVal(AP_dlg,10)
if right($p,1)=$$dirsep
$p = left($p,len($p)-1)
end if
writeptr(VP_$vp,$p)
writeptr(VP_$vf,DialogGetVal(AP_dlg,11))
case DialogGetVal(AP_dlg,5) ' Combine
when 2 ' NO
writeptr(VP_#comb,0)
otherwise ' Yes
writeptr(VP_#comb,1)
end case
case DialogGetVal(AP_dlg,6) ' enter
when 2 ' NO
writeptr(VP_#enter,0)
otherwise ' Yes
writeptr(VP_#enter,1)
end case
case DialogGetVal(AP_dlg,7) 'find
when 2 ' NO
writeptr(VP_#find,0)
otherwise ' Yes
writeptr(VP_#find,1)
end case
case DialogGetVal(AP_dlg,8) ' Update
when 2 ' NO
writeptr(VP_#update,0)
otherwise ' Yes
writeptr(VP_#update,1)
end case
case DialogGetVal(AP_dlg,9) 'Delete
when 2 ' NO
writeptr(VP_#delete,0)
otherwise ' Yes
writeptr(VP_#delete,1)
end case
DialogFree( AP_dlg )
return 1
else
DialogFree( AP_dlg )
return 0
end if
end while
end function
function quotes($str)
return replacestr($str,"'",chr(34))
end function
function XS($str)
return $str
end function