diff --git a/harbour/contrib/libnf/findith.prg b/harbour/contrib/libnf/findith.prg new file mode 100644 index 0000000000..a059f80aa0 --- /dev/null +++ b/harbour/contrib/libnf/findith.prg @@ -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( , , ; + * [, ] ) -> + * $ARGUMENTS$ + * is the string to search for. + * + * is the string to search. + * + * is the number of the occurrence to find. + * + * 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))))) diff --git a/harbour/contrib/libnf/firstday.prg b/harbour/contrib/libnf/firstday.prg new file mode 100644 index 0000000000..673d9362f5 --- /dev/null +++ b/harbour/contrib/libnf/firstday.prg @@ -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( [ ] ) -> dFirstDay + * $ARGUMENTS$ + * 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) + diff --git a/harbour/contrib/libnf/floptst.prg b/harbour/contrib/libnf/floptst.prg new file mode 100644 index 0000000000..c200372707 --- /dev/null +++ b/harbour/contrib/libnf/floptst.prg @@ -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( ) -> nStatus +* $ARGUMENTS$ +* 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 diff --git a/harbour/contrib/libnf/gcd.prg b/harbour/contrib/libnf/gcd.prg new file mode 100644 index 0000000000..ff54ab0042 --- /dev/null +++ b/harbour/contrib/libnf/gcd.prg @@ -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( , ) -> nGCD + * $ARGUMENTS$ + * is the first number to find the GCD of. + * + * 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 ; + => ; + IF ; 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 diff --git a/harbour/contrib/libnf/getenvrn.c b/harbour/contrib/libnf/getenvrn.c new file mode 100644 index 0000000000..7e6de1d60d --- /dev/null +++ b/harbour/contrib/libnf/getenvrn.c @@ -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( [ @ ] ) -> nNumStrings + * $ARGUMENTS$ + * is the variable to receive the environment data. + * + * 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)). + * + * 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 +#include + +#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 +} diff --git a/harbour/contrib/libnf/getver.c b/harbour/contrib/libnf/getver.c new file mode 100644 index 0000000000..f73667b505 --- /dev/null +++ b/harbour/contrib/libnf/getver.c @@ -0,0 +1,180 @@ +/* + * $Id$ + */ + +/* + Harbour Project source code + + Getver.c Support functions for Nanfor Library + + Copyright 2000 Luiz Rafael Culik + 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, ®s, ®s ); + + 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,®s,®s); + 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,®s,®s); + 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,®s,®s); + } +#endif +} +HB_FUNC(_FT_GETMODE) +{ + int iMode; +#if defined(HB_OS_DOS) + { + union REGS regs; + regs.h.ah=0x0F; + HB_DOS_INT86(0x10,®s,®s); + 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,®s,®s,&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 ); + } +} diff --git a/harbour/contrib/libnf/getvid.c b/harbour/contrib/libnf/getvid.c new file mode 100644 index 0000000000..4eb7ff2295 --- /dev/null +++ b/harbour/contrib/libnf/getvid.c @@ -0,0 +1,73 @@ +/* + * $Id$ + */ + +/* + Harbour Project source code + + Getvid.c Support functions for Nanfor Library + + Copyright 2000 Luiz Rafael Culik + 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,®isters,®isters); + 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,®isters,®isters); + } +#endif +} + diff --git a/harbour/contrib/libnf/hex2dec.prg b/harbour/contrib/libnf/hex2dec.prg new file mode 100644 index 0000000000..cfaf14dfc7 --- /dev/null +++ b/harbour/contrib/libnf/hex2dec.prg @@ -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( ) -> nDecNum + * $ARGUMENTS$ + * 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 diff --git a/harbour/contrib/libnf/idle.c b/harbour/contrib/libnf/idle.c new file mode 100644 index 0000000000..44cfebfab6 --- /dev/null +++ b/harbour/contrib/libnf/idle.c @@ -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; +} diff --git a/harbour/contrib/libnf/invclr.prg b/harbour/contrib/libnf/invclr.prg new file mode 100644 index 0000000000..e3ff6bcf25 --- /dev/null +++ b/harbour/contrib/libnf/invclr.prg @@ -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( [ ] ) -> cColor + * $ARGUMENTS$ + * 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 TO [, TO ] ; + => ; + := IF( == NIL,,) ; + [; := IF( == NIL,,)] + +#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, "+"), "*")) diff --git a/harbour/contrib/libnf/isbit.prg b/harbour/contrib/libnf/isbit.prg new file mode 100644 index 0000000000..7655c3de4b --- /dev/null +++ b/harbour/contrib/libnf/isbit.prg @@ -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( , ) -> lResult + * $ARGUMENTS$ + * is a character from CHR(0) to CHR(255) + * + * 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 + diff --git a/harbour/contrib/libnf/isbiton.prg b/harbour/contrib/libnf/isbiton.prg new file mode 100644 index 0000000000..98f695664d --- /dev/null +++ b/harbour/contrib/libnf/isbiton.prg @@ -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( , ) -> lResult + * $ARGUMENTS$ + * is an integer for which a bit state needs to be checked. + * + * 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) diff --git a/harbour/contrib/libnf/isshare.prg b/harbour/contrib/libnf/isshare.prg new file mode 100644 index 0000000000..a4c5269063 --- /dev/null +++ b/harbour/contrib/libnf/isshare.prg @@ -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()