Click above to get retro games delivered to your door ever month!

   * PROGRAM...: CFTS87.PRG
   * AUTHOR....: John A. Reesman
   * ..........: Index Applications Incorporated
   * ..........: 8546 Broadway, Suite 208
   * ..........: San Antonio, TX  78217 USA
   * ..........: (210) 822-4818
   * DATE......: 07/25/93
   * NOTICE....: Copyright (c) 1989-1993 Index Applications Incorporated
   * NOTES.....: UDFs for implementing low level CFTS routines.

   *****
   * CFTS_ADD adds a new record to a CFTS index. Parameters received
   * are a valid CFTS handle and the name of a UDF that returns a
   * string to be indexed.
   *****
   function cfts_add            && add new record to CFTS index
   parameters handle, iafunc

   private handle, instring, rec, tmacro

   m->tmacro = '&iafunc' + '()'

   m->instring = &tmacro.       && evaluate the .ia string function

   m->rec = cftsadd( m->handle, m->instring )
   if m->rec < 1

      cfts_err( procname(), ( procline() - 3 ), m->rec )

   endif

   return( 0 )
   * eof function cfts_add

   *****
   * CFTS_CLOSE closes an existing CFTS index. Receives the file's handle.
   *****
   function cfts_close
   parameters handle          && handle from open file

   private err

   m->err = cftsclose( m->handle )
   if m->err < 0

      cfts_err( procname(), ( procline() - 3 ), m->err )

   endif

   return( 0 )
   * eof function cfts_close

   *****
   * CFTS_DEL marks a record in a CFTS index as deleted.
   * Parameters received are CFTS file handle and record
   * number to delete.
   *****
   function cfts_del
   parameters handle, recnum

   private err

   m->err = cftsdelete( m->handle, m->recnum )
   if m->err < 1 .and. m->err != -8

      cfts_err( procname(), ( procline() - 3 ), m->err )

   endif

   return( 0 )
   * eof function cfts_del

   *****
   * CFTS_ERR prints decoded error return from a CFTS function and
   * then terminates the program.
   *****
   function cfts_err
   parameters pname, pline, perr

   private err_desc

   do case

      case m->perr = -1

         m->err_desc = 'CREATEFAIL: file creation error'

      case m->perr = -2

         m->err_desc = 'MEMERR: memory allocation error'

      case m->perr = -3

         m->err_desc = 'NULLPTR: internal function call with NULL pointer'

      case m->perr = -4

         m->err_desc = 'BADSEEK: illegal seek'

      case m->perr = -5

         m->err_desc = 'BADREAD: read error'

      case m->perr = -6

         m->err_desc = 'BADWRITE: write error'

      case m->perr = -7

         m->err_desc = 'RECBOUND: record number out of bounds'

      case m->perr = -8

         m->err_desc = 'ISDELETED: record already deleted'

      case m->perr = -9

         m->err_desc = 'NOTDELETED: rec not deleted'

      case m->perr = -10

         m->err_desc = 'OPENERR: unable to open CFTS file'

      case m->perr = -11

         m->err_desc = 'INTERR: internal error'

      case m->perr = -13

         m->err_desc = 'NORECS: CFTSset called with empty file'

      case m->perr = -15

         m->err_desc = 'ILLEVEL: bad "level" parameter to CFTSfind'

      case m->perr = -16

         m->err_desc = 'BADPARMS: illegal number or type of parameters'

      case m->perr = -17

         m->err_desc = 'NOMOREHANDLES: out of handles for CFTS'

      case m->perr = -18

         m->err_desc = 'BADHANDLE: invalid handle'

      case m->perr = -19

         m->err_desc = 'BADIHANDLE: invalid internal handle'

      case m->perr = -20

         m->err_desc = 'LOCKFAILED: unable to lock file'

      case m->perr = -21

         m->err_desc = 'NOMORELOCKS: lock table exhausted'

      case m->perr = -22

         m->err_desc = 'CANNOTUNLOCK: unable to unlock file'

      case m->perr = -23

         m->err_desc = 'BADCOMMIT: unable to commit file to disk'

   endcase

   && set device to screen

   && @ 0, 0
   @ 0, 0 say 'Proc ' + m->pname + ' line ' + ltrim( str( m->pline ) ) +;
                           ', ' + m->err_desc

   quit

   return( 0 )
   * eof function cfts_err

   *****
   * CFTS_INDEX creates a new CFTS index. Parameters received are:
   * 1) the name of the CFTS index file (including path, if desired)
   * you want to create, 2) the size of the CFTS buffer in kilobytes;
   * i.e, 10 -> 10K, and 3) the name of a UDF that returns a string to
   * be indexed and 4) the mode in which the CFTS index file is opened.
   *****
   function cfts_index         && index the .dbf using cfts
   parameters fspec, iabuff, iafunc, fmode   && file spec, buffer size,
                                             && .ia string function and
                                             && open mode

   private handle, oldrec, instring, rec, ndx_ord, tmacro, delete_on

   && flush any existing .ia file by recreating it
   && make sure to close it first

   delete_on = .f.             && flag incase we need to turn
                               && SET DELETE ON later

   m->handle = cftscrea( m->fspec, m->iabuff, 3, .t. ,1 )
   if m->handle < 0

      cfts_err( procname(), ( procline() - 3 ), m->handle )

   endif

   m->tmacro = '&iafunc' + '()'

   m->ndx_ord = indexord()     && save current index order
   m->oldrec = recno()         && save rec number of .dbf

   if isdelete()               && set deleted off, if its on
                               
      set deleted off
      delete_on = .t.

   endif

   set order to 0

   goto top

   do while ! eof()

      m->instring = &tmacro.   && evaluate the .ia string function

      m->rec = cftsadd( m->handle, m->instring )
      if m->rec < 1

         cfts_err( procname(), ( procline() - 3 ), m->rec )

      endif

      skip

   enddo

   if delete_on

      set delete on

   endif

   cfts_close( m->handle )    && play safe and flush IA buffers

   m->handle = cfts_open( m->fspec, m->iabuff, m->fmode )

   goto m->oldrec             && restore position in .dbf
   set order to m->ndx_ord    && restore .ntx file

   return( m->handle )        && return new file handle
   * eof function cftsindex

   *****
   * CFTS_IFDEL returns .T. if index record is deleted, else .F.
   * Parameters received are CFTS handle and number of record to test.
   *****
   function cfts_ifdel
   parameters handle, recnum

   private err

   err = cftsifdel( m->handle, m->recnum )
   if m->err < 0

      cfts_err( procname(), ( procline() - 3 ), m->err )

   else

      m->err = if( m->err = 0, .f., .t. )

   endif

   return( m->err )
   * eof function cfts_ifdel

   *****
   * CFTS_NEXT returns the number of the next CFTS index record that matches
   * the search criteria established by CFTS_SET. Returns 0 when the search
   * is exhausted. Use CFTS_VERI to verifiy the record pointed to by
   * CFTS_NEXT against the original search criteria. Parameter received:
   * a CFTS file handle. Note: User's may supply their own verify function.
   *****
   function cfts_next
   parameters handle

   private rec

   m->rec = cftsnext( m->handle )
   if m->rec < 0

      cfts_err( procname(), ( procline() - 3 ), m->rec )

   endif

   return( m->rec )
   * eof function cfts_next

   *****
   * CFTS_OPEN opens an existing CFTS index. Parameters received are:
   * 1) the name of the CFTS index file (including path, if desired)
   * you want to create, 2) the size of the CFTS buffer in kilobytes;
   * i.e, 12 -> 12K, and 3) the mode in which the CFTS index file is opened.
   *****
   function cfts_open
   parameters fspec, iabuff, fmode  && cfts file name, buffer size, open mode
   private handle

   m->handle = cftsopen( m->fspec, m->iabuff, m->fmode )
   if m->handle < 0

      cfts_err( procname(), ( procline() - 3 ), m->handle )

   endif

   return( m->handle )
   * eof function cfts_open

   *****
   * CFTS_RECN returns the number of records in the CFTS index.
   *****
   function cfts_recn
   parameters handle

   private recn

   m->recs = cftsrecn( m->handle )
   if m->recs < 1

      cfts_err( procname(), ( procline() - 3 ), m->recs )

   endif
   return( m->recs )
   * eof function cfts_recn

   *****
   * CFTS_REPL replace an existing CFTS index record with a new record.
   * Parameters received are: 1) CFTS handle, 2) UDF returning the string
   * to be indexed, and 3) the index record number to be replaced.
   *****
   function cfts_repl
   parameters handle, iafunc, recnum

   private err, instring

   m->tmacro = '&iafunc' + '()'

   m->instring = &tmacro.      && evaluate the .ia string function

   m->err = cftsreplac( m->handle, m->instring, m->recnum )
   if m->err < 1

      cfts_err( procname(), ( procline() - 3 ), m->err )

   endif
   return( 0 )
   * eof function cfts_repl

   *****
   * CFTS_SET prepares the CFTS index for searching. The actual
   * searching is performed by CftsNext().
   * Parameters received are the CFTS handle and the string
   * containing the search criteria.
   *****
   function cfts_set
   parameters handle, instring

   private err

   m->err = cftsset( m->handle, m->instring )
   if m->err < 1

      cfts_err( procname(), ( procline() - 3 ), m->err )

   endif

   return( 0 )
   * eof function cfts_set

   *****
   * CFTS_UNDEL 'undeletes' a CFTS index record that has been marked
   * as deleted. Parameters received are CFTS handle and the record number.
   *****
   function cfts_undel
   parameters handle, recnum

   private err

   m->err = cftsundel( m->handle, m->recnum )
   if m->err < 1 .and. m->err != -9

      cfts_err( procname(), ( procline() - 3 ), m->err )

   endif
   return( 0 )
   * eof function cfts_undel

   *****
   * CFTS_VERI verifies the search criteria "target" against the
   * record(s) pointed to by CFTS_NEXT, "source".
   * Parameters received are: 1) CFTS handle, 2) the "source" (.dbf) string,
   * 3) the "target" (search criteria) string, and 4) the verification type;
   * i.e., 1, (beginning of string), 2, (end of string), 3, ( "AND") or
   * 4, ("PHRASE").
   *****
   function cfts_veri
   parameters handle, source, target, vtype

   private err

   m->err = cftsveri( m->handle, m->source, m->target, m->vtype )
   if m->err < 0

      cfts_err( procname(), ( procline() - 3 ), m->err )

   endif
   return( m->err )
   * eof function cfts_veri