home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / CLIPPER / FIXAR3 / SAVEARR.PRG < prev   
Text File  |  1993-12-17  |  10KB  |  347 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.  *    Rev 1.4   17 Dec 1993 12:51:21   CHRISTOPHER OLSON 71212,72
  17.  * Revised FT_SAVEARR() to properly handle multi-dimensional arrays and 
  18.  * Nil array elements.  This function now gives the programmer the option 
  19.  * of failing when encountering a compiled code block in the array or 
  20.  * replacing the compiled code block with a default value.  Also revised 
  21.  * test code for the additions.
  22.  * 
  23.  *    Rev 1.3   28 Sep 1992 22:04:18   GLENN
  24.  * A few users have reported that these functions do not support
  25.  * multi-dimensional arrays.  Until the bugs are verified and
  26.  * workarounds or re-writes devised, a warning has been placed in the
  27.  * documentation.
  28.  * 
  29.  *    Rev 1.2   15 Aug 1991 23:06:06   GLENN
  30.  * Forest Belt proofread/edited/cleaned up doc
  31.  * 
  32.  *    Rev 1.1   14 Jun 1991 19:52:54   GLENN
  33.  * Minor edit to file header
  34.  * 
  35.  *    Rev 1.0   07 Jun 1991 23:39:38   GLENN
  36.  * Initial revision.
  37.  *
  38.  *
  39.  */
  40.  
  41.  
  42.  
  43. MEMVAR lRet
  44.  
  45. #ifdef FT_TEST              // test program to demonstrate functions
  46.  LOCAL bBlock := {|x| str(x,3)}
  47.  LOCAL aArray := { {'Invoice 1', CTOD('04/15/91'), 1234.32, .T., Nil, bBlock},;
  48.                 {'Invoice 2', DATE(), 234.98, .F., Nil, bBlock},;
  49.                 {'Invoice 3', DATE() + 1, 0, .T., Nil, bBlock}  }, aSave
  50.  LOCAL nErrorCode := 0
  51.  ?
  52.  ? 'Should fail on first code block'
  53.  IF FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode) .and. ;
  54.           nErrorCode = 0
  55.    DispArray(aArray)
  56.    aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  57.    IF nErrorCode = 0
  58.      DispArray(aSave)
  59.    ELSE
  60.       ? 'Error restoring array'
  61.    ENDIF
  62.  ELSE
  63.    ? 'Error writing array'
  64.  ENDIF
  65.  ?
  66.  ? 'Should not fail on code blocks'
  67.  IF FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode,.F.,"WAS BLOCK") .and. ;
  68.           nErrorCode = 0
  69.    DispArray(aArray)
  70.    aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  71.    IF nErrorCode = 0
  72.      DispArray(aSave)
  73.    ELSE
  74.       ? 'Error restoring array'
  75.    ENDIF
  76.  ELSE
  77.    ? 'Error writing array'
  78.  ENDIF
  79.  RETURN
  80.  
  81.  FUNCTION DispArray(aTest)
  82.    LOCAL nk
  83.    FOR nk := 1 TO LEN(aTest)
  84.      ? aTest[nk, 1]
  85.      ?? '  '
  86.      ?? DTOC(aTest[nk, 2])
  87.      ?? '  '
  88.      ?? STR(aTest[nk, 3])
  89.      ?? '  '
  90.      ?? IF(aTest[nk, 4], 'true', 'false')
  91.      ?? '  '
  92.      ?? IF(aTest[nk, 5]=Nil, 'Nil', '   ')
  93.      ?? '  '
  94.      ?? if(ValType(aTest[nk, 6])='B', eval(aTest[nk, 6], nk), aTest[nk, 6])
  95.    NEXT
  96.  RETURN Nil
  97. #endif
  98.  
  99.  
  100.  
  101.  
  102. /*  $DOC$
  103.  *  $FUNCNAME$
  104.  *     FT_SAVEARR()
  105.  *  $CATEGORY$
  106.  *     Array
  107.  *  $ONELINER$
  108.  *     Save Clipper array to a disc file.
  109.  *  $SYNTAX$
  110.  *     FT_SAVEARR( <aArray>, <cFileName>, <nErrorCode>,;
  111.  *                 [<lBlockFail>], [<xBlockDef>]) -> lRet
  112.  *  $ARGUMENTS$
  113.  *     <aArray> is any Clipper array except those containing
  114.  *     compiled code blocks.
  115.  *
  116.  *     <cFileName> is a DOS file name.
  117.  *
  118.  *     <nErrorCode> will return any DOS file error.
  119.  *
  120.  *     <lBlockFail> is an optional logical, .T. if a code block in 
  121.  *     the array should fail the save, .F. if xBlockDef should be 
  122.  *     saved in its place.  The default is .T.
  123.  *
  124.  *     <xBlockDef> is any Clipper value other than a code block to be 
  125.  *     saved in place of a code block if one is found in the array 
  126.  *     being saved and lBlockFail is .F.  The default is Nil.
  127.  *
  128.  *     All arguments are required.
  129.  *
  130.  *  $RETURNS$
  131.  *     .F. if there was a DOS file error or the array contained
  132.  *     code blocks, otherwise returns .T.
  133.  *  $DESCRIPTION$
  134.  *     FT_SAVEARR() saves any Clipper array to a disc file.  Compiled 
  135.  *     code blocks are not saved, but either return an error or save 
  136.  *     a specified data value in their place.  The array can be 
  137.  *     restored from the disc file using FT_RESTARR().
  138.  *
  139.  *     [10/1/92 Librarian note:
  140.  *
  141.  *     This function does not appear to work with multi-dimensional
  142.  *     arrays.  If you'd care to modify it to support this feature,
  143.  *     please do and send it to Glenn Scott 71620,1521.]
  144.  *
  145.  *     [12/17/93 Revision note:
  146.  *
  147.  *     I have revised this function to work with multi-dimensional 
  148.  *     arrays as well as to better handle code blocks.  It turns out 
  149.  *     the multi-dimensions failed because of the way Nil values were
  150.  *     saved.  This function now gives the option of failing when
  151.  *     encountering a code block or replacing the block with a default
  152.  *     value.  Christopher Olson 71212,72.]
  153.  *
  154.  *     
  155.  *  $EXAMPLES$
  156.  *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
  157.  *                {'Invoice 2',DATE(),234.98,.F.},;
  158.  *                {'Invoice 3',DATE() + 1,0,.T.}  }
  159.  *    nErrorCode := 0
  160.  *    FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  161.  *    IF nErrorCode = 0
  162.  *      aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  163.  *      IF nErrorCode # 0
  164.  *         ? 'Error restoring array'
  165.  *      ENDIF
  166.  *    ELSE
  167.  *      ? 'Error writing array'
  168.  *    ENDIF
  169.  *
  170.  *  $SEEALSO$
  171.  *     FT_RESTARR()
  172.  *  $END$
  173.  */
  174.  
  175.  
  176. FUNCTION FT_SAVEARR(aArray, cFileName, nErrorCode, lBlockFail, xBlockDef)
  177.  LOCAL nHandle, lRet
  178.  nHandle = FCREATE(cFileName)
  179.  nErrorCode = FError()
  180.  IF lBlockFail = Nil
  181.    lBlockFail = .T.
  182.  ENDIF
  183.  IF nErrorCode = 0
  184.    lRet := _ftsavesub(aArray, nHandle, @nErrorCode, lBlockFail, xBlockDef)
  185.    FCLOSE(nHandle)
  186.    IF (lRet) .AND. (FERROR() # 0)
  187.       nErrorCode = FERROR()
  188.       lRet = .F.
  189.     ENDIF
  190.  ELSE
  191.    lRet = .F.
  192.  ENDIF
  193.  RETURN lRet
  194.  
  195. STATIC FUNCTION _ftsavesub(xMemVar, nHandle, nErrorCode, lBlockFail, xBlockDef)
  196.  LOCAL cValType, nLen, cString
  197.  PRIVATE lRet       // accessed in code block
  198.  lRet := .T.
  199.  cValType := ValType(xMemVar)
  200.  IF cValType = "B" .AND. .NOT. lBlockFail
  201.    xMemVar := xBlockDef
  202.    cValType := ValType(xMemVar)
  203.  ENDIF
  204.  FWrite(nHandle, cValType, 1)
  205.  IF FError() = 0
  206.    DO CASE
  207.      CASE cValType = "A"
  208.        nLen := Len(xMemVar)
  209.        FWrite(nHandle, L2Bin(nLen), 4)
  210.        IF FError() = 0
  211.          AEVAL(xMemVar, {|xMemVar1| lRet := lRet .and.  _ftsavesub(xMemVar1, nHandle,, lBlockFail, xBlockDef) } )
  212.        ELSE
  213.          lRet = .F.
  214.        ENDIF
  215.      CASE cValType = "B"
  216.        lRet := .F.
  217.      CASE cValType = "C"
  218.        nLen := Len(xMemVar)
  219.        FWrite(nHandle, L2Bin(nLen), 4)
  220.        FWrite(nHandle, xMemVar)
  221.      CASE cValType = "D"
  222.        nLen := 8
  223.        FWrite(nHandle, L2Bin(nLen), 4)
  224.        FWrite(nHandle, DTOC(xMemVar))
  225.      CASE cValType = "L"
  226.        nLen := 1
  227.        FWrite(nHandle, L2Bin(nLen), 4)
  228.        FWrite(nHandle, IF(xMemVar, "T", "F") )
  229.      CASE cValType = "N"
  230.        cString := STR(xMemVar)
  231.        nLen := LEN(cString)
  232.        FWrite(nHandle, L2Bin(nLen), 4)
  233.        FWrite(nHandle, cString)
  234.      CASE cValType = "U"
  235.        nLen:=0
  236.        FWrite(nHandle, L2Bin(nLen), 4)
  237.    ENDCASE
  238.  ELSE
  239.    lRet = .F.
  240.  ENDIF
  241.  nErrorCode = FError()
  242.  RETURN lRet
  243.  
  244.  
  245. /*  $DOC$
  246.  *  $FUNCNAME$
  247.  *     FT_RESTARR()
  248.  *  $CATEGORY$
  249.  *     Array
  250.  *  $ONELINER$
  251.  *     Restore a Clipper array from a disc file
  252.  *  $SYNTAX$
  253.  *     FT_RESTARR( <cFileName>, <nErrorCode> ) -> aArray
  254.  *  $ARGUMENTS$
  255.  *     <cFileName> is a DOS file name.
  256.  *
  257.  *     <nErrorCode> will return any DOS file error.
  258.  *
  259.  *     All arguments are required.
  260.  *  $RETURNS$
  261.  *     Return an array variable.
  262.  *  $DESCRIPTION$
  263.  *     FT_RESTARR() restores an array which was saved to
  264.  *     a disc file using FT_SAVEARR().
  265.  *
  266.  *     [10/1/92 Librarian note:
  267.  *
  268.  *     This function does not appear to work with multi-dimensional
  269.  *     arrays.  If you'd care to modify it to support this feature,
  270.  *     please do and send it to Glenn Scott 71620,1521.]
  271.  *
  272.  *     [12/17/93 Revision note:
  273.  *
  274.  *     No revisions were made to this function, however, I have 
  275.  *     revised the FT_SAVEARR() function to work with multi-dimensional 
  276.  *     arrays as well as to better handle code blocks.  It turns out 
  277.  *     the multi-dimensions failed because of the way Nil values were
  278.  *     saved.  Christopher Olson 71212,72.]
  279.  *
  280.  *  $EXAMPLES$
  281.  *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
  282.  *                {'Invoice 2',DATE(),234.98,.F.},;
  283.  *                {'Invoice 3',DATE() + 1,0,.T.}  }
  284.  *    nErrorCode := 0
  285.  *    FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  286.  *    IF nErrorCode = 0
  287.  *      aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  288.  *      IF nErrorCode # 0
  289.  *         ? 'Error restoring array'
  290.  *      ENDIF
  291.  *    ELSE
  292.  *      ? 'Error writing array'
  293.  *    ENDIF
  294.  *
  295.  *  $SEEALSO$
  296.  *     FT_SAVEARR()
  297.  *  $END$
  298.  */
  299.  
  300. FUNCTION FT_RESTARR(cFileName, nErrorCode)
  301.  LOCAL nHandle, aArray
  302.  nHandle := FOPEN(cFileName)
  303.  nErrorCode := FError()
  304.  IF nErrorCode = 0
  305.   aArray := _ftrestsub(nHandle, @nErrorCode)
  306.   FCLOSE(nHandle)
  307.  ELSE
  308.    aArray := {}
  309.  ENDIF
  310.  RETURN aArray
  311.  
  312. STATIC FUNCTION _ftrestsub(nHandle, nErrorCode)
  313.   LOCAL cValType, nLen, cLenStr, xMemVar, cMemVar, nk
  314.   cValType := ' '
  315.   FREAD(nHandle, @cValType, 1)
  316.   cLenStr := SPACE(4)
  317.   FREAD(nHandle, @cLenStr, 4)
  318.   nLen = Bin2L(cLenStr)
  319.   nErrorCode = FError()
  320.   IF nErrorCode = 0
  321.     DO CASE
  322.       CASE cValType = "A"
  323.         xMemVar := {}
  324.         FOR nk := 1 TO nLen
  325.           AADD(xMemVar, _ftrestsub(nHandle))      // Recursive call
  326.         NEXT
  327.       CASE cValType = "C"
  328.         xMemVar := SPACE(nLen)
  329.         FREAD(nHandle, @xMemVar, nLen)
  330.       CASE cValType = "D"
  331.         cMemVar = SPACE(8)
  332.         FREAD(nHandle, @cMemVar,8)
  333.         xMemVar := CTOD(cMemVar)
  334.       CASE cValType = "L"
  335.         cMemVar := ' '
  336.         FREAD(nHandle, @cMemVar, 1)
  337.         xMemVar := (cMemVar =  "T")
  338.       CASE cValType = "N"
  339.         cMemVar := SPACE(nLen)
  340.         FREAD(nHandle, @cMemVar, nLen)
  341.         xMemVar = VAL(cMemVar)
  342.     ENDCASE
  343.     nErrorCode := FERROR()
  344.   ENDIF
  345.   RETURN xMemVar
  346.  
  347.