home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / nfsrc21.zip / SAVEARR.PRG < prev    next >
Text File  |  1992-09-28  |  8KB  |  286 lines
  1. /*
  2.  * File......: SAVEARR.PRG
  3.  * Author....: David Barrett
  4.  * CIS ID....: 72037,105
  5.  * Date......: $Date:   28 Sep 1992 22:04:18  $
  6.  * Revision..: $Revision:   1.3  $
  7.  * Log file..: $Logfile:   C:/nanfor/src/savearr.prv  $
  8.  *
  9.  * This is an original work by David Barrett and is placed in the
  10.  * public domain.
  11.  *
  12.  * Modification history:
  13.  * ---------------------
  14.  *
  15.  * $Log:   C:/nanfor/src/savearr.prv  $
  16.  * 
  17.  *    Rev 1.3   28 Sep 1992 22:04:18   GLENN
  18.  * A few users have reported that these functions do not support
  19.  * multi-dimensional arrays.  Until the bugs are verified and
  20.  * workarounds or re-writes devised, a warning has been placed in the
  21.  * documentation.
  22.  * 
  23.  *    Rev 1.2   15 Aug 1991 23:06:06   GLENN
  24.  * Forest Belt proofread/edited/cleaned up doc
  25.  * 
  26.  *    Rev 1.1   14 Jun 1991 19:52:54   GLENN
  27.  * Minor edit to file header
  28.  * 
  29.  *    Rev 1.0   07 Jun 1991 23:39:38   GLENN
  30.  * Initial revision.
  31.  *
  32.  *
  33.  */
  34.  
  35.  
  36.  
  37. MEMVAR lRet
  38.  
  39. #ifdef FT_TEST              // test program to demonstrate functions
  40.  
  41.  LOCAL  aArray := { {'Invoice 1', CTOD('04/15/91'), 1234.32, .T.},;
  42.                 {'Invoice 2', DATE(), 234.98, .F.},;
  43.                 {'Invoice 3', DATE() + 1, 0, .T.}  }, aSave
  44.  LOCAL nErrorCode := 0
  45.  FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  46.  IF nErrorCode = 0
  47.    CLS
  48.    DispArray(aArray)
  49.    aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  50.    IF nErrorCode = 0
  51.      DispArray(aSave)
  52.    ELSE
  53.       ? 'Error restoring array'
  54.    ENDIF
  55.  ELSE
  56.    ? 'Error writing array'
  57.  ENDIF
  58.  RETURN
  59.  
  60.  FUNCTION DispArray(aTest)
  61.    LOCAL nk
  62.    FOR nk := 1 TO LEN(aTest)
  63.      ? aTest[nk, 1]
  64.      ?? '  '
  65.      ?? DTOC(aTest[nk, 2])
  66.      ?? '  '
  67.      ?? STR(aTest[nk, 3])
  68.      ?? '  '
  69.      ?? IF(aTest[nk, 4], 'true', 'false')
  70.    NEXT
  71.  RETURN Nil
  72. #endif
  73.  
  74.  
  75.  
  76.  
  77. /*  $DOC$
  78.  *  $FUNCNAME$
  79.  *     FT_SAVEARR()
  80.  *  $CATEGORY$
  81.  *     Array
  82.  *  $ONELINER$
  83.  *     Save Clipper array to a disc file.
  84.  *  $SYNTAX$
  85.  *     FT_SAVEARR( <aArray>, <cFileName>, <nErrorCode> ) -> lRet
  86.  *  $ARGUMENTS$
  87.  *     <aArray> is any Clipper array except those containing
  88.  *     compiled code blocks.
  89.  *
  90.  *     <cFileName> is a DOS file name.
  91.  *
  92.  *     <nErrorCode> will return any DOS file error.
  93.  *
  94.  *     All arguments are required.
  95.  *
  96.  *  $RETURNS$
  97.  *     .F. if there was a DOS file error or the array contained
  98.  *     code blocks, otherwise returns .T.
  99.  *  $DESCRIPTION$
  100.  *     FT_SAVEARR() saves any Clipper array, except those
  101.  *     containing compiled code blocks, to a disc file.  The
  102.  *     array can be restored from the disc file using
  103.  *     FT_RESTARR().
  104.  *
  105.  *     [10/1/92 Librarian note:
  106.  *
  107.  *     This function does not appear to work with multi-dimensional
  108.  *     arrays.  If you'd care to modify it to support this feature,
  109.  *     please do and send it to Glenn Scott 71620,1521.]
  110.  *
  111.  *     
  112.  *  $EXAMPLES$
  113.  *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
  114.  *                {'Invoice 2',DATE(),234.98,.F.},;
  115.  *                {'Invoice 3',DATE() + 1,0,.T.}  }
  116.  *    nErrorCode := 0
  117.  *    FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  118.  *    IF nErrorCode = 0
  119.  *      aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  120.  *      IF nErrorCode # 0
  121.  *         ? 'Error restoring array'
  122.  *      ENDIF
  123.  *    ELSE
  124.  *      ? 'Error writing array'
  125.  *    ENDIF
  126.  *
  127.  *  $SEEALSO$
  128.  *     FT_RESTARR()
  129.  *  $END$
  130.  */
  131.  
  132.  
  133. FUNCTION FT_SAVEARR(aArray, cFileName, nErrorCode)
  134.  LOCAL nHandle, lRet
  135.  nHandle = FCREATE(cFileName)
  136.  nErrorCode = FError()
  137.  IF nErrorCode = 0
  138.    lRet := _ftsavesub(aArray, nHandle, @nErrorCode)
  139.    FCLOSE(nHandle)
  140.    IF (lRet) .AND. (FERROR() # 0)
  141.       nErrorCode = FERROR()
  142.       lRet = .F.
  143.     ENDIF
  144.  ELSE
  145.    lRet = .F.
  146.  ENDIF
  147.  RETURN lRet
  148.  
  149. STATIC FUNCTION _ftsavesub(xMemVar, nHandle, nErrorCode)
  150.  LOCAL cValType, nLen, cString
  151.  PRIVATE lRet       // accessed in code block
  152.  lRet := .T.
  153.  cValType := ValType(xMemVar)
  154.  FWrite(nHandle, cValType, 1)
  155.  IF FError() = 0
  156.    DO CASE
  157.      CASE cValType = "A"
  158.        nLen := Len(xMemVar)
  159.        FWrite(nHandle, L2Bin(nLen), 4)
  160.        IF FError() = 0
  161.          AEVAL(xMemVar, {|xMemVar1| lRet := _ftsavesub(xMemVar1, nHandle) } )
  162.        ELSE
  163.          lRet = .F.
  164.        ENDIF
  165.      CASE cValType = "B"
  166.        lRet := .F.
  167.      CASE cValType = "C"
  168.        nLen := Len(xMemVar)
  169.        FWrite(nHandle, L2Bin(nLen), 4)
  170.        FWrite(nHandle, xMemVar)
  171.      CASE cValType = "D"
  172.        nLen := 8
  173.        FWrite(nHandle, L2Bin(nLen), 4)
  174.        FWrite(nHandle, DTOC(xMemVar))
  175.      CASE cValType = "L"
  176.        nLen := 1
  177.        FWrite(nHandle, L2Bin(nLen), 4)
  178.        FWrite(nHandle, IF(xMemVar, "T", "F") )
  179.      CASE cValType = "N"
  180.        cString := STR(xMemVar)
  181.        nLen := LEN(cString)
  182.        FWrite(nHandle, L2Bin(nLen), 4)
  183.        FWrite(nHandle, cString)
  184.    ENDCASE
  185.  ELSE
  186.    lRet = .F.
  187.  ENDIF
  188.  nErrorCode = FError()
  189.  RETURN lRet
  190.  
  191.  
  192. /*  $DOC$
  193.  *  $FUNCNAME$
  194.  *     FT_RESTARR()
  195.  *  $CATEGORY$
  196.  *     Array
  197.  *  $ONELINER$
  198.  *     Restore a Clipper array from a disc file
  199.  *  $SYNTAX$
  200.  *     FT_RESTARR( <cFileName>, <nErrorCode> ) -> aArray
  201.  *  $ARGUMENTS$
  202.  *     <cFileName> is a DOS file name.
  203.  *
  204.  *     <nErrorCode> will return any DOS file error.
  205.  *
  206.  *     All arguments are required.
  207.  *  $RETURNS$
  208.  *     Return an array variable.
  209.  *  $DESCRIPTION$
  210.  *     FT_RESTARR() restores an array which was saved to
  211.  *     a disc file using FT_SAVEARR().
  212.  *
  213.  *     [10/1/92 Librarian note:
  214.  *
  215.  *     This function does not appear to work with multi-dimensional
  216.  *     arrays.  If you'd care to modify it to support this feature,
  217.  *     please do and send it to Glenn Scott 71620,1521.]
  218.  *
  219.  *  $EXAMPLES$
  220.  *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
  221.  *                {'Invoice 2',DATE(),234.98,.F.},;
  222.  *                {'Invoice 3',DATE() + 1,0,.T.}  }
  223.  *    nErrorCode := 0
  224.  *    FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  225.  *    IF nErrorCode = 0
  226.  *      aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  227.  *      IF nErrorCode # 0
  228.  *         ? 'Error restoring array'
  229.  *      ENDIF
  230.  *    ELSE
  231.  *      ? 'Error writing array'
  232.  *    ENDIF
  233.  *
  234.  *  $SEEALSO$
  235.  *     FT_SAVEARR()
  236.  *  $END$
  237.  */
  238.  
  239. FUNCTION FT_RESTARR(cFileName, nErrorCode)
  240.  LOCAL nHandle, aArray
  241.  nHandle := FOPEN(cFileName)
  242.  nErrorCode := FError()
  243.  IF nErrorCode = 0
  244.   aArray := _ftrestsub(nHandle, @nErrorCode)
  245.   FCLOSE(nHandle)
  246.  ELSE
  247.    aArray := {}
  248.  ENDIF
  249.  RETURN aArray
  250.  
  251. STATIC FUNCTION _ftrestsub(nHandle, nErrorCode)
  252.   LOCAL cValType, nLen, cLenStr, xMemVar, cMemVar, nk
  253.   cValType := ' '
  254.   FREAD(nHandle, @cValType, 1)
  255.   cLenStr := SPACE(4)
  256.   FREAD(nHandle, @cLenStr, 4)
  257.   nLen = Bin2L(cLenStr)
  258.   nErrorCode = FError()
  259.   IF nErrorCode = 0
  260.     DO CASE
  261.       CASE cValType = "A"
  262.         xMemVar := {}
  263.         FOR nk := 1 TO nLen
  264.           AADD(xMemVar, _ftrestsub(nHandle))      // Recursive call
  265.         NEXT
  266.       CASE cValType = "C"
  267.         xMemVar := SPACE(nLen)
  268.         FREAD(nHandle, @xMemVar, nLen)
  269.       CASE cValType = "D"
  270.         cMemVar = SPACE(8)
  271.         FREAD(nHandle, @cMemVar,8)
  272.         xMemVar := CTOD(cMemVar)
  273.       CASE cValType = "L"
  274.         cMemVar := ' '
  275.         FREAD(nHandle, @cMemVar, 1)
  276.         xMemVar := (cMemVar =  "T")
  277.       CASE cValType = "N"
  278.         cMemVar := SPACE(nLen)
  279.         FREAD(nHandle, @cMemVar, nLen)
  280.         xMemVar = VAL(cMemVar)
  281.     ENDCASE
  282.     nErrorCode := FERROR()
  283.   ENDIF
  284.   RETURN xMemVar
  285.  
  286.