home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / CLIPPER / NFSRC.ZIP / FIELD.PRG < prev    next >
Encoding:
Text File  |  1991-08-16  |  11.2 KB  |  393 lines
  1. /*
  2.  * File......: FIELD.PRG
  3.  * Author....: Steve Kolterman
  4.  * CIS ID....: 76320,37
  5.  * Date......: $Date:   15 Aug 1991 23:04:50  $
  6.  * Revision..: $Revision:   1.3  $
  7.  * Log file..: $Logfile:   E:/nanfor/src/field.prv  $
  8.  * 
  9.  * This is an original work by Steve Kolterman and is placed in the
  10.  * public domain.
  11.  *
  12.  * Modification history:
  13.  * ---------------------
  14.  *
  15.  * $Log:   E:/nanfor/src/field.prv  $
  16.  * 
  17.  *    Rev 1.3   15 Aug 1991 23:04:50   GLENN
  18.  * Forest Belt proofread/edited/cleaned up doc
  19.  * 
  20.  *    Rev 1.2   17 Jul 1991 22:24:14   GLENN
  21.  * Steve sent in a lot of changes and a couple of extra functions.
  22.  * Too many to mention.
  23.  * 
  24.  *    Rev 1.1   14 Jun 1991 19:51:50   GLENN
  25.  * Minor edit to file header
  26.  * 
  27.  *    Rev 1.0   01 Apr 1991 01:01:20   GLENN
  28.  * Nanforum Toolkit
  29.  *
  30.  */
  31.  
  32.  
  33. #define VTV     Valtype( var )
  34. #define FGV     FieldGet( var )
  35. #define FGFPV   FieldGet(FieldPos(var))
  36. #define VTFGV   Valtype(FGV)
  37. #define VTFGFPV Valtype(FGFPV)
  38. #define FVAL    IF( VTV=="N",FGV,FGFPV )
  39. #define VTFVAL  IF( VTV=="N",VTFGV,VTFGFPV )
  40. #define DBS_NAME  1
  41.  
  42.  
  43. #ifdef FT_TEST
  44.  
  45. #translate Clear() => SCROLL(); SetPos(0,0)
  46. #define NTOC(v) LTRIM(STR( v ))
  47. #define K_ESC 27
  48. #define DEMOCOLOR IF(iscolor(),"+gr/b","+w/n")
  49.  
  50.   FUNCTION Tester( dbff,numrecs )
  51.      LOCAL oldcolor:= SETCOLOR( DEMOCOLOR ),xx,start,end,key:= 0,;
  52.            fc,o_curs:=SetCursor(0)
  53.  
  54.      IF (dbff <> NIL) .AND. ( FILE( dbff ) .OR. FILE( dbff+".DBF" ) )
  55.         Clear(); numrecs:= IF( numrecs==NIL,1,VAL(numrecs) )
  56.         USE (dbff); fc:= fcount()
  57.  
  58.         WHILE numrecs > 0 .AND. key <> K_ESC
  59.            FOR xx:= 1 to fc
  60.               start:= Seconds()
  61. *              ? "Testing SK Field Functions..."
  62.               ? "  DATABASE: ",dbff
  63.               ? "    FIELDS: ",NTOC(fcount())
  64.               ? "    RECORD: ",NTOC(RECNO())
  65.               ? "FIELD NAME: ",fieldname(xx)
  66.               ?
  67.               ? "RETURN values passing a name... "
  68.               ? "  CONTENTS: ",FT_FVal( fieldname(xx) )
  69.               ? "VALUE LENG: ",NTOC( FT_FValLen( fieldname(xx) ) )
  70.               ? "FIELD NUMB: ",NTOC( FT_Fnum( fieldname(xx) ) )
  71.               ? "FIELD TYPE: ",FT_Ftype( fieldname(xx) )
  72.               ? "FIELD LENG: ",NTOC( FT_Flen( fieldname(xx) ) )
  73.               ? "FIELD DECI: ",NTOC( FT_Fdec( fieldname(xx) ) )
  74.               ? "FIELD EXIS: ",FT_Fexist( fieldname(xx) )
  75.               ? "FIELD EMPT: ",FT_Fempty( fieldname(xx) )
  76.               ?
  77.               ? "and...RETURN values passing ordinals"
  78.               ? "  CONTENTS: ",FT_Fval(xx)
  79.               ? "VALUE LENG: ",NTOC( FT_FValLen( (xx) ) )
  80.               ? "FIELD NUMB: ",NTOC( FT_Fnum( (xx) ) )
  81.               ? "FIELD TYPE: ",FT_Ftype( xx )
  82.               ? "FIELD LENG: ",NTOC(FT_Flen( xx ))
  83.               ? "FIELD DECI: ",NTOC(FT_Fdec( xx ))
  84.               ? "FIELD EXIS: ",FT_Fexist( (xx) )
  85.               ? "FIELD EMPT: ",FT_Fempty( (xx) )
  86.               ?
  87.               end:= Seconds()
  88.               ? "Executed In ",TRANSFORM((end -start),"9.999")," Secs."
  89.               ? "Press Any Key; [Esc] To Get Out Now"
  90.               ? key:= INKEY(0); Clear(); IF key==K_ESC; xx:= fc; END
  91.            NEXT
  92.            IF !EOF(); SKIP; ENDIF
  93.            numrecs--
  94.         ENDDO
  95.  
  96.         CLOSE ALL
  97.         Clear()
  98.      ELSE; Clear()
  99.         Alert( "Bad or No .DBF Parameter",{"Quit"} )
  100.      ENDIF
  101.      SETCOLOR(oldcolor); SetCursor(o_curs)
  102.      QUIT
  103.   RETURN NIL
  104.  
  105. #endif
  106.  
  107.  
  108. /*  $DOC$
  109.  *  $FUNCNAME$
  110.  *     FT_FVAL()
  111.  *  $CATEGORY$
  112.  *     Database
  113.  *  $ONELINER$
  114.  *     Return the value of a field.
  115.  *  $SYNTAX$
  116.  *      FT_FVAL( <xVar> ) -> xVal
  117.  *  $ARGUMENTS$
  118.  *     <xVar> is either a field name or ordinal .DBF position.
  119.  *  $RETURNS$
  120.  *     value (contents) of the specified field.  NIL, if error.
  121.  *  $DESCRIPTION$
  122.  *     FT_FVAL() reports the value (contents) of any .DBF field.
  123.  *  $EXAMPLES$
  124.  *     xVal:= FT_FVAL( "unit_prc" )
  125.  *     xVal:= FT_FVAL( 2 )
  126.  *     - or -
  127.  *     nNum:= FT_FNUM( "unit_prc" )
  128.  *     xVal:= FT_FVAL( nNum )
  129.  *  $SEEALSO$
  130.  *     FT_FPLACE()  FT_FVALLEN()  FT_FLEN()  FT_FDEC()  FT_FNUM()  FT_FTYPE()
  131.  *  $END$
  132.  */
  133.  
  134. FUNCTION FT_FVal( var )
  135. RETURN (FVAL)
  136.  
  137.  
  138. /*  $DOC$
  139.  *  $FUNCNAME$
  140.  *     FT_FTYPE()
  141.  *  $CATEGORY$
  142.  *     Database
  143.  *  $ONELINER$
  144.  *     Return a field's type, given field name or ordinal position
  145.  *  $SYNTAX$
  146.  *     FT_FTYPE( <xVar> ) -> cType
  147.  *  $ARGUMENTS$
  148.  *     <xVar> is either a field name or ordinal .DBF position.
  149.  *  $RETURNS$
  150.  *     the type of field: character (C), numeric (N), date (D), logical (L),
  151.  *     or memo (M).  "U", if NIL.
  152.  *  $DESCRIPTION$
  153.  *     FT_FTYPE() reports the type ("C","N","D","L","M") of any .DBF field.
  154.  *  $EXAMPLES$
  155.  *     cType:= FT_FTYPE( "unit_prc" )
  156.  *     cType:= FT_FTYPE( 2 )
  157.  *     - or -
  158.  *     nNum:=  FT_FNUM( "unit_prc" )
  159.  *     cType:= FT_FTYPE( nNum )
  160.  *  $SEEALSO$
  161.  *     FT_FPLACE()  FT_FVALLEN()  FT_FLEN()  FT_FDEC()  FT_FNUM()  FT_FVAL()
  162.  *  $END$
  163.  */
  164.  
  165. FUNCTION FT_FType( var )
  166. RETURN (VTFVAL)
  167.  
  168.  
  169. /*  $DOC$
  170.  *  $FUNCNAME$
  171.  *     FT_FLEN()
  172.  *  $CATEGORY$
  173.  *     Database
  174.  *  $ONELINER$
  175.  *     Return a field's length.
  176.  *  $SYNTAX$
  177.  *     FT_FLEN( <xVar> ) -> nLen
  178.  *  $ARGUMENTS$
  179.  *     <xVar> is either a field name or ordinal .DBF position.
  180.  *  $RETURNS$
  181.  *     the length of the specified field.  -1 if error.
  182.  *  $DESCRIPTION$
  183.  *     FT_FLEN() reports the length of any .DBF field.
  184.  *  $EXAMPLES$
  185.  *     nLen:= FT_FLEN("unit_prc")
  186.  *     nLen:= FT_FLEN( 2 )
  187.  *     - or -
  188.  *     nNum:= FT_FNUM( "unit_prc" )
  189.  *     nLen:= FT_FLEN( nNum )
  190.  *  $SEEALSO$
  191.  *     FT_FPLACE()  FT_FVALLEN()  FT_FDEC()  FT_FNUM()  FT_FTYPE()  FT_FVAL()
  192.  *  $END$
  193.  */
  194.  
  195. FUNCTION FT_FLen( var )
  196. RETURN IF( !FT_FExist(var), -1 ,;
  197.        IF( VTFVAL=="D",len(dtoc( FVAL )),;
  198.        IF( VTFVAL=="L",1,;
  199.        IF( VTFVAL=="M",10,;
  200.        IF( VTFVAL=="C",len( FVAL ),;
  201.        IF( VTFVAL=="N",len(str( FVAL )), -1 ))))))
  202.  
  203.  
  204. /*  $DOC$
  205.  *  $FUNCNAME$
  206.  *     FT_FVALLEN()
  207.  *  $CATEGORY$
  208.  *     Database
  209.  *  $ONELINER$
  210.  *     Return the length of the value in a field.
  211.  *  $SYNTAX$
  212.  *     FT_FVALLEN( <xVar> ) -> nVlen
  213.  *  $ARGUMENTS$
  214.  *      <xVar> is either a field name or ordinal .DBF position.
  215.  *  $RETURNS$
  216.  *      the length of the value in a specified field.  -1 if error.
  217.  *  $DESCRIPTION$
  218.  *      FT_FVALLEN() reports the length of the value in any .DBF field.
  219.  *  $EXAMPLES$
  220.  *      nVallen:= FT_FVALLEN("unit_prc")
  221.  *      nVallen:= FT_FVALLEN( 2 )
  222.  *      - or -
  223.  *      nNum:=    FT_FNUM( "unit_prc" )
  224.  *      nVallen:= FT_FVALLEN( nNum )
  225.  *  $SEEALSO$
  226.  *     FT_FPLACE()  FT_FLEN()  FT_FDEC()  FT_FNUM()  FT_FTYPE()  FT_FVAL()
  227.  *  $END$
  228.  */
  229.  
  230. FUNCTION FT_FValLen( var )
  231. RETURN IF( !FT_FExist(var), -1,;
  232.        IF( VTFVAL=="D",len(dtoc( (FVAL) )),;
  233.        IF( VTFVAL=="L",1,;
  234.        IF( VTFVAL=="M",len( AllTrim( FVAL ) ),;
  235.        IF( VTFVAL=="C",len( AllTrim( FVAL ) ),;
  236.        IF( VTFVAL=="N",len( AllTrim( str(FVAL) ) ),-1 ))))))
  237.  
  238.  
  239. /*  $DOC$
  240.  *  $FUNCNAME$
  241.  *     FT_FDEC()
  242.  *  $CATEGORY$
  243.  *     Database
  244.  *  $ONELINER$
  245.  *     Return the number of decimals in a numeric (type "N") field.
  246.  *  $SYNTAX$
  247.  *     FT_FDEC( <xVar> ) -> nDec
  248.  *  $ARGUMENTS$
  249.  *     <xVar> is either a field name or ordinal .DBF position.
  250.  *  $RETURNS$
  251.  *     the number of decimal places in a numeric field.  -1 if field is
  252.  *     not type "N", or if other error.
  253.  *  $DESCRIPTION$
  254.  *     FT_FDEC() reports the number of decimal places in a numeric field.
  255.  *  $EXAMPLES$
  256.  *     nDec:= FT_FDEC( "unit_prc" )
  257.  *     nDec:= FT_FDEC( 2 )
  258.  *     - or -
  259.  *     nNum:= FT_FNUM( "unit_prc" )
  260.  *     nDec:= FT_FDEC( nNum )
  261.  *  $SEEALSO$
  262.  *     FT_FPLACE()  FT_FVALLEN()  FT_FLEN()  FT_FNUM()  FT_FTYPE()  FT_FVAL()
  263.  *  $END$
  264.  */
  265.  
  266. FUNCTION FT_FDec( var )
  267. RETURN IF( VTFVAL <> "N" .or. !FT_Fexist(var), -1, ;
  268.        IF( VTFVAL=="N" .and. "." $str( FVAL ), ;
  269.        len(str( FVAL )) -at(".",str( FVAL )), 0))
  270.  
  271.  
  272. /*  $DOC$
  273.  *  $FUNCNAME$
  274.  *     FT_FNUM()
  275.  *  $CATEGORY$
  276.  *     Database
  277.  *  $ONELINER$
  278.  *     Return a field's ordinal position given the field name.
  279.  *  $SYNTAX$
  280.  *     FT_FNUM( <cVar> ) -> nNum
  281.  *  $ARGUMENTS$
  282.  *     <cVar> must be a valid field name.
  283.  *  $RETURNS$
  284.  *     the ordinal position of the field.  0, if a non-character value is
  285.  *     passed or field <xVar> does not exist.
  286.  *  $DESCRIPTION$
  287.  *     In 5.01, FT_FNUM() was superseded by FieldPos().  Included here for
  288.  *     those who already coded FT_FNUM() calls.
  289.  *  $EXAMPLES$
  290.  *     nNum:= FT_FNUM( "unit_prc" )
  291.  *  $SEEALSO$
  292.  *     FT_FPLACE()  FT_FVALLEN()  FT_FLEN()  FT_FDEC()  FT_FTYPE()  FT_FVAL()
  293.  *  $END$
  294.  */
  295.  
  296. FUNCTION FT_FNum( var )
  297. RETURN IF( VTV=="C",FieldPos(var),0 )
  298.  
  299.  
  300. /*  $DOC$
  301.  *  $FUNCNAME$
  302.  *     FT_FPLACE()
  303.  *  $CATEGORY$
  304.  *     Database
  305.  *  $ONELINER$
  306.  *     Write a new value to a field.
  307.  *  $SYNTAX$
  308.  *     FT_FPLACE( <xVar>, <xVal> ) -> xVal
  309.  *  $ARGUMENTS$
  310.  *     <xVar> is either a field name or ordinal .DBF position.
  311.  *  $RETURNS$
  312.  *     <xVal>, the FT_FPLACE()d value.  NIL if error.
  313.  *  $DESCRIPTION$
  314.  *     FT_FPLACE() writes a new value to a specified field of *ANY*
  315.  *     Clipper-valid type.  In conjunction with the FIELDPLACE UDC
  316.  *     (in FT_FIELD.CH), it constitutes a fully capable alternative to
  317.  *     REPLACE.
  318.  *  $EXAMPLES$
  319.  *     xVal:= FT_FPLACE( "unit_prc", 15.73 )
  320.  *     xVal:= FT_FPLACE( 2, 15.73 )
  321.  *     - or -
  322.  *     nNum:= FT_FNUM( "unit_prc" )
  323.  *     xVal:= FT_FPLACE( nNum,15.73 )
  324.  *  $SEEALSO$
  325.  *     FT_FVALLEN()  FT_FLEN()  FT_FDEC()  FT_FNUM()  FT_FTYPE()  FT_FVAL()
  326.  *  $END$
  327.  */
  328.  
  329. FUNCTION FT_FPLACE( var,value )
  330. RETURN FieldPut( IF( VTV=="N",var,FieldPos(var) ),value )
  331.  
  332.  
  333. /*  $DOC$
  334.  *  $FUNCNAME$
  335.  *     FT_FEXIST()
  336.  *  $CATEGORY$
  337.  *     Database
  338.  *  $ONELINER$
  339.  *     Check for the existence of a field.
  340.  *  $SYNTAX$
  341.  *     FT_FEXIST( <xVar>, <xVal> ) -> lVal
  342.  *  $ARGUMENTS$
  343.  *     <xVar> may be either a field name or ordinal .DBF position.
  344.  *  $RETURNS$
  345.  *     <lVal>, a logical indicating a field's existence or lack thereof.
  346.  *  $DESCRIPTION$
  347.  *     FT_FEXIST() enables existence checking before proceeding with
  348.  *     other operations.
  349.  *  $EXAMPLES$
  350.  *     lExi:= FT_FEXIST( "unit_prc" )
  351.  *     lExi:= FT_FEXIST( 2 )
  352.  *     - or -
  353.  *     nNum:= FT_FNUM( "unit_prc" )
  354.  *     lExi:= FT_FEXIST( nNum )
  355.  *  $SEEALSO$
  356.  *     FT_FVALLEN()  FT_FLEN()  FT_FDEC()  FT_FNUM()  FT_FTYPE()  FT_FVAL()
  357.  *  $END$
  358.  */
  359.  
  360. FUNCTION FT_Fexist( var )
  361. RETURN IF( (VTV) $ "NC",;
  362.        IF( (VTV)=="N",!Empty(Fieldname(var)),(FieldPos(var) > 0) ), .F. )
  363.  
  364.  
  365. /*  $DOC$
  366.  *  $FUNCNAME$
  367.  *     FT_FEMPTY()
  368.  *  $CATEGORY$
  369.  *     Database
  370.  *  $ONELINER$
  371.  *     Determine if a field is empty, i.e., contains no value.
  372.  *  $SYNTAX$
  373.  *     FT_FEMPTY( <xVar> ) -> lVal
  374.  *  $ARGUMENTS$
  375.  *     <xVar> may be either a field name or ordinal .DBF position.
  376.  *  $RETURNS$
  377.  *     <lVal>, a logical indicating if field <xVar> is empty.
  378.  *  $DESCRIPTION$
  379.  *     FT_FEMPTY() checks for the existence of a value in a field.
  380.  *  $EXAMPLES$
  381.  *     lEmp:= FT_FEMPTY( "unit_prc" )
  382.  *     lEmp:= FT_FEMPTY( 2 )
  383.  *     - or -
  384.  *     nNum:= FT_FNUM( "unit_prc" )
  385.  *     lEmp:= FT_FEMPTY( nNum )
  386.  *  $END$
  387.  */
  388.  
  389. FUNCTION FT_Fempty( var )
  390. RETURN ( FT_FVallen(var) < 1 )
  391.  
  392.  
  393.