'**** HEADER ************************************************************

'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: Smartware II Data Manager index manipulation routines

'**** CHANGE HISTORY ****************************************************
'Revision: 02 06/26/91 ms     fixed delidxrec() bug in the read sizing
'                             area.
'**** FUNCTION DECLARATIONS *********************************************
'library
public   openidx()       'opens the index
public   closeidx()      'closes the index
public   totidxrecs()    'returns total number of current index records
public   getidxval()     'reads an integer from the index (4 byte)
public   addidxrec()     'appends a record to named index
public   wrtidxval()     'writes an integer to the index (4 byte)
public   delidxrec()     'deletes record from named index
public   makeidx()       'creates a new index (empty or one record)
public   wrtidxpad()     'writes blocks of nulls to index
public   wrtidxstr()     'fills strings to length with nulls
public   getidxrecs()    'returns total number of index records (opens file)
public   nxtidxpos()     'seeks the end of an already opened index file
                         'returns byte position
public   wrtidxtot()     'changes index record number of an already opened
                         'index by amount passsed returns (idx records)
public   wrtidxhdr()     'writes already opened idx header
public   idxappend()     'appends named indexes to a passed main idx
'core
global   chkiext()       'checks for valid extension on OPEN and MAKE
'**** VARIABLE DECLARATIONS *********************************************
'library
public ptval ptstr
public currlib
'core
global   ihlen
'**** CODE **************************************************************


MAIN
local ptpsl
ptpsl = "indexlib"
'screen clear box scrheight-3 1 scrheight-3 scrwidth 0 0 no-border
'screen print scrheight-3 1 bginvpleasing bgstandard \
'             "Pop-Tools(tm)"&upper(ptpsl)& \
'             "(Copyright 1990-1991 Applied Resource Technologies, Inc.)"

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 ptval = 0
     ptval = BLANK
     lock module ptval
end if
ihlen = 64
END MAIN


'    openidx is passed the path/name (without .idx) and desired handle number
'    of the target index.  It appends ".idx" to the pathname, then attempts
'    to open.  failure returns cerror | general type of failure.
function openidx(ipidx,fnum)
local f r
     r = 0
     f = chkiext(ipidx)
     if f > null
          error off
          clearerror
          fopen f as fnum
          if lerror <> 0
               r = -2
          end if
          error on
     else
          r = -1
     end if
return (r)
end function


'    closeidx simply closes the file handle number and returns cerror

function closeidx(fnum)
local r
     r = 0
     error off
     clearerror
     fclose fnum
     if lerror <> 0
          r = -1
     end if
     error on
return (r)
end function


'    totidxrecs uses the getidxval function to read the number of current records

function totidxrecs(fnum)
local r
     r = 0
     error off
     clearerror
     fseek fnum 0
     if lerror <> 0
          r = -1
     else
          if getidxval(fnum) <> 0
               r = -2
          end if
     end if
     error on
return (r)
end function


'    getidxval reads the four byte integer at the passed byte position, then
'    returns the actual integer value that is written there.

function getidxval(fnum)
   local r bp
   r = 0
   ptval = blank
   clearerror
   fread fnum binary 4 into bp
   if lerror = 0
        ptval = int(bp[1]+((bp[2]*256)+(bp[3]*65536)+(bp[4]*16777216)))
   else
        r = -1
   end if
   return(r)
end function


'    wrtidxval will write the passed value as a four byte integer at the current
'    file position

function wrtidxval(val,fnum)
local bp1 bp2 bp3 bp4 r
   r = 0
   bp4 = chr(int(val / 16777216))
   bp3 = chr(int(val / 65536))
   bp2 = chr(int(val / 256))
   bp1 = chr(int(val - ((bp2 * 256)+(bp3 * 65536)+(bp4 * 16777216))))
   clearerror
   fwrite fnum length 1 from bp1
   fwrite fnum length 1 from bp2
   fwrite fnum length 1 from bp3
   fwrite fnum length 1 from bp4
   if lerror <> 0
     r = -1
   end if
return (r)
end function


'    addidxrec will append the passed precord number to the indicated index,

function addidxrec(ipidx,prec,fnum)
local r sprec pr i j
     r = openidx(ipidx,fnum)
     if r = 0
          if totidxrecs(fnum) = 0
               sprec = str(prec)
               i = 1
               j = 0
               error off
               clearerror
               fseek fnum (ihlen+(ptval*4))
               while true
                    pr = group(sprec,i)
                    if pr = null
                         exit while
                    end if
                    pr = val(pr)
                    if pr > 0
                         wrtidxval(pr,fnum)
                         j = j + 1
                    end if
                    i = i + 1
               end while
               wrtidxpad(fnum)
               fseek fnum 0
               wrtidxval(ptval+j,fnum)
               closeidx(fnum)
               if lerror <> 0
                    r = -3
               end if
               error on
          else
               r = -2
          end if
     else
          r = -1
     end if
return (r)
end function

'    delidxrec deletes the passed record number from the indicated index

function delidxrec(ipidx,recnum,fnum)
local bpos epos temp r blk rlen tpos vsize
     r = openidx(ipidx,fnum)
     if r = 0
          if totidxrecs(fnum) = 0
               if recnum <= ptval and ptval > 0 and recnum > 0
                    error off
                    clearerror
                    fseek fnum ((ihlen)+(ptval*4))
                    fposition fnum into epos
                    fseek fnum (ihlen+(recnum*4))
                    fposition fnum into bpos
                    vsize = epos-bpos
                    if memleft >= vsize + 2048
                         fseek fnum bpos
                         fread fnum binary (vsize) into temp
                         fseek fnum bpos-4
                         fwrite fnum binary varlength(temp) from temp
                    else
                         clearerror
                         blk = ptval
                         rlen = 0
                         while blk > memleft+2048
                              blk = blk/4
                         end while
                         while rlen < vsize
                              tpos = bpos
                              fseek fnum bpos
                              fread fnum binary blk into temp
                              fposition fnum into tpos
                              fseek fnum bpos-4
                              fwrite fnum binary varlength(temp) from temp
                              bpos = tpos
                              rlen = rlen+blk
                              if blk < (vsize - rlen)
                                   blk = vsize - rlen
                              end if
                         end while
                    end if
                    fseek fnum 0
                    wrtidxval(ptval-1,fnum)
                    fseek fnum epos-4
                    wrtidxpad(fnum)
                    closeidx(fnum)
                    error on
                    if lerror <> 0
                         r = -4
                    end if
               else
                    closeidx(fnum)
                    r = -3
               end if
          else
               r = -2
          end if
     else
          r = -1
     end if
return (r)
end function  'delidxrec()



'    makeidx creates an index.  if desired, passing makeidx a precord of 0
'    preps the newly created index for addidxrec.  otherwise, a one record
'    index will be created, containing the record having the passed precord.

function makeidx(fname,idx,prec,fnum)
local c f r i j sprec pr
     r = 0
     f = chkiext(idx)
     if file(idx) = 1
          return (-4)
     end if
     if f > null
          error off
          clearerror
          if openidx(idx,fnum) < 0
               r = -2
          else
               if wrtidxhdr(fname,0,fnum) < 0
                    closeidx(fnum)
                    r = -2
               else
                    if prec = null
                         if wrtidxpad(fnum) < 0
                              closeidx(fnum)
                              r = -2
                         end if
                    else
                         closeidx(fnum)
                         if addidxrec(idx,prec,fnum) < 0
                              r = -3
                         end if
                    end if
               end if
          end if
          error on
     else
          r = -1
     end if
return (r)
end function


'    wrtidxstr is used to write blocks of data to an index header, where nulls
'    are required after the info, in order to maintain the index header
'    structure

function wrtidxstr(ilim,strn,fnum)
local i rc
   for i = 1  to ilim
      if i > len(strn)
          fwrite fnum length 1 from chr(0)
      else
          rc = asc(mid(strn,i,1))
          fwrite fnum length 1 from chr(rc)
      end if
   end for
end function


'    (nullvar) writes blocks of nulls to an index as required by chkblock

function wrtidxpad(fnum)
local x c n memsize mem nullblk
fposition fnum into n
nullblk=512-mod(n,512)
if nullblk > 0
     memsize = 50
     n = 0x00
     if nullblk > 75
          buffer mem size memsize
          for x = 1 to memsize
               pack mem[x] "C" n
          end for
          while nullblk >= memsize
               fwrite fnum binary varlength(mem) from mem
               nullblk=nullblk-memsize
          end while
     end if
     for x = 1 to nullblk step 1
         fwrite fnum binary 1 from mem[1]
     end for
end if
end function


function getidxrecs(idx,f#)
local r
     error off
     clearerror
     r = openidx(idx,f#)
     error on
     if r = 0
          if totidxrecs(f#) <> 0
               r = -2
          end if
          error off
          closeidx(f#)
          error on
     else
          r = -1
     end if
return (r)
end function  ' getidxrecs


function nxtidxpos(f#)
local r iend
     r = 0
     if totidxrecs(f#) = 0
          iend = ptval * 4
          error off
          clearerror
          fseek f# (ihlen+iend)
          error on
          if lerror <> 0
               r = -2
          end if
     else
          r = -1
     end if
return (r)
end function
'changes index record number of an already opened index file

function wrtidxtot(recs,f#)
local r
     r = 0
     if totidxrecs(f#) = 0
          error off
          clearerror
          fseek f# 0
          wrtidxval(ptval+recs,f#)
          error on
          if lerror <> 0
               r = -2
          else
               ptval = ptval + recs
          end if
     else
          r = -1
     end if
return (r)
end function


'writes an index header record to an already opened index file

function wrtidxhdr(fname,p,fnum)
local c pos r
r = 0
error off
clearerror
fposition fnum into pos
if lerror = 0
     clearerror
     if pos = 0
          wrtidxval(p,fnum)
          wrtidxstr(15,fname,fnum)
          wrtidxstr(9,"querynow",fnum)
          wrtidxstr(36,today,fnum)
          if lerror <> 0
               r = -3
          end if
     else
          r = -2
     end if
else
     r = -1
end if
return (r)
end function




function chkiext(f)
local ext lext rext c err
err = 0
if f > null
     rext = right(f,4)
     if rext ! "."
          lext = "db doc key vw vws ws dfr dfw dfs dfq dfx aif exe com bat psl "
          ext = mid(rext,find(".",rext,0)+2)|chr(32)
          if lext ! ext
               f = null
          end if
     else
          f = f|".idx"
     end if
else
     f = null
end if
return (f)
end function


function idxappend(midx,mf#,aidx,af#,dfname)
local o r rt df f i pb

' returns
'    success =  0
'               ptval = total records
'    failure = -1 bad parameter
'              -2 unable to open named index file
'              -3 "main.idx" listed in the append index list
'              -4 error reading/writing named index
'              -5 data file name in append index does not match main
'              -6 named file does not exist

'regarding error returns
     '    ptstr will contain a narrative description of the exact error

'parameters
'midx     =    main index file <path>name
'mf#      =    int 1-20 for opening main index file for read/write
'aidx     =    "append" index file <path>name (string group)
'dfname   =    if a SmartWare II data file name is here, a new index
'              will be created (if it does not already exist)
'locals
'o        =    store whether main file exists
'r        =    temporary storage of index precords total
'ot       =    original index file total of precords
'rt       =    running total of number of index precords
'df       =    main data file name as read from main index (verification)
'f        =    temporary name for "append index" file read
'i        =    counter to step through the "append list" string group
'pb       =    binary read buffer for storage of "precords" table

'do the standard function setup

ptstr = NULL
r = 0
rt = 0

     '1.  see if the midx exists

o = file(midx)

if (mf#<1 or mf#>20)
     ptstr = "Main index file handle# ("&str(mf#)&") out of range"
     return (-1)
end if

if (af#<1 or af#>20)
     ptstr = "Append index file handle# ("&str(mf#)&") out of range"
     return (-1)
end if

if af# = mf#
     ptstr = "Main and append index file handles (" & str(mf#) & ") are the same"
     return (-1)
end if

if not(o) and ( (len(dfname)>8) or (len(dfname)=0) )
     ptstr = "Needed data file name bad, or does not exist"
     return (-1)
end if


     '2.  check parameters and prepare main index file
     '    if it exists already, verify the main data file name
     '         get the total number of existing precords
     '         store the record total for a running total
     '         seek to the byte position after the last precord
     '    else
     '         open a new index and write the header

if openidx(midx,mf#) < 0
          ptstr = "Unable to open named main index file"
          return (-2)
end if
if o
     if getidxval(mf#) = 0
          r = ptval
          error off
          clearerror
          fread mf# length 9 into dfname
          fseek mf# ihlen + (r*4)
          error on
          if lerror
               ptstr = "Error reading main index data file name"
               return (-4)
          end if
     else
          ptstr = "Error reading main index total precords"
          return (-4)
     end if
else
     if wrtidxhdr(dfname,0,mf#) < 0
          ptstr = "Error writing main index file header"
          return (-4)
     else
          rt = 0
     end if
end if


'3   while there are items in the string group "aidx"

'         open the aidx, if the file exists
'         get total precords
'         verify the main data file name
'              if good
'                   fseek 64 (ihlen), then read length (precs * 4) into buffer
'                   write the buffer to main index
'              else
'                   store the error description in ptstr and return
'
i = 1
while TRUE
     f = group(aidx,i)
     if exact(f,NULL)
          exit while
     end if
     if not(file(f))
          ptstr = "Append index file name" & f & "does not exist"
          return (-6)
     end if
     if openidx(f,af#) < 0
          ptstr = "Unable to open append index file" & f
          return (-2)
     end if
     if getidxval(af#) = 0
          r = ptval
          error off
          clearerror
          fread af# length 9 into df
          if trim(df) == dfname
               fseek af# ihlen
               if r > 0
                    fread af# binary (r*4) into pb
                    if cerror = 0
                         fwrite mf# binary varlength(pb) from pb
                         if cerror = 0
                              rt = rt + r
                         end if
                    end if
               end if
               error on
               if lerror
                    ptstr = "Error reading named append index file" & f
                    closeidx(mf#)
                    closeidx(af#)
                    return (-4)
               end if
          else
               ptstr = "Data file name mismatch:" & dfname & df & "in" & f
               closeidx(mf#)
               closeidx(af#)
               return (-5)
          end if
     else
          ptstr = "Error reading append index file" & f
          closeidx(mf#)
          closeidx(af#)
          return (-4)
end if
closeidx(af#)
i=i+1
end while

closeidx(af#)
wrtidxtot(rt,mf#)
closeidx(mf#)
return (0)
end function 'idxappend()