'**** HEADER ************************************************************
'DFILELIB.PF3

'This program is the CONFIDENTIAL and PROPRIETARY property of Applied
'Resource Technologies, Inc.  Any unauthorized use, reproduction or
'transfer of this program is strictly prohibited.  This is an unpublished
'work, and is subject to limited distribution and restricted disclosure
'only.  ALL RIGHTS RESERVED.

'Copyright (c) 1990-1991 Applied Resource Technologies, Inc.
'2305 Cedar Springs Road, Suite 150, Dallas, Texas 75201 U.S.A.
'Voice: (214) 855-0449  FAX: (214) 969-7506  BBS: (214) 855-1347

'Description: database file management and record navigation functions

'**** FUNCTION DECLARATIONS *********************************************
'library
'core
external messboxwait() dpath get_choice()

public   _dbloadretry()
public   vloadif()       'loads view, or does goto
public   vunloadif()     'unloads view if loaded
public   vloadexcif()    'loads file exclusively
public   findblank()     'uses blank rec or enters new
public   blankrec()      'blanks specified fields
public   find254rec()    'uses special blank rec or enters new
public   make254rec()    'blanks specified fields
public   pagerec()       'issues pagedown/up  specified times
public   navrecs()       'browse type record navigation controller
public   getfields()     ' returns # of fields in db, plus stores the
                         ' field names in public array ptary[]
public   psa dsa
global   messwait() sch scr scw scc
global   dfchkstr()      'verifies if named item is in passed string
global   dpathsep()      'gets file and path from string
'required by getfields()
global   fgcheck() openview() fldcount() readfields() closeview()
'**** VARIABLE DECLARATIONS *********************************************
'library
public currview ptary[1] ptval ptstr currlib
'core
'required by getfields()
global   dbhlen fcnt
global   #dbloadretries
global   #db_ld_fct db_ld_fct()
'**** CODE **************************************************************

MAIN
local ptpsl
sch        = scrheight                  'used by screen display functions
scw        = scrwidth                   'used by screen display functions
scr        = int(sch/2)                 'center row
scc        = int(scw/2)                 'center column
ptpsl = "dfilelib"
if currlib = 0
     currlib = ptpsl
     lock module currlib
else
     if chr(32)|lower(currlib)|chr(32) !! chr(32)|ptpsl|chr(32)
          currlib = currlib & ptpsl
     end if
end if
if currview = 0
     currview = NULL
     lock module currview
end if
if ptary[1] = 0
     ptary[1] = NULL
     lock module ptary[]
end if
if ptval = 0
     ptval = BLANK
     lock module ptval
end if
if ptstr = 0
     ptstr = BLANK
     lock module ptval
end if
END MAIN

function vloadexcif(pf)' unloads file(if loaded) & then loads exclusively
local p f xpf r ss
'-------------------------------------
'p         = datapath  (as "\dir\subdir\")
'f         = viewname  (as "name.ext"
'e         = error var
'requires  dfchkstr()
'-------------------------------------
'returns   0 = success
'         <0 = error
'         -1 = view.ext not found
'         -2 = unable to load/goto
'-------------------------------------
' check if single-step is ON (1) or OFF (0)
smartpeek $_step ss                    ' message "ss is:"&str(ss)
single-step off
' if ss=1
'   single-step on
' end if
r = 0
vunloadif(pf)
if file(pf) = TRUE
     error off
     clearerror
     xpf = dpathsep(pf)
     f = lower(group(xpf,1))
     p = group(xpf,2)
     if dfchkstr(f,lower(currfiles(1))) = FALSE
          if right(f,1) == "s"
               file load standard-view p|f exclusive
          else
               file load custom-view p|f exclusive
          end if
     end if
     data goto view f
     error on
     if lerror = 0
          currview = f
     else
          r = -2
     end if
else
     r = -1
end if
if ss=1
  single-step on
end if
return (r)
end function  'vloadexcif()

function vloadif(pf)
local p f xpf r ss
'-------------------------------------
'p         = datapath  (as "\dir\subdir\")
'f         = viewname  (as "name.ext"
'e         = error var
'requires  dfchkstr()
'-------------------------------------
'returns   0 = success
'         <0 = error
'         -1 = view.ext not found
'         -2 = unable to load/goto
'-------------------------------------
smartpeek $_step ss                    ' message "ss is:"&str(ss)
single-step off
r = 0
if file(pf) = TRUE
  error off
  clearerror
  xpf = dpathsep(pf)
  f = lower(group(xpf,1))
  p = group(xpf,2)
  if dfchkstr(f,lower(currfiles(1))) = FALSE
    if right(f,1) == "s"
      file activate standard-view p|f
    else
      file activate custom-view p|f
    end if
  end if
  data goto view f
  error on
  if lerror = 0
    currview = f
  else
    r = -2
'     messwait("Unable to load `"|upper(pf)|"' - report to Office",0,0,1)
    messwait(" Unable to load `"|upper(pf)|"' - retry later ",0,0,1)
    screen clear box 1 1 sch scw 0 0 no-border
    repaint off
    file unload all
    error off
    while true
      window close
      if cerror
        exit while
      end if
    end while
    transfer "pm_menu.psl" in-memory
  end if
else
  r = -1
  messwait("File `"|upper(pf)|"' not found - report to Office ",0,0,1)
  screen clear box 1 1 sch scw 0 0 no-border
  repaint off
  file unload all
  error off
  while true
    window close
    if cerror
      exit while
    end if
  end while
  transfer "pm_menu.psl" in-memory
end if
if ss=1
  single-step on
end if
return (r)
end function  'vloadif()


function vunloadif(f)
'-------------------------------------
'f         = viewname  (as "name.ext")
'r         = error var
'requires  dfchkstr()
'-------------------------------------
'returns   0 = success
'         <0 = error
'         -1 = unable to unload view
'-------------------------------------
local r ss
smartpeek $_step ss                    ' message "ss is:"&str(ss)
single-step off
r = 0
f = lower(f)
if dfchkstr(f,lower(currfiles(1))) = TRUE
     error off
     clearerror
     file unload view f
     error on
     if lerror = 0
          if currview == f
               currview = NULL
          end if
     else
            r = -1
     end if
elseif f == "all"
     file unload all
     currview = NULL
end if
if ss=1
  single-step on
end if
return (r)
end function  'vunloadif()

function findblank(fld)
local r
r = -2
ptval = BLANK
error off
clearerror
order change key fld
if lerror = 0
     data goto record first
     while dbget(fld) = BLANK
          clearerror
          lock-record
               if lerror = 0
                    ptval = precord
                    r = 0
                    exit while
                end if
          data goto record next
     end while
else
     r = -1
end if
if r < 0
     order change physical
end if
error on
return (r)
end function  'findblank()


function blankrec(list)
local c fld r
c = 1
r = 0
ptstr = blank
error off
clearerror
lock-record
if lerror <> 0
     clearerror
     r = -1
else
     while TRUE
          fld = group(list,c)
          if exact(fld,NULL)=FALSE
               clearerror
               dbput(fld,blank)
                    if lerror <> 0
                         r = -2
                         ptstr = fld
                         exit while
                    end if
          else
               exit while
          end if
          c=c+1
     end while
     if r = 0
          clearerror
          recalc
          write-record
          if lerror <> 0
               r = -3
          end if
     end if
end if
error on
return (r)
end function  'blankrec()


function find254rec(fld)
local r
r = -2
ptval = BLANK
error off
clearerror
order change key fld
if lerror = 0
     data goto record last
     while dbget(fld) = chr(254)
          clearerror
          lock-record
               if lerror = 0
                    ptval = precord
                    r = 0
                    exit while
                end if
          data goto record previous
     end while
else
     r = -1
end if
if r < 0
     order change physical
end if
error on
return (r)
end function  'find254rec()


function make254rec(clist,blist)
local c fld r
r = 0
ptstr = blank
error off
clearerror
lock-record
if lerror <> 0
     r = -1
else
     if exact(clist,NULL)=FALSE
          c = 1
          while TRUE
               fld = group(clist,c)
               if exact(fld,NULL)=FALSE
                    clearerror
                    dbput(fld,chr(254))
                    if lerror <> 0
                         ptstr = fld
                         r = -2
                         exit while
                    end if
               else
                    exit while
               end if
               c=c+1
          end while
     end if
     if r = 0
       if exact(blist,NULL)=FALSE
          c = 1
          while TRUE
               fld = group(blist,c)
               if exact(fld,NULL)=FALSE
                    clearerror
                    dbput(fld,blank)
                    if lerror <> 0
                         ptstr = fld
                         r = -3
                         exit while
                    end if
               else
                    exit while
               end if
               c=c+1
          end while
       end if
     end if
     if r = 0
          clearerror
          recalc
          write-record
          if lerror <> 0
               r = -4
          end if
     end if
end if
error on
return (r)
end function  '254rec()


function pagerec(tp,h)
local c k scn pl rp
c = 1
k = NULL
smartpeek $_paint rp
smartpeek $_l1 pl
screen save pl 1 pl scrwidth scn
if rp = 0
     repaint
     repaint on
end if
while k <> {Esc}
if h = 1
     if tp > 1
          screen print pl 1 bginvpleasing fgstandard \
              str(format("Page: "|str(c)|" of "|str(tp)| \
              "   Use PgUp-PgDn, or press Esc to exit viewing this record", \
              "M"|str(scrwidth)))
     else
'          screen print pl 1 bginvpleasing fgstandard \
          screen print pl 1 bgs fgs \
              str(format("Page: "|str(c)|" of "|str(tp)| \
              "   Press Esc to exit viewing this record","M"|str(scrwidth)))
     end if
end if
k = inchar
     if k = {PgUp}
          if c > 1
               c = c - 1
               data goto page previous
          else
               beep
          end if
     elseif k = {PgDn}
          if c < tp
               c = c + 1
               data goto page next
          else
               beep
          end if
     end if
end while
while c > 1
     data goto page previous
     c=c-1
end while
if rp = 0
     repaint off
end if
screen shortrestore scn
end function 'pagerec()


function navrecs()
'1.5 02/26/91 MS / changed to take advantage of hiding the "Project Suspended"
'                  message during the {Home} and {End} movements
local x bot psmode
screen save scrheight 1 scrheight scrwidth bot
smartpeek $_spndmes psmode
if psmode = 1
     smartpoke $_spndmes 0
end if
while TRUE
     x = inchar
     if x = {Down}
          data goto record next
     elseif x = {Up}
          data goto record previous
     elseif x = {PgDn}
          data goto page next
     elseif x = {PgUp}
          data goto page previous
     elseif x = {^End}
          data goto record last
     elseif x = {^Home}
          data goto record first
     elseif x = {Home}
          suspendone
          keys Home,F8
          screen shortrestore bot
     elseif x = {End}
          suspendone
          keys End,F8
          screen shortrestore bot
     else
          exit while
     end if
end while
if psmode = 1
     smartpoke $_spndmes 1
end if
return (x)
end function   'navrecs()


function getfields(fname,fnum)
'--------------------------------------------------------
'fname = <path>filename to Smartware II data file
'fnum  =  available file number to open data file
'--------------------------------------------------------
'success:
'         returns (0)
'         ptval = field count
'         stores fieldnames in ptary[] (no brackets)
'error:
'         -1   smartware II .db not specified in <path>filename
'         -2   specified file not found
'         -3   not able to open specified file
'         -4   not a Smartware II data file
'         -5   field count < 1  (not valid data file, or damaged data file)
'--------------------------------------------------------
'requires:
' fgcheck()    - verifies extension is ".db" and that file exists
' openview()   - open data file and verifies header id
' fldcount()   - reads the number of fields from header
' readfields() - reads the actual text name of all fields
' closeview()  - closes the view
' dbhlen       - declared data base header size
' fcnt         - field count
' ptval        - public variable for data return (field count)
'--------------------------------------------------------
local chk r
r = 0               ' initialize error return to 0
ptval = BLANK       ' initialize data return to BLANK
dbhlen = 2048       ' data base header size
fcnt = 0            ' initialize field count to 0
chk = fgcheck(fname)
if chk = 0
     chk = openview(fname,fnum)
     if chk = 0
          fcnt = fldcount(fnum)
          if fcnt > 0
               readfields(fnum)
          else
               fcnt = -5      ' field count < 1
          end if
          closeview(fnum)
     else
          fcnt = chk
     end if
else
     fcnt = chk
end if
if fcnt > 0
     ptval = fcnt
else
     r = fcnt
end if
return (r)
end function  'getfields()


function fgcheck(fname)
'required by getfields()
local chk
chk = 0
if right(lower(fname),3) <> ".db"
     chk = -1                      ' smartware II .db not specified
elseif file(fname)=FALSE
     chk = -2                      ' file not found
end if
return (chk)
end function  'fgcheck()


function openview(fname,fnum)
'required by getfields()
local chk id
chk = 0
fopen fname as fnum
if cerror = 0
     fread fnum binary 2 into id
     if (id[1]=0x53 and id[2]=0x04)=FALSE
          chk = -4                           ' not a Smartware II db
     end if
     fseek fnum 0
else
     chk = -3                                ' not able to open file
end if
return (chk)
end function  'openview()

function fldcount(fnum)
'required by getfields()
local bp
fseek fnum dbhlen + 32
fread fnum binary 2 into bp
fcnt = (int(bp[1]+(bp[2]*256)))
redimension ptary[fcnt]
return (fcnt)
end function  'fldcount()



function readfields(fnum)
'required by getfields()
local i t f
fseek fnum dbhlen + 56 + 6
     for i = 1 to fcnt
          fread fnum length 28 into t
          ptary[i] = t
     end for
end function


function closeview(fnum)
'required by getfields()
fclose fnum
end function



function dfchkstr(s,sl)
local t i
'-------------------------------------
's    = string to check
'sl   = string group
't    = targeted item to check
'i    = counter for group() function
'-------------------------------------
'returns  TRUE  = item is in string group
'         FALSE = item is not in list
'-------------------------------------
i=0
while exact(t,NULL)=FALSE
     i=i+1
     t = group(sl,i)
     if t = s
          return (TRUE)
     end if
end while
return (FALSE)
end function  'dfchkstr()




FUNCTION dpathsep(pf)
local j l f p c r
l = len(pf)
if l > 0
     for j = l to 0 step -1
          c = mid(pf,j,1)
          if c="/" or c=":" or c="\"
               p = left(pf,j)
               f = mid(pf,j+1)
               exit for
          end if
     end for
     if j = -1
          r = pf
     else
          if f = null
               r = -1              'path found but not a filename
          else
               r = f&p
          end if
     end if
else
     r = -2                        'no data passed for evaluation
end if
return (r)
END FUNCTION   'pathsep(pf)

function messwait(msg,q,c,e)   'D. Lynn
' msg=message     q=filter for yes/no (0=no filter,1=filter)
' c=color (0=error colors, 1=pleasing)   e=allow escape from "q" filter
local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 c4 lmsg mbox k err waitmsg
  waitmsg = " ... press any key to continue "
  err = 0
  k=0
  if c=0
    fc1=15
    bc1=12
    fc2=15
    bc2=12
  else
    fc1=15
    bc1=1
    fc2=0
    bc2=15
  end if
  mbox = scrwidth
  lmsg=len(msg)
  if lmsg < 30
    c4 = int((30-lmsg)/2)+1
    msg = repeat("ÿ",c4)|msg|repeat("ÿ",c4)
  end if
  lmsg=len(msg)
' message "lmsg + 4 is:"&str(lmsg + 4)
' message "scrwidth is:"&str(scrwidth)
  if lmsg + 4 > scrwidth
    return (-2)
  end if

  r1 = scr-2
  r2 = scr+2
  c3 = int((mbox-lmsg)/2)+1
  c1 = c3-2
  c2 = c3+lmsg+1
  if c1 <= 0
    c1 = 1
  end if
  if (c1-1) < 12
    while (c1-1) < (scrwidth-c2)
      c2=c2+1
    end while
  end if
  if c2 > scrwidth
    return (-2)
  end if
  screen save r1 c1 r2 c2 psa
  screen clear box r1 c1 r2 c2 fc1 bc1
  screen print scr c3 fc2 bc2 msg
  screen print r2 c2-31 fc1 bc1 waitmsg
  screen save r1 c1 r2 c2 dsa
  if q=0
    inchar
  else
    WHILE "yn" !! k
      locate  scr (c3+lmsg) 1
      k=inchar
      if e=0 and k={Esc}
        err = -1
        exit while
      end if
      k = lower(chr(k))
    END WHILE
    locate  scr (c3+lmsg) 0
  end if
  screen shortrestore psa
  if k = 0
    ptstr = NULL
  else
    ptstr = k
  end if
  return (err)
end function   'messwait()

' ************************************************************ _dbloadretry
FUNCTION _dbloadretry($datafile,#view_type,$project,#exclusive,#load,#retry,#errormode)
' ************************************************************************
' Function:   _dbloadretry(7)                    Version:  3.00 - 8/2/2006
'
' Author:     Neil Parrish, IO Systech Limited
' Website:    www.iosystech.co.uk          Email: nparrish@iosystech.co.uk
' Phone:      +44(0)7041 420182/+44(0)1784 432058   Fax: +44(0)870 7064666
'
' Purpose:    Loads a data file from code under RAD, retrying if necesary.
'             Quits if unsuccessful after #dbloadretries tries.
' Parameters: $datafile  - data-file name, including path if required
'             #view_type - 1=standard, 2=custom
'             $project   - calling project file, for failure reporting
'             #exclusive - 0=normal load, 1=exclusive load
'             #load      - 0=activate, 1=load
'             #retry     - 0=single, 1=retries (#dbloadretries times)
'             #errormode - 0=no action, 1=warns user, 2=writes to file
'                          3=warning & writes to file, 4=quits
'                          5=writes to file & quits
' Returns:    0=load failed, 1=successful
'
' Notes:
' Interval between retries increases for each try. Uses RAD get_choice()
' function with ==> on the first button and only responds to the second
' button being pressed (OK) to avoid users just pressing return.
' Even if passwords are not being used on views/data-files the db_ld_fct
' lines may be retained - RAD sets ##db_ld_fct to 0 by default.
' Could easily be amended for use outside RAD by removing get_choice,
' open_file and db_ld_fct.
'
' This code may be used and distributed free of charge, comments may be
' removed if the function is distributed as part of an application but
' should be retained if the function is distributed for development.
' ************************************************************************
 LOCAL #try #retries #error $view_type #error_on #fh1
	SMARTPEEK $_error #error_on
	IF #error_on
		ERROR OFF
	END IF
	#error = 35  'user error
	IF #retry
		#retries = MAX(#dbloadretries,1)
	ELSE
		#retries = 1
	END IF
	#try = 1
	WHILE (#error <> 0 AND #try <= #retries)
		CLEARERROR
' 		IF ##db_ld_fct
		IF #db_ld_fct
			$view_type = CASE #view_type (1,"vws")(2,"vw") ELSE ""
			db_ld_fct($view_type,$datafile,#exclusive,#load)
		ELSE
			IF #view_type = 2 'custom view
				IF #exclusive
					FILE LOAD CUSTOM-VIEW $datafile EXCLUSIVE
				ELSE
					IF #load
						FILE LOAD CUSTOM-VIEW $datafile
					ELSE
						FILE ACTIVATE CUSTOM-VIEW $datafile
					END IF
				END IF
			ELSE 'standard view
				IF #exclusive
					FILE LOAD STANDARD-VIEW $datafile EXCLUSIVE
				ELSE
					IF #load
						FILE LOAD STANDARD-VIEW $datafile
					ELSE
						FILE ACTIVATE STANDARD-VIEW $datafile
					END IF
				END IF
			END IF
		END IF
		#error = lerror
		IF #error <> 0
			IF #try = #retries
				#errormode = MOD(#errormode,6)
				IF CASE #errormode (1,1)(3,1) ELSE 0 'warn the user
					get_choice("ERROR! - Unable to load a datafile: note the details below","and call IT support","View:" & $datafile|CASE #view_type(1,".vws") ELSE ".vw","Error:" & STR(#error) & "Project/Menu:" & $project,"OK",4)
				END IF
				IF CASE #errormode (2,1)(3,1)(5,1) ELSE 0 'write to the file
					IF FILE ($$workdir|"lcerror.txt")
						TOOLS FILE ERASE $$workdir|"lcerror.txt"
					END IF
					#fh1 = open_file($$workdir,"lcerror.txt",rw_mode)
					FWRITE #fh1 FROM FORMAT(NOW,"Ddd/mm/yyyy") & FORMAT(NOW,"T2")
					FWRITE #fh1 FROM "View:" & $datafile
 					FWRITE #fh1 FROM "Type:" & CASE #view_type (1,"STANDARD")(2,"CUSTOM") ELSE ""
					FWRITE #fh1 FROM "Error:" & STR(#error) & ERRORTEXT(#error)
					FWRITE #fh1 FROM "Project/Menu:" & $project
					FWRITE #fh1 FROM "Flags:"
					FWRITE #fh1 FROM "  " & CASE #exclusive (0,"Shared")(1,"Exclusive") ELSE "Unknown"
					FWRITE #fh1 FROM "  " & CASE #load (0,"Activate")(1,"Load") ELSE "Unknown"
					FWRITE #fh1 FROM "  " & CASE #retry (0,"Single Attempt")(1,"Retry" & STR(#retries) & "times") ELSE "Unknown"
					FCLOSE #fh1
				END IF
				IF CASE #errormode (4,1)(5,1) ELSE 0 'quit
					WHILE get_choice("Unable to load a datafile: note the details below","and call IT Support","Error:"&STR(#error)&"Project/Menu:"&$project,"Datafile:"&$datafile|CASE #view_type(1,".vws")ELSE ".vw","--> Quit",4) <> 2
					END WHILE
					QUIT QUIT
				END IF
				IF #error_on
					ERROR ON
				END IF
				RETURN 0 'failed
			END IF
			MILLI-WAIT #try*100
		END IF
		#try = #try + 1
	END WHILE
	IF #error_on
		ERROR ON
	END IF
	RETURN 1 'loaded
END FUNCTION