harbour-core/harbour/contrib/hbnf/savearr.prg

/*
 * $Id$
 */

/*
 * File......: savearr.prg
 * Author....: David Barrett
 * CIS ID....: 72037,105
 *
 * This is an original work by David Barrett and is placed in the
 * public domain.
 *
 * Modification history:
 * ---------------------
 *
 *    Rev 1.3   28 Sep 1992 22:04:18   GLENN
 * A few users have reported that these functions do not support
 * multi-dimensional arrays.  Until the bugs are verified and
 * workarounds or re-writes devised, a warning has been placed in the
 * documentation.
 *
 *    Rev 1.2   15 Aug 1991 23:06:06   GLENN
 * Forest Belt proofread/edited/cleaned up doc
 *
 *    Rev 1.1   14 Jun 1991 19:52:54   GLENN
 * Minor edit to file header
 *
 *    Rev 1.0   07 Jun 1991 23:39:38   GLENN
 * Initial revision.
 *
 *
 */



MEMVAR lRet

#ifdef FT_TEST              // test program to demonstrate functions

 LOCAL  aArray := { {'Invoice 1', CTOD('04/15/91'), 1234.32, .T.},;
                {'Invoice 2', DATE(), 234.98, .F.},;
                {'Invoice 3', DATE() + 1, 0, .T.}  }, aSave
 LOCAL nErrorCode := 0
 FT_SAVEARR(aArray,'invoice.dat',@nErrorCode)
 IF nErrorCode = 0
   CLS
   DispArray(aArray)
   aSave := FT_RESTARR('invoice.dat',@nErrorCode)
   IF nErrorCode = 0
     DispArray(aSave)
   ELSE
      ? 'Error restoring array'
   ENDIF
 ELSE
   ? 'Error writing array'
 ENDIF
 RETURN

 FUNCTION DispArray(aTest)
   LOCAL nk
   FOR nk := 1 TO LEN(aTest)
     ? aTest[nk, 1]
     ?? '  '
     ?? DTOC(aTest[nk, 2])
     ?? '  '
     ?? STR(aTest[nk, 3])
     ?? '  '
     ?? iif(aTest[nk, 4], 'true', 'false')
   NEXT
 RETURN Nil
#endif




/*  $DOC$
 *  $FUNCNAME$
 *     FT_SAVEARR()
 *  $CATEGORY$
 *     Array
 *  $ONELINER$
 *     Save Clipper array to a disc file.
 *  $SYNTAX$
 *     FT_SAVEARR( <aArray>, <cFileName>, <nErrorCode> ) -> lRet
 *  $ARGUMENTS$
 *     <aArray> is any Clipper array except those containing
 *     compiled code blocks.
 *
 *     <cFileName> is a DOS file name.
 *
 *     <nErrorCode> will return any DOS file error.
 *
 *     All arguments are required.
 *
 *  $RETURNS$
 *     .F. if there was a DOS file error or the array contained
 *     code blocks, otherwise returns .T.
 *  $DESCRIPTION$
 *     FT_SAVEARR() saves any Clipper array, except those
 *     containing compiled code blocks, to a disc file.  The
 *     array can be restored from the disc file using
 *     FT_RESTARR().
 *
 *     [10/1/92 Librarian note:
 *
 *     This function does not appear to work with multi-dimensional
 *     arrays.  If you'd care to modify it to support this feature,
 *     please do and send it to Glenn Scott 71620,1521.]
 *
 *
 *  $EXAMPLES$
 *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
 *                {'Invoice 2',DATE(),234.98,.F.},;
 *                {'Invoice 3',DATE() + 1,0,.T.}  }
 *    nErrorCode := 0
 *    FT_SAVEARR(aArray,'invoice.dat',@nErrorCode)
 *    IF nErrorCode = 0
 *      aSave := FT_RESTARR('invoice.dat',@nErrorCode)
 *      IF nErrorCode # 0
 *         ? 'Error restoring array'
 *      ENDIF
 *    ELSE
 *      ? 'Error writing array'
 *    ENDIF
 *
 *  $SEEALSO$
 *     FT_RESTARR()
 *  $END$
 */


FUNCTION FT_SAVEARR(aArray, cFileName, nErrorCode)
 LOCAL nHandle, lRet
 nHandle = FCREATE(cFileName)
 nErrorCode = FError()
 IF nErrorCode = 0
   lRet := _ftsavesub(aArray, nHandle, @nErrorCode)
   FCLOSE(nHandle)
   IF (lRet) .AND. (FERROR() # 0)
      nErrorCode = FERROR()
      lRet = .F.
    ENDIF
 ELSE
   lRet = .F.
 ENDIF
 RETURN lRet

STATIC FUNCTION _ftsavesub(xMemVar, nHandle, nErrorCode)
 LOCAL cValType, nLen, cString
 PRIVATE lRet       // accessed in code block
 lRet := .T.
 cValType := ValType(xMemVar)
 FWrite(nHandle, cValType, 1)
 IF FError() = 0
   DO CASE
     CASE cValType = "A"
       nLen := Len(xMemVar)
       FWrite(nHandle, L2Bin(nLen), 4)
       IF FError() = 0
         AEVAL(xMemVar, {|xMemVar1| lRet := _ftsavesub(xMemVar1, nHandle) } )
       ELSE
         lRet = .F.
       ENDIF
     CASE cValType = "B"
       lRet := .F.
     CASE cValType = "C"
       nLen := Len(xMemVar)
       FWrite(nHandle, L2Bin(nLen), 4)
       FWrite(nHandle, xMemVar)
     CASE cValType = "D"
       nLen := 8
       FWrite(nHandle, L2Bin(nLen), 4)
       FWrite(nHandle, DTOC(xMemVar))
     CASE cValType = "L"
       nLen := 1
       FWrite(nHandle, L2Bin(nLen), 4)
       FWrite(nHandle, iif(xMemVar, "T", "F") )
     CASE cValType = "N"
       cString := STR(xMemVar)
       nLen := LEN(cString)
       FWrite(nHandle, L2Bin(nLen), 4)
       FWrite(nHandle, cString)
   ENDCASE
 ELSE
   lRet = .F.
 ENDIF
 nErrorCode = FError()
 RETURN lRet


/*  $DOC$
 *  $FUNCNAME$
 *     FT_RESTARR()
 *  $CATEGORY$
 *     Array
 *  $ONELINER$
 *     Restore a Clipper array from a disc file
 *  $SYNTAX$
 *     FT_RESTARR( <cFileName>, <nErrorCode> ) -> aArray
 *  $ARGUMENTS$
 *     <cFileName> is a DOS file name.
 *
 *     <nErrorCode> will return any DOS file error.
 *
 *     All arguments are required.
 *  $RETURNS$
 *     Return an array variable.
 *  $DESCRIPTION$
 *     FT_RESTARR() restores an array which was saved to
 *     a disc file using FT_SAVEARR().
 *
 *     [10/1/92 Librarian note:
 *
 *     This function does not appear to work with multi-dimensional
 *     arrays.  If you'd care to modify it to support this feature,
 *     please do and send it to Glenn Scott 71620,1521.]
 *
 *  $EXAMPLES$
 *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
 *                {'Invoice 2',DATE(),234.98,.F.},;
 *                {'Invoice 3',DATE() + 1,0,.T.}  }
 *    nErrorCode := 0
 *    FT_SAVEARR(aArray,'invoice.dat',@nErrorCode)
 *    IF nErrorCode = 0
 *      aSave := FT_RESTARR('invoice.dat',@nErrorCode)
 *      IF nErrorCode # 0
 *         ? 'Error restoring array'
 *      ENDIF
 *    ELSE
 *      ? 'Error writing array'
 *    ENDIF
 *
 *  $SEEALSO$
 *     FT_SAVEARR()
 *  $END$
 */

FUNCTION FT_RESTARR(cFileName, nErrorCode)
 LOCAL nHandle, aArray
 nHandle := FOPEN(cFileName)
 nErrorCode := FError()
 IF nErrorCode = 0
  aArray := _ftrestsub(nHandle, @nErrorCode)
  FCLOSE(nHandle)
 ELSE
   aArray := {}
 ENDIF
 RETURN aArray

STATIC FUNCTION _ftrestsub(nHandle, nErrorCode)
  LOCAL cValType, nLen, cLenStr, xMemVar, cMemVar, nk
  cValType := ' '
  FREAD(nHandle, @cValType, 1)
  cLenStr := SPACE(4)
  FREAD(nHandle, @cLenStr, 4)
  nLen = Bin2L(cLenStr)
  nErrorCode = FError()
  IF nErrorCode = 0
    DO CASE
      CASE cValType = "A"
        xMemVar := {}
        FOR nk := 1 TO nLen
          AADD(xMemVar, _ftrestsub(nHandle))      // Recursive call
        NEXT
      CASE cValType = "C"
        xMemVar := SPACE(nLen)
        FREAD(nHandle, @xMemVar, nLen)
      CASE cValType = "D"
        cMemVar = SPACE(8)
        FREAD(nHandle, @cMemVar,8)
        xMemVar := CTOD(cMemVar)
      CASE cValType = "L"
        cMemVar := ' '
        FREAD(nHandle, @cMemVar, 1)
        xMemVar := (cMemVar =  "T")
      CASE cValType = "N"
        cMemVar := SPACE(nLen)
        FREAD(nHandle, @cMemVar, nLen)
        xMemVar = VAL(cMemVar)
    ENDCASE
    nErrorCode := FERROR()
  ENDIF
  RETURN xMemVar