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

See changelog 20000421 23:00

Browse Source
This commit is contained in:
Luiz Rafael Culik
2000-04-22 02:35:34 +00:00
parent ae5b4f3c1e
commit fdc28e5f1f
13 changed files with 1422 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -0,0 +1,103 @@
/*
* File......: FindIth.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:03:36 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:52 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:22 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_FINDITH()
* $CATEGORY$
* String
* $ONELINER$
* Find the "ith" occurrence of a substring within a string
* $SYNTAX$
* FT_FINDITH( <cCheckFor>, <cCheckIn>, <nWhichOccurrence> ;
* [, <lIgnoreCase> ] ) -> <nStringPosition>
* $ARGUMENTS$
* <cCheckFor> is the string to search for.
*
* <cCheckIn> is the string to search.
*
* <nWhichOccurrence> is the number of the occurrence to find.
*
* <lIgnoreCase> is a logical indicating if the search is to be case
* sensitive. The default is no case sensitivity (.F.).
* $RETURNS$
* The position in the string cCheckIn of the ith occurrence of cCheckFor.
* $DESCRIPTION$
* This function finds the position in a string of the "ith" time another
* string appears in it.
* $EXAMPLES$
* // Find the Position in cMemoString of
* // the 10th Occurrence of "the", case
* // insensitive
*
* nNextPosition := FT_FINDITH("the", cMemoString, 10)
* $SEEALSO$
* FT_AT2()
* $END$
*/
#define IS_NOT_LOGICAL(x) (VALTYPE(x) != "L")
#define MAKE_UPPER(cString) (cString := UPPER(cString))
#define NULL ""
#ifdef FT_TEST
FUNCTION MAIN( cCk, cStr, nOcc, xCase )
LOCAL nFind
if pcount() != 4
QOut( "usage: findith cCk cStr nOcc xCase")
quit
endif
xCase := iif( xCase == "Y", .t., .f. )
nOcc := val(nOcc)
QOut( iif( xCase, "Ignoring ", "Observing ") + "case:" )
QOut( cStr )
nFind := FT_FINDITH( cCk, cStr, nOcc, xCase )
QOut( iif( nFind > 0, space( nFind - 1) + "^" , "Not found" ) )
RETURN nil
#endif
FUNCTION FT_FINDITH(cCheckFor,cCheckIn,nWhichOccurrence,lIgnoreCase)
LOCAL nIthOccurrence
// Is Case Sensitivity 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(nWhichOccurrence == 1, ;
AT(cCheckFor, cCheckIn), ;
IF((nIthOccurrence := AT(cCheckFor, ;
STRTRAN(cCheckIn, cCheckFor, ;
NULL, 1, ;
nWhichOccurrence-1))) == 0, ;
0, ;
nIthOccurrence + ((nWhichOccurrence - 1) * LEN(cCheckFor)))))

59
harbour/contrib/libnf/firstday.prg Normal file
View File

@@ -0,0 +1,59 @@
/*
* File......: FIRSTDAY.PRG
* Author....: Jeff Bryant
* CIS ID....: ?
*
* This function is an original work by Jeff Bryant and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.2 15 Aug 1991 23:03:38 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:54 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:24 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_FDAY()
* $CATEGORY$
* Date/Time
* $ONELINER$
* Return first day of the month
* $SYNTAX$
* FT_FDAY( [ <dDateToChk> ] ) -> dFirstDay
* $ARGUMENTS$
* <dDateToChk> is a date within a month for which you want to find
* the first date of that month. If not passed or is an incorrect type,
* defaults to current system date.
* $RETURNS$
* A Clipper date value representing the first date of the month.
* $DESCRIPTION$
* This function will return the first day of the month of the date
* passed, or the first day of the current month if no argument is
* supplied.
* $EXAMPLES$
* dDate := CTOD( "09/15/90" )
* ? FT_FDAY( dDate ) // 09/01/90
* ? FT_FDAY() // 03/01/91 (current month)
* $SEEALSO$
* FT_LDAY()
* $END$
*/
FUNCTION FT_FDAY(dDateToChk)
IF Valtype(dDatetoChk) # "D"
dDatetoChk := Date()
ENDIF
RETURN dDateToChk - (DAY(dDateToChk)-1)

292
harbour/contrib/libnf/floptst.prg Normal file
View File

@@ -0,0 +1,292 @@
/*
* File......: FLOPTST.PRG
* Author....: Gary Smith
* CIS ID....: 70714,3015
*
* This work is based on an original work by Joseph LaCour that
* was placed in the public domain. This work is placed in the
* public domain.
*
* ACKNOWLEDGEMENTS:
*
* PAOLO RAMOZZI FOR HIS WORK IN DBDCHECK FOR SHOWING HOW TO
* USE INT 13H.
*
*
* Modification history:
* ---------------------
*
* Rev 1.4 05 May 1995 03:05:00 TED
* Gary Smith ported ASM source to Clipper.
*
* Rev 1.3 23 Sep 1991 14:56:42 GLENN
* Bug reports from Craig Austin, James Finnal, and Ted Means. Line 128
* had MOV FDRIVE,AL which should have been MOV FDRIVE,BL. This caused the
* function to erroneously use the last drive available instead of the one
* specified by the calling process.
*
* Rev 1.2 15 Aug 1991 23:07:48 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 11 May 1991 00:21:42 GLENN
* File header changed to conform to Toolkit standard.
*
* $DOC$
* $FUNCNAME$
* FT_FLOPTST()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Test diskette drive status
* $SYNTAX$
* FT_FLOPTST( <nDrive> ) -> nStatus
* $ARGUMENTS$
* <nDrive> is the diskette drive number, 0 = A:, 1 = B:
* $RETURNS$
* -1 - Wrong Parameters
* 0 - Drive Loaded and ready to read or write
* 1 - Drive Door Open or Diskette inserted upside down
* 2 - Diskette is unformatted
* 3 - Write protected
* 4 - Undetermined
* $DESCRIPTION$
* FT_FLOPTST() is designed as a full replacement for ISDRIVE(). Where
* ISDRIVE() returns just .T. or .F. depending if the diskette drive is
* ready or not, FT_FLOPTST() returns a numeric code designating the
* diskette drive's status.
*
* FT_FLOPTST() is particularly useful in backup and restore programs
* that need to test the floppy drive before writing/reading from a
* floppy disk.
*
* No testing has been performed on systems with more than 2 floppy
* drives. If the third drive is "C" and the fourth "D" then there
* should be no problems.
*
* This function does not currently check subst'd drives. So if you
* have SUBST E: A:\ then FT_FLOPTST( ASC("E")-ASC("A") ) == 4
* Any suggestions to fix this limitation are appreciated.
*
* $EXAMPLES$
* iStatus := FT_FLOPTST( 0 )
* DO CASE
* CASE iStatus == 1
* Qout( "The door to drive A is open." )
* CASE iStatus == 2
* Qout( "The diskette in drive A is not formatted." )
* CASE iStatus == 3
* Qout( "The diskette in drive A is write-protected." )
* CASE iStatus == 4
* Qout( "Something is wrong with drive A, but I don't know what." )
* ENDCASE
* $END$
*
*/
#include "FTINT86.CH"
#define TRUE .T.
#define FALSE .F.
#DEFINE ERR_WRONG_PARAMETERS -1
#DEFINE ERR_NO_ERROR 0
#DEFINE ERR_DRIVE_NOT_READY 1
#DEFINE ERR_UNFORMATTED 2
#DEFINE ERR_WRITE_PROTECTED 3
#DEFINE ERR_UNKNOWN 4
#IFDEF FT_TEST
#define CR_LF chr(13)+chr(10)
PROCEDURE MAIN( ;
cArg1 ;
)
LOCAL nErrCode
IF ValType( cArg1 ) == "C"
nErrCode := FT_FLOPTST( Asc( Upper(cArg1) ) - Asc( "A" ) )
OutStd( "Return Code is "+LTrim(Str(nErrCode)) +CR_LF )
ELSE
OutStd( "Usage: floptst cDrive"+CR_LF+" where cDrive is 'A' or 'B' etc..."+CR_LF )
ENDIF
RETURN
#ENDIF
FUNCTION FT_FLOPTST( ; // error code defined by ERR_*
nDriveNum_i ; // letter of floppy drive.
)
LOCAL cDrive
LOCAL cBuffer
LOCAL nErrorCode
LOCAL nRetCode
nRetCode := ERR_WRONG_PARAMETERS
IF ValType( nDriveNum_i ) == "N"
IF _GetDisketteNum( nDriveNum_i )
_ResetDisketteSystem()
_ReadBootSector( nDriveNum_i, @cBuffer, @nErrorCode )
IF nErrorCode == 0
_WriteBootSector( nDriveNum_i, cBuffer, @nErrorCode )
DO CASE
CASE nErrorCode == 0
nRetCode := ERR_NO_ERROR
CASE nErrorCode == 3
nRetCode := ERR_WRITE_PROTECTED
OTHERWISE
nRetCode := ERR_UNKNOWN
ENDCASE
ELSE
DO CASE
CASE nErrorCode == 128 // 80h
nRetCode := ERR_DRIVE_NOT_READY
CASE nErrorCode == 2
nRetCode := ERR_UNFORMATTED
OTHERWISE
nRetCode := ERR_UNKNOWN
END CASE
ENDIF
ENDIF
ENDIF
RETURN nRetCode
#define BITS_6AND7 192 // value of byte when bits 6&7 are high
STATIC FUNCTION _GetDisketteNum( ; // returns false if no floppy drive installed or nDrive_i is invalid
nDrive_i ; // drive number to query status
)
LOCAL aRegs[INT86_MAX_REGS]
LOCAL lRetCode
LOCAL nByte
LOCAL nDriveCount
// ASSERT 0 <= nDrive_i
lRetCode := FALSE
IF FT_INT86( 1*16+1, aRegs ) // INT for equipment determination
nByte := lowbyte( aRegs[AX] )
// bit 0 indicates floppy drive installed
IF Int( nByte / 2 ) * 2 != nByte // is it odd i.e. is bit 0 set??
// bits 6 & 7 indicate number of floppies installed upto 4.
nDriveCount := Asc( FT_BYTEAND( Chr(nByte), chr(BITS_6AND7) ) )
IF nDriveCount >= nDrive_i
lRetCode := TRUE
ENDIF
ENDIF
ENDIF
RETURN lRetCode
STATIC PROCEDURE _ResetDisketteSystem()
LOCAL aRegs[INT86_MAX_REGS]
aRegs[AX] := 0
FT_INT86( 1*16+3, aRegs )
RETURN
#define BUFFER_SIZEOF_SECTOR 512+1
STATIC FUNCTION _ReadBootSector( ;
nDriveNum, ;
cBuffer_o, ;
nErrCode_o ;
)
// call BIOS INT 13 for sector read
LOCAL aRegs[INT86_MAX_REGS]
LOCAL cBuffer := Space( BUFFER_SIZEOF_SECTOR )
LOCAL lSuccess
LOCAL nErrorCode
LOCAL lCarryFlag
aRegs[DX] := nDriveNum // DH = 0 Head 0, DL = drive number
aRegs[CX] := 1 // CH = 0 track 0, CL=1 sector 1
aRegs[BX] := REG_ES // buffer in ES:BX
aRegs[ES] := cBuffer
aRegs[AX] := makehi(2)+1 // AH = 02 read , AL=1 read one sector
lSuccess := _CallInt13hRetry( aRegs, @lCarryFlag, @nErrorCode )
cBuffer_o := aRegs[ES]
nErrCode_o := nErrorCode
RETURN lSuccess
STATIC FUNCTION _WriteBootSector( ;
nDriveNum, ;
cBuffer_i, ;
nErrCode_o ;
)
// call BIOS INT 13 for sector write
LOCAL aRegs[INT86_MAX_REGS]
LOCAL lSuccess
LOCAL nErrorCode
LOCAL lCarryFlag
aRegs[DX] := nDriveNum // DH = 0 Head 0 , DL = drive number
aRegs[CX] := 1 // CH = 0 track 0, CL=1 sector 1
aRegs[BX] := REG_ES // buffer in ES:BX
aRegs[ES] := cBuffer_i
aRegs[AX] := makehi(3)+1 // AH = 03 write , AL=1 read one sector
lSuccess := _CallInt13hRetry( aRegs, @lCarryFlag, @nErrorCode )
nErrCode_o := nErrorCode
RETURN lSuccess
STATIC FUNCTION _CallInt13hRetry( ; // logical: did the interrupt succeed?
aRegs_io, ; // registers values for INT 13h
lCarrySet_o, ; // status of carry flag if return code is true.
nDriveStatus_o ; // status of drive ( error code )
)
LOCAL lCarrySet
LOCAL aRegisters
LOCAL lSuccess
LOCAL nInterrupt_c := 1*16+3 // INT 13h
LOCAL i
lCarrySet := FALSE
aRegisters := AClone( aRegs_io )
lSuccess := FT_INT86( nInterrupt_c, aRegisters )
IF lSuccess
lCarrySet := carrySet( aRegisters[FLAGS] )
IF lCarrySet
_ResetDisketteSystem()
aRegisters := AClone( aRegs_io )
FT_INT86( nInterrupt_c, aRegisters )
lCarrySet := carrySet( aRegisters[FLAGS] )
IF lCarrySet
_ResetDisketteSystem()
aRegisters := AClone( aRegs_io )
FT_INT86( nInterrupt_c, aRegisters )
lCarrySet := carrySet( aRegisters[FLAGS] )
IF lCarrySet
_ResetDisketteSystem()
ENDIF
ENDIF
ENDIF
ENDIF
FOR i := 1 TO INT86_MAX_REGS
// pass altered register back up
aRegs_io[i] := aRegisters[i]
NEXT // i
lCarrySet_o := lCarrySet
nDriveStatus_o := highByte( aRegisters[AX] )
RETURN lSuccess
// EOF

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

@@ -0,0 +1,90 @@
/*
* File......: GCD.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:03:40 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:56 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:26 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_GCD()
* $CATEGORY$
* Math
* $ONELINER$
* Calculate greatest common divisor of two numbers
* $SYNTAX$
* FT_GCD( <nNumber1>, <nNumber2> ) -> nGCD
* $ARGUMENTS$
* <nNumber1> is the first number to find the GCD of.
*
* <nNumber2> is the second number to find the GCD of.
* $RETURNS$
* The greatest common divisor of the 2 numbers, or 0 if either is 0.
* $DESCRIPTION$
* This function calculates the greatest common divisor between 2 numbers,
* i.e., the largest number that will divide into both numbers evenly. It
* will return zero (0) if either number is zero.
* $EXAMPLES$
* ? FT_GCD(10,15) // Result: 5
* ? FT_GCD(108,54) // Result: 54
* ? FT_GCD(102,54) // Result: 6
* ? FT_GCD(111,17) // Result: 1
* $END$
*/
#command REPEAT ;
=> ;
DO WHILE .T.
#command UNTIL <Condition> ;
=> ;
IF <Condition> ; EXIT ; END ; END
#ifdef FT_TEST
FUNCTION MAIN( cNum1, cNum2 )
RETURN OUTSTD( STR(FT_GCD( val(cNum1), val(cNum2) )) + CHR(13) + CHR(10) )
#endif
FUNCTION FT_GCD(nNumber1, nNumber2)
LOCAL nHold1, ; // Temporarily Hold the Maximum Number
nHold2, ; // Temporarily Hold the Minimum Number
nResult // GCD
// Either Number Zero??
IF (nNumber1 == 0 .OR. nNumber2 == 0)
nResult := 0 // Yes, Can't Have a GCD
ELSE // No, Calculate the GCD
nHold1 := MAX(ABS(nNumber1), ABS(nNumber2))
nHold2 := MIN(ABS(nNumber1), ABS(nNumber2))
REPEAT
nResult := nHold1 % nHold2 // Get the Remainder
nHold1 := nHold2 // Which Makes a New Maximum Number
nHold2 := nResult // and it's the Minimum Number
UNTIL nResult <= 0
nResult := nHold1 // Maximum Number Should Be the Answer
ENDIF // nNumber1 == 0 or nNumber2 == 0
RETURN (nResult) // FT_GCD

179
harbour/contrib/libnf/getenvrn.c Normal file
View File

@@ -0,0 +1,179 @@
/*
* $Id$
*/
/*
* File......: GETENVRN.C
* Author....: Rick Whitt
* CIS ID....: 70672,605
*
* This is an original work by Rick Whitt and is placed in the
* public domain.
*
* Modification history:
* ---------------------
* Rev 1.2a 09 Sep 1996 JO
* Added underscore prefix to environ() calls for MSC 8.0
* Note: 5.2e version will work if linked with MSC OldNames.lib
*
* Rev 1.2 01 Jan 1996 03:01:00 TED
* Added prototypes to kill compiler warning.
*
* Rev 1.1 15 Aug 1991 23:08:42 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.0 17 Jul 1991 22:08:12 GLENN
* Initial revision.
*
*/
/* $DOC$
* $FUNCNAME$
* FT_GETE()
* $CATEGORY$
* Environment
* $ONELINER$
* Return the entire current environment
* $SYNTAX$
* FT_GETE( [ @<xReceiveVar> ] ) -> nNumStrings
* $ARGUMENTS$
* <xReceiveVar> is the variable to receive the environment data.
*
* <xReceiveVar> can be a character type variable, in which case
* the function will place all environment strings in the variable
* separated by carriage return/line feeds (chr 13 + chr(10)).
*
* <xReceiveVar> can be an array type, in which case the function
* will place each string in an array element. The array MUST be
* declared with the proper number of elements prior to passing it
* to the function. This can be done by calling FT_GETE() without
* parameters first to get the number of strings in the environment.
*
* Note that the argument MUST be passed by reference. Since arrays
* are by nature passed by reference, the "@" symbol is optional when
* passing an array.
*
* If no argument is passed, FT_GETE() merely returns the number
* of strings in the environment.
* $RETURNS$
* FT_GETE() returns the total number of strings found in the
* current program's environment.
* $DESCRIPTION$
* This function stores ALL of the current program's environment
* variables in either a block of text lines or in an array. It is
* useful for looking at the entire environment at once, or recording
* a snapshot of it to a file for later inspection, such as when a
* program error occurs. If the value of ONE SPECIFIC variable is
* desired, use Clipper's built-in GETE() function.
*
* This function uses the undocumented internal variable "_environ",
* as well as the functions _strcpy(), _strcat(), and _strlen() from
* CLIPPER.LIB
* $EXAMPLES$
* Get the environment in text form and browse it:
*
* cEnvBlock := ""
* nNumStrings := FT_GETE(@cEnvBlock)
* @ 0, 0 to MAXROW() - 1, MAXCOL()
* @ MAXROW(), 0 say 'Browse strings, press ESC to exit...'
* MEMOWRIT(cEnvBlock, 1, 1, MAXROW() - 2,MAXCOL() - 1, .F.)
*
* Get the environment in text form and write it to a file:
*
* cEnvBlock := ""
* FT_GETE(@cEnvBlock)
* MEMOWRIT("ENVIRON.TXT", cEnvBlock)
*
* Get the environment in Array form:
*
* aEnvArray := ARRAY(FT_GETE())
* FT_GETE(aEnvArray)
* ? aEnvArray[1] // "COMSPEC=C:\COMMAND.COM"
* ? aEnvArray[2] // "PATH=C:\;C:\DOS;C:\UTIL;C:\CLIP50\BIN"
* ... etc ...
* $END$
*/
#include <EXTEND.API>
#include <FM.API>
#define NORETURN 0
#define CHARTYPE 1
#define ARRAYTYPE 2
#define CRLF "\x0D\x0A"
/*
unsigned int strlen( char * );
char * strcpy( char *, char * );
char * strcat( char *, char * );
*/
HB_FUNC(FT_GETE)
{
/* INTERNALS WARNING: All references to 'environ', strlen(), ;
strcpy(), and strcat() are undocumented Clipper 5.0 internals.
*/
#if defined(HB_OS_DOS) || defined(HB_OS_WIN_32)
{
extern char **_environ;
char *buffer;
int x;
int buffsize = 0;
int rettype = NORETURN;
if (ISCHAR(1))
rettype = CHARTYPE;
if (ISARRAY(1))
rettype = ARRAYTYPE;
if (rettype == CHARTYPE)
// scan strings first and add up total size
{
for (x = 0; ;x++)
{
if (! _environ[x])
// null string, we're done
break;
// add length of this string plus 2 for the crlf
buffsize += (strlen(_environ[x]) + 2);
}
// add 1 more byte for final nul character
buffsize++;
// now allocate that much memory and make sure 1st byte is a nul
buffer = hb_xalloc(buffsize);
strcpy(buffer,"\0");
}
for (x = 0; ;x++)
{
if (! _environ[x])
// null string, we're done
break;
if (rettype == CHARTYPE)
{
// tack string onto end of buffer
strcat( buffer, _environ[x] );
// add crlf at end of each string
strcat( buffer, CRLF );
}
if (rettype == ARRAYTYPE)
// store string to next array element
hb_storc(_environ[x],1,x + 1);
}
if (rettype == CHARTYPE)
{
// return buffer to app and free memory
hb_storc(buffer,1);
hb_xfree(buffer);
}
// return number of strings found
hb_retni(x);
}
#endif
}

180
harbour/contrib/libnf/getver.c Normal file
View File

@@ -0,0 +1,180 @@
/*
* $Id$
*/
/*
Harbour Project source code
Getver.c Support functions for Nanfor Library
Copyright 2000 Luiz Rafael Culik <Culik@sl.conex.net>
www - http://www.harbour-project.org
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version, with one exception:
The exception is that if you link the Harbour Runtime Library (HRL)
and/or the Harbour Virtual Machine (HVM) with other files to produce
an executable, this does not by itself cause the resulting executable
to be covered by the GNU General Public License. Your use of that
executable is in no way restricted on account of linking the HRL
and/or HVM code into it.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit
their web site at http://www.gnu.org/).
*/
#include "hbapi.h"
#include "hbapiitm.h"
#include "dos.h"
#include "string.h"
#include "stdlib.h"
HB_FUNC(_GET_DOSVER)
{
#if defined(HB_OS_DOS)
{
char * pszPlatform;
union REGS regs;
pszPlatform = ( char * ) hb_xgrab( 256 );
regs.h.ah = 0x30;
HB_DOS_INT86( 0x21, &regs, &regs );
sprintf( pszPlatform, "%d.%02d", regs.h.al, regs.h.ah );
hb_retc(pszPlatform );
hb_xfree(pszPlatform );
}
#endif
}
HB_FUNC(_FT_ISSHARE)
{
int iShare;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0x1000;
regs.HB_XREGS.cx=0;
HB_DOS_INT86(0x2F,&regs,&regs);
iShare=regs.h.al;
}
#else
{
iShare=0;
}
#endif
{
hb_retni(iShare);
}
}
HB_FUNC(_FT_NWKSTAT)
{
int iConnect;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.HB_XREGS.ax=0xDC;
HB_DOS_INT86(0x2F,&regs,&regs);
iConnect=regs.h.al;
}
#else
{
iConnect=0;
}
#endif
{
hb_retni(iConnect);
}
}
HB_FUNC(_FT_SETMODE)
{
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.h.ah=0;
regs.h.al=hb_parni(1);
HB_DOS_INT86(0x10,&regs,&regs);
}
#endif
}
HB_FUNC(_FT_GETMODE)
{
int iMode;
#if defined(HB_OS_DOS)
{
union REGS regs;
regs.h.ah=0x0F;
HB_DOS_INT86(0x10,&regs,&regs);
iMode=regs.h.al;
}
#else
{
iMode=0;
}
#endif
{
hb_retni(iMode);
}
}
HB_FUNC(_FT_TEMPFIL)
{
int nax;
int iflags;
char *cPath;
#if defined(HB_OS_DOS)
{
int iMode=hb_parni(2);
union REGS regs;
struct SREGS sregs;
segread(&sregs);
cPath=hb_parc(1);
regs.h.ah=0x5A;
regs.HB_XREGS.cx=iMode;
sregs.ds=FP_SEG(cPath);
regs.HB_XREGS.dx=FP_OFF(cPath);
int86x(0x21,&regs,&regs,&sregs);
nax=regs.HB_XREGS.ax;
iflags=regs.HB_XREGS.flags;
}
#else
{
nax=0;
iflags=0;
}
#endif
{
PHB_ITEM pArray = hb_itemArrayNew( 3 );
PHB_ITEM pAx = hb_itemPutNI( NULL, nax);
PHB_ITEM pDs = hb_itemPutC( NULL, cPath);
PHB_ITEM pFlags = hb_itemPutNI( NULL, iflags );
hb_itemArrayPut( pArray, 1, pAx );
hb_itemArrayPut( pArray, 2, pDs );
hb_itemArrayPut( pArray, 3, pFlags);
hb_itemReturn( pArray );
hb_itemRelease( pAx);
hb_itemRelease( pDs );
hb_itemRelease( pFlags );
hb_itemRelease( pArray );
}
}

73
harbour/contrib/libnf/getvid.c Normal file
View File

@@ -0,0 +1,73 @@
/*
* $Id$
*/
/*
Harbour Project source code
Getvid.c Support functions for Nanfor Library
Copyright 2000 Luiz Rafael Culik <Culik@sl.conex.net>
www - http://www.harbour-project.org
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version, with one exception:
The exception is that if you link the Harbour Runtime Library (HRL)
and/or the Harbour Virtual Machine (HVM) with other files to produce
an executable, this does not by itself cause the resulting executable
to be covered by the GNU General Public License. Your use of that
executable is in no way restricted on account of linking the HRL
and/or HVM code into it.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit
their web site at http://www.gnu.org/).
*/
#include "hbapi.h"
#include "dos.h"
HB_FUNC(_FT_GETVPG)
{
int iPage;
#if defined(HB_OS_DOS)
{
union REGS registers;
regs.h.ah=0x0F;
HB_DOS_INT86(0x10,&registers,&registers);
iPage=regs.h.bh;
}
#else
{
iPage=0;
}
#endif
{
hb_retni(iPage);
}
}
HB_FUNC(_V_SETVPG)
{
int iPage;
#if defined(HB_OS_DOS)
{
union REGS registers;
iPage=hb_parni(1);
regs.h.ah=0x05;
regs.h.al=iPage;
HB_DOS_INT86(0x10,&registers,&registers);
}
#endif
}

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

@@ -0,0 +1,68 @@
/*
* File......: HEX2DEC.PRG
* Author....: Robert A. DiFalco
* CIS ID....: ?
*
* This is an original work by Robert DiFalco and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 17 Aug 1991 15:32:56 GLENN
* Don Caton fixed some spelling errors in the doc
*
* Rev 1.2 15 Aug 1991 23:03:42 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:51:58 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:28 GLENN
* Nanforum Toolkit
*
*/
/*
* $DOC$
* $FUNCNAME$
* FT_HEX2DEC()
* $CATEGORY$
* Conversion
* $ONELINER$
* Convert a hex number to decimal
* $SYNTAX$
* FT_HEX2DEC( <cHexNum> ) -> nDecNum
* $ARGUMENTS$
* <cHexNum> is a character string representing a hex number.
* $RETURNS$
* A decimal number.
* $DESCRIPTION$
* Converts a hexadecimal number to a BASE 10 decimal number.
* Useful for using FT_INT86().
* $EXAMPLES$
* FT_INT86( HEX2DEC( "21" ), aRegs )
*
* Converts 21h, the Dos Interrupt, to its decimal equivalent,
* 33, for use by FT_INT86().
* $END$
*/
#define HEXTABLE "0123456789ABCDEF"
#ifdef FT_TEST
FUNCTION MAIN( cHexNum )
QOut( FT_HEX2DEC( cHexNum ) )
return ( nil )
#endif
FUNCTION FT_HEX2DEC( cHexNum )
local n, nDec := 0, nHexPower := 1
for n := len( cHexNum ) to 1 step -1
nDec += ( at( subs( upper(cHexNum), n, 1 ), HEXTABLE ) - 1 ) * nHexPower
nHexPower *= 16
next
RETURN nDec

66
harbour/contrib/libnf/idle.c Normal file
View File

@@ -0,0 +1,66 @@
/*
* File......: IDLE.C
* Author....: Ted Means (with much gratitude to Robert DiFalco)
* 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_Idle()
* $CATEGORY$
* Event
* $ONELINER$
* Generate an idle event to allow incremental garbage collection.
* $SYNTAX$
* FT_Idle()
* $ARGUMENTS$
* None
* $RETURNS$
* NIL
* $DESCRIPTION$
* During memory-intensive operations that do not generate much in
* the way of idle states, the Clipper runtime may not get a chance to
* perform garbage collection of discarded memory. This can eventually
* lead to any of a variety of memory-related internal errors.
*
* This function attempts to alleviate the problem by providing a
* mechanism by which an idle event can be artifically generated at
* will. The idle event will cause the CA-Clipper runtime to perform
* an incremental memory scavenge.
*
* This function makes use of an undocumented interal routine. If this
* this fact makes you uncomfortable then don't use this function, you
* miserable jello-spined lump of human debris.
* $EXAMPLES$
*
* while Whatever // Some batch process
*
* Something() // Create 'n' discard a bunch of stuff
*
* FT_Idle() // Take out the garbage
*
* end
* $SEEALSO$
* FT_OnIdle()
* $END$
*/
void _evSendId( unsigned int, unsigned int );
HB_FUNC(FT_Idle)
{
_evSendId( 0x5108, 0xFFFF );
return;
}

73
harbour/contrib/libnf/invclr.prg Normal file
View File

@@ -0,0 +1,73 @@
/*
* File......: InvClr.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:03:44 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:00 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:30 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_INVCLR()
* $CATEGORY$
* Conversion
* $ONELINER$
* Get the inverse of a color
* $SYNTAX$
* FT_INVCLR( [ <cDsrdColor> ] ) -> cColor
* $ARGUMENTS$
* <cDsrdColor> is the color to get the inverse of. Defaults to
* current color.
* $RETURNS$
* The inverse of the passed color.
* $DESCRIPTION$
* This function inverts a passed color (in the Clipper format: ??/??),
* e.g., "W/N" is converted to "N/W".
* $EXAMPLES$
* cInverse := FT_INVCLR() // Get Inverse of Current Color
* cInvErr := FT_INVCLR( cErrColor ) // Get Inverse of cErrorColor
* $END$
*/
#Command DEFAULT <Param1> TO <Def1> [, <ParamN> TO <DefN> ] ;
=> ;
<Param1> := IF(<Param1> == NIL,<Def1>,<Param1>) ;
[; <ParamN> := IF(<ParamN> == NIL,<DefN>,<ParamN>)]
#define NULL ""
FUNCTION FT_INVCLR(cDsrdColor)
LOCAL cBackground, ; // The Background Color, New Foreground
cForeground, ; // The Foreground Color, New Background
cModifiers // Any Color Modifiers (+*)
DEFAULT cDsrdColor TO SETCOLOR()
// Remove Anything Past 1st Color
cDsrdColor := LEFT(cDsrdColor, AT(",", cDsrdColor+",")-1)
// Get Any Modifiers
cModifiers := IF("*" $ cDsrdColor, "*", NULL) + ;
IF("+" $ cDsrdColor, "+", NULL)
// Separate the Fore/Background Colors
cForeground := ALLTRIM(LEFT(cDsrdColor, AT("/", cDsrdColor) - 1))
cBackground := ALLTRIM(SUBSTR(cDsrdColor, AT("/", cDsrdColor) + 1))
RETURN (STRTRAN(STRTRAN(cBackground, "+"), "*") + cModifiers + "/" + ;
STRTRAN(STRTRAN(cForeground, "+"), "*"))

84
harbour/contrib/libnf/isbit.prg Normal file
View File

@@ -0,0 +1,84 @@
/*
* File......: ISBIT.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:46 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 19:52:02 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:32 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ISBIT()
* $CATEGORY$
* String
* $ONELINER$
* Test the status of an individual bit
* $SYNTAX$
* FT_ISBIT( <cByte>, <nBitPos> ) -> lResult
* $ARGUMENTS$
* <cByte> is a character from CHR(0) to CHR(255)
*
* <nBitPos> is a number from 0 to 7 conforming to standard right-to-left
* bit-numbering convention and representing the position of the
* bit within the byte.
* $RETURNS$
* .T. if designated bit is set (1), .F. if not set (0), NIL if
* invalid parameters.
* $DESCRIPTION$
* Tests for status of any selected bit in the byte passed as a parameter.
* Byte must be presented in CHR() form, as a literal constant, or as the
* one-byte character result of an expression.
*
* This function is presented to illustrate that bit-wise operations
* are possible with Clipper code. For greater speed, write .C or
* .ASM versions and use the Clipper Extend system.
* $EXAMPLES$
* This code tests whether bit 3 is set in the byte represented by
* CHR(107):
*
* lBitflag := FT_ISBIT(CHR(107), 3)
* ? lBitflag // result: .T.
*
* This code tests whether bit 5 is set in the byte represented by ASCII
* 65 (letter 'A')
*
* ? FT_ISBIT('A', 5) // result: .F.
*
* For a demonstration of Clipper bit manipulations, compile and
* link the program BITTEST.PRG in the Nanforum Toolkit source code.
* $SEEALSO$
* FT_BITSET() FT_BITCLR()
* $END$
*/
FUNCTION FT_ISBIT(cInbyte,nBitPos)
LOCAL lBitStat
IF valtype(cInbyte) != "C" .or. valtype(nBitPos) != "N" // parameter check
lBitStat := NIL
ELSE
if (nBitPos > 7) .or. (nBitPos < 0) .or. (nBitPos != int(nBitPos))
lBitStat := NIL
else
lBitStat := int(((asc(cInByte) * (2 ^ (7 - nBitPos))) % 256) / 128) == 1
endif
ENDIF
RETURN lBitStat

66
harbour/contrib/libnf/isbiton.prg Normal file
View File

@@ -0,0 +1,66 @@
/*
* File......: ISBITON.PRG
* 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 Aug 1991 23:02:26 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 17 Jul 1991 22:15:12 GLENN
* Ted sent a minor bug fix
*
* Rev 1.1 14 Jun 1991 19:52:04 GLENN
* Minor edit to file header
*
* Rev 1.0 01 Apr 1991 01:01:34 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ISBITON()
* $CATEGORY$
* String
* $ONELINER$
* Determine the state of individual bits in a number
* $SYNTAX$
* FT_ISBITON( <nNumber>, <nBit> ) -> lResult
* $ARGUMENTS$
* <nNumber> is an integer for which a bit state needs to be checked.
*
* <nBit> is a number from 0 to 15 that indicates which bit to test.
* $RETURNS$
* .T. if the specified bit was on., .F. if off.
* $DESCRIPTION$
* This function is useful when dealing with binary integers. It will
* come in very handy if you use the FT_INT86() function, because the
* CPU flags are returned as a series of bits. Using this function, you
* can determine the state of each CPU flag.
* $EXAMPLES$
* if FT_ISBITON( nCPUFlags, 0 )
* Qout( "The carry flag was set." )
* endif
*
* if FT_ISBITON( nCPUFlags, 7 )
* Qout( "The sign flag was set." )
* endif
* $END$
*/
function FT_ISBITON( nWord, nBit )
nWord := iif(nWord < 0, nWord + 65536, nWord)
nWord := int(nWord * (2 ^ (15 - nBit)))
nWord := int(nWord % 65536)
nWord := int(nWord / 32768)
return (nWord == 1)

89
harbour/contrib/libnf/isshare.prg Normal file
View File

@@ -0,0 +1,89 @@
/*
* File......: ISSHARE.PRG
* Author....: Glenn Scott (from Tom Leylan C source)
* CIS ID....: ?
*
* This is an original work by tom leylan and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* Rev 1.3 15 Aug 1991 23:03:48 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.2 14 Jun 1991 19:52:06 GLENN
* Minor edit to file header
*
* Rev 1.1 12 Jun 1991 02:14:56 GLENN
* Documentation adjustment and checking ft_int86() call for compatibility
* with new return value.
*
* Rev 1.0 01 Apr 1991 01:01:34 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_ISSHARE()
* $CATEGORY$
* DOS/BIOS
* $ONELINER$
* Determine if DOS "Share" is installed
* $SYNTAX$
* FT_ISSHARE() -> nRetCode
* $ARGUMENTS$
* None
* $RETURNS$
* nRetcode will be set as follows on exit:
*
* 0 if SHARE not loaded but ok to load
* 1 if SHARE not loaded and not ok to load
* 255 if SHARE loaded
* $DESCRIPTION$
* Uses DOS interrupt 2Fh (MultiPlex interrupt), service 10h
* to determine if DOS SHARE.COM is loaded.
* $EXAMPLES$
* IF FT_ISSHARE() != 255
* Qout("SHARE must be loaded!")
* ENDIF
* $SEEALSO$
* FT_INT86()
* $END$
*/
#include "FTINT86.CH"
#ifdef FT_TEST
function main()
local nLoaded := ft_isshare()
do case
case nLoaded == 0
Qout("Share not loaded, but ok to load")
case nLoaded == 1
Qout("Share not loaded, but NOT ok to load!")
case nLoaded == 255
Qout("Share is loaded!")
endcase
Qout("Retcode: " + str( nLoaded ) )
return nil
#endif
FUNCTION ft_isshare()
/*
local aRegs[ INT86_MAX_REGS ] // Declare the register array
aRegs[ AX ] := makehi(16) // share service
aRegs[ CX ] := 0 // Specify file attribute
FT_Int86( 47, aRegs) // multiplex interrupt
RETURN lowbyte( aRegs[AX] )
*/
RETURN _ft_isshare()