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

see changelog 20000422 08:20 gmt-3

Browse Source
This commit is contained in:
Luiz Rafael Culik
2000-04-22 11:10:53 +00:00
parent 2a61e83cb6
commit 76c7390770
51 changed files with 8815 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

165
harbour/contrib/libnf/n2color.c Normal file
View File

@@ -0,0 +1,165 @@
/*
* $Id$
*/
/*
* File......: N2COLOR.C
* Author....: David Richardson
* CIS ID....: 72271,53
*
* This function is an original work by David Richardson and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 2.0 03 Mar 1997 03:05:01 JO / Phil Barnett
* commented out : if ( iColor > 15 ) in _ftI2Color()
* Rev 1.0 01 Jan 1995 03:01:00 TED
* Initial release
*
*/
/* $DOC$
* $FUNCNAME$
* FT_N2COLOR()
* $CATEGORY$
* String
* $ONELINER$
* Returns the string complement of a Clipper color number
* $SYNTAX$
* FT_COLOR2N( <nColor> ) -> cColor
* $ARGUMENTS$
* <nColor> a number representing a Clipper color
* $RETURNS$
* The string complement of a number representing a Clipper or a
* null string if the parameter is invalid
* $DESCRIPTION$
* This function is useful for converting a number to a Clipper color
* string.
* $EXAMPLES$
* cColor := FT_COLOR2N( 239 ) // returns "*+w/gr"
* $SEEALSO$
* FT_N2COLOR()
* $END$
*/
#include "hbapi.h"
static void _ftI2Color( int iColor, char * cColor );
static int _ftGetColorStr( int iColor, char * cColor );
HB_FUNC(FT_N2COLOR )
{
#if defined(HB_OS_DOS)
{
char * cColor = " ";
// make sure parameter is a numeric type
if ( ISNUM(1))
_ftI2Color( hb_parni( 1 ), cColor );
else
cColor = NULL;
hb_retc( cColor );
return;
}
#endif
}
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
// Function : _ftI2Color
// Purpose : Converts a color int to an Xbase color string
// Parameters: iColor - the color number
// *cColor - pointer to the color string
// Returns : void (string is modified directly)
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
void _ftI2Color( int iColor, char * cColor )
{
unsigned int iBack = 0, iFore = 0, i = 0;
// check for blink attribute
if ( iColor > 127 )
{
cColor[ i++ ] = '*';
iColor %= 128;
}
// check for background and foreground colors
// if ( iColor > 15 )
// {
iFore = iColor % 16;
iBack = ( iColor - iFore ) / 16;
// }
// check for intensity attrib
if ( iFore > 7 )
{
cColor[ i++ ] = '+';
iFore %= 8;
}
// get forground color
i += _ftGetColorStr( iFore, ( cColor + i ) );
// add the seperator
cColor[ i++ ] = '/';
// get background color
i += _ftGetColorStr( iBack, ( cColor + i ) );
// null terminate the color string
cColor[ i ] = 0;
return ;
}
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
// Function : _ftGetColorStr
// Purpose : Returns the corresponding Xbase color for passed number
// Parameters: iColor - a color number
// *cColor - pointer to the color string
// Returns : length of added color string
// ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
int _ftGetColorStr( int iColor, char * cColor )
{
int iLen = 0;
switch ( iColor )
{
case 0 : cColor[iLen++] = 'n'; break;
case 1 : cColor[iLen++] = 'b'; break;
case 2 : cColor[iLen++] = 'g'; break;
case 3 : cColor[iLen++] = 'b';
cColor[iLen++] = 'g'; break;
case 4 : cColor[iLen++] = 'r'; break;
case 5 : cColor[iLen++] = 'r';
cColor[iLen++] = 'b'; break;
case 6 : cColor[iLen++] = 'g';
cColor[iLen++] = 'r'; break;
case 7 : cColor[iLen++] = 'w';
}
return iLen;
}

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

@@ -0,0 +1,86 @@
/*
* File......: NETPV.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:06 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:30 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:50 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_NETPV()
* $CATEGORY$
* Math
* $ONELINER$
* Calculate net present value
* $SYNTAX$
* FT_NETPV( <nInitialInvestment>, <nInterestRate>, <aCashFlow> ;
* [, <nNoOfCashFlows> ] ) -> nNetPV
* $ARGUMENTS$
* <nInitialInvestment> is the amount of cash invested for purposes
* of generating the cash flows.
*
* <nInterestRate> is the annual interest rate used to discount
* expected cash flows (10.5% = 10.5, not .105).
*
* <aCashFlow> is an array of the expected cash receipts each year.
*
* <nNoOfCashFlows> is the number of years cash flows are expected
* (optional, Len( aCashFlow ) ).
* $RETURNS$
* The difference between the initial investment and the discounted
* cash flow in dollars.
* $DESCRIPTION$
* This function calculates the net present value, the difference
* between the cost of an initial investment and the present value
* of the expected cash flow(s) from the investment. The present
* value of the expected cashflow(s) is calculated at the specified
* interest rate, which is often referred to as the "cost of capital".
*
* This function can be used to evaluate alternative investments.
* The larger the NPV, the more profitable the investment. See
* also the FutureValue and PresentValue for further explanations.
* The formula to calculate the net present value is:
*
* NetPresentValue = SUM(CashFlow[i] / ((1 + InterestRate) ** i))
* FOR i = 1 TO NoOfCashFlows
* $EXAMPLES$
* nNetPresentValue := FT_NETPV(10000, 10, { 10000,15000,16000,17000 } )
* $END$
*/
#ifdef FT_TEST
FUNCTION MAIN()
? FT_NETPV( 10000, 10, { 10000,15000,16000,17000 } )
RETURN ( nil )
#endif
FUNCTION FT_NETPV(nInitialInvestment, nInterestRate, aCashFlow, nNoOfCashFlows)
LOCAL nNetPresentValue := 0
nNoOfCashFlows := iif( nNoOfCashFlows == nil, len( aCashFlow ), nNoOfCashFlows )
AEVAL(aCashFlow, ;
{ | nElement, nElementNo | ;
nNetPresentValue += nElement / ;
((1 + (nInterestRate / 100)) ** nElementNo) }, ;
1, nNoOfCashFlows)
RETURN (nNetPresentValue -= nInitialInvestment)

76
harbour/contrib/libnf/nooccur.prg Normal file
View File

@@ -0,0 +1,76 @@
/*
* File......: NoOccur.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:08 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:32 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:52 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_NOOCCUR()
* $CATEGORY$
* String
* $ONELINER$
* Find the number of times one string occurs in another
* $SYNTAX$
* FT_NOOCCUR( <cCheckFor>, <cCheckIn> ;
* [, <lIgnoreCase> ] ) -> <nOccurrences>
* $ARGUMENTS$
* <cCheckFor> is the string to search for
*
* <cCheckIn> is the string to search
*
* <lIgnoreCase> is a boolean variable to force case sensitivity
* (optional, defaults to .F.).
* $RETURNS$
* The number of times <cCheckFor> appears in <cCheckIn>
* $DESCRIPTION$
* This function finds the number of times a string occurs in a
* second string.
* $EXAMPLES$
* // Find the number of times "the" appears in cMemoString, case
* // insensitive
*
* nNoOfOccurrences := FT_NOOCCUR( "the", cMemoString )
*
* // Find the number of times "the" appears in cMemoString, case
* // sensitive
*
* nNoOfOccurrences := FT_NOOCCUR( "the", cMemoString, TRUE )
* $END$
*/
#define IS_NOT_LOGICAL(x) (VALTYPE(x) != "L")
#define MAKE_UPPER(x) (x := UPPER(x))
FUNCTION FT_NOOCCUR(cCheckFor, cCheckIn, lIgnoreCase)
// Is Case Important??
IF (IS_NOT_LOGICAL(lIgnoreCase) .OR. lIgnoreCase)
MAKE_UPPER(cCheckFor) // No, Force Everything to Uppercase
MAKE_UPPER(cCheckIn)
ENDIF // IS_NOT_LOGICAL(lIgnoreCase) or ;
// lIgnoreCase
RETURN (IF(LEN(cCheckFor) == 0 .OR. LEN(cCheckIn) == 0, ;
0, ;
INT((LEN(cCheckIn) - LEN(STRTRAN(cCheckIn, cCheckFor))) / ;
LEN(cCheckFor))))

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

@@ -0,0 +1,134 @@
/*
* File......: NTOW.PRG
* Author....: Gary Baren
* CIS ID....: 75470,1027
*
* This is an original work by Gary Baren and is hereby placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 15 Aug 1991 23:05:54 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 09 Jun 1991 00:26:56 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_NTOW()
* $CATEGORY$
* Conversion
* $ONELINER$
* Translate numeric value to words
* $SYNTAX$
* FT_NTOW( <nNumber> ) -> cWords
* $ARGUMENTS$
* <nNumber> An integer to translate
* $RETURNS$
* A text string representing <nNumber>
* $DESCRIPTION$
* Translates numeric input to a text string.
*
* FT_NTOW is intended to be used with integers only. Since I don't
* know what your application will be, I can't assume the type of
* fraction you want returned (ninety nine cents, 99/100, .99, etc).
* If you want the fraction in words, just pass it as an integer.
*
* Do not pass a negative number! Handle negative numbers any way
* you need to in your code. (ie: CR, DB, Negative, Minus, etc.)
*
* Also, numeric 0 is returned as a null string. You will need to
* make a decision how to output it (zero dollars, no dollars, etc).
* $EXAMPLES$
* ? FT_NTOW( 999 ) -> Nine Hundred Ninety Nine
*
* ? FT_NTOW( 1000 ) -> One Thousand
*
* ? FT_NTOW( 23 ) + " Dollars and " + FT_NTOW( 99 ) + " Cents"
* -> Twenty Three Dollars and Ninety Nine Cents
*
* ? FT_NTOW( 23 ) + " Dollars and " + "99/100"
* -> Twenty Three Dollars and 99/100
*
* x := -23.99
* cents := str( (x - int( x )) * 100, 2, 0 ) + "/100"
* x := int( x )
* string := iif( x < 0, "Credit of ", "Debit of " )
* ? string + FT_NTOW( abs(x) ) + " Dollars and " + "99/100"
* -> Credit of Twenty Three Dollars and 99/100
* $END$
*/
static ones := { "", " One", " Two", " Three", " Four", " Five", ;
" Six", " Seven", " Eight", " Nine" ;
}
static teens := { " Ten", " Eleven", " Twelve", ;
" Thirteen", " Fourteen", " Fifteen", ;
" Sixteen", " Seventeen", " Eighteen", ;
" Nineteen" ;
}
static tens := { "", "", " Twenty", " Thirty", " Forty", " Fifty", ;
" Sixty", " Seventy", " Eighty", " Ninety" }
static qualifiers := { "", " Thousand", " Million", " Billion", " Trillion" }
#ifdef FT_TEST
function main( cNum )
return qout( ft_ntow( val( cNum ) ) )
#endif
function ft_ntow(nAmount)
local nTemp, sResult := " ", nQualNo
local nDiv := 10 ^ ( int( sol10(nAmount) / 3 ) * 3 )
nTemp := int(nAmount % nDiv)
nAmount := int(nAmount / nDiv)
nQualNo := int( sol10( nDiv ) / 3 ) + 1
sResult += grp_to_words(nAmount, qualifiers[ nQualNo ] )
if nTemp > (nDiv /= 1000) .and. (nDiv > 1)
sResult += ft_ntow( nTemp, nDiv )
else
sResult += grp_to_words(nTemp, "")
endif
return( ltrim(sResult) )
static function grp_to_words(nGrp, sQual)
local sResult := "", nTemp
nTemp := int(nGrp % 100)
nGrp := int(nGrp / 100)
sResult += ones[ nGrp + 1 ] + iif( nGrp > 0, " Hundred", "")
do case
case nTemp > 19
sResult += tens[ int( nTemp / 10 ) + 1 ]
sResult += ones[ int( nTemp % 10 ) + 1 ]
case nTemp < 20 .and. nTemp > 9
sResult += teens[ int( nTemp % 10 ) + 1 ]
case nTemp < 10 .and. nTemp > 0
sResult += ones[ int( nTemp) + 1 ]
endcase
return(sResult + sQual)
static function sol10( nNumber )
local sTemp
sTemp := ltrim( str( int(nNumber), 0) )
return( len(sTemp) - 1 )

96
harbour/contrib/libnf/numlock.c Normal file
View File

@@ -0,0 +1,96 @@
/*
* $Id$
*/
/*
* File......: NUMLOCK.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.3 15 Jul 1993 00:08:46 GLENN
* Changed reference to status_byte in order to make this work in
* protected mode.
*
* Rev 1.2 15 Aug 1991 23:08:12 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 27 May 1991 14:43:20 GLENN
* Ted added a parameter to toggle the Numlock on or off.
*
* Rev 1.0 01 Apr 1991 01:02:50 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_NUMLOCK()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Return status of NumLock key
* $SYNTAX$
* FT_NUMLOCK( [ <lNewSetting> ] ) -> lCurrentSetting
* $ARGUMENTS$
* <lNewSetting> is optional and if supplied is the new setting
* for the CapLock key. Specify .T. to turn CapLock on, or .F. to
* turn it off.
* $RETURNS$
* lValue is .T. if NumLock is set, .F. if it isn't set. The value
* returned represents the setting in effect prior to any changes that
* might by made by <lNewSetting>.
* $DESCRIPTION$
* This function is useful if you need to know or set the status of the
* NumLock key for some reason.
* $EXAMPLES$
* IF FT_NUMLOCK()
* Qout( "NumLock is active" )
* ENDIF
*
* Another one, slightly strange, courtesy of Glenn Scott:
*
*
* function numBlink()
* local lOldNum := ft_numlock()
*
* while inkey( .5 ) != 27
* ft_numlock( !ft_numlock() )
* end
*
* return ft_numlock( lOldNum )
* $SEEALSO$
* FT_CAPLOCK() FT_CTRL() FT_PRTSCR() FT_SHIFT() FT_ALT()
* $END$
*/
#include <hbapi.h>
#define status_byte ( *( char * ) ( 0x00400017 ) )
HB_FUNC(FT_NUMLOCK)
{
#if defined(HB_OS_DOS)
{
hb_retl( ( int ) ( status_byte & 0x20 ) );
if ( PCOUNT )
if ( ISLOG(1) )
status_byte = ( status_byte | 0x20 );
else
status_byte = ( status_byte & 0xDF );
return;
}
#endif
}

79
harbour/contrib/libnf/nwlstat.prg Normal file
View File

@@ -0,0 +1,79 @@
/*
* File......: NWLSTAT.PRG
* Author....: Glenn Scott
* CIS ID....: ?
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:06:04 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 12 Jun 1991 02:19:46 GLENN
* Documentation correction and check for compatibility with new return
* value for ft_int86().
*
* Rev 1.0 01 Apr 1991 01:01:54 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_NWLSTAT()
* $CATEGORY$
* NetWare
* $ONELINER$
* Return the current Novell NetWare logical station number
* $SYNTAX$
* FT_NWLSTAT() -> nStatNum
* $ARGUMENTS$
* None
* $RETURNS$
* A numeric corresponding to the current logical station number
* assigned by NetWare.
* $DESCRIPTION$
* In order to find out information about a particular node logged
* in to a NetWare server, you will need the logical
* station number, also known as a "connection number." This
* function will return that number. This will be a number from 1 to 100
* under NetWare 286, or from 1 to 250 under NetWare 386. This is *not*
* the same as a physical station number.
*
* This function requires FT_INT86().
*
* This function does NOT test for the existence of the NetWare shell.
* The behavior is undefined if no shell is loaded.
* $EXAMPLES$
* QOut( "Logical station: " + str( FT_NWLSTAT() ) )
* $END$
*/
#include "FTINT86.CH"
#define DOS 33
#define STATNUM 220
#ifdef FT_TEST
FUNCTION MAIN()
QOut( "Logical station: " + str( FT_NWLSTAT() ) )
return ( nil )
#endif
FUNCTION FT_NWLSTAT()
/* LOCAL aRegs[ INT86_MAX_REGS ] */
LOCAL nStation
/*
aRegs[ AX ] = MAKEHI( STATNUM )
FT_INT86( DOS, aRegs )
*/
nStation := _ft_nwkstat() /* LOWBYTE( aRegs[ AX ] ) */
if nStation < 0
nStation += 256
endif
RETURN nStation

567
harbour/contrib/libnf/nwsem.prg Normal file
View File

@@ -0,0 +1,567 @@
/*
* File......: NWSEM.PRG
* Author....: Glenn Scott
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.4 17 Oct 1992 16:28:22 GLENN
* Leo cleaned up documentation blocks.
*
* Rev 1.3 08 Oct 1992 01:37:34 GLENN
* Added ft_nwsemUnlock() to complement ft_nwsemlock(). Modified
* the calling procedure for ft_nwsemlock() but it shouldn't break any
* existing code, although I doubt anyone's using it.
*
*
* Rev 1.2 17 Aug 1991 16:11:46 GLENN
* Oops, I forgot to comment out some test code.
*
* Rev 1.1 15 Aug 1991 23:05:34 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 28 Jun 1991 00:44:14 GLENN
* Initial revision.
*
*/
// --------------------------------------------------------------
// Semaphore Package for Novell NetWare
// --------------------------------------------------------------
#include "ftint86.ch"
#define INT21 33
#xcommand DEFAULT <v1> TO <x1> [, <vN> TO <xN> ];
=> IIF((<v1>)=NIL,<v1>:=<x1>,NIL) [; IF((<vN>)=NIL,<vN>:=<xN>,NIL)]
#define WAIT_SEMAPHORE 2
#define SIGNAL_SEMAPHORE 3
#define CLOSE_SEMAPHORE 4
// Sorry this test routine is pretty lame but it sort of gets
// the point across
#ifdef FT_TEST
#define INITIAL_SEMAPHORE_VALUE 2
#define WAIT_SECONDS 1
function main()
local nInitVal, nRc, nHandle, nValue, nOpenCnt
cls
nInitVal := INITIAL_SEMAPHORE_VALUE
FT_NWSEMOPEN( "TEST", nInitVal, @nHandle, @nOpenCnt )
qout( "Waiting ten seconds..." )
nRc := ft_nwSemWait( nHandle, 180 )
qout( "Final nRc value = " + STR( nRc ) )
inkey(0)
if nRc == 254
qout("Couldn't get the semaphore. Try again.")
quit
end
cls
@ 24, 0 say "Any key to exit"
@ 0, 0 say "Handle: " + str( nHandle )
ft_nwSemEx( nHandle, @nValue, @nOpenCnt )
while .t.
@ 23, 0 say "Semaphore test -> Open at [" + ;
alltrim(str(nOpenCnt)) + ;
"] stations, value is [" + ;
alltrim(str(nValue)) + "]"
if inkey( WAIT_SECONDS ) != 0
exit
endif
tone( nHandle,.5 )
ft_nwSemEx( nHandle, @nValue, @nOpenCnt )
end
qout( "Signal returns: " + str( ft_nwsemSig( nHandle ) ) )
qout( "Close returns: " + str( ft_nwsemClose( nHandle ) ) )
return nil
#endif
/* $DOC$
* $FUNCNAME$
* FT_NWSEMOPEN()
* $CATEGORY$
* NetWare
* $ONELINER$
* Open or create a NetWare semaphore
* $SYNTAX$
* FT_NWSEMOPEN( <cName>, <nInitVal>, <@nHandle>, <@nOpenCnt> ) -> nRc
* $ARGUMENTS$
* <cName> is the semaphore name, maximum length is 127 characters.
*
* <nInitVal> is the initial value for the semaphore. It must start
* as a positive number, to a maximum of 127.
*
* <@nHandle> is the semaphore handle. THIS MUST BE PASSED BY
* REFERENCE! On exit, <nHandle> will contain a numeric value that
* refers to the opened semaphore. You will need it to pass to
* other semaphore functions! PASS IT BY REFERENCE!
*
* <@nOpenCnt> is the number of stations that have opened the
* semaphore. THIS MUST BE PASSED BY REFERENCE! On exit, <nOpenCnt>
* will contain a numeric value.
* $RETURNS$
* nRc, a numeric result code, as follows:
*
* 0 - success
* 254 - Invalid semaphore name length
* 255 - Invalid semaphore value
*
* <nHandle> will contain the semaphore handle, and
* <nOpenCnt> will contain the number of stations that have opened
* the semaphore.
* $DESCRIPTION$
* A semaphore is simply a label that indirectly controls network
* activity. There is a semaphore name, which can be up to 127
* characters, and an associated value, which can range from 0 to
* 127.
*
* A semaphore can be used for many things, but is most often used
* to limit the number of users in an application, and to control
* access to a network resource.
*
* A semaphore essentially allows you to place locks on resources
* other than files.
*
* An application begins the process by calling FT_NWSEMOPEN().
* If the semaphore doesn't exist, NetWare will create it.
* FT_NWSEMOPEN() returns a handle that is used in other semaphore
* calls.
*
* Applications use FT_NWSEMWAIT() to wait for a semaphore to
* become available. FT_NWSEMWAIT() decrements the semaphore's
* value by 1. If the value > 0, then the application should
* be allowed to access the semaphore's resource. If the value
* goes negative, then the application is placed in a queue.
* How long your app is in the queue is determined by how you
* set the timeout parameter. If you can't get the resource in
* the time you allot, you're let out of the queue and the
* value increments by 1 again.
*
* When an application finishes with a semaphore, it should
* call FT_NWSEMSIG() to increment the value, and then
* FT_NWSEMCLOSE() to close the semaphore. When the semaphore's
* open count goes to 0, NetWare deletes it.
*
* FT_NWSEMEX() can be used to examine the value and open count
* without affecting them.
*
* For an interesting discussion on the operating system aspects
* of semaphores, check "Operating Systems Design and Implementation"
* by A. Tanenbaum, page 60. For more details on NetWare's
* semaphore facilities, refer to Charles Rose's "Programmer's
* Guide to NetWare". The "Programmer's Guide" will make an
* excellent companion guide to the source code for all NetWare
* functions in the Nanforum Toolkit.
* $EXAMPLES$
* LOCAL nInitVal, nRc, nHandle, nOpenCnt
*
* nInitVal := 2
* nRc := FT_NWSEMOPEN( "Semaphore Test", nInitVal, ;
* @nHandle, @nOpenCnt )
*
* IF nRc != 0
* QOUT =: "Error: " + STR( nRc ) )
* QUIT
* ENDIF
* $SEEALSO$
* FT_NWSEMEX() FT_NWSEMWAIT() FT_NWSEMSIG() FT_NWSEMCLOSE() FT_NWSEMLOCK()
* $END$
*/
function ft_nwSemOpen( cName, nInitVal, nHandle, nOpenCnt )
local aRegs[ INT86_MAX_REGS ], cRequest, nRet
default cName to "", ;
nInitVal to 0, ;
nHandle to 0, ;
nOpenCnt to 0
cName := iif( len( cName ) > 127, substr( cName, 1, 127 ), cName )
cRequest := chr( len( cName ) ) + cName
aRegs[ AX ] := makehi( 197 ) // C5h
aRegs[ DS ] := cRequest
aRegs[ DX ] := REG_DS
aRegs[ CX ] := nInitVal
ft_int86( INT21, aRegs )
nHandle := bin2l( i2bin( aRegs[CX] ) + i2bin( aRegs[DX] ) )
nOpenCnt := lowbyte( aRegs[ BX ] )
nRet := lowbyte( aRegs[AX] )
return iif( nRet < 0, nRet + 256, nRet )
/* $DOC$
* $FUNCNAME$
* FT_NWSEMEX()
* $CATEGORY$
* NetWare
* $ONELINER$
* Examine a NetWare semaphore's value and open count
* $SYNTAX$
* FT_NWSEMEX( <nHandle>, <@nValue>, <@nOpenCnt> ) -> nRc
* $ARGUMENTS$
* <nHandle> is the semaphore handle, returned from a previous call
* to FT_NWSEMOPEN().
*
* <@nValue> will get the current semaphore value. THIS NUMERIC
* ARGUMENT MUST BE PASSED BY REFERENCE!
*
* <@nOpenCnt> will get the current number of workstations
* that have opened the semaphore. THIS NUMERIC ARGUMENT MUST BE
* PASSED BY REFERENCE!
* $RETURNS$
* nRc, a numeric, as follows:
*
* 0 - success
* 255 - invalid semaphore handle
*
* In addition, nValue will be set to the semaphore's current value,
* and nOpenCnt will be set to the number of stations that have
* opened the semaphore.
* $DESCRIPTION$
* See the description for FT_NWSEMOPEN().
* $EXAMPLES$
* nInitVal := 2
* nHandle := 0
* nOpenCnt := 0
*
* FT_NWSEMOPEN( "Semaphore Test", nInitVal, @nHandle, @nOpenCnt )
*
* nRc := FT_NWSEMWAIT( nHandle )
* IF nRc == 254
* QOUT( "All slots for this resource are currently in use" )
* QUIT
* ENDIF
*
* FT_NWSEMEX( nHandle, @nValue, @nOpenCnt )
* QOUT( "Semaphore test -> Open at [" + ;
* ALLTRIM(STR(nOpenCnt)) + ;
* "] stations, value is [" + ;
* ALLTRIM(STR(nValue)) + "]" )
* $SEEALSO$
* FT_NWSEMOPEN() FT_NWSEMWAIT() FT_NWSEMSIG() FT_NWSEMCLOSE() FT_NWSEMLOCK()
* $END$
*/
function ft_nwSemEx( nHandle, nValue, nOpenCnt )
local aRegs[ INT86_MAX_REGS ], nRet
default nHandle to 0, ;
nValue to 0, ;
nOpenCnt to 0
aRegs[ AX ] := makehi( 197 ) + 1 // C5h, 01h
aRegs[ CX ] := bin2i( substr( l2bin( nHandle ), 1, 2 ) )
aRegs[ DX ] := bin2i( substr( l2bin( nHandle ), 3, 2 ) )
ft_int86( INT21, aRegs )
#ifdef FT_TEST
@ 5, 1 say highbyte( aregs[CX] )
@ 6, 1 say lowbyte( aregs[CX ] )
#endif
nValue := aRegs[ CX ]
nOpenCnt := lowbyte( aRegs[ DX ] )
nRet := lowbyte( aRegs[ AX ] )
return iif( nRet < 0, nRet + 256, nRet )
/* $DOC$
* $FUNCNAME$
* FT_NWSEMWAIT()
* $CATEGORY$
* NetWare
* $ONELINER$
* Wait on a NetWare semaphore (decrement)
* $SYNTAX$
* FT_NWSEMWAIT( <nHandle> [, nTimeout ] ) -> nRc
* $ARGUMENTS$
* <nHandle> is the semaphore handle, returned from a previous call
* to FT_NWSEMOPEN().
*
* <nTimeOut> is an optional parameter telling how long you wish to
* wait on this semaphore. This is a numeric indicating the number
* of clock ticks (approx 1/18 sec ) to wait. A zero (the default)
* means "don't wait."
* $RETURNS$
* nRc, a numeric, as follows:
*
* 0 - success
* 254 - timeout failure
* 255 - invalid semaphore handle
* $DESCRIPTION$
* See the description for the FT_NWSEMOPEN() function.
* $EXAMPLES$
* FT_NWSEMOPEN( "Semaphore Test", nInitVal, @nHandle, @nOpenCnt )
*
* nRc := FT_NWSEMWAIT( nHandle )
* IF nRc == 254
* QOUT( "All slots for this resource are currently in use" )
* QUIT
* ENDIF
* $SEEALSO$
* FT_NWSEMOPEN() FT_NWSEMEX() FT_NWSEMSIG() FT_NWSEMCLOSE() FT_NWSEMLOCK()
* $END$
*/
function ft_nwSemWait( nHandle, nTimeout )
return _ftnwsem( WAIT_SEMAPHORE, nHandle, nTimeout )
/* $DOC$
* $FUNCNAME$
* FT_NWSEMSIG()
* $CATEGORY$
* NetWare
* $ONELINER$
* Signal a NetWare semaphore (increment)
* $SYNTAX$
* FT_NWSEMSIG( nHandle ) -> nRc
* $ARGUMENTS$
* <nHandle> is the semaphore handle, returned from a previous call
* to FT_NWSEMOPEN().
* $RETURNS$
* nRc, a numeric, as follows
*
* 0 - success
* 1 - semaphore overflow ( value > 127 )
* 255 - invalid semaphore handle
* $DESCRIPTION$
* Use FT_NWSEMSIG() when your app has finished with the resource
* locked by a semaphore. This will increase the value (thus
* making a slot available to another app).
*
* For more information, see the description under FT_NWSEMOPEN().
* $EXAMPLES$
* QOUT( "Signal returns: " + STR( FT_NWSEMSIG( nHandle ) ) )
* $SEEALSO$
* FT_NWSEMOPEN() FT_NWSEMEX() FT_NWSEMWAIT() FT_NWSEMCLOSE() FT_NWSEMLOCK()
* $END$
*/
function ft_nwSemSig( nHandle )
return _ftnwsem( SIGNAL_SEMAPHORE, nHandle )
/* $DOC$
* $FUNCNAME$
* FT_NWSEMCLOSE()
* $CATEGORY$
* NetWare
* $ONELINER$
* Close a NetWare semaphore
* $SYNTAX$
* FT_NWSEMCLOSE( <nHandle> ) -> nRc
* $ARGUMENTS$
* <nHandle> is the semaphore handle, returned from a previous call
* to FT_NWSEMOPEN().
* $RETURNS$
* nRc, a numeric, as follows:
*
* 0 - success
* 255 - invalid semaphore handle
* $DESCRIPTION$
* Call FT_NWSEMCLOSE() when the app is finished. This decrements
* the open count for the semaphore. If the open count hits zero,
* the semaphore is deleted by NetWare.
* $EXAMPLES$
* QOUT( "Close returns: " + STR( FT_NWSEMCLOSE( nHandle ) ) )
* $SEEALSO$
* FT_NWSEMOPEN() FT_NWSEMEX() FT_NWSEMWAIT() FT_NWSEMSIG() FT_NWSEMLOCK()
* $END$
*/
function ft_nwSemClose( nHandle )
return _ftnwsem( CLOSE_SEMAPHORE, nHandle )
// ---------------------------------------------------------
// _ftnwsem() - internal for the semaphore package
// ---------------------------------------------------------
static function _ftnwsem( nOp, nHandle, nTimeout )
local aRegs[ INT86_MAX_REGS ],;
nRet
default nOp to SIGNAL_SEMAPHORE, ;
nHandle to 0, ;
nTimeout to 0
aRegs[ AX ] := makehi( 197 ) + nOp
aRegs[ CX ] := bin2i( substr( l2bin( nHandle ), 1, 2 ) )
aRegs[ DX ] := bin2i( substr( l2bin( nHandle ), 3, 2 ) )
aRegs[ BP ] := nTimeout
ft_int86( INT21, aRegs )
nRet := lowbyte( aRegs[AX] )
nRet := iif( nRet < 0, nRet + 256, nRet )
return nRet
/* $DOC$
* $FUNCNAME$
* FT_NWSEMLOCK()
* $CATEGORY$
* NetWare
* $ONELINER$
* Perform a semaphore "lock"
* $SYNTAX$
* FT_NWSEMLOCK ( <cSemaphore>, <@nHandle> ) -> lRet
* $ARGUMENTS$
* <cSemaphore> is the name of a semaphore you want to "lock."
* <nHandle> is the semaphore's handle, if you get the lock.
* THIS MUST BE PASSED BY REFERENCE!
* $RETURNS$
* lRet == .t. if you get the lock, .f. if you don't.
* If the lock succeeds, <nHandle> will contain the semaphore
* handle. If it fails, the value of <nHandle> is undefined.
*
* $DESCRIPTION$
* FT_NWSEMLOCK() uses the Nanforum Toolkit's NetWare Semaphore API
* functions in order to provide a general purpose "lock" you can use in
* a NetWare environment.
*
* An interesting byproduct of NetWare's semaphore functions is
* the "open count" which tells you how many connections have this
* semaphore open. This is different from the semaphore's _value_,
* which is set when the semaphore is opened and changed with
* signal() and wait().
*
* The point of semaphores is that you don't care how many users
* are using the resource; you merely wait on a semaphore until
* the resource becomes available or you give up. When you're done,
* you signal it and off you go.
*
* Back to the open count. FT_NWSEMLOCK() opens the semaphore
* as named in <cSemaphore>. After it is opened, the open count
* is checked. If it is anything other than 1, that means someone
* else has it (or you failed in your open) so the semaphore is
* closed and the "lock" is refused. If the value is 1, then your
* app is that 1 station so the "lock" is granted.
*
* You can use a semaphore lock to control access to anything
* that Clipper's RLOCK() and FLOCK() can't help you with, such
* as text files written with the low level file i/o functions,
* etc.
* $EXAMPLES$
* LOCAL nHandle := 0
* IF FT_NWSEMLOCK( "k:\apps\error.log", @nHandle )
* // Note, you aren't actually LOCKING this file, you are
* // just locking a semaphore by the same name. As long as
* // all apps that might be using this file are cooperating
* // with the same kind of semaphore lock, you can effectively
* // control access to the file.
* ELSE
* QOUT("Couldn't lock file.")
* ENDIF
* * Processing, then:
* FT_NWSEMUNLOCK( nHandle )
*
* $SEEALSO$
* FT_NWSEMOPEN() FT_NWSEMEX() FT_NWSEMWAIT() FT_NWSEMSIG() FT_NWSEMUNLOCK()
* $END$
*/
function ft_nwSemLock( cSemaphore, nHandle )
local nRc
local nOpenCnt := 0
nRc := FT_NWSEMOPEN( cSemaphore, 0, @nHandle, @nOpenCnt )
if nRc == 0
if nOpenCnt != 1
ft_nwSemClose( nHandle )
endif
endif
return ( nOpenCnt == 1 )
/* $DOC$
* $FUNCNAME$
* FT_NWSEMUNLOCK()
* $CATEGORY$
* NetWare
* $ONELINER$
* "Unlock" a semaphore locked by FT_NWSEMLOCK()
* $SYNTAX$
* FT_NWSEMUNLOCK( <nHandle> ) -> lRet
* $ARGUMENTS$
* <nHandle> is the semaphore handle returned from FT_NWSEMLOCK()
* $RETURNS$
* lRet == .t. if you successfully unlock the semaphore, .f. if
* you don't. If this call fails, it could be that you're passing
* an invalid semaphore handle.
* $DESCRIPTION$
*
* This call unlocks a semaphore prevsiously locked via FT_NWSEMLOCK().
* It is important that you get a valid semaphore handle from
* FT_NWSEMLOCK() before you use this call. Make sure when you call
* FT_NWSEMLOCK() that you pass a numeric parameter in for the handle
* BY REFERENCE.
* $EXAMPLES$
* LOCAL nHandle := 0
* IF FT_NWSEMLOCK( "k:\apps\error.log", @nHandle )
* // Note, you aren't actually LOCKING this file, you are
* // just locking a semaphore by the same name. As long as
* // all apps that might be using this file are cooperating
* // with the same kind of semaphore lock, you can effectively
* // control access to the file.
* ELSE
* QOUT("Couldn't lock file.")
* ENDIF
* * Processing, then:
* FT_NWSEMUNLOCK( nHandle )
*
* $SEEALSO$
* FT_NWSEMOPEN() FT_NWSEMEX() FT_NWSEMWAIT() FT_NWSEMSIG() FT_NWSEMLOCK()
* $END$
*/
function ft_nwSemUnLock( nHandle )
return ( ft_nwSemClose( nHandle ) == 0 )

125
harbour/contrib/libnf/nwuid.prg Normal file
View File

@@ -0,0 +1,125 @@
/*
* File......: NWUID.PRG
* Author....: Glenn Scott
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.4 15 Aug 1991 23:04:10 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.3 14 Jun 1991 19:52:34 GLENN
* Minor edit to file header
*
* Rev 1.2 14 Jun 1991 04:31:30 GLENN
* Return value still needs to have nulls (chr(0)) removed. Put that back
* in.
*
* Rev 1.1 12 Jun 1991 02:25:22 GLENN
* Documentation correction and revision of ft_int86() call to account
* for Ted's new string passing conventions.
*
* Rev 1.0 01 Apr 1991 01:01:56 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_NWUID()
* $CATEGORY$
* NetWare
* $ONELINER$
* Return the current Novell NetWare User ID
* $SYNTAX$
* FT_NWUID( [ <nConnection> ] ) -> cUid
* $ARGUMENTS$
* <nConnection> is a connection number, or logical station number,
* to find a userid for. Under NetWare 286, this number can be from
* 1 to 100. Under NetWare 386, 1-250. If not supplied, FT_NWUID()
* defaults to the current connection (i.e., the connection running
* the application).
* $RETURNS$
* A string containing the userid, or "login name."
* The maximum length of this string, as defined by current
* versions of Novell NetWare, is 48 characters.
* $DESCRIPTION$
* FT_NWUID() returns the current NetWare userid, or "login
* name." This is useful for implementing security or audit
* trail procedures within your programs.
*
* There is no simple way a user can "fool" this function into
* retrieving an incorrect value, provided a NetWare shell is loaded.
*
* This function requires FT_INT86() and FT_NWLSTAT()
*
* This function does NOT test for the existence of the NetWare shell.
* The behavior is undefined if no shell is loaded. You'll usually get
* garbage. This function has not been tested on NetWare 386.
* $EXAMPLES$
* QOut( "I am: " + FT_NWUID() )
*
* FOR x := 1 TO 100
* cUid := FT_NWUID( x )
* IF .NOT Empty( cUid )
* QOut( Str( x, 3 ) + Space(3) + cUid )
* ENDIF
* NEXT
* $END$
*/
#include "FTINT86.CH"
#define DOS 33
#define NW_LOG 227
#ifdef FT_TEST
FUNCTION MAIN()
local x, cUid
QOut( "I am: [" + FT_NWUID() + "]" )
QOut( "---------------------" )
for x:= 1 to 100
cUid := FT_NWUID( x )
if .not. empty( cUid )
QOut( str( x, 3 ) + space(3) + cUid )
endif
next
return ( nil )
#endif
FUNCTION FT_NWUID( nConn )
LOCAL aRegs[ INT86_MAX_REGS ], ;
cReqPkt, ;
cRepPkt
nConn := IIF( nConn == nil, FT_NWLSTAT(), nConn )
// Set up request packet
cReqPkt := chr( 22 ) // Function 22: Get Connection Information
cReqPkt += chr( nConn )
cReqPkt := i2bin( len( cReqPkt ) ) + cReqPkt
// Set up reply packet
cRepPkt := space(63)
// Assign registers
aRegs[ AX ] := MAKEHI( NW_LOG )
aRegs[ DS ] := cReqPkt
aRegs[ SI ] := REG_DS
aRegs[ ES ] := cRepPkt
aRegs[ DI ] := REG_ES
FT_INT86( DOS, aRegs )
RETURN alltrim( strtran( substr( aRegs[ ES ], 9, 48 ), chr(0) ) )

139
harbour/contrib/libnf/ontick.c Normal file
View File

@@ -0,0 +1,139 @@
/*
* File......: ONTICK.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.0 01 Jan 1995 03:01:00 TED
* Initial release
*/
/* $DOC$
* $FUNCNAME$
* FT_OnTick()
* $CATEGORY$
* Event
* $ONELINER$
* Evaluate a designated code block at a designated interval.
* $SYNTAX$
* FT_OnTick( bCode, nInterval )
* $ARGUMENTS$
* <bCode> is the code block to evaluate.
* <nInterval> is the number of clock ticks to wait between
* evaluations of the code block.
* $RETURNS$
* NIL
* $DESCRIPTION$
* This function effectively allows you to run tasks in the background
* by transparently and periodically calling a designated routine.
*
* To halt the execution of the background function, call FT_OnTick()
* with no arguments.
*
* This function makes heavy use of several undocumented internal
* routines. If this fact makes you uncomfortable then don't use
* this function, you quivering sack of cowardly slime.
* $EXAMPLES$
*
* // Set up a self-updating on-screen clock
*
* FT_OnTick( "CLOCK", 9 )
*
* procedure Clock
*
* local nRow := Row()
* local nCol := Col()
*
* @ 0, 0 say Time()
*
* SetPos( nRow, nCol )
*
* return
*
* $SEEALSO$
* $END$
*/
#include <EXTEND.API>
#include <ITEM.API>
#include <CPMI.H>
typedef union
{
long far * Address;
struct
{
unsigned int Offset;
unsigned int Segment;
} Pointer;
} LONGPTR;
void cdecl _evLow( unsigned int, void *, unsigned int );
void cdecl _bcopy( void *, void *, unsigned int );
static long far Ticks = 0;
static long far Interval = 1;
static ITEM far codeBlock;
static char inProgress = 0;
static void cdecl TickTock( void )
{
auto unsigned int ProtMode = cpmiIsProtected();
auto LONGPTR Timer;
auto EVALINFO eval;
if ( inProgress ) return;
inProgress = 1;
if ( ProtMode )
{
Timer.Pointer.Segment = cpmiProtectedPtr( ( long * ) ( 0x0000046C ), sizeof( long ) );
Timer.Pointer.Offset = 0;
if ( Timer.Pointer.Segment == 0 ) goto Exit;
}
else
Timer.Address = ( long * ) ( 0x0000046C );
if ( *Timer.Address >= ( Ticks + Interval ) ||
( *Timer.Address < Ticks ) )
{
Ticks = *Timer.Address;
_evalNew( &eval, codeBlock );
_itemRelease( _evalLaunch( &eval ) );
}
if ( ProtMode ) cpmiFreeSelector( Timer.Pointer.Segment );
Exit: inProgress = 0;
return;
}
CLIPPER FT_OnTick( void )
{
if ( _itemType( codeBlock ) == BLOCK ) _itemRelease( codeBlock );
codeBlock = _itemParam( 1 );
if ( _itemType( codeBlock ) == BLOCK )
{
Interval = _parnl( 2 );
_evLow( 5, TickTock, TRUE );
}
else
_evLow( 5, TickTock, FALSE );
return;
}

77
harbour/contrib/libnf/origin.c Normal file
View File

@@ -0,0 +1,77 @@
/*
* $Id$
*/
/*
* File......: ORIGIN.C
* Author....: Steve Larsen
* CIS ID....: 76370,1532
*
* This is an original work by K. Stephan Larsen and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 09 Nov 1992 22:35:52 GLENN
* Function was inadvertently named origin() instead of ft_origin() when
* it went from an .asm to a .c file. Renamed it back to ft_origin().
*
* Rev 1.0 03 Oct 1992 02:13:54 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ORIGIN()
* $CATEGORY$
* Environment
* $ONELINER$
* Report the drive, path and filename of the current program
* $SYNTAX$
* FT_ORIGIN() -> cString
* $ARGUMENTS$
* None
* $RETURNS$
* A string containing the full drive/directory/filename of
* the currently executing file.
* $DESCRIPTION$
* Often users will install multiple copies of application software,
* especially on networks and in situations where the user is trying
* to get around a copy protection scheme.
*
* This function enables you to learn the name and source location
* of the currently executing file, so that you may take whatever
* action you need to.
*
* Requires DOS v3.xx and above.
* $EXAMPLES$
* cMyFile := FT_ORIGIN()
*
* IF cMyFile <> "C:\APPDIR\MYFILE.EXE"
* ?"Incorrect startup file. Please remove/rename and start again"
* QUIT
* ENDIF
* $INCLUDE$
* extend.h
* $SEEALSO$
* FT_WHEREIS() FT_TREE()
* $END$
*/
#include <hbapi.h>
HB_FUNC(FT_ORIGIN)
{
#if defined(HB_OS_DOS) || defined(HB_OS_WIN_32)
{
extern char **_argv;
hb_retc( *_argv );
return;
}
#endif
}

110
harbour/contrib/libnf/page.prg Normal file
View File

@@ -0,0 +1,110 @@
/*
* File......: PAGE.PRG
* Author....: Glenn Scott
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 15 Aug 1991 23:05:18 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:52:36 GLENN
* Minor edit to file header
*
* Rev 1.1 12 Jun 1991 02:29:14 GLENN
* Documentation mods and check for ft_int86() compatibility
*
* Rev 1.0 01 Apr 1991 01:01:58 GLENN
* Nanforum Toolkit
*
*/
#include "FTINT86.CH"
#define VIDEO 16
/* $DOC$
* $FUNCNAME$
* FT_SETVPG()
* $CATEGORY$
* Video
* $ONELINER$
* Set the current video page
* $SYNTAX$
* FT_SETVPG( <nPage> ) -> NIL
* $ARGUMENTS$
* <nMode> is a valid video page.
* $RETURNS$
* NIL
* $DESCRIPTION$
* Selects the video page.
*
* For more information on graphics programming and video pages,
* consult a reference such as "Programmer's Guide to PC and PS/2
* Video Systems" (Microsoft Press).
* $EXAMPLES$
* // The following sets the current video page to 1
*
* FT_SETVPG( 1 )
* $SEEALSO$
* FT_GETVPG()
* $END$
*/
FUNCTION FT_SETVPG( nPage )
/*
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] = MAKEHI( 5 ) + nPage
FT_INT86( VIDEO, aRegs )
*/
_ft_setvpg(nPage)
RETURN( NIL )
/* $DOC$
* $FUNCNAME$
* FT_GETVPG()
* $CATEGORY$
* Video
* $ONELINER$
* Get the currently selected video page
* $SYNTAX$
* FT_GETVPG() -> <nPage>
* $ARGUMENTS$
* None.
* $RETURNS$
* The video page, as a numeric.
* $DESCRIPTION$
* Get the currently selected video page
*
* For more information on graphics programming and video pages,
* consult a reference such as _Programmer's Guide to PC and PS/2
* Video Systems_ (Microsoft Press).
*
* $EXAMPLES$
* nPage := FT_GETVPG()
* $SEEALSO$
* FT_SETVPG()
* $END$
*/
FUNCTION FT_GETVPG()
/*
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := MAKEHI( 15 )
FT_INT86( VIDEO, aRegs )
RETURN ( HIGHBYTE( aRegs[ BX ] ) ) */
Return _ft_getvpg()

224
harbour/contrib/libnf/pchr.prg Normal file
View File

@@ -0,0 +1,224 @@
/*
* File......: PCHR.PRG
* Author....: Jim Gale
* CIS ID....: 73670,2561
*
* This is an original work by Jim Gale and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 17 Aug 1991 15:40:16 GLENN
* Don Caton fixed some spelling errors in the doc
*
* Rev 1.1 15 Aug 1991 23:06:00 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 12 Jun 1991 01:45:04 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_PCHR()
* $CATEGORY$
* String
* $ONELINER$
* Convert printer control codes
* $SYNTAX$
* FT_PCHR( <cString> ) -> <cPrinterFormat>
* $ARGUMENTS$
* <cString> is the representation of the printer control codes in
* text, numeric, hexadecimal, Epson command format, or any combination
* separated by commas.
* $RETURNS$
* A character string of printer control codes.
* $DESCRIPTION$
* This function is useful for allowing the user to enter printer
* control codes in text (enclosed in double quotes), numeric,
* hexadecimal, or Epson commands preceded by a slash and returns
* the printer control code equivalent.
*
* NOTES"
*
* - Combinations of text, numbers, hex, and commands must be
* separated by commas ("A",27,&1B,/RESET).
* - Text must be enclosed in double quotes ("x").
* - Hexadecimal must be preceded by an ampersand (&1B).
* - Epson commands, listed below, must be preceded by a forward
* slash (/RESET).
*
* Epson commands: (slash commands are specific to the Epson)
*
* Job Control:
*
* /RESET or /INIT Reset or initialize the printer
* /BELL or /BEEP Cause the printer's speaker to beep (not HS)
* /CAN Clear print buffers (not MX)
* /SLOW Set low speed mode (not CR, HS, MX)
* /FAST Cancel low speed mode (not CR, HS, MX)
* /ONE Select Unidirectional mode
* /TWO Select Directional mode
* /ON Activate printer
* /OFF Turn off printer
*
* /FF or /EJECT Form Feed
*
* Page Control:
*
* /1/6 Set 6 lines per inch
* /1/8 Set 8 lines per inch
* /SKIP Set Skip perforation ON
* /SKIPOFF Set Skip perforation OFF
*
* Font Selection and Manipulation:
*
* /ITALIC Select italic char. set (only FX86, EX, LX,
* no LQ-1500, SX)
* /GRAPHIC Select graphic char. set (only FX86, EX, LX,
* no LQ-1500, SX)
* /ROMAN Choose Roman font
* /SANS Choose Sans Serif font
* /DRAFT Choose draft
* /NLQ Choose near letter quality
* /PICA Choose 10 chars per inch
* /ELITE Choose 12 chars per inch
* /COND or /SI Choose 15 chars per inch
* /EMPH Turn emphasize on
* /EMPHOFF Turn emphasize off
* /SPANISH Select spanish international char set
* /USA Select USA international char set
*
* $EXAMPLES$
* cSetUp := '27,116,1'
* Set Print ON
* ? FT_PCHR( cSetUp ) -> (CHR(27)+CHR(116)+CHR(1))
* <select Epson char. graphics>
*
* ? FT_PCHR( '27,"x",0' ) -> (CHR(27)+CHR(120)+CHR(0))
* <Epson draft mode>
*
* ? FT_PCHR( '&1B,"E"' ) -> (CHR(27)+CHR(69)) <HP reset>
*
* ? FT_PCHR( '/ELITE,/NLQ' ) ->(CHR(27)+CHR(77)+CHR(27)+CHR(120)+CHR(1))
* <Epson elite & near letter quality>
* $SEEALSO$
*
* $END$
*/
Function FT_PCHR(c_nums)
Local c_ret:='', c_st:=0,c_part,c_st2,c_hex:="0123456789ABCDEF"
Local c_upper,c_t1,c_t2
If Substr(c_nums,1,1)=','.or.Trim(c_nums)==''
Return ""
Endif
c_nums := Trim(c_nums) + ",~,"
c_part := Substr(c_nums,c_st+1,At(",",Substr(c_nums,c_st+2)))
Do While .not.(c_part=="~".or.c_part=="")
If Substr(c_part,1,1)=Chr(34)
c_st2:=At(Chr(34),Substr(c_part,2))+1
c_ret:=c_ret+Substr(c_part,2,c_st2-2)
Elseif Substr(c_part,1,1)="&"
c_upper=Upper(c_part)
c_t1=At(Substr(c_upper,2,1),c_hex)-1
If c_t1>-1
c_t2=At(Substr(c_upper,3,1),c_hex)-1
If c_t2>-1
c_t1=c_t1*16+c_t2
Endif
c_ret=c_ret+Chr(c_t1)
Endif
ElseIf (Val(c_part)>0.and.Val(c_part)<256).or.c_part="0"
c_ret=c_ret+Chr(Val(c_part))
Else
If Substr(c_part,1,1)="/"
c_upper=Upper(c_part)
Do Case
Case c_upper = '/GRAPHIC'
c_ret = c_ret + Chr(27)+Chr(116)+Chr(1)
Case c_upper = '/ITALIC'
c_ret = c_ret + Chr(27)+Chr(116)+Chr(0)
Case c_upper = '/PICTURE'
c_ret = c_ret + Chr(27)+Chr(116)+Chr(1)+;
Chr(27)+Chr(120)+Chr(1)+Chr(27)+Chr(107)+Chr(1)+;
Chr(27)+Chr(77)+Chr(27)+'U'
Case c_upper = '/COND' .or. c_upper = '/SI'
c_ret = c_ret + Chr(15)
Case c_upper = '/ROMAN'
c_ret = c_ret + Chr(27)+Chr(107)+Chr(0)
Case c_upper = '/SANS'
c_ret = c_ret + Chr(27)+Chr(107)+Chr(1)
Case c_upper = '/NLQ'
c_ret = c_ret + Chr(27)+Chr(120)+Chr(1)
Case c_upper = '/DRAFT'
c_ret = c_ret + Chr(27)+Chr(120)+Chr(0)
Case c_upper = '/ELITE'
c_ret = c_ret + Chr(27)+Chr(77)
Case c_upper = '/PICA'
c_ret = c_ret + Chr(27)+Chr(80)
Case c_upper = '/EMPHOFF'
c_ret = c_ret + Chr(27)+Chr(70)
Case c_upper = '/EMPH'
c_ret = c_ret + Chr(27)+Chr(69)
Case c_upper = '/1/6'
c_ret = c_ret + Chr(27)+Chr(50)
Case c_upper = '/1/8'
c_ret = c_ret + Chr(27)+Chr(48)
Case c_upper = '/SKIPOFF'
c_ret = c_ret + Chr(27)+Chr(79)
Case c_upper = '/SKIP'
c_ret = c_ret + Chr(27)+Chr(78)
Case c_upper = '/FF'.or.c_upper='/EJECT'
c_ret = c_ret + Chr(12)
Case c_upper = '/INIT'.or.c_upper = '/RESET'
c_ret = c_ret + Chr(27)+Chr(64)
Case c_upper = '/SPANISH'
c_ret = c_ret + Chr(27)+Chr(82)+Chr(12)
Case c_upper = '/USA'
c_ret = c_ret + Chr(27)+Chr(82)+Chr(0)
Case c_upper = '/ONE'
c_ret = c_ret + Chr(27)+'U'+Chr(1)
Case c_upper = '/TWO'
c_ret = c_ret + Chr(27)+'U'+Chr(0)
Case c_upper = '/FAST'
c_ret = c_ret + Chr(27)+'s'+Chr(0)
Case c_upper = '/SLOW'
c_ret = c_ret + Chr(27)+'s'+Chr(1)
Case c_upper = '/OFF'
c_ret = c_ret + Chr(19)
Case c_upper = '/ON'
c_ret = c_ret + Chr(17)
Case c_upper = '/BEEP' .or. c_upper='/BELL'
c_ret = c_ret + Chr(7)
Case c_upper = '/CAN'
c_ret = c_ret + Chr(24)
Endcase
Endif
Endif
c_st = At(",",Substr(c_nums,c_st+1))+c_st
c_part = Substr(c_nums,c_st+1,At(",",Substr(c_nums,c_st+2)))
Enddo
Return c_ret

90
harbour/contrib/libnf/peek.c Normal file
View File

@@ -0,0 +1,90 @@
/*
* File......: PEEK.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.3 07 Feb 1994 20:11:50 GLENN
* Ted re-wrote to make it CPMI compliant.
*
* Rev 1.2 15 Aug 1991 23:08:18 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:46 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:52 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_PEEK()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Retrieve a byte from a specified memory location.
* $SYNTAX$
* FT_PEEK( <nSegment>, <nOffset> ) -> nValue
* $ARGUMENTS$
* <nSegment> is the segment of the desired memory address.
*
* <nOffset> is the offset of the desired memory address.
* $RETURNS$
* <nValue> will be a value from 0 to 255 if all parameters were valid and
* the function was able to retrieve the desired byte.
* <nValue> will be -1 if invalid parameters were passed.
* $DESCRIPTION$
* Use this function if you have a need to examine a specific memory
* location. The function will return the byte at the specified
* address as a numeric value. If you need this value as a character,
* use the Chr() function to convert it.
*
* This function was written for version 5.1 of MicroSoft C. You may
* have to modify the source code to use another compiler.
* $EXAMPLES$
* local nVMode := FT_PEEK( 0, 1097 ) // Get the current video mode
* $END$
*/
#include <EXTEND.API>
#include <CPMI.H>
#define FP_SEG( fp ) ( *( ( unsigned int * ) &( fp ) + 1 ) )
#define FP_OFF( fp ) ( *( ( unsigned int * ) &( fp ) ) )
HB_FUNC(FT_PEEK)
{
auto unsigned int ProtMode = cpmiIsProtected();
auto unsigned char * bytePtr;
if ( ( PCOUNT >= 2 ) && ( ISNUM( 1 ) ) && ( ISNUM( 2 ) ) )
{
FP_SEG( bytePtr ) = _parni( 1 );
FP_OFF( bytePtr ) = _parni( 2 );
if ( ProtMode )
{
FP_SEG( bytePtr ) = hb_cpmiProtectedPtr( bytePtr, 1 );
FP_OFF( bytePtr ) = 0;
if ( FP_SEG( bytePtr ) == 0 ) goto Bogus;
}
_retni( ( int ) *bytePtr );
if ( ProtMode ) hb_cpmiFreeSelector( FP_SEG( bytePtr ) );
}
else
Bogus: _retni( -1 );
return;
}

234
harbour/contrib/libnf/pegs.prg Normal file
View File

@@ -0,0 +1,234 @@
/*
* File......: PEGS.PRG
* Author....: Greg Lief
* CIS ID....: 72460,1760
*
* This function is an original work by Mr. Grump and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 28 Sep 1991 03:09:44 GLENN
* Allowed "No peg at that location" messagee to exceed the boundary of the
* box at the bottom of the matrix. Just shortened the message to "No
* piece there, per Greg's instructions.
*
* Rev 1.2 15 Aug 1991 23:04:18 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:38 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:00 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_PEGS()
* $CATEGORY$
* Game
* $ONELINER$
* FT_PEGS GAME (all work and no play...)
* $SYNTAX$
* FT_PEGS() -> NIL
* $ARGUMENTS$
* None
* $RETURNS$
* NIL
* $DESCRIPTION$
* This function can be used to alleviate boredom. The object is to
* remove all pegs except one. This is done by jumping over adjacent
* pegs.
* $EXAMPLES$
* FT_PEGS()
* $END$
*/
#include "inkey.ch"
#translate SINGLEBOX(<top>, <left>, <bottom>, <right>) => ;
@ <top>, <left>, <bottom>, <right> BOX "ÚÄ¿³ÙÄÀ³ "
#translate DOUBLEBOX(<top>, <left>, <bottom>, <right>) => ;
@ <top>, <left>, <bottom>, <right> BOX 'ÉÍ»º¼ÍȺ '
memvar getlist
/*
here's the board array -- structure of which is:
board_[xx, 1] = subarray containing box coordinates for this peg
board_[xx, 2] = subarray containing all adjacent locations
board_[xx, 3] = subarray containing all target locations
board_[xx, 4] = is the location occupied or not? .T. = Yes, .F. = No
*/
static board_ := { { {0, 29, 2, 34}, {2, 4}, {3, 9}, .T. } , ;
{ {0, 37, 2, 42}, {5}, {10}, .T.} , ;
{ {0, 45, 2, 50}, {2, 6}, {1, 11}, .T. } , ;
{ {3, 29, 5, 34}, {5, 9}, {6, 16}, .T. } , ;
{ {3, 37, 5, 42}, {10}, {17}, .T. } , ;
{ {3, 45, 5, 50}, {5, 11}, {4, 18}, .T. } , ;
{ {6, 13, 8, 18}, {8, 14}, {9, 21}, .T. } , ;
{ {6, 21, 8, 26}, {9, 15}, {10, 22}, .T. } , ;
{ {6, 29, 8, 34}, {4, 8, 10, 16}, {1, 7, 11, 23}, .T. } , ;
{ {6, 37, 8, 42}, {5, 9, 11, 17}, {2, 8, 12, 24}, .T. } , ;
{ {6, 45, 8, 50}, {6, 10, 12, 18}, {3, 9, 13, 25}, .T. } , ;
{ {6, 53, 8, 58}, {11, 19}, {10, 26}, .T. } , ;
{ {6, 61, 8, 66}, {12, 20}, {11, 27}, .T. } , ;
{ {9, 13, 11, 18}, {15}, {16}, .T. } , ;
{ {9, 21, 11, 26}, {16}, {17}, .T. } , ;
{ {9, 29, 11, 34}, {9, 15, 17, 23}, {4, 14, 18, 28}, .T. } , ;
{ {9, 37, 11, 42}, {10, 16, 18, 24}, {5, 15, 19, 29}, .F. } , ;
{ {9, 45, 11, 50}, {11, 17, 19, 25}, {6, 16, 20, 30}, .T. } , ;
{ {9, 53, 11, 58}, {18}, {17}, .T. } , ;
{ {9, 61, 11, 66}, {19}, {18}, .T. } , ;
{ {12, 13, 14, 18}, {14, 22}, {7, 23}, .T. } , ;
{ {12, 21, 14, 26}, {15, 23}, {8, 24}, .T. } , ;
{ {12, 29, 14, 34}, {16, 22, 24, 28}, {9, 21, 25, 31}, .T. } , ;
{ {12, 37, 14, 42}, {17, 23, 25, 29}, {10, 22, 26, 32}, .T. } , ;
{ {12, 45, 14, 50}, {18, 24, 26, 30}, {11, 23, 27, 33}, .T. } , ;
{ {12, 53, 14, 58}, {19, 25}, {12, 24}, .T. } , ;
{ {12, 61, 14, 66}, {20, 26}, {13, 25}, .T. } , ;
{ {15, 29, 17, 34}, {23, 29}, {16, 30}, .T. } , ;
{ {15, 37, 17, 42}, {24}, {17}, .T. } , ;
{ {15, 45, 17, 50}, {25, 29}, {18, 28}, .T. } , ;
{ {18, 29, 20, 34}, {28, 32}, {23, 33}, .T. } , ;
{ {18, 37, 20, 42}, {29}, {24}, .T. } , ;
{ {18, 45, 20, 50}, {30, 32}, {25, 31}, .T. } }
function FT_PEGS
LOCAL XX, MOVE, MPOS, POSSIBLE_, BUFFER, TOPROW, OLDSCORE, MOVE2, ;
SCANBLOCK, OLDCOLOR := SETCOLOR('w/n'), ;
oldscrn := savescreen(0, 0, maxrow(), maxcol())
/*
the following code block is used in conjunction with ASCAN()
to validate entry when there is more than one possible move
*/
scanblock := { | a | a[2] == move2 }
cls
xx := 1
setcolor('w/r')
SINGLEBOX(22, 31, 24, 48)
@ 23, 33 say "Your move:"
aeval(board_, { | a, x | drawbox(x) } )
do while lastkey() != K_ESC .and. moremoves()
move := 1
setcolor('w/n')
@ 23, 44 get move picture '##' range 1, 33
read
if move > 0
do case
case ! board_[move][4]
err_msg("No piece there!")
otherwise
possible_ := {}
for xx := 1 to len(board_[move][2])
if board_[board_[move][2,xx] ][4] .and. ;
! board_[board_[move][3,xx] ][4]
aadd(possible_, { board_[move][2,xx], board_[move][3,xx] })
endif
next
// only one available move -- do it
do case
case len(possible_) = 1
// clear out original position and the position you jumped over
board_[move][4] := board_[possible_[1, 1] ][4] := .F.
board_[possible_[1, 2] ][4] := .T.
drawbox(move, board_[move])
drawbox(possible_[1,1])
drawbox(possible_[1,2])
case len(possible_) = 0
err_msg('Illegal move!')
otherwise
move2 := possible_[1, 2]
toprow := 21 - len(possible_)
setcolor('+w/b')
buffer := savescreen(toprow, 55, 22, 74)
DOUBLEBOX(toprow, 55, 22, 74)
@ toprow, 58 say 'Possible Moves'
devpos(toprow, 65)
aeval(possible_, { | a | devpos(row()+1, 65), ;
devoutpict(a[2], '##') } )
oldscore := set(_SET_SCOREBOARD, .f.)
@23, 44 get move2 picture '##' ;
valid ascan(possible_, scanblock) > 0
read
restscreen(toprow, 55, 22, 74, buffer)
set(_SET_SCOREBOARD, oldscore)
mpos := ascan(possible_, { | a | move2 == a[2] })
// clear out original position and the position you jumped over
board_[move][4] := board_[possible_[mpos, 1] ][4] := .F.
board_[move2][4] := .T.
drawbox(move)
drawbox(possible_[mpos,1])
drawbox(move2)
endcase
endcase
move := 1
endif
enddo
setcolor(oldcolor)
restscreen(0, 0, maxrow(), maxcol(), oldscrn)
return NIL
* end function FT_PEGS()
*--------------------------------------------------------------------*
static function DrawBox(nelement)
setcolor(if(board_[nelement][4], '+w/rb', 'w/n'))
@ board_[nelement][1,1], board_[nelement][1,2], board_[nelement][1,3], ;
board_[nelement][1,4] box "ÚÄ¿³ÙÄÀ³ "
DevPos(board_[nelement][1,1] + 1, board_[nelement][1,2] + 2)
DevOut(ltrim(str(nelement)))
return NIL
* end static function DrawBox()
*--------------------------------------------------------------------*
static function err_msg(msg)
local buffer := savescreen(23, 33, 23, 47)
setcursor(0)
setcolor('+w/r')
@ 23, 33 say msg
inkey(2)
setcursor(1)
restscreen(23, 33, 23, 47, buffer)
return nil
* end static function Err_Msg()
*--------------------------------------------------------------------*
static function moremoves()
local xx, yy, canmove := .f., piecesleft := 0, buffer
for xx := 1 to 33
for yy := 1 to len(board_[xx][2])
if board_[xx][4] .and. ; // if current location is filled
board_[board_[xx][2,yy] ][4] .and. ; // adjacent must be filled
! board_[board_[xx][3,yy] ][4] // target must be empty
canmove := .t.
exit
endif
next
// increment number of pieces left
if board_[xx][4]
piecesleft++
endif
next
if ! canmove
setcolor('+w/b')
buffer := savescreen(18, 55, 21, 74)
DOUBLEBOX(18, 55, 21, 74)
@ 19, 58 say "No more moves!"
@ 20, 58 say ltrim(str(piecesleft)) + " pieces left"
inkey(0)
restscreen(18, 55, 21, 74, buffer)
endif
return canmove
* end static function MoreMoves()
*--------------------------------------------------------------------*
* eof pegs.prg

127
harbour/contrib/libnf/pending.prg Normal file
View File

@@ -0,0 +1,127 @@
/*
* File......: PENDING.PRG
* Author....: Isa Asudeh
* CIS ID....: 76477,647
*
* This is an original work by Isa Asudeh and is placed in the
* public domain.
*
* Modification History
* --------------------
*
* Rev 1.1 15 Aug 1991 23:05:20 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 31 May 1991 21:18:04 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_PENDING()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Display same-line pending messages after a wait.
* $SYNTAX$
* FT_PENDING ( <cMsg>, [ <nRow> ], [ <nCol> ], ;
* [ <nWait> ], [ <cColor> ] ) -> NIL
* $ARGUMENTS$
* <cMsg> is the message string to display.
*
* <nRow> is an optional screen row for message display, default row 24.
*
* <nCol> is an optional screen col for message display, default col 0.
*
* <nWait> is an optional wait (sec) between messages, default 5 sec.
*
* <cColor> is an optional color string for displayed messages, default
* is white text over red background.
* $RETURNS$
* NIL
* $DESCRIPTION$
* A good way to display information messages during the running
* of an application is to send them all to the SAME line on the
* screen where users are expected to look for them. In order to
* give users a chance to read the current message before the next one
* is displayed we may need to insert a delay after each message.
*
* FT_PENDING() function displays messages by keeping track of
* the time of the last message and providing a delay ONLY if the next
* pending message is issued much too soon after the current one.
*
* $EXAMPLES$
* FT_PENDING("Message one",20,0,3,"W+/G") // Displays "Message one."
* // sets row to 20, col to 0.
* // wait to 3 and color to
* // bright white over green.
* FT_PENDING("Message two") // Displays "Message two", after 5 sec.
* FT_PENDING("Message three") // Displays "Message three", after 5 sec.
*
*
* Note that default row, col, wait time and color need to be set only
* once in the very first call to FT_PENDING() and only if the internal
* default values are not appropriate.
*
* $END$
*/
#ifdef FT_TEST
FUNCTION MAIN()
@0,0 CLEAR
FT_PENDING("Message one",20,0,3,"W+/G") // Displays "Message one."
// sets row to 20, col to 0.
// wait to 3 and color to
// bright white over green.
FT_PENDING("Message two") // Displays "Message two", after 5 sec.
FT_PENDING("Message three") // Displays "Message three", after 5 sec.
return ( nil )
#endif
FUNCTION FT_PENDING (cMsg, nRow, nCol, nWait, cColor)
STATIC nLast_Time := 0, nRow1 := 24, nCol1 := 0
STATIC nWait1 := 5, cColor1 := 'W+/R,X'
LOCAL nThis_Time, nTiny := 0.1, cSavColor
*
* cMsg Message to display
* nRow Row of displayed message
* nCol Col of displayed message
* nWait Wait in seconds between messages
* cColor Color of displayed message
*
IF (cMsg == NIL ) //if no message, no work
RETURN NIL
ENDIF
nRow1 := IIF( nRow <> NIL, nRow, nRow1 ) //reset display row
nCol1 := IIF( nCol <> NIL, nCol, nCol1 ) //reset display col
nWait1 := IIF ( nWait <> NIL, nWait, nWait1) //reset display wait
cColor1 := IIF (cColor <> NIL, cColor, cColor1) //reset display color
nThis_Time := SECONDS() //time of current message
IF nLast_Time == 0
nLast_Time := nThis_Time - nWait1 //for first time round.
ENDIF
IF (nThis_Time - nLast_Time) < nTiny //if messages are coming too fast,
nLast_Time := nThis_Time + nWait1 //set time counter and then
INKEY (nWait1) //wait a few seconds.
ELSE
nLast_Time := nThis_Time //set time counter for next message.
ENDIF
@nRow1,0 clear to nRow1,80 //clear the display line
cSavColor := SETCOLOR(cColor1) //save current and set display color
@nRow1,nCol1 SAY cMsg //display message
SETCOLOR( cSavColor ) //restore colors.
RETURN NIL

67
harbour/contrib/libnf/pickday.prg Normal file
View File

@@ -0,0 +1,67 @@
/*
* File......: PICKDAY.PRG
* Author....: Greg Lief
* CIS ID....: 72460,1760
*
* This is an original work by Mr. Grump and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:04:24 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:40 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:00 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_PICKDAY()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Picklist of days of week
* $SYNTAX$
* FT_PICKDAY() -> cDayOfWeek
* $ARGUMENTS$
* None
* $RETURNS$
* Character string containing day of week
* $DESCRIPTION$
* This function is ideal if you need the user to select a day.
* $EXAMPLES$
* mday := FT_PICKDAY()
* $END$
*/
#include "box.ch"
// test code
#ifdef FT_TEST
FUNCTION MAIN
QOUT("You selected " + FT_PICKDAY())
return nil
#endif
function FT_PICKDAY
LOCAL DAYS := { "SUNDAY", "MONDAY", "TUESDAY", "WEDNESDAY", "THURSDAY", ;
"FRIDAY", "SATURDAY" }, SEL := 0
LOCAL OLDSCRN := SAVESCREEN(8, 35, 16, 45), oldcolor := setcolor('+w/r')
@ 8, 35, 16, 45 box B_SINGLE + " "
/* do not allow user to Esc out, which would cause array access error */
do while sel = 0
sel = achoice(9, 36, 15, 44, days)
enddo
/* restore previous screen contents and color */
restscreen(8, 35, 16, 45, oldscrn)
setcolor(oldcolor)
return days[sel]

95
harbour/contrib/libnf/poke.c Normal file
View File

@@ -0,0 +1,95 @@
/*
* File......: POKE.C
* Author....: Ted Means
* CIS ID....: 73067,3332
*
* This is an original work by Ted Means and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 07 Feb 1994 20:13:22 GLENN
* Ted re-wrote to make it CPMI compliant.
*
* Rev 1.2 15 Aug 1991 23:08:20 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:48 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:54 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_POKE()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Write a byte to a specified memory location
* $SYNTAX$
* FT_POKE( <nSegment>, <nOffset>, <nValue> ) -> lResult
* $ARGUMENTS$
* <nSegment> is the segment of the desired memory address.
*
* <nOffset> is the offset of the desired memory address.
*
* <nValue> is the value to write to the desired memory address.
* $RETURNS$
* <lResult> will be .T. if all parameters were valid and the function was
* able to write the desired byte.
* <lResult> will be .F. if invalid parameters were passed.
* $DESCRIPTION$
* Use this function if you have a need to change the value at a specific
* memory location. The function will write the specified byte to the
* specified address. The value must be passed as a numeric; if the byte
* you wish to use is stored as a character, use the Asc() function
* to convert it.
*
* This function was written for version 5.1 of MicroSoft C. You may
* have to modify the source code to use another compiler.
* $EXAMPLES$
* FT_POKE( 0, 1047, 64) // Turn CapsLock on
* $END$
*/
#include <EXTEND.API>
#include <cpmi.H>
#define FP_SEG( fp ) ( *( ( unsigned int * ) &( fp ) + 1 ) )
#define FP_OFF( fp ) ( *( ( unsigned int * ) &( fp ) ) )
HB_FUNC( FT_POKE )
{
auto unsigned int ProtMode = hb_cpmiIsProtected();
auto unsigned char * bytePtr;
if ( ( PCOUNT >= 3 ) && ( ISNUM( 1 ) ) && ( ISNUM( 2 ) ) && ( ISNUM( 3 ) ) )
{
FP_SEG( bytePtr ) = _parni( 1 );
FP_OFF( bytePtr ) = _parni( 2 );
if ( ProtMode )
{
FP_SEG( bytePtr ) = hb_cpmiProtectedPtr( bytePtr, 1 );
FP_OFF( bytePtr ) = 0;
if ( FP_SEG( bytePtr ) == 0 ) goto Bogus;
}
*bytePtr = ( unsigned char ) _parni( 3 );
if ( ProtMode ) hb_cpmiFreeSelector( FP_SEG( bytePtr ) );
_retl( TRUE );
}
else
Bogus: _retl( FALSE );
return;
}

1960
harbour/contrib/libnf/popadder.prg Normal file
View File

File diff suppressed because it is too large Load Diff

148
harbour/contrib/libnf/proper.c Normal file
View File

@@ -0,0 +1,148 @@
/*
* $Id$
*/
/*
* File......: PROPER.C
* Author....: Robert DiFalco and Glenn Scott
* CIS ID....: 71610,1705
*
* This is an original work by Glenn Scott and Robert DiFalco
* and is placed in the public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.4 01 Jan 1995 03:01:00 TED
* Ted Means made a couple of minor mods to eliminate some (mostly
* benign) compiler warnings.
*
* Rev 1.3 28 Sep 1992 00:54:58 GLENN
* Don Caton fixed the function to conform to extend system rules.
*
* Rev 1.2 15 Aug 1991 23:08:22 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:50 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:56 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_PROPER()
* $CATEGORY$
* String
* $ONELINER$
* Convert a string to proper-name case
* $SYNTAX$
* FT_PROPER( <cString> ) -> cProperName
* $ARGUMENTS$
* <cString> is the string to be converted.
* $RETURNS$
* A string of the same length as <cString>, only converted to
* proper name case (upper/lower case).
* $DESCRIPTION$
* FT_PROPER() uses a brute-force algorithm to convert a string
* to propername case. First, it capitalizes the first letter of
* all words starting after a blank, dash, or apostrophe. This
* catches most names, including special cases such as names
* beginning with O' (O'Malley, O'Reilly) and hyphenated names
* (such as Susan Chia-Mei Lo).
*
* Next, it does a specific adjustment for words beginning in "Mc"
* It finds the first 'Mc' and capitalizes the next character after
* it. It does this for all occurrences of Mc.
*
* The original FT_PROPER() was written in Clipper by Glenn Scott
* and Mark Zechiel; it was re-written in C (and thus, optimized
* and enhanced) by Robert DiFalco.
* $EXAMPLES$
* FUNCTION main( cStr )
* OutStd( FT_PROPER( cStr ) + chr(13) + chr(10) )
* RETURN ( nil )
* $END$
*/
#include "hbapi.h"
static int _ftIsAlpha( char );
static char _ftToLower( char );
static char _ftToUpper( char );
static int _ftIsUpper( char );
static int _ftIsLower( char );
HB_FUNC(FT_PROPER )
{
#if defined(HB_OS_DOS) || defined(HB_OS_WIN_32)
{
int iLen = hb_parclen(1);
char *cStr;
int i, fCap = TRUE, iPos = 0;
hb_storc( NULL, 1 );
cStr = hb_parc(1);
for( i = 0; i < iLen + 1; i++ ) {
if( _ftIsAlpha( cStr[i] ) == TRUE ) {
if( fCap == TRUE )
cStr[i] = _ftToUpper( cStr[i] );
else cStr[i] = _ftToLower( cStr[i] );
}
fCap = ( cStr[i] == ' ' || cStr[i] == '-' || cStr[i] == 0x27 );
}
// Find "Mc"
for( i = 0; i <= iLen; i++ )
if( cStr[i] == 'M' && cStr[i+1] == 'c' ) {
cStr[i+2] = _ftToUpper( cStr[i+2] );
}
/* // If "Mc" was found, Cap next letter if Alpha
if( iPos > 1 )
if( iPos < iLen )
if( _ftIsUpper( cStr[iPos] ) == FALSE )
cStr[iPos] = _ftToUpper( cStr[iPos] );
*/
hb_retc( cStr );
return;
}
#endif
}
static int _ftIsAlpha( char c )
{
return( _ftIsUpper(c) || _ftIsLower(c));
}
static char _ftToLower( char c )
{
return(c >= 'A' && c <= 'Z' ? c - 'A' + 'a' : c);
}
static char _ftToUpper( char c )
{
return(c >= 'a' && c <= 'z' ? c - 'a' + 'A' : c);
}
static int _ftIsUpper( char c )
{
return(c >= 'A' && c <= 'Z');
}
static int _ftIsLower( char c )
{
return(c >= 'a' && c <= 'z');
}

102
harbour/contrib/libnf/prtesc.prg Normal file
View File

@@ -0,0 +1,102 @@
/*
* File......: PRTESC.PRG
* Author....: Steven Tyrakowski
* CIS ID....: ?
*
* This is an original work by Steven Tyrakowski and is placed
* in the public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:04:26 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:42 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:02 GLENN
* Nanforum Toolkit
*
*/
#ifdef FT_TEST
FUNCTION MAIN( cParm1 )
*-------------------------------------------------------
* Sample routine to test function from command line
*-------------------------------------------------------
IF PCount() > 0
? FT_ESCCODE( cParm1 )
ELSE
? "Usage: PRT_ESC 'escape code sequence' "
? " outputs converted code to standard output"
?
ENDIF
RETURN (nil)
#endif
/* $DOC$
* $FUNCNAME$
* FT_ESCCODE()
* $CATEGORY$
* Conversion
* $ONELINER$
* Convert Lotus style escape codes
* $SYNTAX$
* FT_ESCCODE( <cASCII> ) -> <cPrinterFormat>
* $ARGUMENTS$
* <cASCII> is the ASCII representation of the printer control
* codes in Lotus 123 format (e.g. "\027E" for Chr(27)+"E")
*
* "\nnn" will be converted to Chr(nnn)
* "\\" will be converted to "\"
* $RETURNS$
* The binary version of an ASCII coded printer setup string.
* $DESCRIPTION$
* This function is useful for allowing the user to enter printer
* control codes in Lotus-style ASCII format, and then having
* this function convert that code to the format that the printer
* needs to receive.
* $EXAMPLES$
* cSetup = "\015" // default = Epson compressed print
* UserInput( @cSetup ) // Let user modify setup code
* SET DEVICE TO PRINT // get ready to print
* ?? FT_ESCCODE( cSetup ) // Output the converted code
* $END$
*/
FUNCTION FT_ESCCODE( cInput )
LOCAL cOutput := "" ,;
cCurrent ,;
nPointer := 1 ,;
nLen := Len( cInput )
DO WHILE nPointer <= nLen
cCurrent := Substr( cInput, nPointer, 1 )
DO CASE
CASE cCurrent == "\" .AND. ;
IsDigit(Substr(cInput, nPointer+1, 1) ) .AND. ;
IsDigit(Substr(cInput, nPointer+2, 1) ) .AND. ;
IsDigit(Substr(cInput, nPointer+3, 1) )
cOutput += Chr(Val(Substr(cInput, nPointer+1,3)))
nPointer += 4
CASE cCurrent == "\" .AND. ;
Substr(cInput, nPointer+1, 1) == "\"
cOutput += "\"
nPointer += 2
OTHERWISE
cOutput += cCurrent
nPointer++
ENDCASE
ENDDO
RETURN cOutput

85
harbour/contrib/libnf/prtscr.c Normal file
View File

@@ -0,0 +1,85 @@
/*
* $Id$
*/
/*
* File......: PRTSCR.C
* Author....: Ted Means
* CIS ID....: 73067,3332
*
* This is an original work by Ted Means and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 01 Jan 1995 03:01:00 TED
* Added dual-mode compatibility.
*
* Rev 1.2 15 Aug 1991 23:08:24 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:54 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:58 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_PRTSCR()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Enable or disable the Print Screen key
* $SYNTAX$
* FT_PRTSCR( [ <lSetStat> ] ) -> lCurStat
* $ARGUMENTS$
* <lSetStat> set to .T. will enable the Print Screen key,
* .F. will disable it. If omitted, leaves status as is.
* $RETURNS$
* The current state: .T. if enabled, .F. if disabled.
* $DESCRIPTION$
* This function is valuable if you have a need to disable the
* printscreen key. It works by fooling the BIOS into thinking that
* a printscreen is already in progress. The BIOS will then refuse
* to invoke the printscreen handler.
* $EXAMPLES$
* FT_PRTSCR( .F. ) && Disable the printscreen key
* FT_PRTSCR( .T. ) && Enable the printscreen key
* MemVar := FT_PRTSCR() && Get the current status
* $SEEALSO$
* FT_CAPLOCK() FT_CTRL() FT_NUMLOCK() FT_SHIFT() FT_ALT()
* $END$
*/
#include <hbapi.h>
#define pbyte *( ( char * ) 0x00400100 )
HB_FUNC(FT_PRTSCR)
{
#if defined(HB_OS_DOS)
{
if ( PCOUNT && ISLOG( 1 ) )
{
if ( hb_parl( 1 ) )
pbyte = 0;
else
pbyte = 1;
}
if ( pbyte == 1)
hb_retl( FALSE );
else
hb_retl( TRUE );
return;
}
#endif
}

127
harbour/contrib/libnf/pvid.prg Normal file
View File

@@ -0,0 +1,127 @@
/*
* File......: PVID.PRG
* Author....: Ted Means
* CIS ID....: 73067,3332
*
* This is an original work by Ted Means and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 16 Oct 1992 00:05:22 GLENN
* Just making sure we had Ted's most current revision.
*
* Rev 1.0 22 Aug 1992 16:51:32 GLENN
* Initial revision.
*/
#include "SET.CH"
#define PV_ROW 1
#define PV_COL 2
#define PV_COLOR 3
#define PV_IMAGE 4
#define PV_CURSOR 5
#define PV_BLINK 6
#define PV_NOSNOW 7
#define PV_MAXROW 8
#define PV_MAXCOL 9
#define PV_SCORE 10
static aVideo := {}
/* $DOC$
* $FUNCNAME$
* FT_PUSHVID()
* $CATEGORY$
* Video
* $ONELINER$
* Save current video states on internal stack.
* $SYNTAX$
* FT_PushVid() -> <nStackSize>
* $ARGUMENTS$
* None
* $RETURNS$
* The current size of the internal stack (i.e. the number of times
* FT_PushVid() has been called).
* $DESCRIPTION$
* Menus, picklists, browses, and other video-intensive items often
* require you to save certain video states -- screen image, cursor
* position, and so forth. Constantly saving and restoring these items
* can get very tedious. This function attempts to alleviate this
* problem. When called, it saves the cursor position, color setting,
* screen image, cursor style, blink setting, scoreboard setting, snow
* setting, and maximum row and column to a series of static arrays. All
* that is needed to restore the saved settings is a call to FT_PopVid().
* $EXAMPLES$
* FT_PushVid() // Save the current video states
* $SEEALSO$
* FT_PopVid()
* $END$
*/
function FT_PushVid()
AAdd( aVideo, { row(), ;
col(), ;
setcolor(), ;
savescreen( 0, 0, maxrow(), maxcol() ), ;
set( _SET_CURSOR ), ;
setblink(), ;
nosnow(), ;
maxrow() + 1, ;
maxcol() + 1, ;
set( _SET_SCOREBOARD ) } )
return len( aVideo )
/* $DOC$
* $FUNCNAME$
* FT_POPVID()
* $CATEGORY$
* Video
* $ONELINER$
* Restore previously saved video states.
* $SYNTAX$
* FT_PopVid() -> <nStackSize>
* $ARGUMENTS$
* None
* $RETURNS$
* The number of items remaining in the internal stack.
* $DESCRIPTION$
* This is the complementary function to FT_PushVid(). At some time
* after saving the video states it will probably be necessary to restore
* them. This is done by restoring the settings from the last call to
* FT_PushVid(). The number of items on the internal stack is then
* reduced by one. Note that the use of stack logic means that items on
* the stack are retrieved in Last In First Out order.
* $EXAMPLES$
* FT_PopVid() // Restore video states
* $SEEALSO$
* FT_PushVid()
* $END$
*/
function FT_PopVid()
local nNewSize := len( aVideo ) - 1
local aBottom := ATail( aVideo )
if nNewSize >= 0
setmode( aBottom[ PV_MAXROW ], aBottom[ PV_MAXCOL ] )
set( _SET_CURSOR, aBottom[ PV_CURSOR ] )
nosnow( aBottom[ PV_NOSNOW ] )
setblink( aBottom[ PV_BLINK ] )
restscreen( 0, 0, maxrow(), maxcol(), aBottom[ PV_IMAGE ] )
setcolor( aBottom[ PV_COLOR ] )
setpos( aBottom[ PV_ROW ], aBottom[ PV_COL ] )
set( _SET_SCOREBOARD, aBottom[ PV_SCORE ] )
aSize( aVideo, nNewSize )
endif
return len( aVideo )

110
harbour/contrib/libnf/qtr.prg Normal file
View File

@@ -0,0 +1,110 @@
/*
* File......: QTR.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:41:40 GLENN
* Jo French cleaned up.
*
* Rev 1.2 15 Aug 1991 23:04:28 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:44 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:04 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_QTR()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return Calendar or Fiscal Quarter Data.
* $SYNTAX$
* FT_QTR( [ <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 quarter as a character string "YYYYQQ"
* aDateInfo[2] - The beginning date of the quarter
* aDateInfo[3] - The ending date of the quarter
* $DESCRIPTION$
* FT_QTR() returns an array containing data about the quarter
* containing the given date.
*
* Normally the return data will be based on a year beginning
* on January 1st with weeks beginning on Sunday.
*
* The beginning of year date and/or beginning of week day can be
* changed by using FT_DATECNFG(), which will affect all subsequent
* calls to FT_QTR() until another call to FT_DATECNFG().
*
* The beginning of year date and beginning of week day may be reset
* to January 1 and Sunday by calling FT_DATECNFG() with no
* parameters.
* $EXAMPLES$
* // get info about quarter containing 9/15/90
* aDateInfo := FT_QTR( CTOD("09/15/90") )
* ? aDateInfo[1] // 199003 (3rd quarter)
* ? aDateInfo[2] // 07/01/90 beginning of quarter 3
* ? aDateInfo[3] // 09/30/90 end of week quarter 3
*
* // get info about quarter 2 in year containing 9/15/90
* aDateInfo := FT_QTR( CTOD("09/15/90"), 2 )
* ? aDateInfo[1] // 199002
* ? aDateInfo[2] // 04/01/90 beginning of quarter 2
* ? aDateInfo[3] // 06/30/90 end of quarter 2
*
* // get info about quarter 2 in current year (1991)
* aDateInfo := FT_QTR( , 2 )
* ? aDateInfo[1] // 199102
* ? aDateInfo[2] // 04/01/91 beginning of quarter 2
* ? aDateInfo[3] // 06/30/91 end of quarter 2
* $SEEALSO$
* FT_DATECNFG() FT_WEEK() FT_MONTH() FT_YEAR()
* $END$
*/
FUNCTION FT_QTR(dGivenDate,nQtrNum)
LOCAL lIsQtr, nTemp, aRetVal
IF !(VALTYPE(dGivenDate) $ 'ND')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nQtrNum := dGivenDate
dGivenDate := DATE()
ENDIF
aRetval := FT_YEAR(dGivenDate)
lIsQtr := ( VALTYPE(nQtrNum) == 'N' )
IF lIsQtr
IF( nQtrNum < 1 .OR. nQtrNum > 4, nQtrNum := 4, )
dGivenDate := FT_MADD(aRetVal[2], 3*(nQtrNum - 1) )
ENDIF
nTemp := MONTH( dGivenDate ) - MONTH( aRetVal[2] )
nTemp += IF( nTemp >= 0, 1, 13 )
nTemp := INT( (nTemp - 1) / 3 )
aRetVal[1] += PADL(LTRIM(STR( nTemp + 1, 2)), 2, '0')
aRetVal[2] := FT_MADD( aRetVal[2], nTemp * 3 )
aRetVal[3] := FT_MADD( aRetVal[2], 3 ) - 1
RETURN aRetVal

77
harbour/contrib/libnf/rand1.prg Normal file
View File

@@ -0,0 +1,77 @@
/*
* File......: RAND1.PRG
* Author....: Gary Baren
* CIS ID....: 75470,1027
*
* This is an original work by Gary Baren and is hereby placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:04:30 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:46 GLENN
* Minor edit to file header
*
* Rev 1.0 07 Jun 1991 23:03:38 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_RAND1()
* $CATEGORY$
* Math
* $ONELINER$
* Generate a random number
* $SYNTAX$
* FT_RAND1( <nMax> ) -> nRand
* $ARGUMENTS$
* <nMax> Maximum limit of value to be produced.
* $RETURNS$
* nRand is a random number between 0 (inclusive) and <nMax> (exclusive).
* $DESCRIPTION$
* Generates a non-integer random number based on the Linear
* Congruential Method.
*
* If you need a random number between 1 and <nMax> inclusive, INT()
* the result and add 1.
*
* If you need a random number between 0 and <nMax> inclusive,
* then you should ROUND() the result.
* $EXAMPLES$
* nResult := INT( FT_RAND1(100) ) + 1 // 1 <= nResult <= 100
* nResult := ROUND( FT_RAND1(100), 0 ) // 0 <= nResult <= 100
* nResult := FT_RAND1( 1 ) // 0 <= nResult < 1
* $END$
*/
#ifdef FT_TEST
// Write 100 random numbers from 1 to 100 to stdout.
// Run it multiple times and redirect output to a file
// to check it
function main()
local x
for x := 1 to 100
outstd( int( ft_rand1(100) ) )
outstd( chr(13) + chr(10) )
next
return nil
#endif
function ft_rand1(nMax)
static nSeed
local m := 100000000, b := 31415621
nSeed := iif( nSeed == NIL, seconds(), nSeed ) // init_seed()
return( nMax * ( ( nSeed := mod( nSeed*b+1, m ) ) / m ) )

68
harbour/contrib/libnf/restsets.prg Normal file
View File

@@ -0,0 +1,68 @@
/*
* File......: RestSets.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:34 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 27 May 1991 13:04:20 GLENN
* Minor documentation change.
*
* Rev 1.0 01 Apr 1991 01:02:06 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_RESTSETS()
* $CATEGORY$
* Environment
* $ONELINER$
* Restore status of all SET command settings
* $SYNTAX$
* FT_RESTSETS( [ <aOldSets> ] ) -> NIL
* $ARGUMENTS$
* aOldSets is an array of SET settings created by FT_SAVESETS()
* $RETURNS$
* NIL
* $DESCRIPTION$
* This function "restores" the SET Settings, i.e., it sets them to the
* values in the array aOldSets. The following SETs are not currently
* supported: FILTER, FORMAT, FUNCTION, INDEX, KEYS, MODE, ORDER,
* PROCEDURE, RELATION, TYPEAHEAD
* $EXAMPLES$
* FT_RESTSETS(aOldSets)
* $INCLUDE$
* SET.CH
* $SEEALSO$
* FT_SAVESETS() FT_SETCENTURY()
* $END$
*/
#include "set.ch"
#Define FT_EXTRA_SETS 2
#DEFINE FT_SET_CENTURY _SET_COUNT + 1
#DEFINE FT_SET_BLINK _SET_COUNT + 2
FUNCTION FT_RESTSETS(aOldSets)
AEVAL(aOldSets, ;
{ | xElement, nElementNo | ;
SET(nElementNo, xElement) }, ;
1, _SET_COUNT )
FT_SETCENTURY(aOldSets[FT_SET_CENTURY])
SETBLINK(aOldSets[FT_SET_BLINK])
RETURN (NIL) // FT_RestSets

104
harbour/contrib/libnf/rmdir.c Normal file
View File

@@ -0,0 +1,104 @@
/*
* $Id$
*/
/* File......: RMDIR.ASM
* 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.2 15 Aug 1991 23:07:12 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:54:58 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:03:52 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_RMDIR()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Delete a subdirectory
* $SYNTAX$
* FT_RMDIR( <cDirName> ) -> nResult
* $ARGUMENTS$
* <cDirName> is the name of the directory to delete.
* $RETURNS$
* 0 if successful
* 3 if Path Not Found
* 5 if Access Denied (directory not empty)
* 16 if attempt to delete current directory.
* 99 if invalid parameters passed
* $DESCRIPTION$
* This function is useful if you need to remove a subdirectory for
* some reason.
*
* The source code is written to adhere to Turbo Assembler's IDEAL mode.
* To use another assembler, you will need to rearrange the PROC and
* SEGMENT directives, and also the ENDP and ENDS directives (a very
* minor task).
* $EXAMPLES$
* FT_RMDIR( "C:\CLIPPER" )
* FT_RMDIR( "\EXAMPLE" )
* FT_RMDIR( "..\SOURCE" )
* $END$
*/
/*This is the Original FT_RMDIR() code
IDEAL
Public FT_RMDIR
Extrn __ftdir:Far
Segment _NanFor Word Public "CODE"
Assume CS:_NanFor
Proc FT_RMDIR Far
Mov AH,3Ah * DOS service--remove directory
Push AX * Save on stack
Call __ftdir * Call generic directory routine
Add SP,2 * Realign stack
Ret
Endp FT_RMDIR
Ends _NanFor
End
*/
/* This is the New one Rewriten in C*/
#include "extend.h"
#include "dos.h"
HB_FUNC(FT_RMDIR)
{
#if defined(HB_OS_DOS)
{
int Status;
char *path=hb_parc(1);
union REGS regs;
struct SREGS sregs;
segread(&sregs);
regs.h.ah=0x3A ;
sregs.ds=FP_SEG(path);
regs.HB_XREGS.dx=FP_OFF(path);
int86x(0x21,&regs,&regs,&sregs);
Status=regs.HB_XREGS.ax;
hb_retni(Status);
}
#endif
}

185
harbour/contrib/libnf/round.prg Normal file
View File

@@ -0,0 +1,185 @@
/*
* File......: Round.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:05:30 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:48 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:08 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ROUND()
* $CATEGORY$
* Math
* $ONELINER$
* Rounds a number to a specific place
* $SYNTAX$
* FT_ROUND( <nNumber> [, <nRoundToAmount> ;
* [, <cRoundType> [, <cRoundDirection> ;
* [, <nAcceptableError> ] ] ] ] ) -> nNumber
* $ARGUMENTS$
* <nNumber> is the number to round
*
* <nRoundToAmount> is the fraction to round to or the number of places,
* default is 2.
*
* <cRoundType> is the type of rounding desired
*
* "D" for Decimal (3 for thousandth, 1/1000) (default)
* "F" for Fraction (3 for thirds, 1/3)
* "W" for Whole numbers (3 for thousand, 1000)
*
* <cRoundDirection> is the direction to round the number toward
*
* "U" to round Up 1.31 -> 1.4
* -1.31 -> -1.4
* "D" to round Down 1.36 -> 1.3
* -1.36 -> -1.3
* "N" to round Normal 1.5 -> 2
* -1.5 -> -2
* 1.49 -> 1
* -1.49 -> -1
*
* <nAcceptableError> is the amount that is considered acceptable
* to be within, i.e., if you're within this amount of the number
* you don't need to round
* $RETURNS$
* The number, rounded as specified.
* $DESCRIPTION$
* This function will allow you to round a number. The following can
* be specified:
* a. Direction (up, down or normal - normal is 4/5 convention)
* b. Type (whole, decimal, fraction)
* c. Amount (100's, 5 decimals, 16th, etc.)
* $EXAMPLES$
* // round normal to 2 decimal places
* nDollars := FT_ROUND(nDollars)
*
* // round normal to 6 decimal places
* nIntRate := FT_ROUND(nIntRate, 6)
*
* // round to nearest thousands
* nPrice := FT_ROUND(nPrice, 3, NEAREST_WHOLE_NUMBER)
*
* // round Up to nearest third
* nAmount := FT_ROUND(nAmount, 3, NEAREST_FRACTION, ROUND_UP)
*
* // round down to 3 decimals Within .005
* nAvg := FT_ROUND(nAvg, 3, , ROUND_DOWN, .005)
* $END$
*/
#define IS_NEGATIVE(x) ((x) < 0)
#define NEAREST_DECIMAL "D"
#define NEAREST_FRACTION "F"
#define NEAREST_WHOLE_NUMBER "W"
#define ROUND_DOWN "D"
#define ROUND_NORMAL "N"
#define ROUND_UP "U"
#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>)]
FUNCTION FT_ROUND(nNumber, nRoundToAmount, cRoundType, cRoundDirection, ;
nAcceptableError)
LOCAL nResult := ABS(nNumber) // The Result of the Rounding
DEFAULT nRoundToAmount TO 2, ;
cRoundType TO NEAREST_DECIMAL, ;
cRoundDirection TO ROUND_NORMAL, ;
nAcceptableError TO 1 / (nRoundToAmount ** 2)
// Are We Rounding to the Nearest Whole
// Number or to Zero Decimal Places??
IF (LEFT(cRoundType,1) != NEAREST_WHOLE_NUMBER .AND. ;
(nRoundToAmount := INT(nRoundToAmount)) != 0)
// No, Are We Rounding to the Nearest
// Decimal Place??
IF (LEFT(cRoundType,1) == NEAREST_DECIMAL)
// Yes, Convert to Nearest Fraction
nRoundToAmount := 10 ** nRoundToAmount
ENDIF // LEFT(cRoundType,1) == NEAREST_DECIMAL
// Are We Already Within the Acceptable
// Error Factor??
IF (ABS(INT(nResult * nRoundToAmount) - (nResult * nRoundToAmount)) > ;
nAcceptableError)
// No, Are We Rounding Down??
nResult -= IIF(LEFT(cRoundDirection,1) == ROUND_DOWN, ;
; // Yes, Make Downward Adjustment
1 / nRoundToAmount / 2, ;
; // Are We Rounding Up??
IIF(LEFT(cRoundDirection,1) == ROUND_UP , ;
; // Yes, Make Upward Adjustment
-1 / (nRoundToAmount) / 2, ;
; // No, Rounding Normal, No Adjustment
0))
//Do the Actual Rounding
nResult := INT((nRoundToAmount * nResult) + .5 + nAcceptableError) / ;
nRoundToAmount
ENDIF // ABS(INT(nResult * nRoundToAmount) -
// (mResult * nRoundAmount)) >
// nAcceptableError
ELSE // Yes, Round to Nearest Whole Number
// or to Zero Places
nRoundToAmount := MAX(nRoundToAmount, 1)
DO CASE // Do "Whole" Rounding
CASE LEFT(cRoundDirection,1) == ROUND_UP
nResult := (INT(nResult / nRoundToAmount) * nRoundToAmount) + ;
nRoundToAmount
CASE LEFT(cRoundDirection,1) = ROUND_DOWN
nResult := INT(nResult / nRoundToAmount) * nRoundToAmount
OTHERWISE // Round Normally
nResult := INT((nResult + nRoundToAmount / 2) / nRoundToAmount) * ;
nRoundToAmount
ENDCASE
ENDIF // LEFT(cRoundType,1)!=NEAREST_WHOLE or
// nRoundToAmount == 0
IF IS_NEGATIVE(nNumber) // Was the Number Negative??
nResult := -nResult // Yes, Make the Result Negative Also
ENDIF // IS_NEGATIVE(nNumber)
RETURN (nResult) // FT_Round

279
harbour/contrib/libnf/savearr.prg Normal file
View File

@@ -0,0 +1,279 @@
/*
* 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])
?? ' '
?? IF(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, IF(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

79
harbour/contrib/libnf/savesets.prg Normal file
View File

@@ -0,0 +1,79 @@
/*
* File......: SaveSets.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:05:06 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 12 Apr 1991 00:18:04 GLENN
* There was a call to SETCENTURY() that should have been FT_SETCENTURY().
* Another one of those errors that came from testing earlier versions of
* a routine before FT_ prefix was added to function names. Lesson learned.
*
* Rev 1.0 01 Apr 1991 01:02:10 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SAVESETS()
* $CATEGORY$
* Environment
* $ONELINER$
* Save the status of all the SET command settings
* $SYNTAX$
* FT_SAVESETS() -> aOldSets
* $ARGUMENTS$
* None
* $RETURNS$
* An array containing the values of the supported SETs.
* $DESCRIPTION$
* This function saves the SET Settings, i.e., it copies them into an
* array, aOldSets. The following SETs are not currently supported:
* FILTER, FORMAT, FUNCTION, INDEX, KEYS, MODE, ORDER, PROCEDURE,
* RELATION, TYPEAHEAD
* $EXAMPLES$
* aOldSets := FT_SAVESETS()
* $INCLUDE$
* SET.CH
* $SEEALSO$
* FT_RESTSETS() FT_SETCENTURY()
* $END$
*/
#include "set.ch"
#Define FT_EXTRA_SETS 2
#DEFINE FT_SET_CENTURY _SET_COUNT + 1
#DEFINE FT_SET_BLINK _SET_COUNT + 2
#IFDEF FT_TEST
FUNCTION MAIN
LOCAL ASETS := FT_SAVESETS()
INKEY(0)
RETURN Nil
#endif
FUNCTION FT_SAVESETS()
LOCAL aOldSets := ARRAY(_SET_COUNT + FT_EXTRA_SETS)
AEVAL(aOldSets, ;
{ | xElement, nElementNo | ;
aOldSets[nElementNo] := SET(nElementNo) } )
aOldSets[FT_SET_CENTURY] := FT_SETCENTURY()
aOldSets[FT_SET_BLINK] := SETBLINK()
RETURN (aOldSets) // FT_SaveSets

103
harbour/contrib/libnf/scancode.prg Normal file
View File

@@ -0,0 +1,103 @@
/*
* File......: SCANCODE.PRG
* Author....: Glenn Scott (from John Kaster)
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 15 Aug 1991 23:04:32 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:52:52 GLENN
* Minor edit to file header
*
* Rev 1.1 12 Jun 1991 02:30:32 GLENN
* Documentation mod and check for ft_int86() compatibility
*
* Rev 1.0 01 Apr 1991 01:02:12 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SCANCODE()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Wait for keypress and return keyboard scan code
* $SYNTAX$
* FT_SCANCODE() -> cCode
* $ARGUMENTS$
* None
* $RETURNS$
* A two-character string, corresponding to the keyboard scan code.
* $DESCRIPTION$
* FT_SCANCODE() enables you to distinguish the different scancodes
* of similar keys (such as Grey minus versus regular minus), thus
* increasing the number of keys your input routine can recognize.
*
* It works like INKEY(), in that it waits for a key to be pressed.
* The scan code consists of two bytes, which are returned as a
* two-character string.
*
* For example, calling FT_SCANCODE() and pressing the Grey-minus
* key will return a two character string:
*
* CHR(45) + CHR(74)
*
* LASTKEY() is not updated by FT_SCANCODE(), so don't try to
* test LASTKEY() to see what was pressed during an FT_SCANCODE()
* call. Simply assign the return value to a variable and test
* that (see the test driver below).
*
* * This was adapted from a short C routine posted by John Kaster on
* NANFORUM. It was written in Clipper to help demonstrate the
* FT_INT86 function of the Nanforum Toolkit.
*
* This program requires FT_INT86().
* $EXAMPLES$
* cKey := FT_SCANCODE()
*
* [grey-] returns: CHR(45) + CHR(74)
* [-] returns: CHR(45) + CHR(12)
* [grey+] returns: CHR(43) + CHR(78)
* [+] returns: CHR(43) + CHR(13)
* $END$
*/
#include "FTINT86.CH"
#define KEYB 22
#ifdef FT_TEST
#DEFINE SCANCODE_ESCAPE (chr(27) + chr(1))
FUNCTION main()
LOCAL getlist, cKey
CLEAR
QOut("Press any key, ESCape to exit:")
while .t.
cKey := FT_SCANCODE()
QOUT( "chr(" + str(asc(substr(cKey,1,1)),3) + ")+chr(" + str(asc(substr(cKey,2,1)),3) + ")" )
if cKey == SCANCODE_ESCAPE
exit
endif
end
RETURN nil
#endif
FUNCTION FT_SCANCODE()
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] = MAKEHI( 0 )
FT_INT86( KEYB, aRegs )
RETURN ( chr(LOWBYTE( aRegs[AX] )) + chr(HIGHBYTE( aRegs[AX] )) )

225
harbour/contrib/libnf/scregion.prg Normal file
View File

@@ -0,0 +1,225 @@
/*
* File......: SCREGION.PRG
* Author....: David A. Richardson
* CIS ID....: ?
*
* This is an original work by David A. Richardson and is hereby placed
* in the public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:05:46 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:56 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:14 GLENN
* Nanforum Toolkit
*
*/
STATIC aRgnStack:={}
/* $DOC$
* $FUNCNAME$
* FT_SAVRGN()
* $CATEGORY$
* Video
* $ONELINER$
* Save a screen region for later display
* $SYNTAX$
* FT_SAVRGN( <nTop>, <nLeft>, <nBottom>, <nRight> ) -> cScreen
* $ARGUMENTS$
* <nTop>, <nLeft>, <nBottom>, and <nRight> define the portion of the
* screen to save. Allowable values are 0 through 255.
* $RETURNS$
* FT_SAVRGN() returns the saved screen region and its coordinates
* as a character string.
* $DESCRIPTION$
* FT_SAVRGN() is similar to Clipper's SAVESCREEN(), but it saves the
* screen coordinates as well as the display information. The saved
* area can be restored by passing the returned string to FT_RSTRGN().
*
* Note that the strings returned from FT_SAVRGN() and Clipper's
* SAVESCREEN() are not interchangeable. A screen region saved with
* with FT_SAVRGN() must be restored using FT_RSTRGN().
*
* FT_SAVRGN() calls Clipper's SAVESCREEN(). Refer to the Clipper
* documentation for more information regarding this function.
* $EXAMPLES$
* The following example uses FT_SAVRGN() and FT_RSTRGN() to save
* and restore a portion of the screen.
*
* @ 00, 00, 24, 79 BOX "111111111" // fill the screen with 1's
* cScreen = FT_SAVRGN(10, 10, 20, 30) // save a region
* @ 00, 00, 24, 79 BOX "222222222" // fill the screen with 2's
* FT_RSTRGN(cScreen) // restore the 1's region
* $SEEALSO$
* FT_RSTRGN() FT_RGNSTACK()
* $END$
*/
FUNCTION FT_SAVRGN(nTop, nLeft, nBottom, nRight)
RETURN (CHR(nTop) + CHR(nLeft) + CHR(nBottom) + CHR(nRight) + ;
SAVESCREEN(nTop, nLeft, nBottom, nRight))
/* $DOC$
* $FUNCNAME$
* FT_RSTRGN()
* $CATEGORY$
* Video
* $ONELINER$
* Restore region of the screen saved with FT_SAVRGN()
* $SYNTAX$
* FT_RSTRGN( <cScreen>, [ <nTop> ], [ <nLeft> ] ) -> NIL
* $ARGUMENTS$
* <cScreen> is a screen region previously returned from FT_SAVRGN().
*
* <nTop> and <nLeft> are optional parameters that define a new location
* for the upper left corner of the screen area contained in <cScreen>.
* Allowable values are 0 through 255.
* $RETURNS$
* FT_RSTRGN() returns NIL.
* $DESCRIPTION$
* FT_RSTRGN() restores a screen region previously saved with
* FT_SAVRGN(). Calling FT_RSTRGN() with <cScreen> as the only
* parameter will restore the saved region to its original location.
* <nTop> and <nLeft> may be used to define a new location for the
* upper left corner of the saved region.
*
* <nTop> and <nLeft> are dependent upon each other. You may not
* specify one without the other.
*
* FT_RSTRGN() calls Clipper's RESTSCREEN(). Refer to the Clipper
* documentation for more information regarding this function.
* $EXAMPLES$
* The following example uses FT_RSTRGN() to restore a saved portion
* of the screen to different locations.
*
* @ 00, 00, 24, 79 BOX "111111111" // fill the screen with 1's
* cScreen = FT_SAVRGN(10, 10, 20, 30) // save a region
* @ 00, 00, 24, 79 BOX "222222222" // fill the screen with 2's
* FT_RSTRGN(cScreen) // restore the 1's region
* @ 00, 00, 24, 79 BOX "222222222" // fill the screen with 2's
* FT_RSTRGN(cScreen, 15, 15) // restore to a different location
* @ 00, 00, 24, 79 BOX "222222222" // fill the screen with 2's
* FT_RSTRGN(cScreen, 20, 60) // restore to a different location
* $SEEALSO$
* FT_SAVRGN() FT_RGNSTACK()
* $END$
*/
FUNCTION FT_RSTRGN(cScreen, nTop, nLeft)
IF PCOUNT() == 3
RESTSCREEN(nTop, nLeft, (nTop - ASC(cScreen)) + ASC(SUBSTR(cScreen, 3)), ;
(nLeft - ASC(SUBSTR(cScreen, 2))) + ASC(SUBSTR(cScreen, 4)), ;
SUBSTR(cScreen, 5))
ELSE
RESTSCREEN(ASC(cScreen), ASC(SUBSTR(cScreen, 2)), ASC(SUBSTR(cScreen, 3)), ;
ASC(SUBSTR(cScreen, 4)), SUBSTR(cScreen, 5))
ENDIF
RETURN NIL
/* $DOC$
* $FUNCNAME$
* FT_RGNSTACK()
* $CATEGORY$
* Video
* $ONELINER$
* Push or pop a saved screen region on or off the stack
* $SYNTAX$
* FT_RGNSTACK( <cAction>, [ <nTop> ], [ <nLeft> ], [ <nBottom> ],
* [ <nRight> ] ) -> NIL
* $ARGUMENTS$
* <cAction> determines what action FT_RGNSTACK() will take. The
* allowable values for this parameter are "push", "pop", and "pop all".
* If the function is called with any other string as the first parameter
* no action is performed.
*
* <cAction> with a value of "push" will push a saved screen region onto
* the stack. A value of "pop" will restore the most recently pushed
* screen region. "pop all" tells the function to restore all screen
* images which are currently on the stack.
*
* The use of <nTop>, <nLeft>, <nBottom>, and <nRight> depends on the
* <cAction> parameter. If <cAction> is "push", the next four parameters
* define the screen region to save. If <cAction> is "pop" or "pop all"
* the following four parameters are ignored.
* $RETURNS$
* FT_RGNSTACK() returns NIL.
* $DESCRIPTION$
* FT_RGNSTACK() allows multiple screens to be saved and restored from
* a stack. The stack is implemented with Clipper static array that is
* visible only to FT_RGNSTACK().
*
* The purpose of FT_RGNSTACK() is to allow multiple screen regions to be
* managed without the need to remember the original coordinates or to
* create variables for each one.
*
* When called with "push", FT_RGNSTACK() places the saved screen area
* at the end of the static array. The array size is incremented by one
* to accommodate the new screen area.
*
* When called with "pop", the function restores the screen image stored
* in the last element of the array, and the array size is decremented by
* one. If "pop all" is specified, all the saved screens are restored
* until the array is empty.
*
* FT_RGNSTACK() calls FT_SAVRGN() and FT_RSTRGN(). Refer to the
* documentation for these two functions for more information.
* $EXAMPLES$
* The following example uses FT_RGNSTACK() to save and restore various
* sections of the screen.
*
* @ 00, 00, 24, 79 BOX "111111111" // fill the screen with 1's
* FT_RGNSTACK("push", 10, 05, 15, 15) // push a region
* @ 00, 00, 24, 79 BOX "222222222" // fill the screen with 2's
* FT_RGNSTACK("push", 10, 20, 15, 30) // push a region
* @ 00, 00, 24, 79 BOX "333333333" // fill the screen with 3's
* FT_RGNSTACK("push", 10, 35, 15, 45) // push a region
* @ 00, 00, 24, 79 BOX "444444444" // fill the screen with 4's
* FT_RGNSTACK("push", 10, 50, 15, 60) // push a region
* @ 00, 00, 24, 79 BOX "555555555" // fill the screen with 5's
* FT_RGNSTACK("push", 10, 65, 15, 75) // push a region
* CLEAR
* FT_RGNSTACK("pop") // restore the 5's region
* FT_RGNSTACK("pop") // restore the 4's region
* FT_RGNSTACK("pop all") // restore the 3's, 2's and 1's regions
* $SEEALSO$
* FT_SAVRGN() FT_RSTRGN()
* $END$
*/
FUNCTION FT_RGNSTACK(cAction, nTop, nLeft, nBottom, nRight)
STATIC nStackPtr := 0
LOCAL nPopTop
IF cAction == "push"
ASIZE(aRgnStack, ++nStackPtr)[nStackPtr] = ;
FT_SAVRGN(nTop, nLeft, nBottom, nRight)
ELSEIF cAction == "pop" .OR. cAction = "pop all"
nPopTop = IIF("all" $ cAction, 0, nStackPtr-1)
DO WHILE nStackPtr > nPopTop
FT_RSTRGN(aRgnStack[nStackPtr--])
ENDDO
ASIZE(aRgnStack, nStackPtr)
ENDIF
RETURN NIL

96
harbour/contrib/libnf/setdate.prg Normal file
View File

@@ -0,0 +1,96 @@
/*
* File......: SETDATE.PRG
* Author....: Glenn Scott
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 15 Aug 1991 23:04:36 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:52:58 GLENN
* Minor edit to file header
*
* Rev 1.1 12 Jun 1991 02:32:28 GLENN
* Documentation mod and change documented return value from "n" to "l"
* reflecting Ted's update of ft_int86().
*
* Rev 1.0 01 Apr 1991 01:02:16 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SETDATE()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Set the DOS system date
* $SYNTAX$
* FT_SETDATE( <dDate> ) -> <lResult>
* $ARGUMENTS$
* <dDate> is a Clipper date variable that you want to set the current
* DOS system date to.
*
* It is up to you to send in a valid date. The
* year must be within the range 1980 through 2099. If DOS
* thinks the date is not valid, it won't change the date.
*
* $RETURNS$
* <lResult> is simply the result of FT_INT86(), passed back
* to your program.
*
* $DESCRIPTION$
* FT_SETDATE() uses NANFOR.LIB's FT_INT86() function to invoke
* the DOS Set Date service (Interrupt 33, service 43).
*
* $EXAMPLES$
*
* The following program takes a date from the command line and sets
* the DOS system date:
*
* FUNCTION main( cDate )
*
* cDate := iif( cDate == nil, dtoc( date() ), cDate )
* QOut( "Setting date to: " + cDate + "... " )
* FT_SETDATE( ctod( cDate ) )
* Qout( "Today is now: " + dtoc( date() ) )
*
* RETURN ( nil )
*
* $END$
*/
#include "FTINT86.CH"
#define DOS 33
#define SETDATE 43
#ifdef FT_TEST
FUNCTION MAIN( cDate )
cDate := iif( cDate == nil, dtoc( date() ), cDate )
QOut( "Setting date to: " + cDate + "... " )
FT_SETDATE( ctod( cDate ) )
Qout( "Today is now: " + dtoc( date() ) )
return ( nil )
#endif
function FT_SETDATE( dDate )
local aRegs[ INT86_MAX_REGS ]
dDate := iif( valtype(dDate) != "D", date(), dDate )
aRegs[ AX ] = SETDATE * ( 2 ^ 8 )
aregs[ CX ] = year( dDate )
aregs[ DX ] = ( month( dDate ) * ( 2 ^ 8 ) ) + day( dDate )
return( FT_INT86( DOS, aRegs ) )

97
harbour/contrib/libnf/settime.prg Normal file
View File

@@ -0,0 +1,97 @@
/*
* File......: SETTIME.PRG
* Author....: Glenn Scott
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 15 Aug 1991 23:06:08 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:53:00 GLENN
* Minor edit to file header
*
* Rev 1.1 12 Jun 1991 02:34:58 GLENN
* Documentation mods: change documented return value form "n" to "l" in
* accordance with the new return value from ft_int86().
*
* Rev 1.0 01 Apr 1991 01:02:16 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SETTIME()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Set the DOS system time
* $SYNTAX$
* FT_SETTIME( <cTime> ) -> <lResult>
* $ARGUMENTS$
* <cTime> is a string in the form <hh:mm:ss> that you want to set
* the current DOS system time to.
*
* Use 24-hour time. It is up to you to send in a valid time. If
* DOS doesn't think it is valid, it won't reset the time anyway.
* $RETURNS$
* <lResult> is simply the result of FT_INT86(), passed back
* to your program.
*
* $DESCRIPTION$
* FT_SETTIME() uses NANFOR.LIB's FT_INT86() function to invoke
* the DOS Set Time service (Interrupt 33, service 45).
*
* $EXAMPLES$
*
* The following program takes a time string from the command line and sets
* the DOS system time:
*
* FUNCTION main( cTime )
*
* cTime := iif( cTime == nil, time(), cTime )
* QOut( "Setting time to: " + cTime + "... " )
* FT_SETTIME( cTime )
* Qout( "Time is now: " + time() )
*
* RETURN ( nil )
*
* $END$
*/
#include "FTINT86.CH"
#define DOS 33
#define SETTIME 45
#define SECS( ts ) ( val( substr( ts, 7 ) ) )
#define HRS( ts ) ( val( substr( ts, 1, 2 ) ) )
#define MINS( ts ) ( val( substr( ts, 4, 2 ) ) )
#ifdef FT_TEST
FUNCTION MAIN( cTime )
cTime := iif( cTime == nil, time(), cTime )
QOut( "Setting time to: " + cTime + "... " )
FT_SETTIME( cTime )
Qout( "Time is now: " + time() )
return ( nil )
#endif
function FT_SETTIME( cTime )
local aRegs[ INT86_MAX_REGS ]
cTime := iif( cTime == nil, time(), cTime )
// -------- High Byte ------ ----- Low Byte -------
aRegs[ AX ] = SETTIME * ( 2 ^ 8 )
aRegs[ CX ] = HRS( cTime ) * ( 2 ^ 8 ) + MINS( cTime )
aRegs[ DX ] = SECS( cTime ) * ( 2 ^ 8 )
return( FT_INT86( DOS, aRegs ) )

74
harbour/contrib/libnf/shift.c Normal file
View File

@@ -0,0 +1,74 @@
/*
* $Id$
*/
/*
* File......: SHIFT.C
* Author....: Ted Means
* CIS ID....: 73067,3332
*
* This is an original work by Ted Means and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.4 15 Jul 1993 23:53:12 GLENN
* Dropped _MK_FP for the preferred 0x00400017
*
* Rev 1.3 15 Jul 1993 08:06:46 GLENN
* Added call to _MK_FP() in order to make this work in protected mode.
*
* Rev 1.2 15 Aug 1991 23:08:26 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:56 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:03:00 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SHIFT()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Determine status of shift key
* $SYNTAX$
* FT_SHIFT() -> lValue
* $ARGUMENTS$
* None
* $RETURNS$
* .T. if a shift key is pressed, .F. if otherwise.
* $DESCRIPTION$
* This function is useful for times you need to know whether or not the
* shift key is pressed, such as during a MemoEdit().
* $EXAMPLES$
* IF FT_SHIFT()
* @24, 0 say "Shift"
* ELSE
* @24, 0 say " "
* ENDIF
* $SEEALSO$
* FT_CAPLOCK() FT_CTRL() FT_NUMLOCK() FT_PRTSCR() FT_ALT()
* $END$
*/
#include <hbapi.h>
HB_FUNC(FT_SHIFT )
{
#if defined(HB_OS_DOS)
{
hb_retl( ( int ) ( ( *( char * ) 0x00400017 ) & 0x3 ) );
return;
}
#endif
}

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

@@ -0,0 +1,90 @@
/*
* File......: SINKEY.PRG
* Author....: Greg Lief
* CIS ID....: 72460,1760
*
* This is an original work by Greg Lief and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:06:10 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:02 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:18 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SINKEY()
* $CATEGORY$
* Keyboard/Mouse
* $ONELINER$
* Replacement for INKEY() that tests for SET KEY procedures
* $SYNTAX$
* FT_SINKEY( [ <nWaitTime> ] ) -> nKey
* $ARGUMENTS$
* <nWaitTime> is the number of seconds to wait. If zero,
* FT_SINKEY() will wait indefinitely for a keypress. If not
* passed, FT_SINKEY() does not wait for a keypress. If NIL,
* it is treated the same as 0.
* $RETURNS$
* The INKEY() value of the key pressed.
* $DESCRIPTION$
* FT_SINKEY() is similar to the function provided by Nantucket in
* KEYBOARD.PRG, with one significant difference: you can pass NIL
* to INKEY(), which will be treated as a zero (i.e., wait indefinitely
* for keypress). Therefore, it is necessary to differentiate between
* an explicit NIL and one that is a result of a formal parameter NOT
* being received.
*
* FT_SINKEY() differs from the standard INKEY() in that it will
* respond to any keys set with SET KEY TO or SetKey().
* $EXAMPLES$
* SetKey( K_F1, {|n,l,r| Help(n,l,r) } )
* nKey := FT_SINKEY(0) // Help() will be called if F1 pressed
* $END$
*/
FUNCTION FT_SINKEY(waittime)
LOCAL key, cblock
DO CASE
/* if no WAITTIME passed, go straight through */
CASE pcount() == 0
key := inkey()
/* dig this... if you pass inkey(NIL), it is identical to INKEY(0)!
therefore, I allow you to pass FT_SINKEY(NIL) -- hence this mild bit
of convolution */
CASE waittime == NIL .AND. Pcount() == 1
key := inkey(0)
OTHERWISE
key := inkey(waittime)
ENDCASE
cblock := Setkey(key)
IF cblock != NIL
// run the code block associated with this key and pass it the
// name of the previous procedure and the previous line number
Eval(cblock, Procname(1), Procline(1), NIL)
ENDIF
RETURN key

108
harbour/contrib/libnf/sleep.prg Normal file
View File

@@ -0,0 +1,108 @@
/*
* File......: SLEEP.PRG
* Author....: Leo Letendre
* CIS ID....: 73607,233
*
* This is an original work by Leo Letendre and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 17 Oct 1992 16:18:18 GLENN
* Leo cleaned up the doc and file header.
*
* Rev 1.0 01 Jul 1992 02:19:12 GLENN
* Initial revision.
*
*/
#ifdef FT_TEST
* Test routine
* Invoke by running SLEEP 1.0 to sleep 1.0 seconds
*
FUNCTION MAIN(nSleep)
? "Time is now: " + time()
FT_SLEEP(VAL(nSleep))
? "Time is now: " + time()
RETURN ( nil )
#endif
/* $DOC$
* $FUNCNAME$
* FT_SLEEP
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Wait for a specified amount of time
* $SYNTAX$
* FT_SLEEP( <nSeconds>, [<nInitial>] ) -> nil
* $ARGUMENTS$
* <nSeconds> is the number of seconds to pause
*
* <nInitial> is an optional clock value (from a call to SECONDS())
* from which the <nSeconds> seconds are to elapse. Useful
* for setting a minimum time between the start of events
* which could take a variable amount of time due to the
* execution of intervening code.
* $RETURNS$
* NIL
* $DESCRIPTION$
* This routine will wait a specified period of time. It provides
* resolution based upon the execution of the SECONDS() function.
* It does not use an input state such as INKEY(). The specified time
* is the minimum time sleeping and will usually be slightly longer.
*
* The second optional argument allows one to begin timing an event
* prior to executing some operation. This is useful when, for example,
* you input a key or mouse click and wish to do something but still want
* to note if the user double entered (mouse or key) within a certain time
* which in turn may have meaning within your program's context.
*
* The routine correctly handles passing through midnight but will not
* work for more than 24 hours.
* $EXAMPLES$
* Example 1:
* FT_SLEEP(10.0) && Sleep for 10.0 seconds
* Example 2:
* nTime=SECONDS() && usually after some interupt from mouse or
* && keyboard
*
* ... intervening code ...
*
* FT_SLEEP(0.5, nTime) && Sleep until the sytem clock is
* && nTime+0.5 seconds.
*
* $END$
*/
FUNCTION FT_SLEEP( nSeconds, nInitial )
IF nInitial == NIL .OR. VALTYPE( nInitial ) != "N"
nInitial := SECONDS()
ENDIF
// correct for running at midnight
IF nInitial + nSeconds > 86399
nInitial -= 86399
* Wait until midnight
DO WHILE SECONDS() > 100 // no problem with a _very_ slow machine
ENDDO
ENDIF
// calculate final time
nSeconds += ninitial
// Loop until we are done
DO WHILE ( SECONDS() < nSeconds )
ENDDO
RETURN NIL

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

@@ -0,0 +1,134 @@
/*
* File......: SQZN.PRG
* Author....: Joseph D. Booth, Sr.
* CIS ID....: 72040,2112
*
* This is an original work by Joseph D. Booth Sr. and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 15 Aug 1991 23:04:38 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 13 Jun 1991 15:21:36 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SQZN()
* $CATEGORY$
* Conversion
* $ONELINER$
* Compress a numeric value into a character string
* $SYNTAX$
* FT_SQZN( <nValue> [, <nSize> [, <nDecimals> ] ] ) -> cCompressed
* $ARGUMENTS$
* nValue - The numeric value to be compressed
* nSize - Optional size of numeric field, defaults to 10
* nDecimals - Optional number of decimal places, defaults to 0
* $RETURNS$
* cCompressed - Compressed string, 50% the size of nSize
* $DESCRIPTION$
*
* The FT_SQZN function allows a numeric value to be compressed when
* stored in the database. The compression is 50% the storage space
* of the original number. The companion function, FT_UNSQZN returns
* the original number from the compressed string.
*
* $EXAMPLES$
*
* replace TRANS->cust_id with FT_SQZN(mcust_id,8),;
* TRANS->amount with FT_SQZN(mamount,12,2)
*
* $SEEALSO$
* FT_UNSQZN()
* $INCLUDE$
*
* $END$
*/
function ft_sqzn(nValue,nSize,nDecimals)
local tmpstr,cCompressed,k
nSize := if(nSize ==NIL,10,nSize )
nDecimals := if(nDecimals==NIL, 0,nDecimals )
nValue := nValue * (10**nDecimals)
nSize := if(nSize/2<>int(nSize/2),nSize+1,nSize)
tmpstr := str( abs(nValue),nSize )
tmpstr := strtran(tmpstr," ","0")
cCompressed := chr( val(substr(tmpstr,1,2))+if(nValue<0,128,0) )
for k := 3 to len(tmpstr) step 2
cCompressed += chr(val(substr(tmpstr,k,2)))
next
return cCompressed
/* $DOC$
* $FUNCNAME$
* FT_UNSQZN()
* $CATEGORY$
* Conversion
* $ONELINER$
* Uncompress a numeric compressed by FT_SQZN()
* $SYNTAX$
* FT_UNSQZN( <cCompressed>, <nSize> [, <nDecimals> ] ) -> nValue
* $ARGUMENTS$
* <cCompressed> - Compressed string, obtained from FT_SQZN()
*
* <nSize> - Size of numeric field
*
* <nDecimals> - Optional number of decimal places
* $RETURNS$
* nValue - Uncompressed numeric value
* $DESCRIPTION$
*
* The FT_UNSQZN function returns the numeric value from the compressed
* string. The compression is 50% the storage space of the original
* number. The original number must have been compressed using the
* FT_SQZN() function.
*
* This function, along with FT_SQZN() can be used to reduce disk storage
* requirements for numeric fields in a database file.
*
* $EXAMPLES$
*
* mcust_id := FT_UNSQZN(TRANS->cust_id,8),;
* mamount := FT_UNSQZN(TRANS->amount,12,2)
*
* $SEEALSO$
* FT_SQZN()
* $INCLUDE$
*
* $END$
*/
function ft_unsqzn(cCompressed,nSize,nDecimals)
local tmp:="",k,cValue,multi:=1
nSize := if(nSize ==NIL,10,nSize )
nDecimals := if(nDecimals==NIL, 0,nDecimals)
cCompressed := if(multi ==-1,substr(cCompressed,2),cCompressed)
nSize := if(nSize/2<>int(nSize/2),nSize+1,nSize)
if asc(cCompressed) > 127
tmp := str(asc(cCompressed)-128,2)
multi := -1
else
tmp := str(asc(cCompressed),2)
endif
for k := 2 to len(cCompressed)
tmp += str(asc(substr(cCompressed,k,1)),2)
next
tmp := strtran(tmp," ","0")
cValue := substr(tmp,1,nSize-nDecimals)+"."+substr(tmp,nSize-nDecimals+1)
return val(cValue) * multi

64
harbour/contrib/libnf/stod.c Normal file
View File

@@ -0,0 +1,64 @@
/*
* $Id$
*/
/*
* File......: STOD.C
* Author....: Clayton Neff
* CIS ID....:
*
* This is an original work by Clayton Neff and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:08:28 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:58 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:03:00 GLENN
* Nanforum Toolkit
*
*
*/
/* $DOC$
* $FUNCNAME$
* FT_STOD()
* $CATEGORY$
* Conversion
* $ONELINER$
* Convert a date string to a Clipper date data type
* $SYNTAX$
* FT_STOD( <cDateStr> ) -> dDateType
* $ARGUMENTS$
* <cDateStr> is a Clipper string in the format "CCYYMMDD".
* $RETURNS$
* A Clipper date type.
* $DESCRIPTION$
* This function allows the programmer to hard code a date into the
* program without knowing what the current date type is. This
* function is the converse of the Clipper DTOS() function.
* $EXAMPLES$
* LOCAL dMyDate
* dMyDate := FT_STOD( "19901127" )
* $END$
*/
#include "hbapi.h"
HB_FUNC(FT_STOD)
{
#if defined(HB_OS_DOS) || defined(HB_OS_WIN_32)
{
hb_retds( hb_parc(1) ) ;
return;
}
#endif
}

72
harbour/contrib/libnf/sysmem.prg Normal file
View File

@@ -0,0 +1,72 @@
/*
* File......: SYSMEM.PRG
* Author....: Glenn Scott
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.4 17 Aug 1991 15:46:10 GLENN
* Don Caton fixed some spelling errors in the doc
*
* Rev 1.3 15 Aug 1991 23:04:40 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:53:04 GLENN
* Minor edit to file header
*
* Rev 1.1 12 Jun 1991 02:41:50 GLENN
* Documentation mod and check for ft_int86() compatibility
*
* Rev 1.0 01 Apr 1991 01:02:20 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_SYSMEM()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Determine the amount of conventional memory installed
* $SYNTAX$
* FT_SYSMEM() -> nMemSize
* $ARGUMENTS$
* None
* $RETURNS$
* A numeric corresponding to the number of K memory.
* $DESCRIPTION$
* FT_SYSMEM() simply reports the amount of conventional memory
* (up to 640K) installed.
*
* FT_SYSMEM() uses DOS interrupt 12h to get this information.
* For information, refer to Peter Norton's _Programmer's Guide
* to the IBM PC_ (Brady).
*
* $EXAMPLES$
* QOut( "Conventional memory installed: " + Str( FT_SYSMEM() ) + "K" )
* $END$
*/
#include "FTINT86.CH"
#define MEMSIZE 18
#ifdef FT_TEST
FUNCTION MAIN()
QOut( "Conventional memory: " + str( FT_SYSMEM() ) + "K installed" )
return ( nil )
#endif
FUNCTION FT_SYSMEM()
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] := 0
FT_INT86( MEMSIZE, aRegs )
RETURN ( aRegs[ AX ] )

496
harbour/contrib/libnf/tbwhile.prg Normal file
View File

@@ -0,0 +1,496 @@
/*
* File......: TBWHILE.PRG
* Author....: Jim Orlowski
* CIS ID....: ?
*
* This is an original work by Jim Orlowski and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.4 28 Sep 1991 02:56:56 GLENN
* Moved Jim's "Tricks used" comment out of the file header and
* into the source code area.
*
* Rev 1.3 28 Sep 1991 02:52:22 GLENN
* Jim's modifications:
*
* 1. Changed SAVESCREEN() and RESTSCREEN to use MaxRow(), MaxCol()
* instead of 24,79
*
* 2. Added Nantucket's cleaner code for:
* - Cleaned up logic around line 334 while loop section
* - Added refreshCurrent and another stabilize around line 349
* - TbSkipWhile was redone
* Note: Leo's line was changed to:
* ELSEIF ( n > 0 .AND. RECNO() <> LASTREC() + 1)
*
* 3. Added DispBegin() and DispEnd() around both Stabilize sections
*
*
*
*
* Rev 1.2 15 Aug 1991 23:04:20 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:08 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:22 GLENN
* Nanforum Toolkit
*
*/
/* The tricks are:
*
* 1. Setting up functions for goTop() and goBottom() so that you can
* quickly move to the right record when the user presses the
* Ctrl-PgUp ( goTop() ) and Ctrl-PgDn ( goBottom() ) keys.
*
* 2. Passing and evaluating the block for the TbSkipWhil().
*/
#command DEFAULT <param> TO <val> [, <paramn> TO <valn> ];
=> ;
<param> := IIF(<param> = NIL, <val>, <param> ) ;
[; <paramn> := IIF(<paramn> = NIL, <valn>, <paramn> ) ]
#include "inkey.ch"
#ifdef FT_TEST
/*
* THIS DEMO SHOWS TBNAMES.DBF CONSISTING OF LAST, FIRST, ADDR, CITY,
* STATE, ZIP WITH ACTIVE INDEX ON LAST + FIRST. IT SHOWS LAST NAME,
* FIRST NAME, CITY ONLY FOR THOSE LAST NAMES THAT BEGIN WITH LETTER
* THAT YOU INPUT FOR THE CKEY GET.
*
* TBNAMES.DBF/.NTX ARE AUTOMATICALLY CREATED BY THIS TEST PROGRAM
*/
#INCLUDE "SETCURS.CH"
FUNCTION TBWHILE()
LOCAL aFields := {}, cKey := "O", cOldColor
LOCAL nFreeze := 1, lSaveScrn := .t., nRecSel
LOCAL cColorList := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
LOCAL cColorShad := "N/N"
FIELD last, first
MEMVAR GetList
IF ! FILE( "TBNAMES.DBF" )
MAKE_DBF()
ENDIF
USE TBNames
IF ! FILE( "TBNAMES.NTX" )
INDEX ON last + first TO TBNAMES
ENDIF
SET INDEX TO TBNAMES
* Pass Heading as character and Field as Block including Alias
* To eliminate the need to use FIELDWBLOCK() function in FT_BRWSWHL()
AADD(aFields, {"Last Name" , {||TBNames->Last} } )
AADD(aFields, {"First Name", {||TBNames->First} } )
AADD(aFields, {"City" , {||TBNames->City} } )
cOldColor := SetColor("N/BG")
CLEAR SCREEN
@ 5,10 SAY "Enter First Letter Of Last Name:" GET cKey PICTURE "!"
READ
* TBNames->Last = cKey is the Conditional Block passed to this function
* you can make it as complicated as you want, but you would then
* have to modify TBWhileSet() to find first and last records
* matching your key.
nRecSel := FT_BRWSWHL( aFields, {||TBNames->Last = cKey}, cKey, nFreeze,;
lSaveScrn, cColorList, cColorShad, 3, 6, MaxRow() - 2, MaxCol() - 6)
* Note you can use Compound Condition
* such as cLast =: "Pierce " and cFirst =: "Hawkeye "
* by changing above block to:
* {||TBNames->Last = cLast .AND. TBNames->First = cFirst}
* and setting cKey := cLast + cFirst
?
IF nRecSel == 0
? "Sorry, NO Records Were Selected"
ELSE
? "You Selected " + TBNames->Last +" "+ ;
TBNames->First +" "+ TBNames->City
ENDIF
?
WAIT
SetColor(cOldColor)
CLEAR SCREEN
RETURN nil
STATIC FUNCTION make_dbf
LOCAL x, aData := { ;
{ "SHAEFER","KATHRYN","415 WEST CITRUS ROAD #150","LOS ANGELES","CA","90030" },;
{ "OLSON","JAMES","225 NORTH RANCH ROAD","LOS ANGELES","CA","90023" },;
{ "KAYBEE","JOHN","123 SANDS ROAD","CAMARILLO","CA","93010" },;
{ "HERMAN","JIM","123 TOON PAGE ROAD","VENTURA","CA","93001" },;
{ "BURNS","FRANK","123 VIRGINA STREET","OXNARD","CA","93030" },;
{ "PIERCE","HAWKEYE","123 OLD TOWN ROAD","PORT MUGU","CA","93043" },;
{ "MORGAN","JESSICA","123 FRONTAGE ROAD","CAMARILLO","CA","93010" },;
{ "POTTER","ROBERT","123 FIR STREET","OXNARD","CA","93030" },;
{ "WORTH","MARY","123-1/2 JOHNSON DRIVE","OXNARD","CA","93033" },;
{ "JOHNSON","SUSAN","123 QUEENS STREET","OXNARD","CA","93030" },;
{ "SAMSON","SAM","215 MAIN STREET","OXNARD","CA","93030" },;
{ "NEWNAME","JAMES","215 MAIN STREET","LOS ANGELES","CA","90000" },;
{ "OLEANDAR","JILL","425 FLORAL PARK DRIVE","FLORAL PARK","NY","10093" },;
{ "SUGARMAN","CANDY","1541 SWEETHEART ROAD","HERSHEY","PA","10132" } }
DbCreate( "TBNAMES", { { "LAST ", "C", 18, 0, } ,;
{ "FIRST", "C", 9, 0, } ,;
{ "ADDR ", "C", 28, 0, } ,;
{ "CITY ", "C", 21, 0, } ,;
{ "STATE", "C", 2, 0, } ,;
{ "ZIP ", "C", 9, 0, } } )
USE tbnames
FOR x := 1 TO Len( aData )
APPEND BLANK
Aeval( aData[x], {|e,n| FieldPut( n, e ) } )
NEXT
USE
RETURN NIL
#endif
/* ------------------------------------------------------------------- */
/* $DOC$
* $FUNCNAME$
* FT_BRWSWHL()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Browse an indexed database limited to a while condition
* $SYNTAX$
* FT_BRWSWHL( <aFields>, <bWhileCond>, <cKey>, ;
* [ <nFreeze> ], [ <lSaveScrn> ], [ <cColorList> ], ;
* [ <cColorShadow> ], [ <nTop> ], [ <nLeft> ], ;
* [ <nBottom> ], [ <nRight> ] -> nRecno
* $ARGUMENTS$
* <aFields> is array of field blocks of fields you want to display.
* Example to set up last name and first name in array:
* aFields := {}
* AADD(aFields, {"Last Name" , {||Names->Last} } )
* AADD(aFields, {"First Name", {||Names->First} } )
*
* <bWhileCond> is the limiting WHILE condition as a block.
* Example 1: { ||Names->Last == "JONES" }
* Example 2: { ||Names->Last == "JONES" .AND. Names->First == "A" }
*
* <cKey> is the key to find top condition of WHILE.
* cLast := "JONES "
* cFirst := "A"
* Example 1: cKey := cLast
* Example 2: cKey := cLast + cFirst
*
* <nFreeze> is number of fields to freeze in TBrowse. Defaults
* to 0 if not passed.
*
* <lSaveScrn> is a logical indicating whether or not you want to
* save the screen from the calling program. Defaults to .T. if
* not passed.
*
* <cColorList> is a list of colors for the TBrowse columns.
* The 1st color is used as SAY/TBrowse Background and the
* 3rd and 4th colors are used as part of column:defColor := {3, 4}
* Thus if you pass a cColorList, you MUST pass at least 4 colors.
* Defaults to "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R" if not passed.
*
* <cColorShad> is the color of the TBrowse box shadow. Defaults
* to "N/N" if not passed.
*
* <nTop>, <nLeft>, <nBottom>, <nRight> are the coordinates of
* the area to display the TBrowse in. Defaults to 2, 2,
* MAXROW() - 2, MAXCOL() - 2 with shadowed box, i.e. full screen.
* $RETURNS$
* nRecno is the number of the record selected by the <Enter> key.
* 0 is returned if there are either no records matching the WHILE
* condition or an <Esc> is pressed instead of an <Enter>
* $DESCRIPTION$
* This is a demonstration of TBrowse with a WHILE condition for an
* indexed database.
* $EXAMPLES$
* * This example will only show those people with last name of "JONES"
* * in the TBNames.dbf which contains at least the fields:
* * Last, First, City AND is indexed on Last + First.
* LOCAL nRecSel := 0
* LOCAL aFields := {}
* LOCAL bWhile := {||TBNames->Last = "JONES"}
* LOCAL cKey := "JONES"
* LOCAL nFreeze := 1
* LOCAL lSaveScrn := .t.
* LOCAL cColorList := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
* LOCAL cColorShad := "N/N"
*
* USE TBNames INDEX TBNames NEW // indexed on Last + First
*
* * Pass Heading as character and Field as Block including Alias
* * To eliminate the need to use FIELDWBLOCK() function in FT_BRWSWHL()
* AADD(aFields, {"Last Name" , {||TBNames->Last} } )
* AADD(aFields, {"First Name", {||TBNames->First} } )
* AADD(aFields, {"City" , {||TBNames->City} } )
*
* IF FT_BRWSWHL( aFields, bWhile, cKey, nFreeze, lSaveScrn, ;
* cColorList, cColorShad, 3, 6, MaxRow() - 2, MaxCol() - 6) == 0
* ? "Sorry, NO Records Were Selected"
* ELSE
* ? "You Selected: " + TBNames->Last +" "+ ;
* TBNames->First +" "+ TBNames->City
* ENDIF
* $END$
*/
FUNCTION FT_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
cColorList, cColorShad, nTop, nLeft, nBottom, nRight )
LOCAL b, column, cType, i
LOCAL cHead, bField, lKeepScrn, cScrnSave
LOCAL cColorSave, cColorBack, nCursSave
LOCAL lMore, nKey, nPassRec
DEFAULT nFreeze TO 0, ;
lSaveScrn TO .t., ;
cColorList TO "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R", ;
cColorShad TO "N/N", ;
nTop TO 2, ;
nLeft TO 2, ;
nBottom TO MaxRow() - 2, ;
nRight TO MaxCol() - 2
lKeepScrn := (PCOUNT() > 6)
SEEK cKey
IF .NOT. FOUND() .OR. LASTREC() == 0
RETURN(0)
ENDIF
/* make new browse object */
b := TBrowseDB(nTop, nLeft, nBottom, nRight)
/* default heading and column separators */
b:headSep := "ÍÑÍ"
b:colSep := " ³ "
b:footSep := "ÍÏÍ"
/* add custom 'TbSkipWhil' (to handle passed condition) */
b:skipBlock := {|x| TbSkipWhil(x, bWhileCond)}
/* Set up substitute goto top and goto bottom */
/* with While's top and bottom records */
b:goTopBlock := {|| TbWhileTop(cKey)}
b:goBottomBlock := {|| TbWhileBot(cKey)}
/* colors */
b:colorSpec := cColorList
/* add a column for each field in the current workarea */
FOR i = 1 TO LEN(aFields)
cHead := aFields[i, 1]
bField := aFields[i, 2]
/* make the new column */
column := TBColumnNew( cHead, bField )
/* these are color setups from tbdemo.prg from Nantucket */
* IF ( cType == "N" )
* column:defColor := {5, 6}
* column:colorBlock := {|x| if( x < 0, {7, 8}, {5, 6} )}
*ELSE
* column:defColor := {3, 4}
*ENDIF
/* To simplify I just used 3rd and 4th colors from passed cColorList */
/* This way 1st is SAY, 2nd is GET, 3rd and 4th are used here,
/* 5th is Unselected Get, extras can be used as in tbdemo.prg */
column:defColor := {3, 4}
b:addColumn(column)
NEXT
/* freeze columns */
IF nFreeze <> 0
b:freeze := nFreeze
ENDIF
/* save old screen and colors */
IF lSaveScrn
cScrnSave = SAVESCREEN(0, 0, MaxRow(), MaxCol())
ENDIF
cColorSave := SetColor()
/* Background Color Is Based On First Color In Passed cColorList
cColorBack := IF(',' $ cColorList, ;
SUBSTR(cColorList, 1, AT(',', cColorList) - 1), cColorList )
IF .NOT. lKeepScrn
SetColor(cColorBack)
CLEAR SCREEN
ENDIF
/* make a window shadow */
SetColor(cColorShad)
@ nTop+1, nLeft+1 CLEAR TO nBottom+1, nRight+1
SetColor(cColorBack)
@ nTop, nLeft CLEAR TO nBottom, nRight
SetColor(cColorSave)
nCursSave := SetCursor(0)
lMore := .t.
WHILE (lMore)
/* stabilize the display */
nKey := 0
DISPBEGIN()
DO WHILE nKey == 0 .AND. .NOT. b:stable
b:stabilize()
nKey := InKey()
ENDDO
DISPEND()
IF ( b:stable )
/* display is stable */
IF ( b:hitTop .OR. b:hitBottom )
Tone(125, 0)
ENDIF
// Make sure that the current record is showing
// up-to-date data in case we are on a network.
DISPBEGIN()
b:refreshCurrent()
DO WHILE .NOT. b:stabilize()
ENDDO
DISPEND()
/* everything's done; just wait for a key */
nKey := INKEY(0)
ENDIF
/* process key */
DO CASE
CASE ( nKey == K_DOWN )
b:down()
CASE ( nKey == K_UP )
b:up()
CASE ( nKey == K_PGDN )
b:pageDown()
CASE ( nKey == K_PGUP )
b:pageUp()
CASE ( nKey == K_CTRL_PGUP )
b:goTop()
CASE ( nKey == K_CTRL_PGDN )
b:goBottom()
CASE ( nKey == K_RIGHT )
b:right()
CASE ( nKey == K_LEFT )
b:left()
CASE ( nKey == K_HOME )
b:home()
CASE ( nKey == K_END )
b:end()
CASE ( nKey == K_CTRL_LEFT )
b:panLeft()
CASE ( nKey == K_CTRL_RIGHT )
b:panRight()
CASE ( nKey == K_CTRL_HOME )
b:panHome()
CASE ( nKey == K_CTRL_END )
b:panEnd()
CASE ( nKey == K_ESC )
nPassRec := 0
lMore := .f.
CASE ( nKey == K_RETURN )
nPassRec := RECNO()
lMore := .f.
ENDCASE
ENDDO // for WHILE (lmore)
/* restore old screen */
IF lSaveScrn
RESTSCREEN(0, 0, MaxRow(), MaxCol(), cScrnSave)
ENDIF
SetCursor(nCursSave)
SetColor(cColorSave)
RETURN (nPassRec)
/* -------------------------------------------------------------------- */
STATIC FUNCTION TbSkipWhil(n, bWhileCond)
LOCAL i := 0
IF n == 0 .OR. LASTREC() == 0
SKIP 0 // significant on a network
ELSEIF ( n > 0 .AND. RECNO() <> LASTREC() + 1)
WHILE ( i < n )
SKIP 1
IF ( EOF() .OR. .NOT. Eval(bWhileCond) )
SKIP -1
EXIT
ENDIF
i++
ENDDO
ELSEIF ( n < 0 )
WHILE ( i > n )
SKIP -1
IF ( BOF() )
EXIT
ELSEIF .NOT. Eval( (bWhileCond) )
SKIP
EXIT
ENDIF
i--
ENDDO
ENDIF
RETURN (i)
* EOFcn TbSkipWhil()
/* -------------------------------------------------------------------- */
STATIC FUNCTION TbWhileTop(cKey)
SEEK cKey
RETURN NIL
/* -------------------------------------------------------------------- */
STATIC FUNCTION TbWhileBot(cKey)
* SeekLast: Finds Last Record For Matching Key
* Developed By Jon Cole
* With softseek set on, seek the first record after condition.
* This is accomplished by incrementing the right most character of the
* string cKey by one ascii character. After SEEKing the new string,
* back up one record to get to the last record which matches cKey.
#include "set.ch"
LOCAL cSoftSave := SET(_SET_SOFTSEEK, .t.)
SEEK LEFT(cKey, LEN(cKey) -1) + CHR( ASC( RIGHT(cKey,1) ) +1)
SET(_SET_SOFTSEEK, cSoftSave)
SKIP -1
RETURN NIL

139
harbour/contrib/libnf/tempfile.prg Normal file
View File

@@ -0,0 +1,139 @@
/*
* File......: TEMPFILE.PRG
* Author....: Glenn Scott
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.7 28 Sep 1992 23:48:48 GLENN
* Deleted #define for FLAG_CARRY as Toolkit v2.1's ftint86.ch has it.
*
* Rev 1.6 03 Oct 1991 18:36:28 GLENN
* Tim Wong from Nantucket pointed out that this DOS function actually
* leaves a file handle in AX. In order to preserve the functionality,
* I now fclose() that handle if the call is succsessful.
*
* Rev 1.5 15 Aug 1991 23:05:04 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.4 17 Jul 1991 22:11:18 GLENN
* Stripped off chr(0)s in the return value (aRegs[DS])
*
* Rev 1.3 03 Jul 1991 01:08:08 GLENN
* Changed one line in FT_TEST driver ( cHide == "Y" )
*
* Rev 1.2 14 Jun 1991 19:53:10 GLENN
* Minor edit to file header
*
* Rev 1.1 12 Jun 1991 02:45:40 GLENN
* Documentation mods, and convert to new ft_int86() syntax, return value.
*
* Rev 1.0 01 Apr 1991 01:02:24 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_TEMPFIL()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Create a file with a unique name
* $SYNTAX$
* FT_TEMPFIL( [ <cPath> ] [, <lHide> ] ) -> cFileSpec
* $ARGUMENTS$
* <cPath> is the directory where you want to create the temporary
* file. If you omit this argument, the root of the current drive
* is assumed ("\").
*
* If <lHide> is .T., then the file will be created with the hidden
* attribute set. The default is .F.
* $RETURNS$
* <cFileSpec> should be your path, including the name of the newly
* created unique file. Use this with FOPEN(), etc.
*
* If a DOS error occurred when trying to create the file, a
* null string will be returned.
*
* $DESCRIPTION$
* This function uses DOS Interrupt 21, service 5Ah (Create temporary
* file) to create a unique filename in a directory you specify.
* There will be no extension. After the file is created, you may
* then fopen() it and do any i/o you need (see the test driver
* in the source code).
*
* This function requires FT_INT86().
* $EXAMPLES$
* Create a unique file in the root of the current drive:
*
* myFile := FT_TEMPFIL()
*
* Create a unique file in the current directory and hide it:
*
* myFile := FT_TEMPFIL(".\", .t.)
*
* Create a unique file on another drive, but do not hide it:
*
* myFile := FT_TEMPFIL("e:\nanfor\src\")
* $END$
*/
#include "FTINT86.CH"
#define DOS 33
#define TEMPNAME 90
#ifdef FT_TEST
FUNCTION MAIN( cPath, cHide )
LOCAL cFile, nHandle
cFile := FT_TEMPFIL( cPath, (cHide == "Y") )
if !empty( cFile )
QOut( cFile )
nHandle := fopen( cFile, 1 )
fwrite( nHandle, "This is a test!" )
fclose( nHandle )
else
Qout( "An error occurred" )
endif
RETURN nil
#endif
FUNCTION FT_TEMPFIL( cPath, lHide )
LOCAL cRet,aRegs[3]
cPath := iif( valType(cPath) != "C", ;
repl( chr(0),12) , ;
cPath += repl( chr(0), 12 ) ;
)
lHide := iif( valType(lHide) != "L", .f., lHide )
/*
aRegs[AX] := MAKEHI( TEMPNAME )
aRegs[CX] := iif( lHide, 2, 0 )
aRegs[DS] := cPath
aRegs[DX] := REG_DS
FT_INT86( DOS, aRegs )
*/
aRegs:=_ft_tempfil(cPath,lHide)
/* If carry flag is clear, then call succeeded and a file handle is
* sitting in AX that needs to be closed.
*/
if !ft_isBitOn( aRegs[3], FLAG_CARRY )
fclose( aRegs[1] )
cRet := strtran( aRegs[2], chr(0) )
else
cRet := ""
endif
RETURN cRet

27
harbour/contrib/libnf/test.prg Normal file
View File

@@ -0,0 +1,27 @@
function main()
local nver,nmar,ntype,nir,ppp
nmar:=FT_MVERSION(@nver,@ntype,@nir)
ppp:=nmar+nver
? str(nmar,2,0),'.',str(nver,2,0)
? ppp/100
inkey(0)
? 'is mouse on', ft_mreset()
inkey(0)
? FT_MSHOWCRS()
inkey(0)
? ft_mxlimit(0,8*maxcol())
inkey(0)
? ft_mylimit(0,8*maxrow())
inkey(0)
do while lastkey()<>27
? 'mouse row is',ft_mgetx()
? 'mouse col is',ft_mgety()
if lastkey()==27
exit
endif
enddo
FT_MHIDECRS()
return nil

180
harbour/contrib/libnf/vertmenu.prg Normal file
View File

@@ -0,0 +1,180 @@
/*
* File......: VERTMENU.PRG
* Author....: Greg Lief
* CIS ID....: 72460,1760
*
* This function is an original work by Mr. Grump and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 15 Aug 1991 23:04:48 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 01 Apr 1991 01:02:26 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_MENU2()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Vertical lightbar menu
* $SYNTAX$
* FT_MENU2( <aMenuarray> [, <cColors> ] ) -> NIL
* $ARGUMENTS$
* <aMenuarray> is an array of menu options, messages, and action
* blocks.
*
* Each element in this array is a nested array with the structure:
*
* element[x, 1] = menu option
* element[x, 2] = message to be displayed when option is highlighted
* element[x, 3] = code block to be executed when option is selected
*
* <cColors> is a string containing colors for the prompts, in the same
* format as that returned by Set( _SET_COLOR ). If not supplied,
* colors default to the current color setting.
* $RETURNS$
* NIL
* $DESCRIPTION$
* This function greatly simplifies the process of displaying light-bar
* menus. All prompts are padded out with spaces so they are the same
* length, a box is drawn around the prompts, the box is automatically
* centered on the screen, and the underlying screen is restored after
* a menu selection has been made.
*
* Additionally, because you can tie action blocks to each menu
* option, you can save on a lot of DO CASE or IF..ELSEIF code in your
* main program. See the test code for a succinct demonstration.
* $EXAMPLES$
* LOCAL mainmenu := ;
* { { "Data Entry", "Enter data", { || FT_MENU2(datamenu) } }, ;
* { "Reports", "Hard copy", { || FT_MENU2(repmenu) } }, ;
* { "Maintenance","Reindex files",{ || FT_MENU2(maintmenu) } }, ;
* { "Quit", "See ya later" } }
* FT_MENU2(mainmenu)
* $END$
*/
#include "box.ch"
// test code
#ifdef FT_TEST
FUNCTION MAIN
LOCAL MAINMENU := ;
{ { "DATA ENTRY", "ENTER DATA", { || FT_MENU2(datamenu) } }, ;
{ "Reports", "Hard copy", { || FT_MENU2(repmenu) } }, ;
{ "Maintenance","Reindex files, etc.",{ || FT_MENU2(maintmenu) } }, ;
{ "Quit", "See ya later" } }
local datamenu := { { "Customers", , { || cust() } } , ;
{ "Invoices", , { || inv() } } , ;
{ "Vendors", , { || vendors() } }, ;
{ "Exit", "Return to Main Menu" } }
local repmenu := { { "Customer List", , { || custrep() } } , ;
{ "Past Due", , { || pastdue() } } , ;
{ "Weekly Sales", , { || weeksales() } }, ;
{ "Monthly P&L", , { || monthpl() } } , ;
{ "Vendor List", , { || vendorrep() } }, ;
{ "Exit", "Return to Main Menu" } }
local maintmenu := { { "Reindex", "Rebuild index files", { || re_ntx() } } , ;
{ "Backup", "Backup data files" , { || backup() } } , ;
{ "Compress", "Compress data files", { || compress()} }, ;
{ "Exit", "Return to Main Menu" } }
FT_MENU2(mainmenu)
return nil
/* stub functions to avoid missing symbols */
static function cust
static function inv
static function vendors
static function custrep
static function pastdue
static function weeksales
static function monthpl
static function vendorrep
static function re_ntx
static function backup
static function compress
#endif
/*
FT_MENU2(): display vertical menu
*/
FUNCTION ft_menu2( aMenuInfo, cColors )
LOCAL nChoice := 1 ,;
nOptions := Len( aMenuInfo ) ,;
nMaxwidth := 0 ,;
nLeft ,;
x ,;
cOldscreen ,;
nTop ,;
lOldwrap := Set( _SET_WRAP, .T. ) ,;
lOldcenter := Set( _SET_MCENTER, .T. ),;
lOldmessrow := Set( _SET_MESSAGE ) ,;
cOldcolor := Set( _SET_COLOR )
IF cColors # NIL
Set( _SET_COLOR, cColors )
ENDIF
/* if no message row has been established, use bottom row */
IF lOldmessrow == 0
Set( _SET_MESSAGE, Maxrow() )
ENDIF
/* determine longest menu option */
Aeval( aMenuInfo, { | ele | nMaxwidth := max( nMaxwidth, len( ele[1] ) ) } )
/* establish top and left box coordinates */
nLeft := ( ( Maxcol() + 1 ) - nMaxwidth ) / 2
nTop := ( ( Maxrow() + 1 ) - ( nOptions + 2 ) ) / 2
DO WHILE nChoice != 0 .AND. nChoice != nOptions
cOldscreen := Savescreen( nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth )
@ nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth BOX B_SINGLE + ' '
Devpos( nTop, nLeft )
FOR x := 1 to Len( aMenuInfo )
IF Len( aMenuInfo[x] ) > 1 .AND. aMenuInfo[x,2] != NIL
@ Row() + 1, nLeft PROMPT Padr( aMenuInfo[x, 1], nMaxwidth ) ;
MESSAGE aMenuInfo[x,2]
ELSE
@ Row() + 1, nLeft PROMPT Padr( aMenuInfo[x,1], nMaxwidth )
ENDIF
NEXT
MENU TO nChoice
Restscreen( nTop, nLeft - 1, nTop + nOptions + 1, nLeft + nMaxwidth, cOldscreen )
/* execute action block attached to this option if there is one */
IF nChoice > 0 .AND. Len( aMenuInfo[ nChoice ] ) == 3
Eval( aMenuInfo[nChoice,3] )
ENDIF
ENDDO
/* restore previous message and wrap settings */
Set( _SET_MESSAGE, lOldmessrow )
Set( _SET_MCENTER, lOldcenter )
Set( _SET_WRAP, lOldwrap )
Set( _SET_COLOR, cOldcolor )
RETURN NIL
* end of file: vertmenu.prg

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

@@ -0,0 +1,136 @@
/*
* File......: VIDCUR.PRG
* Author....: Glenn Scott
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 15 Aug 1991 23:03:30 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:53:12 GLENN
* Minor edit to file header
*
* Rev 1.1 14 Jun 1991 17:59:18 GLENN
* Documentation change (minor), and checked for compatibility with new
* ft_int86().
*
* Rev 1.0 01 Apr 1991 01:02:28 GLENN
* Nanforum Toolkit
*
*/
#include "FTINT86.CH"
#define VIDEO 16
/* $DOC$
* $FUNCNAME$
* FT_SETVCUR()
* $CATEGORY$
* Video
* $ONELINER$
* Set the cursor position on a specified video page
* $SYNTAX$
* FT_SETVCUR( [ <nPage> ], [ <nRow> ], [ <nCol> ] ) -> NIL
* $ARGUMENTS$
* <nPage> is the video page (defaults to current page, determined
* by FT_GETVPG()
*
* <nRow> is the row coordinate (defaults to 0 )
*
* <nCol> is the column coordinate (defaults to 0 )
* $RETURNS$
* NIL
* $DESCRIPTION$
* FT_SETVCUR() sets the cursor position on a specific video page.
* It uses FT_INT86() to invoke interrupt 10h, function 2.
*
* For more information on graphics programming, cursors, and video
* pages, refer to Richard Wilton's _Programmer's Guide to PC and
* PS/2 Video Systems_ (Microsoft Press).
*
* $EXAMPLES$
*
* // Set the position to row 5, column 10 on video page 1:
*
* FT_SETVCUR( 1, 5, 10 )
* $END$
*/
FUNCTION FT_SETVCUR( nPage, nRow, nCol )
LOCAL aRegs[ INT86_MAX_REGS ]
nPage := iif( nPage == nil, FT_GETVPG() , nPage )
nRow := iif( nRow == nil, 0 , nRow )
nCol := iif( nCol == nil, 0 , nCol )
aRegs[ AX ] := MAKEHI( 2 )
aRegs[ BX ] := MAKEHI( nPage )
aRegs[ DX ] := MAKEHI( nRow ) + nCol
FT_INT86( VIDEO, aRegs )
RETURN ( NIL )
/* $DOC$
* $FUNCNAME$
* FT_GETVCUR()
* $CATEGORY$
* Video
* $ONELINER$
* Return info about the cursor on a specified video page
* $SYNTAX$
* FT_GETVCUR( [ <nPage> ] ) -> <aCurInfo>
* $ARGUMENTS$
* <nPage> is the video page to get the cursor information for.
* Defaults to the current page, as returned by FT_GETVPG().
* $RETURNS$
* A four-element array (<aCurInfo>), set up as follows:
*
* aCurInfo[1] = Top line of cursor
* aCurInfo[2] = Bottom line of cursor
* aCurInfo[3] = Character row
* aCurInfo[4] = Character column
*
* $DESCRIPTION$
*
* FT_GETVCUR() uses FT_INT86() to invoke interrupt 10h, function
* 3, to return the character cursor location for the specified
* video page.
*
* The top line and bottom line of cursor are set depending on
* the current cursor mode, and are only meaningful in alphanumeric
* video modes.
*
* For more information on graphics programming, cursors, and
* cursor modes, refer to Richard Wilton's _Programmer's Guide to
* PC and PS/2 Video Systems_ (Microsoft Press).
*
* $EXAMPLES$
*
* aCurInfo := getVCur( 1 ) // Get info on cursor pos in page 1
* QOut("Row: " + str( aCurInfo[3] ) + " Col: " + str( aCurInfo[4] ) )
*
*
* $END$
*/
FUNCTION FT_GETVCUR( nPage )
LOCAL aRegs[ INT86_MAX_REGS ]
nPage := iif( nPage == nil, FT_GETVPG(), nPage )
aRegs[ AX ] := MAKEHI( 3 )
aRegs[ BX ] := MAKEHI( nPage )
FT_INT86( VIDEO, aRegs )
RETURN ( { HIGHBYTE( aRegs[CX] ), LOWBYTE( aRegs[CX] ), HIGHBYTE( aRegs[DX] ), LOWBYTE( aRegs[DX] ) } )

126
harbour/contrib/libnf/vidmode.prg Normal file
View File

@@ -0,0 +1,126 @@
/*
* File......: VIDMODE.PRG
* Author....: Glenn Scott
* CIS ID....: 71620,1521
*
* This is an original work by Glenn Scott and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 15 Aug 1991 23:06:12 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:53:14 GLENN
* Minor edit to file header
*
* Rev 1.1 14 Jun 1991 18:00:42 GLENN
* Documentation change (minor), and checked for compatibility with new
* ft_int86().
*
* Rev 1.0 01 Apr 1991 01:02:30 GLENN
* Nanforum Toolkit
*
*/
#include "FTINT86.CH"
#define VIDEO 16
#define GETMODE 15
#ifdef FT_TEST
FUNCTION MAIN( cMode )
FT_SETMODE( val( cMode ) )
QOut( "Video mode is: " + str( FT_GETMODE() ) )
return ( nil )
#endif
/* $DOC$
* $FUNCNAME$
* FT_SETMODE()
* $CATEGORY$
* Video
* $ONELINER$
* Set the video mode
* $SYNTAX$
* FT_SETMODE( <nMode> ) -> NIL
* $ARGUMENTS$
* <nMode> is one of the DOS video modes.
* $RETURNS$
* NIL
* $DESCRIPTION$
* Use this function to put your display adapter into a video mode.
* Uses DOS interrupt 10h to set the mode. For a table of modes
* available on various graphics adapters, refer to a book such
* as Wilton's "Programmer's Guide to PC & PS/2 Video Systems"
* (Microsoft Press)
* $EXAMPLES$
* FUNCTION Main( cMode )
*
* FT_SETMODE( VAL( cMode ) )
* QOUT( "Video mode is: " + STR( FT_GETMODE() ) )
* RETURN ( NIL )
* $SEEALSO$
* FT_ADAPTER()
* $END$
*/
FUNCTION FT_SETMODE( nMode )
/*
LOCAL aRegs[ INT86_MAX_REGS ]
aRegs[ AX ] = nMode
FT_INT86( VIDEO, aRegs )
*/
_ft_setmode(nMode)
RETURN( NIL )
/* $DOC$
* $FUNCNAME$
* FT_GETMODE()
* $CATEGORY$
* Video
* $ONELINER$
* Get the video mode
* $SYNTAX$
* FT_GETMODE() -> nVMode
* $ARGUMENTS$
* None.
* $RETURNS$
* The video mode, as a numeric.
* $DESCRIPTION$
* Use this function to find out what mode your display adapter is in.
* Uses DOS interrupt 10h to get the mode. For a table of modes
* available on various graphics adapters, refer to a book such
* as Wilton's "Programmer's Guide to PC & PS/2 Video Systems"
* (Microsoft Press)
* $EXAMPLES$
* function main( cMode )
*
* FT_SETMODE( val( cMode ) )
* QOut( "Video mode is: " + str( FT_GETMODE() ) )
* return ( nil )
*
* $END$
*/
FUNCTION FT_GETMODE()
/*
LOCAL aRegs[INT86_MAX_REGS]
aRegs[ AX ] := MAKEHI( GETMODE )
FT_INT86( VIDEO, aRegs )
RETURN ( LOWBYTE( aRegs[ AX ] ) )
*/
RETURN _ft_getmode()

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

@@ -0,0 +1,81 @@
/*
* File......: WDA.PRG
* Author....: Eric Splaver
* CIS ID....: ?
*
* This is an original work by Eric Splaver and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.1 15 Aug 1991 23:04:34 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 14 Jun 1991 04:25:46 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ADDWKDY()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return true number of days to add given number of workdays
* $SYNTAX$
* FT_ADDWKDY( <dStart>, <nWorkDays> ) -> nTrueDays
* $ARGUMENTS$
* <dStart> = date to start adding from
* <nWorkDays> = number of workdays to add
* $RETURNS$
* <nTrueDays> = Number of actual days to add to <dStart> in
* order to add the required <nWorkDays>
* $DESCRIPTION$
* Let's say you are given the problem:
*
* "All invoices are due 10 working days from the date they
* are printed. Please display the due date on the invoice."
*
* When is the due date? Assuming you are printing the invoices
* today, your answer is:
*
* dDueDate := DATE() + ft_addWkDay( DATE(), 10 )
*
* A work day is defined as Monday through Friday. Unfortunately
* this routine does _not_ account for holidays.
*
* This documentation was written by Glenn Scott so if it's wrong,
* blame him.
*
* $EXAMPLES$
* // Postdate 5 working days from the first of January
* dPost := CTOD("01/01/91")
* dPost += FT_ADDWKDY( dPost, 5 ) // returns 7 true days
* ? dPost // 01/08/91
*
* $SEEALSO$
* FT_WORKDAYS()
* $END$
*/
#ifdef FT_TEST
function main( cDate, cDays )
local nDays := ft_addWkDy( ctod(cDate), val(cDays) )
qout( "Num days to add: " + str( nDays ) )
qout( "New date: " + dtoc( ctod( cDate ) + nDays ) )
return nil
#endif
FUNCTION ft_addWkDy( dStart, nDys )
LOCAL nDc := dow( dStart )
RETURN ( iif( nDc == 7, ;
(nDys-1) % 5 + 7 * int( (nDys-1) / 5 ) + 2, ;
(nDys+nDc-2) % 5 + 7 * int( (nDys+nDc-2) / 5 ) + 2 - nDc ;
) ;
)

112
harbour/contrib/libnf/week.prg Normal file
View File

@@ -0,0 +1,112 @@
/*
* File......: WEEK.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:44:52 GLENN
* Jo French cleaned up and correct to bow().
*
* Rev 1.2 15 Aug 1991 23:05:26 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:16 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:30 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_WEEK()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return calendar or fiscal week data
* $SYNTAX$
* FT_WEEK( [ <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 53 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 week
* aDateInfo[3] - The ending date of the week
* $DESCRIPTION$
* FT_WEEK() returns an array containing data about the week
* containing the given date.
*
* Normally the return data will be based on a year beginning
* on January 1st with weeks beginning on Sunday.
*
* The beginning of year date and/or beginning of week day can be
* changed by using FT_DATECNFG(), which will affect all subsequent
* calls to FT_WEEK() until another call to FT_DATECNFG().
*
* The beginning of year date and beginning of week day may be reset
* to January 1 and Sunday by calling FT_DATECNFG() with no
* parameters.
* $EXAMPLES$
* // get info about week containing 9/15/90
* aDateInfo := FT_WEEK( 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 week 25 in year containing 9/15/90
* aDateInfo := FT_WEEK( CTOD("09/15/90"), 25 )
* ? aDateInfo[1] // 199025
* ? aDateInfo[2] // 06/17/90 beginning of week 25
* ? aDateInfo[3] // 06/23/90 end of week 25
*
* // get info about week 25 in current year( 1991 )
* aDateInfo := FT_WEEK( , 25 )
* ? aDateInfo[1] // 199025
* ? aDateInfo[2] // 06/16/91 beginning of week 25
* ? aDateInfo[3] // 06/22/91 end of week 25
* $SEEALSO$
* FT_DATECNFG() FT_MONTH() FT_QTR() FT_YEAR() FT_DAYTOBOW()
* $END$
*/
FUNCTION FT_WEEK( dGivenDate, nWeekNum )
LOCAL lIsWeek, nTemp, aRetVal, dTemp
IF ! (VALTYPE(dGivenDate) $ 'ND')
dGivenDate := DATE()
ELSEIF VALTYPE(dGivenDate) == 'N'
nWeekNum := dGivenDate
dGivenDate := DATE()
ENDIF
aRetVal := FT_YEAR(dGivenDate)
dTemp := aRetVal[2]
aRetVal[2] -= FT_DAYTOBOW( aRetVal[2] )
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
dGivenDate += ( 6 - FT_DAYTOBOW(dGivenDate) ) // end of week
aRetVal[1] += PADL(LTRIM(STR(INT( (dGivenDate - ;
aRetVal[2]) / 7 ) + 1, 2)), 2, '0')
aRetVal[2] := MAX( dGivenDate - 6, dTemp )
aRetVal[3] := MIN( dGivenDate, aRetVal[3] )
RETURN aRetVal

101
harbour/contrib/libnf/workdays.prg Normal file
View File

@@ -0,0 +1,101 @@
/*
* File......: WORKDAYS.PRG
* Author....: John F. Kaster
* CIS_ID....: 71510,3321
*
* The functions contained herein are the original work of John Kaster
* and are placed in the public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 07 Mar 1992 22:15:06 GLENN
* Mark K. Zechiel discovered a bug where the incorrect number of
* workdays was reported when <dStart> was a Tuesday through Friday and
* dStop was a multiple of 7 days away from dStart (i.e., 7, or 14, or
* 21, etc). Fixed.
*
* Rev 1.1 15 Aug 1991 23:05:48 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 12 Jun 1991 01:33:10 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_WORKDAYS()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return number of work days between two dates
* $SYNTAX$
* FT_WORKDAYS( [ <dStart> ], [ <dStop> ] ) -> nDays
* $ARGUMENTS$
* <dStart> is the beginning value for the date range.
*
* <dStop> is the ending value for the date range.
*
* $RETURNS$
* The number of work days (Monday through Friday) between two dates.
*
* $DESCRIPTION$
* FT_WORKDAYS() returns a number indicating the number of work days
* between two dates. Work days are considered Monday through Friday.
* (The five day work week none of us Clipper programmers have.)
*
* $EXAMPLES$
* ? FT_WorkDays( CTOD("5/16/91"), CTOD("5/20/91") ) // 3 (Th - Mo)
* ? FT_WorkDays( CTOD("5/18/91"), CTOD("5/19/91") ) // 0 (Sa - Su)
* ? FT_WorkDays( CTOD("5/17/91"), CTOD("5/17/91") ) // 1 (Fr - Fr)
* $SEEALSO$
* $END$
*/
#ifdef FT_TEST
function main( cStart, cStop )
return qout( ft_workdays( ctod( cStart ), ctod( cStop ) ) )
#endif
FUNCTION FT_WorkDays( dStart, dStop )
LOCAL nWorkDays := 0, nDays, nAdjust
IF dStart # NIL .AND. dStop # NIL
IF dStart # dStop
IF dStart > dStop // Swap the values
nAdjust := dStop
dStop := dStart
dStart := nAdjust
ENDIF
IF ( nDays := Dow( dStart ) ) == 1 // Sunday (change to next Monday)
dStart++
ELSEIF nDays == 7 // Saturday (change to next Monday)
dStart += 2
ENDIF
IF ( nDays := Dow( dStop ) ) == 1 // Sunday (change to prev Friday)
dStop -= 2
ELSEIF nDays == 7 // Saturday (change to prev Friday)
dStop--
ENDIF
nAdjust := ( nDays := dStop - dStart + 1 ) % 7
IF Dow( dStop ) + 1 < Dow( dStart ) // Weekend adjustment
nAdjust -= 2
ENDIF
nWorkDays := Int( nDays / 7 ) * 5 + nAdjust
ELSEIF ( Dow( dStart ) # 1 .AND. Dow( dStart ) # 7 )
nWorkDays := 1
ENDIF
ENDIF
RETURN ( IIF(nWorkDays>0,nWorkDays,0) )

223
harbour/contrib/libnf/woy.prg Normal file
View File

@@ -0,0 +1,223 @@
/*
* File......: WOY.PRG
* Author....: Forest Belt, Computer Diagnostic Services, Inc.
* CIS ID....: ?
*
* This is an original work by Forest Belt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:03:18 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 11 May 1991 00:01:00 GLENN
* Documentation correction on ft_doy() oneliner. Was identical to ft_woy(),
* now it's right.
*
* Rev 1.0 01 Apr 1991 01:02:32 GLENN
* Nanforum Toolkit
*
*/
#ifdef FT_TEST
// ADD PARAMETER "CENTURY" ON COMMAND LINES TO TEST 4-DIGIT YEARS
FUNCTION MAIN( cCent )
LOCAL lCentOn := .F., cDate
MEMVAR getlist
IF VALTYPE( cCent) == "C" .AND. "CENT" $ UPPER( cCent)
SET CENTURY ON
lCentOn := .T.
END
DO WHILE .T.
CLEAR
@ 2,10 SAY "Date to Test"
IF lCentOn
cDate := SPACE(10)
@ 2,24 GET cDate PICTURE "##/##/####"
ELSE
cDate := SPACE(8)
@ 2,24 GET cDate PICTURE "##/##/##"
END
READ
IF EMPTY(cDate)
EXIT
END
IF DTOC( CTOD( cDate) ) = " "
QQOUT( CHR( 7) )
@ 4,24 SAY "INVALID DATE"
INKEY(2)
LOOP
END
@ 4,10 SAY "Is Day Number " + STR( FT_DOY( CTOD( cDate)) ,3)
@ 6,10 SAY "Is in Week Number " + STR( FT_WOY( CTOD( cDate)) ,2)
@ 7,0
WAIT
END
CLEAR
RETURN nil
#endif
/* $DOC$
* $FUNCNAME$
* FT_WOY()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Find number of week within year
* $SYNTAX$
* FT_WOY( <dDate> ) -> <nResult>
* $ARGUMENTS$
* <dDate> is a date in the form "mm/dd/yy" or "mm/dd/yyyy"
* $RETURNS$
* Return numeric position of week within the year or NIL if
* parameter does not conform.
* $DESCRIPTION$
* Considers a full week as starting on Sunday, ending on Saturday.
* First week of year (week 1) may start on any day, and thus
* contain any number of days.
* Final week of year (week 53) may contain any number of days.
* Handles dates with CENTURY ON|OFF, to allow for 21st century.
* Date validation must be external to this function.
* $EXAMPLES$
* These code fragments find the week number, given a date.
*
* // literal character date
* dDate := CTOD("01/01/91")
* nWkNum := FT_WOY(dDate) // result: 1
*
* // presume DOS date to be 01/06/91
* nWkNum := FT_WOY(DATE()) // result: 2
*
* // date input
* cDate := SPACE(8)
* @ 4,10 get cDate PICT "##/##/##" // input 07/04/91
* READ
* nWkNum := FT_WOY(CTOD(cDate)) // result: 27
*
* // last day of year
* nWkNum := FT_WOY(CTOD("12/31/91")) // result: 53
*
* For a demonstration of this function, compile and link the
* program WOY.PRG in the Nanforum Toolkit source code.
* $END$
*/
FUNCTION FT_WOY(dInDate)
LOCAL nFirstDays, nDayOffset, nWkNumber, cCentury
IF VALTYPE( dInDate) != "D"
nWkNumber := NIL
ELSE
// resolve century issue
IF LEN( DTOC( dInDate) ) > 8 // CENTURY is on
cCentury := SUBSTR( DTOC( dInDate) ,7 ,4)
ELSE
cCentury := SUBSTR( DTOC( dInDate) ,7 ,2)
END
// find number of days in first week of year
nFirstDays := 8 - (DOW (CTOD ("01/01/" + cCentury) ) )
nWkNumber := 1
// find how many days after first week till dInDate
nDayOffset := (dInDate - ;
CTOD ("01/01/" + cCentury) ) - nFirstDays + 1
// count weeks in offset period
DO WHILE nDayOffset > 0
++nWkNumber
nDayOffset -= 7
END
END
RETURN (nWkNumber)
/* $DOC$
* $FUNCNAME$
* FT_DOY()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Find number of day within year
* $SYNTAX$
* FT_DOY( <dDate> ) -> <nResult>
* $ARGUMENTS$
* <dDate> is a date in the form "mm/dd/yy" or "mm/dd/yyyy"
* $RETURNS$
* Return numeric position of day within the year.
* Return NIL if parameter does not conform.
* $DESCRIPTION$
* Finds the day number, considering 01/01 as day 1
* Handles dates with CENTURY ON|OFF, to allow for 21st century.
* Date validation must be external to this function.
* $EXAMPLES$
* These code fragments find the day number, given a date.
*
* // literal character date
* dDate := CTOD("01/01/91")
* nDayNum := FT_DOY(dDate) // result: 1
*
* // presume DOS date to be 01/06/91
* nDayNum := FT_DOY(DATE()) // result: 6
*
* // date input
* cDate := SPACE(8)
* @ 4,10 get cDate PICT "##/##/##" // input 07/04/91
* READ
* nDayNum := FT_DOY(CTOD(cDate)) // result: 185
*
* // last day of year
* nDayNum := FT_DOY(CTOD("12/31/91")) // result: 365
*
* For a demonstration of this function, compile and link the
* program WOY.PRG in the Nanforum Toolkit source code.
* $END$
*/
FUNCTION FT_DOY(dInDate)
LOCAL nDayNum, cCentury
IF VALTYPE(dInDate) != "D"
nDayNum := NIL
ELSE
// resolve century issue
IF LEN( DTOC( dInDate) ) > 8 // CENTURY is on
cCentury := SUBSTR( DTOC( dInDate) ,7 ,4)
ELSE
cCentury := SUBSTR( DTOC( dInDate) ,7 ,2)
END
// calculate
nDayNum := (dInDate - CTOD ("01/01/" + cCentury)) + 1
END
RETURN (nDayNum)

224
harbour/contrib/libnf/xbox.prg Normal file
View File

@@ -0,0 +1,224 @@
/*
* File......: XBOX.PRG
* Author....: Don Opperthauser
* CIS ID....: ?
*
* This is an original work by Don Opperthauser and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 17 Aug 1991 15:47:06 GLENN
* Don Caton fixed some spelling errors in the doc
*
* Rev 1.2 15 Aug 1991 23:05:12 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 17:55:50 GLENN
* Fixed bug where extra blank line was displayed in the box.
*
* Rev 1.0 01 Apr 1991 01:02:34 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_XBOX()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Display a self-sizing message box and message
* $SYNTAX$
* FT_XBOX( [ <cJustType> ], [ <cRetWait> ], [ <cBorType> ], ;
* [ <cBorColor> ], [ <cBoxColor> ], [ <nStartRow> ], ;
* [ <nStartCol> ], <cLine1>, <cLine2>, <cLine3>, ;
* <cLine4>, <cLine5>, <cLine6>, <cLine7>, <cLine8> ) -> NIL
* $ARGUMENTS$
* <cJustType> is a character indicating the type of text justification.
* "L" or "l" will cause the text to be left-justified in the box.
* Centered text is the default.
*
* <cRetWait> is a character which determines if the function will wait
* for a keypress after displaying the box. "W" or "w" will cause the
* function to wait for a keypress before returning control to the
* calling routine. Not waiting is the default
*
* <cBorType> is a character which determines whether a single or double
* border will be displayed. "D" or "d" will cause a double border to
* be displayed. A single border is the default.
*
* <cBorColor> is a character string denoting the border color. 'N/W' is
* the default if this parameter is not a string.
*
* <cBoxColor> is a character string denoting the text color. 'W/N' is
* the default if this parameter is not a string.
*
* <nStartRow> is a number denoting the starting row. If '99' is passed,
* the box is centered vertically. If necessary, nStartRow is decreased
* so the entire box can be displayed.
*
* <nStartCol> is a number denoting the starting column. If '99' is passed,
* the box is centered horizontally. If necessary, nStartCol is decreased
* so the entire box can be displayed.
*
* <cLine1> thru <cLine8> are 1 to 8 character strings to be displayed.
* They are truncated to fit on the screen if necessary.
* $RETURNS$
* NIL
* $DESCRIPTION$
* FT_XBOX() allows the programmer to display a message box on the screen
* without needing to calculate the dimensions of the box. Only the upper
* left corner needs to be defined. The function will calculate the lower
* right corner based on the number and length of strings passed.
*
* A maximum of eight strings can be displayed. If a string is too long
* to fit on the screen it is truncated.
*
* The first seven parameters are optional. The default settings are:
* Lines of text are centered.
* Control is returned to the calling routine immediately.
* A single line border is painted.
* The border is black on white.
* The text is white on black.
* The box is centered both vertically and horizontally.
*
* WARNING: Shadowing is achieved by a call to FT_SHADOW(), an assembly
* routine not found in this .PRG. In order to use XBOX,
* SHADOW.OBJ must also be present somewhere (if you are using
* NANFOR.LIB, then it is).
* $EXAMPLES$
* The following displays a two-line box with default settings:
*
* FT_XBOX(,,,,,,,'This is a test','of the XBOX() function')
*
* The following uses all optional parameters and displays a three-line
* box. The box is left-justified with a double border. It has a yellow
* on red border and white on blue text. The function will wait for a
* keypress before returning control to the calling routine.
*
* FT_XBOX('L','W','D','GR+/R','W/B',5,10,'It is so nice',;
* 'to not have to do the messy chore',;
* 'of calculating the box size!')
* $END$
*/
#ifdef FT_TEST
FUNCTION MAIN()
local i
setcolor('W/B')
* clear screen
for i = 1 to 24
@ i, 0 say replicate('@', 80)
next
FT_XBOX(,,,,,,,'This is a test','of the XBOX() function')
FT_XBOX('L','W','D','GR+/R','W/B',1,10,'It is so nice',;
'to not have to do the messy chore',;
'of calculating the box size!')
FT_XBOX(,'W','D','GR+/R','W/B',16,10,'It is so nice',;
'to not have to do the messy chore',;
'of calculating the box size!',;
'Even though this line is way too long, and is in fact more than 80 characters long, if you care to check!')
return ( nil )
#endif
FUNCTION FT_XBOX(cJustType,; // "L" = left, otherwise centered
cRetWait, ; // "W" = wait for keypress before continuing
cBorType, ; // "D" = double, anything else single border
cBorColor,; // color string for border
cBoxColor,; // color string for text
nStartRow,; // upper row of box. 99=center vertically
nStartCol,; // left edge of box. 99=center horizontally
cLine1, cLine2, cLine3, cLine4, cLine5, cLine6, cLine7, cLine8)
LOCAL nLLen := 0, ;
cOldColor, ;
nLCol, ;
nRCol, ;
nTRow, ;
nBRow, ;
nLoop, ;
cSayStr, ;
nSayRow, ;
nSayCol, ;
nNumRows, ;
aLines_[8]
// validate parameters
cJustType := if(ValType(cJustType)='C',Upper(cJustType),'')
cRetWait := if(ValType(cRetWait )='C',Upper(cRetWait), '')
cBorType := if(ValType(cBorType )='C',Upper(cBorType), '')
cBorColor := if(ValType(cBoxColor)='C',cBorColor, 'N/W')
cBoxColor := if(ValType(cBoxColor)='C',cBoxColor, 'W/N')
nStartRow := if(ValType(nStartRow)='N',nStartRow,99)
nStartCol := if(ValType(nStartCol)='N',nStartCol,99)
nNumRows := Min(PCount()-7,8)
//establish array of strings to be displayed
aLines_[1] := if(ValType(cLine1) = 'C',AllTrim(SubStr(cLine1,1,74)),'')
aLines_[2] := if(ValType(cLine2) = 'C',AllTrim(SubStr(cLine2,1,74)),'')
aLines_[3] := if(ValType(cLine3) = 'C',AllTrim(SubStr(cLine3,1,74)),'')
aLines_[4] := if(ValType(cLine4) = 'C',AllTrim(SubStr(cLine4,1,74)),'')
aLines_[5] := if(ValType(cLine5) = 'C',AllTrim(SubStr(cLine5,1,74)),'')
aLines_[6] := if(ValType(cLine6) = 'C',AllTrim(SubStr(cLine6,1,74)),'')
aLines_[7] := if(ValType(cLine7) = 'C',AllTrim(SubStr(cLine7,1,74)),'')
aLines_[8] := if(ValType(cLine8) = 'C',AllTrim(SubStr(cLine8,1,74)),'')
ASize(aLines_,Min(nNumRows,8))
// determine longest line
nLoop := 1
AEVAL(aLines_,{|| nLLen:=Max(nLLen,Len(aLines_[nLoop])),nLoop++})
// calculate corners
nLCol = if(nStartCol=99,Int((76-nLLen)/2),Min(nStartCol,74-nLLen))
nRCol = nLCol+nLLen+3
nTRow = if(nStartRow=99,INT((24-nNumRows)/2),Min(nStartRow,22-nNumRows))
nBRow = nTRow+nNumRows+1
// form box and border
// save screen color and set new color
cOldColor = SetColor(cBoxColor)
@ nTRow,nLCol Clear to nBRow,nRCol
// draw border
SetColor(cBorColor)
IF cBorType = "D"
@ nTRow,nLCol TO nBRow,nRCol double
ELSE
@ nTRow,nLCol TO nBRow,nRCol
ENDIF
// write shadow
FT_SHADOW(nTRow,nLCol,nBRow,nRCol)
// print text in box
SetColor(cBoxColor)
nLoop :=1
AEVAL(aLines_,{|cSayStr|;
nSayRow := nTRow+nLoop,;
nSayCol := if(cJustType = 'L',;
nLCol+2,;
nLCol+2+(nLLen-Int(Len(aLines_[nLoop])))/2),;
nLoop++,;
_FTSAY(nSayRow,nSayCol,cSayStr);
})
// wait for keypress if desired
IF cRetWait ='W'
Inkey(0)
ENDIF
RETURN NIL
STATIC FUNCTION _FTSAY(nSayRow,nSayCol,cSayStr)
@ nSayRow,nSayCol SAY cSayStr
RETURN NIL

92
harbour/contrib/libnf/year.prg Normal file
View File

@@ -0,0 +1,92 @@
/*
* File......: YEAR.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:45:50 GLENN
* Jo French cleaned up.
*
* Rev 1.2 15 Aug 1991 23:04:56 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:53:20 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:02:36 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_YEAR()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return calendar or fiscal year data
* $SYNTAX$
* FT_YEAR( [ <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 year
* aDateInfo[3] - The ending date of the year
* $DESCRIPTION$
* FT_YEAR() returns an array containing data about the year
* containing the given date.
*
* Normally the return data will be based on a year beginning
* on January 1st.
*
* The beginning of year date can be changed by using FT_DATECNFG(),
* which will affect all subsequent calls to FT_YEAR() until another
* call to FT_DATECNFG().
*
* The beginning of year date may be reset to January 1 by calling
* FT_DATECNFG() with no parameters.
* $EXAMPLES$
* // Get info about year containing 9/15/90, assuming default
* // beginning of year is January 1st.
* aDateInfo := FT_YEAR( Ctod("09/15/90") )
* ? aDateInfo[1] // 1990
* ? aDateInfo[2] // 01/01/90 beginning of year
* ? aDateInfo[3] // 12/31/90 end of year
*
* // get info about current year (1991).
* aDateInfo := FT_YEAR()
* ? aDateInfo[1] // 1991
* ? aDateInfo[2] // 01/01/91 beginning of year
* ? aDateInfo[3] // 12/31/91 end of year
* $SEEALSO$
* FT_DATECNFG() FT_WEEK() FT_MONTH() FT_QTR()
* $END$
*/
FUNCTION FT_YEAR(dGivenDate)
LOCAL aRetVal[3], cFY_Start, cDateFormat
cFY_Start := FT_DATECNFG()[1]
cDateFormat := SET(_SET_DATEFORMAT, "yyyy.mm.dd")
IF( VALTYPE(dGivenDate) != 'D', dGivenDate := DATE(), )
aRetVal[2] := CTOD(STR( YEAR(dGivenDate) - IF(MONTH(dGivenDate) < ;
MONTH(CTOD(cFY_Start)), 1, 0), 4) + ;
SUBSTR(cFY_Start, 5, 6) )
aRetval[3] := FT_MADD(aRetVal[2], 12) - 1
aRetVal[1] := STR(YEAR(aRetVal[3]),4) // End of Year
SET(_SET_DATEFORMAT, cDateFormat)
RETURN aRetVal