fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

See changelog 20000421 23:00

Browse Source
This commit is contained in:
Luiz Rafael Culik
2000-04-22 01:55:57 +00:00
parent ac869c43ec
commit a80cc1cbc6
17 changed files with 2161 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

160
harbour/contrib/libnf/aading.prg Normal file
View File

@@ -0,0 +1,160 @@
/*
* File......: Aadding.prg
* Author....: Ralph Oliver, TRANSCOM SYSTEMS
* CIS ID....: 74030,703
*
* This is an original work by Ralph Oliver and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 15 Aug 1991 23:05:40 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 07 Jun 1991 23:03:08 GLENN
* Initial revision.
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_AADDITION()
* $CATEGORY$
* Array
* $ONELINER$
* Add elements unique of source array to target array
* $SYNTAX$
* FT_AADDITION( <aList1>, <aList2> [, <lTrimmer> [, <lCaseSens> ] ] ) ;
* -> aNewArray
* $ARGUMENTS$
* <aList1> is the primary array.
*
* <aList2> is the secondary array.
*
* <lTrimmer> is a logical value denoting whether leading or
* trailing spaces should be included in the
* comparison. If .T., then ignores spaces in
* comparison, defaults to .T., .F. includes spaces.
*
* <lCaseSens> is a logical value denoting case sensitivity.
* If .T., then comparison is sensitive to case,
* defaults to .T., .F. ignores case.
* $RETURNS$
* An array of the union of aList1 and aList2.
* $DESCRIPTION$
* This function will add the elements unique of aList2 with aList1.
* It returns a new array including all the elements of aList1
* plus the unique elements of aList2.
* $EXAMPLES$
* aList1 := {"apple", "orange", "pear"}
* aList2 := {"apple ", "banana", "PEAR"}
*
* FT_AADDITION( aList1, aList2 )
* // ignores spaces, sensitive to case
* // returns {"apple","orange","pear","banana","PEAR"}
*
* FT_AADDITION( aList1, aList2, , .F. )
* // ignores spaces, not sensitive to case
* // returns {"apple","orange","pear","banana"}
*
* FT_AADDITION( aList1, aList2, .F., .F. )
* // sensitive to spaces, not sensitive to case
* // returns {"apple","orange","pear","apple ","banana"}
* $END$
*/
#ifdef FT_TEST
FUNCTION MAIN()
LOCAL aList1,aList2,var0,nstart,nstop,nelapsed,nCtr
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AADDITION"
?
aList1 := {"apple", "orange", "pear"}
aList2 := {"apple ", "banana", "PEAR"}
? "aList1 : "
AEVAL( aList1, { |x| QQOUT(x + ",") } )
?
? "aList2 : "
AEVAL( aList2, { |x| QQOUT(x + ",") } )
?
nstart := SECONDS()
FOR nCtr := 1 to 100
var0 := FT_AADDITION( aList1, aList2 )
NEXT
nstop := SECONDS()
nelapsed := nstop - nstart
? "time for 100 merges:", nelapsed
? PADR("FT_AADDITION( aList1, aList2 ) ->",44)
AEVAL( var0, { |x| QQOUT(x + ",") } )
?
var0 := FT_AADDITION( aList1, aList2, , .F. )
? PADR("FT_AADDITION( aList1, aList2, , .F. ) ->",44)
AEVAL( var0, { |x| QQOUT(x + ",") } )
?
var0 := FT_AADDITION( aList1, aList2, .F., .F. )
? PADR("FT_AADDITION( aList1, aList2, .F., .F. ) ->",44)
AEVAL( var0, { |x| QQOUT(x + ",") } )
?
RETURN NIL
#endif
FUNCTION FT_AADDITION( aList1, aList2, lTrimmer, lCaseSens )
LOCAL nElement, nPos, bScanCode
LOCAL aNewArray := ACLONE( aList1 )
// Set default parameters as necessary.
IF lCaseSens == NIL
lCaseSens := .T.
ENDIF
IF lTrimmer == NIL
lTrimmer := .T.
ENDIF
// Assign code blocks according to case sensitivity and trim.
IF lCaseSens
IF lTrimmer // Ignore spaces.
bScanCode := { |x| ;
ALLTRIM( x ) == ;
ALLTRIM( aList2[ nElement ]) }
ELSE
bScanCode := { |x| ( aList2[ nElement ]) }
ENDIF
ELSE // Ignore case.
IF lTrimmer // Ignore spaces.
bScanCode := { |x| ;
UPPER( ALLTRIM( x )) == ;
UPPER( ALLTRIM( aList2[ nElement ] )) }
ELSE
bScanCode := { |x| ;
UPPER( x ) == ;
UPPER( aList2[ nElement ] ) }
ENDIF
ENDIF
// Add the unique elements of aList2 to aList1.
FOR nElement := 1 TO LEN( aList2 )
nPos := ASCAN( aList1, bScanCode )
// If unique, then add element to new array.
IF nPos = 0
AADD( aNewArray, aList2[ nElement ] )
ENDIF
NEXT
RETURN ( aNewArray )

82
harbour/contrib/libnf/aavg.prg Normal file
View File

@@ -0,0 +1,82 @@
/*
* File......: AAvg.Prg
* Author....: David Husnian
* CIS ID....: ?
*
* This is an original work by David Husnian and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:04:54 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:38 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:20 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_AAVG()
* $CATEGORY$
* Array
* $ONELINER$
* Average numeric values in an array
* $SYNTAX$
* FT_AAVG( <aArray> [, <nStartIndex> [, <nEndIndex> ] ] ) -> nAverage
* $ARGUMENTS$
* <aArray> is the array containing the elements to be averaged.
*
* <nStartIndex> is the first array item to include,
* defaults to first element.
*
* <nEndIndex> is the last array element to include,
* defaults to all elements.
* $RETURNS$
* The average of the specified array elements.
* $DESCRIPTION$
* This function is used to get a numeric average of selected or all
* elements of an array.
*
* This routine requires FT_ASUM().
* $EXAMPLES$
* FT_AAVG(aSubTotals) // Get Average of Entire Array
*
* FT_AAVG(aSubTotals, 5) // Get Average of 5th Element On
*
* FT_AAVG(aSubTotals, , 10) // Get Average of 1st 10 Elements
*
* FT_AAVG(aSubTotals, 5, 10) // Get Average of Elements 5-10
* $END$
*/
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
#define IS_NOT_ARRAY(x) (VALTYPE(x) != "A")
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := IF(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := IF(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_AAVG(aArray, nStartIndex, nEndIndex)
DEFAULT nStartIndex TO 1, ;
nEndIndex TO LEN(aArray)
// Make Sure Bounds are in Range
FORCE_BETWEEN(1, nEndIndex, LEN(aArray))
FORCE_BETWEEN(1, nStartIndex, nEndIndex)
RETURN (IF(IS_NOT_ARRAY(aArray) .OR. LEN(aArray) == 0, ;
0, ;
FT_ASUM(aArray, nStartIndex, nEndIndex) / ;
(nEndIndex - nStartIndex + 1)))

106
harbour/contrib/libnf/acctadj.prg Normal file
View File

@@ -0,0 +1,106 @@
/*
* File......: ACCTADJ.PRG
* Author....: Jo W. French dba Practical Computing
* CIS ID....: 74731,1751
*
* The functions contained herein are the original work of Jo W. French
* and are placed in the public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.4 28 Sep 1992 00:22:38 GLENN
* Jo French clean up.
*
* Rev 1.3 15 Aug 1991 23:04:58 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:50:40 GLENN
* Minor edit to file header
*
* Rev 1.1 11 May 1991 00:34:00 GLENN
* Documentation rewrite. Enter DOC header was rewritten and resubmitted
* by the author. No code changes.
*
* Rev 1.0 01 Apr 1991 01:00:22 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ACCTADJ()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Adjust beginning or ending fiscal pd. dates to acctg. dates
* $SYNTAX$
* FT_ACCTADJ( [ <dGivenDate> ], [ <lIsEnd> ] ) -> dDate
* $ARGUMENTS$
* <dGivenDate> is any valid date in any valid format.
* Defaults to DATE() if not supplied.
*
* <lIsEnd> is a logical variable. .F. = adjust for beginning of
* period mode, .T. = adjust for end of period mode. Defaults to
* beginning of period mode.
* $RETURNS$
* An adjusted date dependent upon mode and work week start day.
* $DESCRIPTION$
* Called by other FT_ACCT.. functions. The algorithm is:
*
* Beginning of period mode:
*
* If dGivenDate is in last 3 days of work week
* Return next week's start date
* Else
* Return this week's start date
* Endif
*
* End of period mode:
*
* If dGivenDate is in last 4 days of work week
* Return this week's end date
* Else
* Return prior week's end date
* Endif
* $EXAMPLES$
* Beginning of period mode (lIsEnd == .F.)
*
* dDate := Ctod( "01/31/91" ) // In last 3 days of work week
* ? FT_ACCTADJ( dDate ) // 02/03/91 (next week's start)
*
* dDate := Ctod( "03/31/91" ) // Not in last 3 days of work week
* ? FT_ACCTADJ( dDate ) // 03/31/91 (this week's start)
*
* End of period mode (lIsEnd == .T.)
*
* dDate := Ctod( "01/31/91" ) // In last 4 days of work week
* ? FT_ACCTADJ( dDate, .T. ) // 02/02/91 (this week's end)
*
* dDate := Ctod( "03/31/91" ) // Not in last 4 days of work week
* ? FT_ACCTADJ( dDate, .T. ) // 03/30/91 (prior week's end)
* $SEEALSO$
* FT_DATECNFG() FT_DAYTOBOW()
* $END$
*/
FUNCTION FT_ACCTADJ(dGivenDate, lIsEnd)
LOCAL nTemp
IF( VALTYPE(dGivenDate) != 'D', dGivenDate := DATE(), )
lIsEnd := ( VALTYPE(lIsEnd) == 'L' )
nTemp := FT_DAYTOBOW(dGivenDate)
IF nTemp > ( 2 + IF(!lIsEnd, 1, 0) )
dGivenDate += ( 7 - nTemp ) // Next Week Start (This Week End + 1)
ELSE
dGivenDate -= nTemp // This Week Start (Prior Week End + 1)
ENDIF
IF( lIsEnd, dGivenDate -= 1, )
RETURN dGivenDate

135
harbour/contrib/libnf/acctmnth.prg Normal file
View File

@@ -0,0 +1,135 @@
/*
* File......: ACCTMNTH.PRG
* Author....: Jo W. French dba Practical Computing
* CIS ID....: 74731,1751
*
* The functions contained herein are the original work of Jo W. French
* and are placed in the public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 28 Sep 1992 00:24:54 GLENN
* Jo French clean up.
*
* Rev 1.2 15 Aug 1991 23:02:30 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:42 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:24 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ACCTMONTH()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return accounting month data
* $SYNTAX$
* FT_ACCTMONTH( [ <dGivenDate> ], [ <nMonthNum> ] ) -> aDateInfo
* $ARGUMENTS$
* <dGivenDate> is any valid date in any date format. Defaults
* to current system date if not supplied.
*
* <nMonthNum> is a number from 1 to 12 signifying a month.
* Defaults to current month if not supplied.
* $RETURNS$
* A three element array containing the following data:
*
* aDateInfo[1] - The year and month as a character string "YYYYMM"
* aDateInfo[2] - The beginning date of the accounting month
* aDateInfo[3] - The ending date of the accounting month
* $DESCRIPTION$
* FT_ACCTMONTH() creates an array containing data about the
* accounting month containing the given date.
*
* An accounting period has the following characteristics:
*
* If the first week of the period contains 4 or more 'work'
* days, it is included in the period; otherwise, the first
* week was included in the prior period.
*
* If the last week of the period contains 4 or more 'work'
* days it is included in the period; otherwise, the last week
* is included in the next period. This results in 13 week
* 'quarters' and 4 or 5 week 'months'. Every 5 or 6 years, a
* 'quarter' will contain 14 weeks and the year will contain 53
* weeks.
* $EXAMPLES$
* // get info about accounting month containing 9/15/90
* aDateInfo := FT_ACCTMONTH( Ctod("09/15/90") )
* ? aDateInfo[1] // 199009 (9th month)
* ? aDateInfo[2] // 09/02/90 beginning of month 9
* ? aDateInfo[3] // 09/29/90 end of month 9
*
* // get info about accounting month 5 in year containing 9/15/90
* aDateInfo := FT_ACCTMONTH( Ctod("09/15/90"), 5 )
* ? aDateInfo[1] // 199005
* ? aDateInfo[2] // 04/29/89 beginning of month 5
* ? aDateInfo[3] // 06/02/90 end of month 5
* $SEEALSO$
* FT_DATECNFG() FT_ACCTWEEK() FT_ACCTQTR() FT_ACCTYEAR()
* $END$
*/
FUNCTION FT_ACCTMONTH(dGivenDate,nMonthNum)
LOCAL nYTemp, nMTemp, lIsMonth, aRetVal
IF ! ( VALTYPE(dGivenDate) $ 'ND' )
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nMonthNum := dGivenDate
dGivenDate := DATE()
ENDIF
aRetVal := FT_MONTH(dGivenDate)
nYTemp := VAL(SUBSTR(aRetVal[1],1,4))
nMTemp := VAL(SUBSTR(aRetVal[1],5,2))
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
IF dGivenDate < aRetVal[2]
dGivenDate := FT_MADD(dGivenDate, -1)
aRetVal := FT_MONTH(dGivenDate)
nMTemp -= 1
IF nMTemp == 0
nYTemp -= 1
nMTemp := 12
ENDIF
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ELSEIF dGivenDate > aRetVal[3]
dGivenDate := FT_MADD(dGivenDate, 1)
aRetVal := FT_MONTH(dGivenDate)
nMTemp += 1
IF nMTemp == 13
nYTemp += 1
nMTemp := 1
ENDIF
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ENDIF
lIsMonth := ( VALTYPE(nMonthNum) == 'N' )
IF lIsMonth
IF( nMonthNum < 1 .OR. nMonthNum > 12 , nMonthNum := 12, )
aRetVal := FT_MONTH(dGivenDate, nMonthNum)
nYTemp := VAL(SUBSTR(aRetVal[1],1,4))
nMTemp := VAL(SUBSTR(aRetVal[1],5,2))
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ENDIF
aRetVal[1] := STR(nYTemp,4) + PADL(LTRIM(STR(nMTemp,2)), 2, '0')
RETURN aRetVal

134
harbour/contrib/libnf/acctqtr.prg Normal file
View File

@@ -0,0 +1,134 @@
/*
* File......: ACCTQTR.PRG
* Author....: Jo W. French dba Practical Computing
* CIS ID....: 74731,1751
*
* The functions contained herein are the original work of Jo W. French
* and are placed in the public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 28 Sep 1992 00:26:30 GLENN
* Jo French clean up.
*
* Rev 1.2 15 Aug 1991 23:02:36 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:44 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:26 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ACCTQTR()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return accounting quarter data
* $SYNTAX$
* FT_ACCTQTR( [ <dGivenDate> ], [ <nQtrNum> ] ) -> aDateinfo
* $ARGUMENTS$
* <dGivenDate> is any valid date in any date format. Defaults
* to current system date if not supplied.
*
* <nQtrNum> is a number from 1 to 4 signifying a quarter.
* Defaults to current quarter if not supplied.
* $RETURNS$
* A three element array containing the following data:
*
* aDateInfo[1] - The year and qtr. as a character string "YYYYQQ"
* aDateInfo[2] - The beginning date of the accounting quarter
* aDateInfo[3] - The ending date of the accounting quarter
* $DESCRIPTION$
* FT_ACCTQTR() creates an array containing data about the
* accounting quarter containing the given date.
*
* An accounting period has the following characteristics:
*
* If the first week of the period contains 4 or more 'work'
* days, it is included in the period; otherwise, the first
* week was included in the prior period.
*
* If the last week of the period contains 4 or more 'work'
* days it is included in the period; otherwise, the last week
* is included in the next period. This results in 13 week
* 'quarters' and 4 or 5 week 'months'. Every 5 or 6 years, a
* 'quarter' will contain 14 weeks and the year will contain 53
* weeks.
* $EXAMPLES$
* // get info about accounting month containing 9/15/90
* aDateInfo := FT_ACCTQTR( CTOD("09/15/90") )
* ? aDateInfo[1] // 199003 (3rd quarter)
* ? aDateInfo[2] // 07/01/90 beginning of quarter 3
* ? aDateInfo[3] // 09/29/90 end of quarter 3
*
* // get info about accounting qtr. 2 in year containing 9/15/90
* aDateInfo := FT_ACCTQTR( CTOD("09/15/90"), 2 )
* ? aDateInfo[1] // 199002
* ? aDateInfo[2] // 04/01/89 beginning of quarter 2
* ? aDateInfo[3] // 06/30/90 end of quarter 2
* $SEEALSO$
* FT_DATECNFG() FT_ACCTWEEK() FT_ACCTMONTH() FT_ACCTYEAR()
* $END$
*/
FUNCTION FT_ACCTQTR(dGivenDate,nQtrNum)
LOCAL nYTemp, nQTemp, lIsQtr, aRetVal
IF ! ( VALTYPE(dGivenDate) $ 'ND' )
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nQtrNum := dGivenDate
dGivenDate := DATE()
ENDIF
aRetVal := FT_QTR(dGivenDate)
nYTemp := VAL(SUBSTR(aRetVal[1],1,4))
nQTemp := VAL(SUBSTR(aRetVal[1],5,2))
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
IF dGivenDate < aRetVal[2]
dGivenDate := FT_MADD(dGivenDate, -1)
aRetVal := FT_QTR(dGivenDate)
nQTemp -= 1
IF nQTemp == 0
nYTemp -= 1
nQTemp := 4
ENDIF
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ELSEIF dGivenDate > aRetVal[3]
dGivenDate := FT_MADD(dGivenDate,1)
aRetVal := FT_QTR(dGivenDate)
nQTemp += 1
IF nQTemp == 5
nYTemp += 1
nQTemp := 1
ENDIF
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ENDIF
lIsQtr := ( VALTYPE(nQtrNum) == 'N' )
IF lIsQtr
IF( nQtrNum < 1 .OR. nQtrNum > 4 , nQtrNum := 4, )
aRetVal := FT_QTR(dGivenDate, nQtrNum)
nYTemp := VAL(SUBSTR(aRetVal[1],1,4))
nQTemp := VAL(SUBSTR(aRetVal[1],5,2))
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ENDIF
aRetVal[1] := STR(nYTemp,4) + PADL(LTRIM(STR(nQTemp,2)), 2, '0')
RETURN aRetVal

107
harbour/contrib/libnf/acctweek.prg Normal file
View File

@@ -0,0 +1,107 @@
/*
* File......: ACCTWEEK.PRG
* Author....: Jo W. French dba Practical Computing
* CIS ID....: 74731,1751
*
* The functions contained herein are the original work of Jo W. French
* and are placed in the public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 28 Sep 1992 00:27:50 GLENN
* Jo French clean up.
*
* Rev 1.2 15 Aug 1991 23:02:38 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:46 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:28 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ACCTWEEK()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return accounting week data
* $SYNTAX$
* FT_ACCTWEEK( [ <dGivenDate> ], [ <nWeekNum> ] ) -> aDateInfo
* $ARGUMENTS$
* <dGivenDate> is any valid date in any date format. Defaults
* to current system date if not supplied.
*
* <nWeekNum> is a number from 1 to 52 signifying a week.
* Defaults to current week if not supplied.
* $RETURNS$
* A three element array containing the following data:
*
* aDateInfo[1] - The year and week as a character string "YYYYWW"
* aDateInfo[2] - The beginning date of the accounting week
* aDateInfo[3] - The ending date of the accounting week
* $DESCRIPTION$
* FT_ACCTWEEK() returns an array containing data about the
* accounting week containing the given date.
*
* An accounting period has the following characteristics:
*
* If the first week of the period contains 4 or more 'work'
* days, it is included in the period; otherwise, the first
* week was included in the prior period.
*
* If the last week of the period contains 4 or more 'work'
* days it is included in the period; otherwise, the last week
* is included in the next period. This results in 13 week
* 'quarters' and 4 or 5 week 'months'. Every 5 or 6 years, a
* 'quarter' will contain 14 weeks and the year will contain 53
* weeks.
* $EXAMPLES$
* // get info about accounting week containing 9/15/90
* aDateInfo := FT_ACCTWEEK( CTOD("09/15/90") )
* ? aDateInfo[1] // 199037 (37th week)
* ? aDateInfo[2] // 09/09/90 beginning of week 37
* ? aDateInfo[3] // 09/15/90 end of week 37
*
* // get info about accounting week 25 in year containing 9/15/90
* aDateInfo := FT_ACCTWEEK( CTOD("09/15/90"), 25 )
* ? aDateInfo[1] // 199025
* ? aDateInfo[2] // 06/17/89 beginning of week 25
* ? aDateInfo[3] // 06/23/90 end of week 25
* $SEEALSO$
* FT_DATECNFG() FT_ACCTMONTH() FT_ACCTQTR() FT_ACCTYEAR()
* $END$
*/
FUNCTION FT_ACCTWEEK(dGivenDate,nWeekNum)
LOCAL nTemp, lIsWeek, aRetVal
IF ! VALTYPE(dGivenDate) $ 'ND'
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nWeekNum := dGivenDate
dGivenDate := DATE()
ENDIF
aRetVal := FT_ACCTYEAR(dGivenDate)
lIsWeek := ( VALTYPE(nWeekNum) == 'N' )
IF lIsWeek
nTemp := INT( (aRetVal[3] - aRetVal[2]) / 7 ) + 1
IF( nWeekNum < 1 .OR. nWeekNum > nTemp, nWeekNum := nTemp, )
dGivenDate := aRetVal[2] + (nWeekNum - 1) * 7
ENDIF
aRetVal[1] += PADL(LTRIM(STR(INT( (dGivenDate - ;
aRetVal[2]) / 7 ) + 1, 2)), 2, '0')
dGivenDate += ( 6 - FT_DAYTOBOW(dGivenDate) ) // end of week
aRetVal[2] := dGivenDate - 6
aRetVal[3] := dGivenDate
RETURN aRetVal

98
harbour/contrib/libnf/acctyear.prg Normal file
View File

@@ -0,0 +1,98 @@
/*
* File......: ACCTYEAR.PRG
* Author....: Jo W. French dba Practical Computing
* CIS ID....: 74731,1751
*
* The functions contained herein are the original work of Jo W. French
* and are placed in the public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 28 Sep 1992 00:29:14 GLENN
* Jo French clean up.
*
* Rev 1.2 15 Aug 1991 23:02:40 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:48 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:28 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ACCTYEAR()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return accounting year data
* $SYNTAX$
* FT_ACCTYEAR( [ <dGivenDate> ] ) -> aDateInfo
* $ARGUMENTS$
* <dGivenDate> is any valid date in any date format. Defaults
* to current system date if not supplied.
* $RETURNS$
* A three element array containing the following data:
*
* aDateInfo[1] - The year as a character string "YYYY"
* aDateInfo[2] - The beginning date of the accounting year
* aDateInfo[3] - The ending date of the accounting year
* $DESCRIPTION$
* FT_ACCTYEAR() creates an array containing data about the
* accounting year containing the given date.
*
* An accounting period has the following characteristics:
*
* If the first week of the period contains 4 or more 'work'
* days, it is included in the period; otherwise, the first
* week was included in the prior period.
*
* If the last week of the period contains 4 or more 'work'
* days it is included in the period; otherwise, the last week
* is included in the next period. This results in 13 week
* 'quarters' and 4 or 5 week 'months'. Every 5 or 6 years, a
* 'quarter' will contain 14 weeks and the year will contain 53
* weeks.
* $EXAMPLES$
* // get info about accounting year containing 9/15/90
* aDateInfo := FT_ACCTYEAR( CTOD("09/15/90") )
* ? aDateInfo[1] // 1990
* ? aDateInfo[2] // 12/31/89 beginning of year
* ? aDateInfo[3] // 12/29/90 end of year
* $SEEALSO$
* FT_DATECNFG() FT_ACCTWEEK() FT_ACCTMONTH() FT_ACCTQTR()
* $END$
*/
FUNCTION FT_ACCTYEAR(dGivenDate)
LOCAL nYTemp, aRetVal
IF( VALTYPE(dGivenDate) != 'D', dGivenDate := DATE(), )
aRetVal := FT_YEAR(dGivenDate)
nYTemp := VAL(aRetVal[1])
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
IF dGivenDate < aRetVal[2]
aRetVal := FT_YEAR(FT_MADD(dGivenDate, -1))
nYTemp --
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ELSEIF dGivenDate > aRetVal[3]
aRetVal := FT_YEAR(FT_MADD(dGivenDate, 1))
nYTemp ++
aRetVal[2] := FT_ACCTADJ(aRetVal[2])
aRetVal[3] := FT_ACCTADJ(aRetVal[3], .T. )
ENDIF
aRetVal[1] := STR(nYTemp,4)
RETURN aRetVal

81
harbour/contrib/libnf/adessort.prg Normal file
View File

@@ -0,0 +1,81 @@
/*
* File......: ADesSort.Prg
* Author....: David Husnian
* CIS ID....: ?
*
* This is an original work by David Husnian and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:02:42 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:50 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:30 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ADESSORT()
* $CATEGORY$
* Array
* $ONELINER$
* Sort an array in descending order
* $SYNTAX$
* FT_ADESSORT( <aArray> [, <nStartIndex> [, <nEndIndex> ] ] ) -> aSorted
* $ARGUMENTS$
* <aArray> is the array to be sorted
*
* <nStartIndex> is the first array item to include in the sort,
* defaults to first element
*
* <nEndIndex> is the last array element to include in the sort,
* defaults to all elements
* $RETURNS$
* The array, sorted in descending order.
* $DESCRIPTION$
* This function is used to sort an array in descending order, i.e., Z-A
* $EXAMPLES$
* FT_ADESSORT(aNames) // Sort the Entire Array
*
* FT_ADESSORT(aNames, 5) // Sort from the 5th Element On
*
* FT_ADESSORT(aNames, , 10) // Sort the 1st 10 Elements
*
* FT_ADESSORT(aNames, 5, 10) // Sort Elements 5-10
* $END$
*/
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := IF(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := IF(<ParamN> == NIL,<DefN>,<ParamN>)]
#command DEFAULT <Param1> TO <Def1> IF NOT <Type1> ;
[, <ParamN> TO <DefN> IF NOT <TypeN> ] ;
=> ;
<Param1> := IF(VALTYPE(<Param1>) == <Type1>,<Param1>,<Def1>) ;
[; <ParamN> := IF(VALTYPE(<ParamN>) == <TypeN>,<ParamN>,<DefN>)]
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
FUNCTION FT_ADESSORT(aArray, nStartIndex, nEndIndex)
DEFAULT nStartIndex TO 1, ;
nEndIndex TO LEN(aArray)
// Make Sure Bounds are in Range
FORCE_BETWEEN(1, nEndIndex, LEN(aArray))
FORCE_BETWEEN(1, nStartIndex, nEndIndex)
RETURN (ASORT(aArray, nStartIndex, nEndIndex, ;
{ | xElement1, xElement2 | xElement1 > xElement2 } ))

133
harbour/contrib/libnf/aemaxlen.prg Normal file
View File

@@ -0,0 +1,133 @@
/*
* File......: AEmaxlen.prg
* Author....: Ralph Oliver, TRANSCOM SYSTEMS
* CIS ID....: 74030,703
*
* This is an original work by Ralph Oliver and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 15 Aug 1991 23:05:38 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 07 Jun 1991 23:03:12 GLENN
* Initial revision.
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_AEMAXLEN()
* $CATEGORY$
* Array
* $ONELINER$
* Find longest element within an array
* $SYNTAX$
* FT_AEMAXLEN( <aArray> [, <nDimension> [, <nStart> [, <nCount> ] ] ] ) ;
* -> nMaxlen
* $ARGUMENTS$
* <aArray> is the array containing the elements to be measured.
*
* <nDimension> is the array dimension to be measured,
* defaults to first dimension.
*
* <nStart> is the starting array element to include,
* defaults to first array element.
*
* <nCount> is the number of array elements to process from
* from <nStart>, defaults to remaining elements
* in array.
* $RETURNS$
* The length of the longest size element of an array.
* $DESCRIPTION$
* This function will measure each element of an array
* dimension and return the longest element.
* $EXAMPLES$
* FT_AEMAXLEN(aArray) // Measure the 1st dimension of an Array
*
* FT_AEMAXLEN(aArray,2) // Measure the 2nd dimension of an Array
*
* FT_AEMAXLEN(aArray,2,,9) // Measure Elements 1-9 of the
* 2nd dimension or subarray
*
* FT_AEMAXLEN(aArray,3,5,9) // Measure Elements 5-9 of the
* 3rd dimension or subarray
*
* FT_AEMAXLEN(aArray,3,5) // Measure Elements 5 to last in the
* 3rd dimension or subarray
* $SEEALSO$
* FT_AEMINLEN()
* $END$
*/
#ifdef FT_TEST
FUNCTION MAIN()
LOCAL var0, myarray1 := DIRECTORY()
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AEMAXLEN"
?
? "myarray1 = DIRECTORY()"
?
var0 := FT_AEMAXLEN( myarray1 )
? PADR('FT_AEMAXLEN( myarray1 ) ->',30)
?? var0
?
var0 := FT_AEMAXLEN( myarray1,2 )
? PADR('FT_AEMAXLEN( myarray1,2 ) ->',30)
?? var0
?
var0 := FT_AEMAXLEN( myarray1,3 )
? PADR('FT_AEMAXLEN( myarray1,3 ) ->',30)
?? var0
?
var0 := FT_AEMAXLEN( aTail( myarray1 ) )
? PADR('FT_AEMAXLEN( aTail( myarray1 ) ) ->',30)
?? var0
?
RETURN NIL
#endif
FUNCTION FT_AEmaxlen( aArray, nDimension, nStart, nCount )
LOCAL i, nLast, cType, nMaxlen := 0
// Set default parameters as necessary.
IF nDimension == NIL
nDimension := 1
ENDIF
IF nStart == NIL
nStart := 1
ENDIF
IF nCount == NIL
nCount := LEN( aArray ) - nStart + 1
ENDIF
nLast := MIN( nStart +nCount -1, LEN( aArray ))
FOR i := nStart TO nLast
cType := VALTYPE( aArray[i] )
DO CASE
CASE ( cType == "C" )
nMaxlen := MAX( nMaxlen, LEN( aArray[i] ))
CASE ( cType == "A" )
nMaxlen := MAX( nMaxlen, ;
LEN( LTRIM( TRANSFORM( aArray[i] [nDimension], "@X"))))
OTHERWISE
nMaxlen := MAX( nMaxlen, ;
LEN( LTRIM( TRANSFORM( aArray[i], "@X" ))))
ENDCASE
NEXT
RETURN ( nMaxlen )

134
harbour/contrib/libnf/aeminlen.prg Normal file
View File

@@ -0,0 +1,134 @@
/*
* File......: AEminlen.prg
* Author....: Ralph Oliver, TRANSCOM SYSTEMS
* CIS ID....: 74030,703
*
* This is an original work by Ralph Oliver and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 15 Aug 1991 23:02:28 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 07 Jun 1991 23:03:16 GLENN
* Initial revision.
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_AEMINLEN()
* $CATEGORY$
* Array
* $ONELINER$
* Find shortest element within an array
* $SYNTAX$
* FT_AEMINLEN( <aArray> [, <nDimension> [, <nStart> [, <nCount> ] ] ] )
* -> nMinlen
* $ARGUMENTS$
* <aArray> is the array containing the elements to be measured.
*
* <nDimension> is the array dimension to be measured,
* defaults to first dimension.
*
* <nStart> is the starting array element to include,
* defaults to first array element.
*
* <nCount> is the number of array elements to process from
* from <nStart>, defaults to remaining elements
* in array.
* $RETURNS$
* The length of the shortest size element of an array.
* $DESCRIPTION$
* This function will measure each element of an array
* dimension and return the shortest element.
* $EXAMPLES$
* FT_AEMINLEN(aArray) // Measure the 1st dimension of an Array
*
* FT_AEMINLEN(aArray,2) // Measure the 2nd dimension of an Array
*
* FT_AEMINLEN(aArray,2,,9) // Measure Elements 1-9 of 2nd dimension
*
* FT_AEMINLEN(aArray,3,5,9) // Measure Elements 5-9 of 3rd dimension
*
* FT_AEMINLEN(aArray,3,5) // Measure Elements 5 to end of 3rd dimension
* $SEEALSO$
* FT_AEMAXLEN()
* $END$
*/
#ifdef FT_TEST
FUNCTION MAIN()
LOCAL var0, myarray1 := DIRECTORY()
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AEMINLEN"
?
? "myarray1 = DIRECTORY()"
?
aEval( myarray1, {|v| qout( padr(v[1],12), v[2], v[3], v[4], v[5] ) } )
var0 := FT_AEMINLEN( myarray1 )
? PADR('FT_AEMINLEN( myarray1 ) ->',30)
?? var0
?
var0 := FT_AEMINLEN( myarray1,2 )
? PADR('FT_AEMINLEN( myarray1,2 ) ->',30)
?? var0
?
?
var0 := FT_AEMINLEN( myarray1[2] )
? PADR('FT_AEMINLEN( myarray1[2] ) ->',30)
?? var0
?
?
var0 := FT_AEMINLEN( myarray1,3 )
? PADR('FT_AEMINLEN( myarray1,3 ) ->',30)
?? var0
?
RETURN NIL
#endif
FUNCTION FT_AEminlen( aArray, nDimension, nStart, nCount )
LOCAL i, nLast, cType, nMinlen := 65519
// Set default parameters as necessary.
IF nDimension == NIL
nDimension := 1
ENDIF
IF nStart == NIL
nStart := 1
ENDIF
IF nCount == NIL
nCount := LEN( aArray ) - nStart + 1
ENDIF
nLast := MIN( nStart +nCount -1, LEN( aArray ))
FOR i := nStart TO nLast
cType := VALTYPE( aArray[i] )
DO CASE
CASE ( cType == "C" )
nMinlen := MIN( nMinlen, LEN( aArray[i] ))
CASE ( cType == "A" )
nMinlen := MIN( nMinlen, ;
LEN( LTRIM( TRANSFORM( aArray[i] [nDimension], "@X" ))))
OTHERWISE
nMinlen := MIN( nMinlen, ;
LEN( LTRIM( TRANSFORM( aArray[i], "@X" ))))
ENDCASE
NEXT
RETURN ( nMinlen )

76
harbour/contrib/libnf/alt.c Normal file
View File

@@ -0,0 +1,76 @@
/*
* $Id$
*/
/*
* File......: ALT.C
* Author....: Ted Means
* CIS ID....: 73067,3332
*
* This function is an original work by Ted Means and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.5 16 Apr 2000 17:30:00 Luiz Rafael Culik
* Ported to Harbour
*
* Rev 1.4 15 Jul 1993 23:48:00 GLENN
* Dropped _MK_FP for preferred 0x00400017
*
* Rev 1.3 13 Jul 1993 22:28:58 GLENN
* Added call to _MK_FP in order to be compatible in protected mode.
*
* Rev 1.2 15 Aug 1991 23:08:34 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:36 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:42 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ALT()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Determine status of the Alt key
* $SYNTAX$
* FT_ALT() -> lValue
* $ARGUMENTS$
* None
* $RETURNS$
* .T. if Alt key is pressed, .F. if otherwise.
* $DESCRIPTION$
* This function is useful for times you need to know whether or not the
* Alt key is pressed, such as during a MemoEdit().
* $EXAMPLES$
* IF FT_ALT()
* @24, 0 say "Alt"
* ELSE
* @24, 0 say " "
* ENDIF
* $SEEALSO$
* FT_CAPLOCK() FT_CTRL() FT_NUMLOCK() FT_PRTSCR() FT_SHIFT()
* $END$
*/
#include <hbapi.h>
HB_FUNC(FT_ALT)
{
#if defined(HB_OS_DOS)
{
hb_retl( ( int ) ( ( *( char * ) 0x00400017 ) & 0x8 ) );
return;
}
#endif
}

132
harbour/contrib/libnf/amedian.prg Normal file
View File

@@ -0,0 +1,132 @@
/*
* File......: AMedian.Prg
* Author....: Ralph Oliver, TRANSCOM SYSTEMS
* CIS ID....: 74030,703
*
* This is an original work by Ralph Oliver and is placed in the
* public domain.
*
* This program uses the preprocessor #defines and #command in
* Aavg.prg by David Husnian.
*
* Modification history:
* ---------------------
*
* Rev 1.1 15 Aug 1991 23:05:22 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 07 Jun 1991 23:03:20 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_AMEDIAN()
* $CATEGORY$
* Array
* $ONELINER$
* Find middle value in array, or average of two middle values
* $SYNTAX$
* FT_AMEDIAN( <aArray> [, <nStart> [, <nEnd> ] ] )
* -> nMedian
* $ARGUMENTS$
* <aArray> is the array containing the elements to be averaged.
*
* <nStart> is the first array element to include,
* defaults to first element.
*
* <nEnd> is the last array element to include,
* defaults to last element.
* $RETURNS$
* The median average of the array elements
* $DESCRIPTION$
* This function sorts the elements of a numeric array and
* then returns the value in the middle element of the sorted
* array. If there is no exact middle value, then it returns
* the average of the two middle values. Half of the elements
* are > median and half are < median. A median average may
* more reflect a more useful average when there are extreme
* values in the set.
* $EXAMPLES$
* FT_AMEDIAN( aArray ) // Return Median for entire array
*
* FT_AMEDIAN( aArray, 2) // Return Median for elements from 2 to end
*
* FT_AMEDIAN( aArray, ,9) // Return Median for 1st 9 elements
*
* FT_AMEDIAN( aArray,8,40 ) // Return Median for elements 8 to 40
* $END$
*/
#ifdef FT_TEST
#include "directry.ch"
FUNCTION MAIN()
LOCAL var0, myarray0 := DIRECTORY(), myarray1 := {}
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AMEDIAN"
?
AEVAL( myarray0, { |x| AADD( myarray1, x[ F_SIZE ]) } )
var0 := FT_AMEDIAN( myarray1 )
? PADR('FT_AMEDIAN( myarray1 ) ->',35)
?? var0
?
var0 := FT_AMEDIAN( myarray1, 2 )
? PADR('FT_AMEDIAN( myarray1, 2 ) ->',35)
?? var0
?
var0 := FT_AMEDIAN( myarray1, , 9 )
? PADR('FT_AMEDIAN( myarray1, , 9 ) ->',35)
?? var0
?
var0 := FT_AMEDIAN( myarray1, 8, 40 )
? PADR('FT_AMEDIAN( myarray1, 8, 40 ) ->',35)
?? var0
?
RETURN NIL
#endif
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := IF(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := IF(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_AMEDIAN( aArray, nStart, nEnd )
LOCAL nTemplen, aTemparray, nMiddle1, nMiddle2, nMedian
DEFAULT nStart TO 1, ;
nEnd TO LEN( aArray )
// Make Sure Bounds are in Range
FORCE_BETWEEN(1, nEnd, LEN( aArray ))
FORCE_BETWEEN(1, nStart, nEnd)
// Length of aTemparray
nTemplen := ( nEnd - nStart ) + 1
// Initialize aTemparray
aTemparray := ACOPY( aArray, ARRAY( nTemplen ), nStart, nTemplen )
// Sort aTemparray
aTemparray := ASORT( aTemparray )
// Determine middle value(s)
IF ( nTemplen % 2 ) == 0
nMiddle1 := aTemparray[ (nTemplen / 2) ]
nMiddle2 := aTemparray[ INT(nTemplen / 2) +1 ]
nMedian := INT( ( nMIddle1 + nMiddle2 ) / 2 )
ELSE
nMedian := aTemparray[ INT( nTemplen / 2 ) + 1 ]
ENDIF
RETURN ( nMedian )

90
harbour/contrib/libnf/anomatch.prg Normal file
View File

@@ -0,0 +1,90 @@
/*
* File......: ANoMatch.Prg
* Author....: David Husnian
* CIS ID....: ?
*
* This is an original work by David Husnian and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:02:44 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:52 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:32 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ANOMATCHES()
* $CATEGORY$
* Array
* $ONELINER$
* Find the number of array elements meeting a condition
* $SYNTAX$
* FT_ANOMATCHES( <aArray>, <bCompareBlock> ;
* [, <nStartIndex> [, <nEndIndex> ] ] ) -> nNoOfMatches
* $ARGUMENTS$
* <aArray> is the array to be searched
*
* <bCompareBlock> is a code block containing the expression for
* the array elements to be tested with. Each element is passed
* as a parameter to the block. If the block returns .T., the
* number of matches will be incremented by one.
*
* <nStartIndex> is the first array item to include in the search,
* defaults to first element.
*
* <nEndIndex> is the last array element to include in the search,
* defaults to all elements.
* $RETURNS$
* The number of elements that cause the code block to return .T.
* $DESCRIPTION$
* This function returns the number of array elements that, when passed
* to the supplied code block, cause that code block to return a .T. value.
* $EXAMPLES$
* // Search the Entire Array
* FT_ANOMATCHES(aTries, { | x | x <= 100 } )
*
* // Search from the 5th Element On
* FT_ANOMATCHES(aCodes, { | x | UPPER(x) == cCurrentCode }, 5)
*
* // Search the 1st 10 Elements
* FT_ANOMATCHES(aDates, { | x | IS_BETWEEN(DATE()-7,x,DATE() + 7) }, 10)
*
* // Search Elements 5-10
* FT_ANOMATCHES(aNames, { | x | x <= cLastGoodName }, 5, 10)
* $END$
*/
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := IF(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := IF(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_ANOMATCHES(aArray, bCompareBlock, nStartIndex, nEndIndex)
LOCAL nNoOfMatches := 0 // Number of Matches Found
DEFAULT nStartIndex TO 1, ;
nEndIndex TO LEN(aArray)
// Make Sure Bounds are in Range
FORCE_BETWEEN(1, nEndIndex, LEN(aArray))
FORCE_BETWEEN(1, nStartIndex, nEndIndex)
AEVAL(aArray, ;
{ | xElement | ;
IIF(EVAL(bCompareBlock, xElement), nNoOfMatches++, NIL) }, ;
nStartIndex, nEndIndex - nStartIndex + 1)
RETURN (nNoOfMatches) // FT_ANoMatches

168
harbour/contrib/libnf/any2any.prg Normal file
View File

@@ -0,0 +1,168 @@
/*
* File......: Any2Any.Prg
* Author....: David Husnian
* CIS ID....: ?
*
* This is an original work by David Husnian and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:02:46 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:54 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:34 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_XTOY()
* $CATEGORY$
* Conversion
* $ONELINER$
* Convert from any data type to any other data type
* $SYNTAX$
* FT_XTOY( <xValueToConvert>, <cTypeToConvertTo> ;
* [, <lWantYesNo> ] ) -> xResult
* $ARGUMENTS$
* <xValueToConvert> is the value to convert.
*
* <cTypeToConvertTo> is the type of value to convert to
* ("C","D","L","N","A" or "B").
*
* <lWantYesNo> is a logical to signal if 'Y' or 'N' is to be returned
* if Converting a logical, otherwise '.T.' or '.F.' will be returned
* for logicals.
* $RETURNS$
* The original value converted to the new type.
* $DESCRIPTION$
* This function converts a value of character, date, numeric, logical,
* array or code block type to any of the other type. While it is
* guaranteed to return a value of the correct type, that value may not
* be meaningful (i.e., converting from a code block returns an EMPTY()
* value of the desired type).
* $EXAMPLES$
* nNumericValue := FT_XTOY(cInputValue, "N")
* IF (FT_XTOY(nInputValue, "L"))
* $END$
*/
#define BLOCKIFY(x) { || x }
#define IS_CHAR(x) (VALTYPE(x) == "C")
#define IS_DATE(x) (VALTYPE(x) == "D")
#define IS_LOGICAL(x) (VALTYPE(x) == "L")
#define IS_NUMERIC(x) (VALTYPE(x) == "N")
#define CASE_AT(x,y,z) z[AT(x,y)+1]
#define TRIM_NUMBER(x) LTRIM(STR(x))
#define NULL ""
#define IS_NOT_CHAR(x) (VALTYPE(x) != "C")
#define IS_NOT_DATE(x) (VALTYPE(x) != "D")
#define EARLIEST_DATE CTOD("01/01/0100")
#define BLANK_DATE CTOD(NULL)
#define IS_NOT_ARRAY(x) (VALTYPE(x) != "A")
#define IS_NOT_LOGICAL(x) (VALTYPE(x) != "L")
#define IS_NOT_NUMERIC(x) (VALTYPE(x) != "N")
#define IS_NOT_CODE_BLOCK(x) (VALTYPE(x) != "B")
#define TRUE (.t.)
#define FALSE (.f.)
#Define XTOC(x) CASE_AT(VALTYPE(x), "CNDLM", ;
{ NULL, ;
x, ;
IF(IS_NUMERIC(x),;
TRIM_NUMBER(x), ;
NULL), ;
IF(IS_DATE(x),DTOC(x),NULL),;
IF(IS_LOGICAL(x),;
IF(x,".T.",".F."), ;
NULL), ;
x })
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := IF(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := IF(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_XTOY(xValueToConvert, cTypeToConvertTo, lWantYesNo)
DEFAULT lWantYesNo TO FALSE
DO CASE
CASE cTypeToConvertTo == "C" .AND.; // They Want a Character String
IS_NOT_CHAR(xValueToConvert)
xValueToConvert := XTOC(xValueToConvert)
CASE cTypeToConvertTo == "D" .AND.; // They Want a Date
IS_NOT_DATE(xValueToConvert)
xValueToConvert := IF(IS_CHAR(xValueToConvert), ;
; // Convert from a Character
CTOD(xValueToConvert), ;
IF(IS_NUMERIC(xValueToConvert), ;
; // Convert from a Number
xValueToConvert + EARLIEST_DATE, ;
IF(IS_LOGICAL(xValueToConvert), ;
; // Convert from a Logical
IF(xValueToConvert, DATE(), BLANK_DATE), ;
; // Unsupported Type
BLANK_DATE)))
CASE cTypeToConvertTo == "N" .AND.; // They Want a Number
IS_NOT_NUMERIC(xValueToConvert)
xValueToConvert := IF(IS_CHAR(xValueToConvert), ;
; // Convert from a Character
VAL(xValueToConvert), ;
IF(IS_DATE(xValueToConvert), ;
; // Convert from a Date
xValueToConvert - EARLIEST_DATE, ;
IF(IS_LOGICAL(xValueToConvert), ;
; // Convert from a Logical
IF(xValueToConvert, 1, 0), ;
; // Unsupported Type
0)))
CASE cTypeToConvertTo == "L" .AND.; // They Want a Logical
IS_NOT_LOGICAL(xValueToConvert)
xValueToConvert := IF(IS_CHAR(xValueToConvert), ;
; // Convert from a Character
UPPER(xValueToConvert) == IF(lWantYesNo,"Y",".T."), ;
IF(IS_DATE(xValueToConvert), ;
; // Convert from a Date
! EMPTY(xValueToConvert), ;
IF(IS_NUMERIC(xValueToConvert), ;
; // Convert from a Number
xValueToConvert != 0, ;
; // Unsupported Type
FALSE)))
CASE cTypeToConvertTo == "A" .AND.; // They Want an Array
IS_NOT_ARRAY(xValueToConvert)
xValueToConvert := { xValueToConvert }
CASE cTypeToConvertTo == "B" .AND.; // They Want a Code Block
IS_NOT_CODE_BLOCK(xValueToConvert)
xValueToConvert := BLOCKIFY(xValueToConvert)
ENDCASE
RETURN (xValueToConvert) // XToY

303
harbour/contrib/libnf/aredit.prg Normal file
View File

@@ -0,0 +1,303 @@
/*
* File......: ArEdit.prg
* Author....: James J. Orlowski, M.D.
* CIS ID....: 72707,601
*
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:05:56 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 12 Jun 1991 00:42:38 GLENN
* A referee suggested changing the documentation such that the return value
* is shown as "xElement" rather than "cElement" because the function
* can return different types.
*
* Rev 1.0 07 Jun 1991 23:03:24 GLENN
* Initial revision.
*
*
*/
/*
Some notes:
The tbmethods section is a short cut from Spence's book instead
of using the longer DO CASE method.
Jim Gale showed me the basic array browser and Robert DiFalco
showed me the improved skipblock in public messages on Nanforum.
I added the functionality of the "Edit Get" code block
(ie bGetFunc), TestGet() demo, and the add/delete rows.
*/
/* $DOC$
* $FUNCNAME$
* FT_AREDIT()
* $CATEGORY$
* Array
* $ONELINER$
* 2 dimensional array editing function using TBrowse
* $SYNTAX$
* FT_AREDIT( <nTop>, <nLeft>, <nBottom>, <nRight>, <Array Name>, ;
* <nElem>, <aHeadings>, <aBlocks> [, <bGetFunc> ] ) -> xElement
* $ARGUMENTS$
* <nTop>, <nLeft>, <nBottom>, <nRight> are coordinates for TBrowse
*
* <Array Name> is name of 2 dimensional to array edit
*
* <nElem> is pointer for element in array
*
* <aHeadings> is array of column headings
*
* <aBlocks> is array of blocks describing each array element
*
* [ <bGetFunc> ] is get editing function for handling individual elements
* $RETURNS$
* Value of element positioned on when exit FT_AREDIT()
* The type of this value depends on what is displayed.
* $DESCRIPTION$
* This function allows you to position yourself in an array,
* add and delete rows with the <F7> and <F8> keys,
* and pass a UDF with information to edit the individual gets.
* $EXAMPLES$
* FT_AREDIT(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks)
*
* This example will allow you to browse a 2 dimensional array
* But you can't edit it since there is no GetBlock UDF
* It allows the user to hit ENTER to select an element or ESC to
* return 0
*
* * This second example shows how to edit a 2 dimensional array
* * as might be done to edit an invoice
*
* LOCAL i, ar[3, 26], aBlocks[3], aHeadings[3]
* LOCAL nElem := 1, bGetFunc
*
* * Set up two dimensional array "ar"
*
* FOR i = 1 TO 26
* ar[1, i] := i // 1 -> 26 Numeric
* ar[2, i] := CHR(i+64) // "A" -> "Z" Character
* ar[3, i] := CHR(91-i) // "Z" -> "A" Character
* NEXT i
*
* * SET UP aHeadings Array for column headings
*
* aHeadings := { "Numbers", "Letters", "Reverse" }
*
* * Need to set up individual array blocks for each TBrowse column
*
* aBlocks[1] := {|| STR(ar[1, nElem], 2) } // prevent default 10 spaces
* aBlocks[2] := {|| ar[2, nElem] }
* aBlocks[3] := {|| ar[3, nElem] }
*
* * set up TestGet() as the passed Get Function so FT_ArEdit knows how
* * to edit the individual gets.
*
* bGetFunc := { | b, ar, nDim, nElem | TestGet(b, ar, nDim, nElem) }
* SetColor( "N/W, W/N, , , W/N" )
* CLEAR SCREEN
* FT_AREDIT(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks, bGetFunc)
*
* $END$
*/
#include "inkey.ch"
* Default heading, column, footer separators
#define DEF_HSEP "ÍÑÍ"
#define DEF_CSEP " ³ "
#define DEF_FSEP "ÍÏÍ"
* Default info for tb_methods section
#define KEY_ELEM 1
#define BLK_ELEM 2
#ifdef FT_TEST
PROCEDURE Test
* Thanks to Jim Gale for helping me understand the basics
LOCAL i, ar[3, 26], aBlocks[3], aHeadings[3], nElem := 1, bGetFunc, cRet
* set up 2 dimensional array ar[]
FOR i = 1 TO 26
ar[1, i] := i // 1 -> 26 Numeric
ar[2, i] := CHR(i+64) // "A" -> "Z" Character
ar[3, i] := CHR(91-i) // "Z" -> "A" Character
NEXT i
* Set Up aHeadings[] for column headings
aHeadings := { "Numbers", "Letters", "Reverse" }
* Set Up Blocks Describing Individual Elements in Array ar[]
aBlocks[1] := {|| STR(ar[1, nElem], 2)} // to prevent default 10 spaces
aBlocks[2] := {|| ar[2, nElem]}
aBlocks[3] := {|| ar[3, nElem]}
* Set up TestGet() as bGetFunc
bGetFunc := {|b, ar, nDim, nElem|TestGet(b, ar, nDim, nElem)}
SET SCOREBOARD OFF
SetColor( "W/N")
CLEAR SCREEN
@ 21,4 SAY "Use Cursor Keys To Move Between Fields, <F7> = Delete Row, <F8> = Add Row"
@ 22,7 SAY "<ESC> = Quit Array Edit, <Enter> or <Any Other Key> Edits Element"
SetColor( "N/W, W/N, , , W/N" )
cRet := FT_ArEdit(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks, bGetFunc)
SetColor( "W/N")
CLEAR SCREEN
? cRet
? "Lastkey() = ESC:", LASTKEY() == K_ESC
RETURN
FUNCTION TestGet( b, ar, nDim, nElem)
LOCAL GetList := {}
LOCAL nRow := ROW()
LOCAL nCol := COL()
LOCAL cSaveScrn := SAVESCREEN(21, 0, 22, MaxCol())
LOCAL cOldColor := SetColor( "W/N")
@ 21, 0 CLEAR TO 22, MaxCol()
@ 21,29 SAY "Editing Array Element"
SetColor(cOldColor)
DO CASE
CASE nDim == 1
@ nRow, nCol GET ar[1, nElem] PICTURE "99"
READ
b:refreshAll()
CASE nDim == 2
@ nRow, nCol GET ar[2, nElem] PICTURE "!"
READ
b:refreshAll()
CASE nDim == 3
@ nRow, nCol GET ar[3, nElem] PICTURE "!"
READ
b:refreshAll()
ENDCASE
RESTSCREEN(21, 0, 22, MaxCol(), cSaveScrn)
@ nRow, nCol SAY ""
RETURN(.t.)
#endif
FUNCTION FT_ArEdit( nTop, nLeft, nBot, nRight, ;
ar, nElem, aHeadings, aBlocks, bGetFunc)
* ANYTYPE[] ar - Array to browse
* NUMERIC nElem - Element In Array
* CHARACTER[] aHeadings - Array of Headings for each column
* BLOCK[] aBlocks - Array containing code block for each column.
* CODE BLOCK bGetFunc - Code Block For Special Get Processing
* NOTE: When evaluated a code block is passed the array element to
* be edited
LOCAL exit_requested := .F., nKey, meth_no, ;
cSaveWin, i, b, column
LOCAL nDim, nWorkRow, cType, cVal
LOCAL tb_methods := ;
{ ;
{K_DOWN, {|b| b:down()}}, ;
{K_UP, {|b| b:up()}}, ;
{K_PGDN, {|b| b:pagedown()}}, ;
{K_PGUP, {|b| b:pageup()}}, ;
{K_CTRL_PGUP, {|b| b:gotop()}}, ;
{K_CTRL_PGDN, {|b| b:gobottom()}}, ;
{K_RIGHT, {|b| b:right()}}, ;
{K_LEFT, {|b| b:left()}}, ;
{K_HOME, {|b| b:home()}}, ;
{K_END, {|b| b:end()}}, ;
{K_CTRL_LEFT, {|b| b:panleft()}}, ;
{K_CTRL_RIGHT, {|b| b:panright()}}, ;
{K_CTRL_HOME, {|b| b:panhome()}}, ;
{K_CTRL_END, {|b| b:panend()}} ;
}
cSaveWin := SaveScreen(nTop, nLeft, nBot, nRight)
@ nTop, nLeft TO nBot, nRight
b := TBrowseNew(nTop + 1, nLeft + 1, nBot - 1, nRight - 1)
b:headsep := DEF_HSEP
b:colsep := DEF_CSEP
b:footsep := DEF_FSEP
b:gotopblock := {|| nElem := 1}
b:gobottomblock := {|| nElem := LEN(ar[1])}
* skipblock originally coded by Robert DiFalco
b:SkipBlock := {|nSkip, nStart| nStart := nElem,;
nElem := MAX( 1, MIN( LEN(ar[1]), nElem + nSkip ) ),;
nElem - nStart }
FOR i = 1 TO LEN(aBlocks)
column := TBColumnNew(aHeadings[i], aBlocks[i] )
b:addcolumn(column)
NEXT
exit_requested = .F.
DO WHILE !exit_requested
DO WHILE NEXTKEY() == 0 .AND. !b:stabilize()
ENDDO
nKey := INKEY(0)
meth_no := ASCAN(tb_methods, {|elem| nKey = elem[KEY_ELEM]})
IF meth_no != 0
EVAL(tb_methods[meth_no, BLK_ELEM], b)
ELSE
DO CASE
CASE nKey == K_F7
FOR nDim = 1 TO LEN(ar)
ADEL(ar[nDim], nElem)
ASIZE(ar[nDim], LEN(ar[nDim]) - 1)
NEXT
b:refreshAll()
CASE nKey == K_F8
FOR nDim = 1 TO LEN(ar)
* check valtype of current element before AINS()
cType := VALTYPE(ar[nDim, nElem])
cVal := ar[nDim, nElem]
ASIZE(ar[nDim], LEN(ar[nDim]) + 1)
AINS(ar[nDim], nElem)
IF cType == "C"
ar[nDim, nElem] := SPACE(LEN(cVal))
ELSEIF cType == "N"
ar[nDim, nElem] := 0
ELSEIF cType == "L"
ar[nDim, nElem] := .f.
ELSEIF cType == "D"
ar[nDim, nElem] := CTOD(" / / ")
ENDIF
NEXT
b:refreshAll()
CASE nKey == K_ESC
exit_requested := .T.
* Other exception handling ...
CASE VALTYPE(bGetFunc) == "B"
IF nKey <> K_ENTER
* want last key to be part of GET edit so KEYBOARD it
KEYBOARD CHR(LASTKEY())
ENDIF
EVAL(bGetFunc, b, ar, b:colPos, nElem )
* after get move to next field
KEYBOARD IF(b:colPos < b:colCount, ;
CHR(K_RIGHT), CHR(K_HOME) + CHR(K_DOWN) )
* Placing K_ENTER here below Edit Block (i.e. bGetFunc)
* defaults K_ENTER to Edit when bGetFunc Is Present
* BUT if no bGetFunc, then K_ENTER selects element to return
CASE nKey == K_ENTER
exit_requested := .T.
ENDCASE
ENDIF // meth_no != 0
ENDDO // WHILE !exit_requested
RestScreen(nTop, nLeft, nBot, nRight, cSaveWin)
* if no bGetFunc then ESC returns 0, otherwise return value of last element
RETURN IF( VALTYPE(bGetFunc) == NIL .AND. nKey == K_ESC, ;
0, ar[b:colPos, nElem] )
* EOFcn FT_ArEdit()

86
harbour/contrib/libnf/asum.prg Normal file
View File

@@ -0,0 +1,86 @@
/*
* File......: ASum.Prg
* Author....: David Husnian
* CIS ID....: ?
*
* This is an original work by David Husnian and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:02:48 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:50:56 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:00:36 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ASUM()
* $CATEGORY$
* Array
* $ONELINER$
* Sum the elements of an array
* $SYNTAX$
* FT_ASUM( <aArray> [, <nStartIndex> [, <nEndIndex> ] ] ) -> nSum
* $ARGUMENTS$
* <aArray> is the array containing the elements to be summed.
*
* <nStartIndex> is the first array item to include,
* defaults to first element.
*
* <nEndIndex> is the last array element to include,
* defaults to all elements.
* $RETURNS$
* The sum of the elements of the array or the lengths of the elements.
* $DESCRIPTION$
* This function is to sum the elements of a numeric array or to sum the
* lengths of a character array.
* $EXAMPLES$
*
* FT_ASUM(aSubTotals) // Sum the Entire Array
*
* FT_ASUM(aSubTotals, 5) // Sum from the 5th Element On
*
* FT_ASUM(aSubTotals, , 10) // Sum the 1st 10 Elements
*
* FT_ASUM(aSubTotals, 5, 10) // Sum Elements 5-10
* $END$
*/
#define CASE_AT(x,y,z) z[AT(x,y)+1]
#define FORCE_BETWEEN(x,y,z) (y := MAX(MIN(y,z),x))
#define IS_CHAR(x) (VALTYPE(x) == "C")
#command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := IF(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := IF(<ParamN> == NIL,<DefN>,<ParamN>)]
FUNCTION FT_ASUM(aArray, nStartIndex, nEndIndex)
LOCAL nSumTotal := 0 // Array Sum
DEFAULT nStartIndex TO 1, ;
nEndIndex TO LEN(aArray)
// Make Sure Bounds are in Range
FORCE_BETWEEN(1, nEndIndex, LEN(aArray))
FORCE_BETWEEN(1, nStartIndex, nEndIndex)
AEVAL(aArray, ;
{ | xElement | ;
nSumTotal += ;
CASE_AT(VALTYPE(xElement), "NC", ;
{ 0, xElement, ;
IF(IS_CHAR(xElement),LEN(xElement),0) }) }, ;
nStartIndex, nEndIndex - nStartIndex + 1)
RETURN (nSumTotal) // FT_ASum

136
harbour/contrib/libnf/at2.prg Normal file
View File

@@ -0,0 +1,136 @@
/*
* File......: AT2.prg
* Author....: Ralph Oliver, TRANSCOM SYSTEMS
* CIS ID....: 74030,703
*
* This is an original work by Ralph Oliver and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:05:58 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 12 Jun 1991 00:46:28 GLENN
* Posted a referee suggestion: Around line 118, break out if no
* occurrences (note the IF/ENDIF before the NEXT and RETURN at the
* bottom of the function).
*
* Rev 1.0 07 Jun 1991 23:03:28 GLENN
* Initial revision.
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_AT2()
* $CATEGORY$
* String
* $ONELINER$
* Find position of the nth occurrence of a substring
* $SYNTAX$
* FT_AT2( <cSearch>, <cTarget> [, <nOccurs> [, <lCaseSens> ] ] ) -> nPos
* $ARGUMENTS$
* <cSearch> is the character substring to search for.
*
* <cTarget> is the character string to search.
*
* <nOccurs> is the occurrence of cSearch to look for,
* defaults to 1.
*
* <lCaseSens> is a logical value denoting case sensitivity.
* If .F., then search is NOT sensitive to case,
* defaults to .T.
* $RETURNS$
* The position of the nth occurrence of a substring
* $DESCRIPTION$
* This function will find the nth occurrence of a substring
* within a string.
* $EXAMPLES$
* cSearch := "t"
* cTarget := "This is the day that the Lord has made."
*
* FT_AT2( cSearch, cTarget ) // Returns ( 9 )
*
* FT_AT2( cSearch, cTarget, 2 ) // Returns ( 17 )
*
* FT_AT2( cSearch, cTarget, 2, .F. ) // Returns ( 9 )
* $SEEALSO$
* FT_FINDITH()
* $END$
*/
#ifdef FT_TEST
FUNCTION MAIN()
LOCAL cSearch,cTarget,var0
CLS
? "TEST TO DEMONSTRATE EXAMPLES OF FT_AT2"
?
cSearch := 't'
? "Find occurrences of 't' in: "
cTarget := "This is the day that the Lord has made."
?? cTarget
?
var0 := ft_at2( cSearch, cTarget )
? PADR("FT_AT2( cSearch, cTarget ) -> ",40)
?? var0
?
var0 := ft_at2( cSearch, cTarget, 2 )
? PADR("FT_AT2( cSearch, cTarget, 2 ) -> ",40)
??var0
?
var0 := ft_at2( cSearch, cTarget, 2, .F. )
? PADR("FT_AT2( cSearch, cTarget, 2, .F. ) -> ",40)
??var0
?
RETURN NIL
#endif
FUNCTION FT_AT2( cSearch, cTarget, nOccurs, lCaseSens )
LOCAL nCount, nPos, nPos2 := 0
LOCAL cSubstr := cTarget
// Set default parameters as necessary.
IF lCaseSens == NIL
lCaseSens := .T.
ENDIF
IF nOccurs == NIL
nOccurs := 1
ENDIF
FOR nCount := 1 TO nOccurs
// Store position of next occurrence of cSearch.
IF lCaseSens
nPos := AT( cSearch, cSubstr )
ELSE
nPos := AT( UPPER( cSearch ), UPPER( cSubstr ) )
ENDIF
// Store position of cSearch relative to original string.
nPos2 += nPos
// Resize cSubstr
cSubstr := SUBSTR( cSubstr, AT( cSearch, cSubstr ) +1 )
// Breakout if there are no occurences here
IF nPos == 0
EXIT
ENDIF
NEXT
RETURN ( nPos2 )