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

See changelog 2000-12-10 15:50 GMT -3

Browse Source
This commit is contained in:
Luiz Rafael Culik
2000-12-10 18:25:36 +00:00
parent af3ecd9cda
commit 3c05a78a4e
16 changed files with 3393 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
harbour/ChangeLog
View File

@@ -1,3 +1,29 @@
2000-12-10 15:50 GMT -3 Luiz Rafael Culik <culik@sl.conex.net>
*makefile.bc
hb_slex.bc
*Add hbmake to dependencies list
+utils/hbmake
*hbmake directoy
+utils/hbmake/hbmake.prg
*Harbour make utility main file
+utils/hbmake/radios.prg
utils/hbmake/checks.prg
utils/hbmake/pickarry.prg
utils/hbmake/pickfile.prg
utils/hbmake/prb_stak.prg
utils/hbmake/radios.ch
utils/hbmake/checks.ch
utils/hbmake/radiodef.ch
utils/hbmake/checkdef.ch
*Utilityes functions need by hbmake
*utils/hbmake/fclass1.prg
utils/hbmake/ft_funcs.prg
utils/hbmake/ffile1.prg
Hbdoc File class engine
*utils/hbmake/makefile
*makefile for GNu compiler
utils/hbmake/checks.ch
2000-12-09 14:09 UTC-0800 Brian Hays <bhays@abacuslaw.com>
* source/rdd/dbfntx/dbfntx1.c
* More fixes by Alexander

78
harbour/hb_slex.bc
View File

@@ -86,6 +86,7 @@ HBRUN_DIR = utils\hbrun
HBTEST_DIR = utils\hbtest
HBDOC_DIR = utils\hbdoc
HBPP_DIR = utils\hbpp
HBMAKE_DIR = utils\hbmake
!if $d(PDF)
HBPDF_DIR = contrib\pdflib
!endif
@@ -131,7 +132,7 @@ HBPP_EXE = $(BIN_DIR)\hbpp.exe
HBRUN_EXE = $(BIN_DIR)\hbrun.exe
HBTEST_EXE = $(BIN_DIR)\hbtest.exe
HBDOC_EXE = $(BIN_DIR)\hbdoc.exe
HBMAKE_EXE = $(BIN_DIR)\hbmake.exe
#
# GT driver list
#
@@ -605,6 +606,14 @@ HBDOC_EXE_OBJS = \
$(OBJ_DIR)\genpdf1.obj
!endif
HBMAKE_EXE_OBJS = \
$(OBJ_DIR)\hbmake.obj \
$(OBJ_DIR)\checks.obj \
$(OBJ_DIR)\pickarry.obj \
$(OBJ_DIR)\pickfile.obj \
$(OBJ_DIR)\prb_stak.obj \
$(OBJ_DIR)\radios.obj
#
# Our default target
#
@@ -626,7 +635,8 @@ all: \
$(HBRUN_EXE) \
$(HBPP_EXE) \
$(HBTEST_EXE) \
$(HBDOC_EXE)
$(HBDOC_EXE) \
$(HBMAKE_EXE)
#
# Library dependencies and build rules
@@ -2351,3 +2361,67 @@ $(OBJ_DIR)\genpdf1.obj : $(OBJ_DIR)\genpdf1.c
$(OBJ_DIR)\pdfhbdoc.obj : $(HBPDF_DIR)\pdfhbdoc.c
$(CC) $(CLIBFLAGS) -v -y -I$(HBPDF_DIR) -o$@ $**
!endif
$(HBMAKE_EXE) : $(HBMAKE_EXE_OBJS)
echo. $(CFLAGS) > make.tmp
echo. -M -e$(HBMAKE_EXE) >> make.tmp
echo. $(OBJ_DIR)\hbmake.obj >> make.tmp
echo. $(OBJ_DIR)\radios.obj >> make.tmp
echo. $(OBJ_DIR)\checks.obj >> make.tmp
echo. $(OBJ_DIR)\fclass1.obj >> make.tmp
echo. $(OBJ_DIR)\ffile1.obj >> make.tmp
echo. $(OBJ_DIR)\ft_funcs.obj >> make.tmp
echo. $(OBJ_DIR)\pickarry.obj >> make.tmp
echo. $(OBJ_DIR)\pickfile.obj >> make.tmp
echo. $(OBJ_DIR)\prb_stak.obj >> make.tmp
echo. $(PP_LIB) >> make.tmp
echo. $(COMMON_LIB) >> make.tmp
echo. $(VM_LIB) >> make.tmp
echo. $(RTL_LIB) >> make.tmp
echo. $(HB_GT_LIB) >> make.tmp
echo. $(LANG_LIB) >> make.tmp
echo. $(RDD_LIB) >> make.tmp
echo. $(MACRO_LIB) >> make.tmp
echo. $(DBFNTX_LIB) >> make.tmp
echo. $(DBFCDX_LIB) >> make.tmp
$(CC) @make.tmp
del make.tmp
$(OBJ_DIR)\hbmake.c : $(HBMAKE_DIR)\hbmake.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\hbmake.obj : $(OBJ_DIR)\hbmake.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\radios.c : $(HBMAKE_DIR)\radios.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\radios.obj : $(OBJ_DIR)\radios.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\checks.c : $(HBMAKE_DIR)\checks.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\checks.obj : $(OBJ_DIR)\checks.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\pickarry.c : $(HBMAKE_DIR)\pickarry.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\pickarry.obj : $(OBJ_DIR)\pickarry.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\pickfile.c : $(HBMAKE_DIR)\pickfile.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\pickfile.obj : $(OBJ_DIR)\pickfile.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\prb_stak.c : $(HBMAKE_DIR)\prb_stak.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\prb_stak.obj : $(OBJ_DIR)\prb_stak.c
$(CC) $(CLIBFLAGS) -o$@ $**

79
harbour/makefile.bc
View File

@@ -86,6 +86,7 @@ HBRUN_DIR = utils\hbrun
HBTEST_DIR = utils\hbtest
HBDOC_DIR = utils\hbdoc
HBPP_DIR = utils\hbpp
HBMAKE_DIR = utils\hbmake
!if $d(PDF)
HBPDF_DIR = contrib\pdflib
!endif
@@ -131,7 +132,7 @@ HBPP_EXE = $(BIN_DIR)\hbpp.exe
HBRUN_EXE = $(BIN_DIR)\hbrun.exe
HBTEST_EXE = $(BIN_DIR)\hbtest.exe
HBDOC_EXE = $(BIN_DIR)\hbdoc.exe
HBMAKE_EXE = $(BIN_DIR)\hbmake.exe
#
# GT driver list
#
@@ -606,6 +607,14 @@ HBDOC_EXE_OBJS = \
$(OBJ_DIR)\genpdf1.obj
!endif
HBMAKE_EXE_OBJS = \
$(OBJ_DIR)\hbmake.obj \
$(OBJ_DIR)\checks.obj \
$(OBJ_DIR)\pickarry.obj \
$(OBJ_DIR)\pickfile.obj \
$(OBJ_DIR)\prb_stak.obj \
$(OBJ_DIR)\radios.obj
#
# Our default target
#
@@ -627,8 +636,8 @@ all: \
$(HBRUN_EXE) \
$(HBPP_EXE) \
$(HBTEST_EXE) \
$(HBDOC_EXE)
$(HBDOC_EXE) \
$(HBMAKE_EXE)
#
# Library dependencies and build rules
#
@@ -2343,3 +2352,67 @@ $(OBJ_DIR)\genpdf1.obj : $(OBJ_DIR)\genpdf1.c
$(OBJ_DIR)\pdfhbdoc.obj : $(HBPDF_DIR)\pdfhbdoc.c
$(CC) $(CLIBFLAGS) -v -y -I$(HBPDF_DIR) -o$@ $**
!endif
$(HBMAKE_EXE) : $(HBMAKE_EXE_OBJS)
echo. $(CFLAGS) > make.tmp
echo. -M -e$(HBMAKE_EXE) >> make.tmp
echo. $(OBJ_DIR)\hbmake.obj >> make.tmp
echo. $(OBJ_DIR)\radios.obj >> make.tmp
echo. $(OBJ_DIR)\checks.obj >> make.tmp
echo. $(OBJ_DIR)\fclass1.obj >> make.tmp
echo. $(OBJ_DIR)\ffile1.obj >> make.tmp
echo. $(OBJ_DIR)\ft_funcs.obj >> make.tmp
echo. $(OBJ_DIR)\pickarry.obj >> make.tmp
echo. $(OBJ_DIR)\pickfile.obj >> make.tmp
echo. $(OBJ_DIR)\prb_stak.obj >> make.tmp
echo. $(PP_LIB) >> make.tmp
echo. $(COMMON_LIB) >> make.tmp
echo. $(VM_LIB) >> make.tmp
echo. $(RTL_LIB) >> make.tmp
echo. $(HB_GT_LIB) >> make.tmp
echo. $(LANG_LIB) >> make.tmp
echo. $(RDD_LIB) >> make.tmp
echo. $(MACRO_LIB) >> make.tmp
echo. $(DBFNTX_LIB) >> make.tmp
echo. $(DBFCDX_LIB) >> make.tmp
$(CC) @make.tmp
del make.tmp
$(OBJ_DIR)\hbmake.c : $(HBMAKE_DIR)\hbmake.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\hbmake.obj : $(OBJ_DIR)\hbmake.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\radios.c : $(HBMAKE_DIR)\radios.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\radios.obj : $(OBJ_DIR)\radios.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\checks.c : $(HBMAKE_DIR)\checks.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\checks.obj : $(OBJ_DIR)\checks.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\pickarry.c : $(HBMAKE_DIR)\pickarry.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\pickarry.obj : $(OBJ_DIR)\pickarry.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\pickfile.c : $(HBMAKE_DIR)\pickfile.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\pickfile.obj : $(OBJ_DIR)\pickfile.c
$(CC) $(CLIBFLAGS) -o$@ $**
$(OBJ_DIR)\prb_stak.c : $(HBMAKE_DIR)\prb_stak.prg
$(HARBOUR_EXE) $(HARBOURFLAGS) $** -o$@
$(OBJ_DIR)\prb_stak.obj : $(OBJ_DIR)\prb_stak.c
$(CC) $(CLIBFLAGS) -o$@ $**

9
harbour/utils/hbmake/checkdef.ch Normal file
View File

@@ -0,0 +1,9 @@
/***
* Checkdef.ch
*
* Definition of translates for simulated Check box class.
*/
#translate :checkGsb => :cargo\[1\]
#define CHECK_NUM_IVARS 1

15
harbour/utils/hbmake/checks.ch Normal file
View File

@@ -0,0 +1,15 @@
/***
* Checks.ch
*
* Definition of @ ... GET Check box command.
*/
#define CHECK_BOX "X"
#command @ <row>, <col> GET <var> CHECKBOX <cStr> ;
;
=> ;
SetPos(<row>, <col>) ;
; Aadd(GetList, ;
CheckGetNew({|x| iif(x == NIL, <var>, <var> := x) }, ;
<(var)>, <cStr>))

185
harbour/utils/hbmake/checks.prg Normal file
View File

@@ -0,0 +1,185 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* checks.Prg checks gets for hbmake
*
* 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 "Getexit.ch"
#include "InKey.ch"
#include "Checks.ch"
#include "Checkdef.ch"
FUNCTION CheckGetNew(bVar, cVar, cStr)
LOCAL oGet
LOCAL nRow := Row(), nCol := Col()
// Display [ ] before the get
DevPos(nRow, nCol)
DevOut("[ ]")
// Create an empty get object and initialize its cargo
oGet := GetNew()
oGet := GetNew(nRow,ncol+4,{|| cStr },cvar)
oGet:cargo := Array(CHECK_NUM_IVARS)
// Get / Set block for real variable
oGet:checkGsb := bVar
// Check box gets have their own reader, of course
oGet:reader := {|o| CheckReader(o) }
// Draw the check box
DrawCheck(oGet)
oGet:display()
RETURN oGet
// The reader for check boxes
Proc CheckReader( oGet )
// read the GET if the WHEN condition is satisfied
IF ( GetPreValidate(oGet) )
// activate the GET for reading
oGet:SetFocus()
DO WHILE ( oGet:exitState == GE_NOEXIT )
// check for initial typeout (no editable positions)
IF ( oGet:typeOut )
oGet:exitState := GE_ENTER
ENDIF
// apply keystrokes until exit
DO WHILE ( oGet:exitState == GE_NOEXIT )
CheckApplyKey(oGet, InKey(0))
ENDDO
// disallow exit if the VALID condition is not satisfied
IF ( !GetPostValidate(oGet) )
oGet:exitState := GE_NOEXIT
ENDIF
ENDDO
// de-activate the GET
oGet:KillFocus()
ENDIF
RETURN
PROC CheckApplyKey(oGet, nKey)
LOCAL cKey
LOCAL bKeyBlock
LOCAL nSaveRow, nSaveCol
// check for SET KEY first
IF ( (bKeyBlock := SetKey(nKey)) <> NIL )
GetDoSetKey(bKeyBlock, oGet)
RETURN // NOTE
ENDIF
DO CASE
CASE ( nKey == K_UP )
oGet:exitState := GE_UP
CASE ( nKey == K_SH_TAB )
oGet:exitState := GE_UP
CASE ( nKey == K_DOWN )
oGet:exitState := GE_DOWN
CASE ( nKey == K_TAB )
oGet:exitState := GE_DOWN
CASE ( nKey == K_ENTER )
oGet:exitState := GE_ENTER
CASE nKey == K_SPACE
// Toggle state of this check box.
Eval(oGet:checkGsb, !Eval(oGet:checkGsb))
oGet:changed := .T.
// And redraw the getlist
DrawCheck(oGet)
CASE ( nKey == K_ESC )
IF ( Set(_SET_ESCAPE) )
oGet:undo()
oGet:exitState := GE_ESCAPE
ENDIF
CASE (nKey == K_PGUP )
oGet:exitState := GE_WRITE
CASE (nKey == K_PGDN )
oGet:exitState := GE_WRITE
CASE ( nKey == K_CTRL_HOME )
oGet:exitState := GE_TOP
// both ^W and ^End terminate the READ (the default)
CASE (nKey == K_CTRL_W)
oGet:exitState := GE_WRITE
CASE (nKey == K_INS)
Set( _SET_INSERT, !Set(_SET_INSERT) )
ENDCASE
RETURN
// Redraw check box
PROC DrawCheck(oGet)
LOCAL lSelected := Eval(oGet:checkGsb)
LOCAL oGet1
LOCAL nSaveRow := Row()
LOCAL nSaveCol := Col()
LOCAL nGet
DevPos(oGet:row, oGet:col - 3)
IF lSelected
DevOut(CHECK_BOX)
ELSE
DevOut(" ")
ENDIF
DevPos(nSaveRow, nSaveCol)
RETURN

353
harbour/utils/hbmake/fclass1.prg Normal file
View File

@@ -0,0 +1,353 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* FCLASS.PRG Fileman class for hbdoc
*
* 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 "hbclass.ch"
#include 'common.ch'
#include 'hbdocdef.ch'
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Class FileMan
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
CLASS FileMan
data aDosHandles // Holds an array of dos handles and names
data nHan
data nLastDosMessage // Holds the DOS error level of last operation
METHOD addItem( nDos, cFile, cPath ) // Adds an item to the array of handles
METHOD delItem( xitem ) // Deletes an item from the array of handles
METHOD new() // The constructor for this class
METHOD closeAll() // Closes all of those files
METHOD rewindAll() // Positions the file pointer for each file
METHOD writeAll() // Performs hard-write of all
METHOD getFileName( cfile ) // Obtains the name of the file based on ID
METHOD getFileId( nid ) // Obtains the ID based on file name
METHOD getFilePath( xItem ) // Obtains file path based on either ID or name
METHOD noDosError() // Returns a logical true/false
METHOD openfile( cFile, nMethod ) // Opens the specified file and sets error
METHOD Buffget( ld ) virtual
ENDCLASS
/* Method: Init/New
Params: N/A
Returns: Self
Purpose: Constructor
*/
METHOD new() CLASS FileMan
IF ::aDosHandles == NIL // has yet to be initialized
::aDosHandles := {}
ENDIF
IF ::nLastDosMessage == NIL // has yet to be initialized
::nLastDosMessage := 0
ENDIF
RETURN ( self )
// The following are global operations that need to be performed by all
// files regardless of their format
/* Method: ::closeAll()
Params: N/A
Returns: Self
Purpose: To go through the stack of opened file handles and close each
file, one at a time. Since this is a global operation, it
will not check on the status of the error message on each
pass but will at the start of the evaluation.
*/
METHOD closeAll() CLASS FileMan
IF ::nLastDosMessage == 0
AEVAL( ::aDosHandles, { | aFile | FCLOSE( aFile[ pDOS_HANDLE ] ) } )
ENDIF
RETURN ( self )
/* Method: ::rewindAll()
Params: N/A
Returns: Self
Purpose: To go through the stack of opened file handles and places the
file pointer to the top of each file, one at a time. Since
Since this is a global operation, it will not check on the
status of the error message on each pass but will at the
start of the evaluation.
*/
METHOD rewindAll() CLASS FileMan
IF ::nLastDosMessage == 0
AEVAL( ::aDosHandles, { | aFile | FSEEK( aFile[ pDOS_HANDLE ], 0, 0 ) } )
ENDIF
RETURN ( self )
/* Method: ::writeAll()
Params: N/A
Returns: Self
Purpose: To go through the stack of opened file handles and writes each
file, one at a time. Since this is a global operation, it
will not check on the status of the error message on each
pass but will at the start of the evaluation.
*/
METHOD writeAll() CLASS FileMan
IF ::nLastDosMessage == 0
AEVAL( ::aDosHandles, { | aFile | FWRITE( aFile[ pDOS_HANDLE ], "", 0 ) } )
ENDIF
RETURN ( self )
/* Method: ::getFileName( <nId> )
Params: <nId> DOS File handle / ID
Returns: <cName> File name store with that ID handle
Purpose: This method will return the file's name found
within the table of this class.
*/
METHOD getFileName( nId ) CLASS FileMan // Obtains the name of the file based on ID
LOCAL cName := "" // as char
LOCAL nPosition // as int
IF ::nLastDosMessage == 0
IF nId IS pNUMERIC
nPosition := ASCAN( ::aDosHandles, ;
{ | aFile | nId == aFile[ pDOS_HANDLE ] } )
IF nPosition != 0
cName := ::aDosHandles[ nPosition, pDOS_FILE ]
ENDIF
ENDIF
ENDIF
RETURN ( cName )
/* Method: ::getFileId( <cName> )
Params: <cName> File names used to store item to stack
Returns: <nId> DOS File handle or ID associated with name
Purpose: This method will return the file's ID or DOS handle found
within the table of this class.
*/
METHOD getFileId( cName ) CLASS FileMan // Obtains the ID based on file name
LOCAL nId := 0 // as int
LOCAL nPosition // as int
IF ::nLastDosMessage == 0
IF cName IS pCHARACTER
nPosition := ASCAN( ::aDosHandles, ;
{ | aFile | cName == aFile[ pDOS_FILE ] } )
IF nPosition != 0
nId := ::aDosHandles[ nPosition, pDOS_HANDLE ]
ENDIF
ENDIF
ENDIF
RETURN ( nId )
/* Method: ::getFilePath( <xItem> )
Params: <xItem> DOS File handle / ID or stored file name
Returns: <cPath> Associated file path
Purpose: This method will return the associated DOS path for either the
given file name or DOS file handle / ID. If there is no file
path or if there is an error with the method, the return value
will be a NULL character byte.
*/
METHOD getFilePath( xItem ) CLASS FileMan // Obtains file path based on either ID or name
LOCAL cPath := "" // as char
LOCAL nPosition // as int
IF ::nLastDosMessage == 0
DO CASE
CASE ( xItem IS pCHARACTER ) // we've got the file name
nPosition := ASCAN( ::aDosHandles, ;
{ | aFile | xItem == aFile[ pDOS_FILE ] } )
IF nPosition != 0
cPath := ::aDosHandles[ nPosition, pDOS_PATH ]
ENDIF
CASE ( xItem IS pNUMERIC ) // we've got the file path
nPosition := ASCAN( ::aDosHandles, ;
{ | aFile | xItem == aFile[ pDOS_HANDLE ] } )
IF nPosition != 0
cPath := ::aDosHandles[ nPosition, pDOS_PATH ]
ENDIF
ENDCASE
ENDIF
RETURN ( cPath )
// The following two methods are for the sole purpose of manipulating the
// array of DOS file handles
/* Method: ::addItem( <nDos>, <cFile> [, <cPath] )
Params: <nDos> DOS file handle
<cFile> File name
<cPath> File path, defaults to ""
Returns: self
Purpose: This method will add the DOS file ID and name to the internal
stack. It will not work if either of the the first two
parameters are not passed to the method OR if the value of
::nLastDosMessage is 0. The return value of the method will
be the object itself.
*/
METHOD addItem( nDos, cFile, cPath ) CLASS FileMan
DEFAULT cPath TO ""
IF ::nLastDosMessage == 0
AADD( ::aDosHandles, { nDos, cFile, cPath } )
ENDIF
RETURN ( self )
/* Method: ::delItem( <xItem> )
Params: <xItem> DOS file handle or file name
Returns: <lSuccess> Success status of operation
Purpose: To go through the stack of opened file handles and based on the
parameter passed to the method, it will remove the file from
the stack. If <xItem> is a numeric, it will be assumed a
valud DOS file handle. If <xItem> is character, then it will
be assumed the name of the file. If <xItem> is neither numeric
or character or if the value of ::nLastDosMessage is not 0,
then the method will return a logical false (.F.) value;
otherwise, a logical true (.T.) will be returned.
*/
METHOD delItem( xItem ) CLASS FileMan
LOCAL nPosition // as int
LOCAL lSuccess := pTRUE // as logical
// if xItem is N/Numeric, then seek on first element;
// if xItem is C/Character, then seek on second element
IF ::nLastDosMessage == 0 // No DOS error!
DO CASE
CASE ( xItem IS pNUMERIC ) // It's a DOS file handle
nPosition := ASCAN( ::aDosHandles, ;
{ | aItem | xItem == aItem[ pDOS_HANDLE ] } )
IF nPosition == 0
// Don't remove and set the return value of the function
lSuccess := pFALSE
ELSE
// Since we have a position, remove from the table and keep the
// default return value
ADEL( ::aDosHandles, nPosition )
ASIZE( ::aDosHandles, LEN( ::aDosHandles ) - 1 )
ENDIF
CASE ( xItem IS pCHARACTER ) // It's a file name
nPosition := ASCAN( ::aDosHandles, ;
{ | aItem | xItem == aItem[ pDOS_FILE ] } )
IF nPosition == 0
// Don't remove and set the return value of the function
lSuccess := pFALSE
ELSE
// Since we have a position, remove from the table and keep the
// default return value
ADEL( ::aDosHandles, nPosition )
ASIZE( ::aDosHandles, LEN( ::aDosHandles ) - 1 )
ENDIF
OTHERWISE
// Invalid data passed to method
lSuccess := pFALSE
ENDCASE
ELSE
lSuccess := pFALSE
ENDIF
RETURN ( lSuccess )
/* Method: noDosError()
Params: N/A
Returns: <lNoError>
Purpose: To return a logical true (.T.) if there is no existing error
state within the system
*/
METHOD noDosError() CLASS FileMan
RETURN ( ::nLastDosMessage == 0 )
/* Method: open()
Params: N/A
Returns: <nDosHandle>
Purpose: This method acutally opens the file specified by the parameter
<cFile> with the open mode of <nMethod>. Each file object
should carry this information locally and use this method only
to update the internal table.
*/
METHOD openfile( cFile, nMethod ) CLASS FileMan
LOCAL nFileHandle // as int
LOCAL cFilename // as char
LOCAL cPath // as char
DEFAULT nMethod TO 0
nFileHandle := FOPEN( cFile, nMethod ) // opens the file
IF !EMPTY( FERROR() ) // There was an error in opening
::nLastDosMessage := FERROR()
nFileHandle := - 1
ELSE
cFileName := DOSFILENAME( cFile )
cPath := STRTRAN( cFile, cFileName, "" )
::addItem( nFileHandle, cFileName, cPath )
ENDIF
::nHan := nFileHandle
RETURN ( nFileHandle )
// End of File: FClass1.prg
*+ EOF: FCLASS1.PRG

625
harbour/utils/hbmake/ffile1.prg Normal file
View File

@@ -0,0 +1,625 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* FFILE1.PRG Filebase class for hbdoc
*
* 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 "hbclass.ch"
#include 'common.ch'
#include 'hbdocdef.ch'
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Class FileBase
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
CLASS FileBase FROM FileMan
DATA nOpenMode // Holds the value to use when opening the file
DATA nCreateMode // Holds the value to use when creating the file
DATA nDosHandle // Holds the DOS file handle for this
DATA nEndOfFile // Holds the last byte value in the file
DATA nSkipLength // This holds the default skpping length of 1
DATA cName // This holds the name of the file being worked on
DATA nPosition // This holds the position in the file at
DATA lAtBottom // This is a value to show if at bottom of file
DATA lAtTop // This is a value to show if at top of file
METHOD new( cname ) // This is the constructor for the file
METHOD FOPEN() // This opens the specified file
METHOD closefile() // This closes the specified file
METHOD fskip( n ) // Moves the byte pointer within the file
METHOD FWRITE( c ) // Write passed data to file w/ len() == nSkipLenght
METHOD retrieve() // Returns the contents of the file at current pos
METHOD fgoTop() // Move the byte pointer to the top of the file
METHOD fgoBottom() // Move the byte pointer to the bottom of the file
METHOD fgoto() // Moves the byte pointer to a specific location
METHOD create()
message fappend METHOD fappendByte( cByte )
message BuffGet METHOD BufferGet( lDirection )
METHOD SKIP( nRecord ) // Moves the byte pointer within the file
METHOD WRITE( cChar ) // Write passed data to file w/ len() == nSkipLenght
METHOD goTop() // Move the byte pointer to the top of the file
METHOD goBottom() // Move the byte pointer to the bottom of the file
METHOD GOTO( nValue ) // Moves the byte pointer to a specific location
METHOD OPEN()
message append METHOD appendLine( cline )
ENDCLASS
/* Method: Init/New
Params: N/A
Returns: Self
Purpose: Constructor
*/
METHOD new( cName ) CLASS FileBase
super:new()
// first thing to do is check to see if there is a valid file
::nSkipLength := 1
::nOpenMode := 2 // Mode for which to open the file
::nCreateMode := 0 // Mode for which to create the file
::cName := cName
RETURN ( self )
/* Method: skip( <nRecords> )
Params: <nRecords>
Returns: Self
Purpose: This method moves the file's byte pointer <nRecords> position
from the current location. The actualy movement is determined
on the value of ::nSkipLength which holds the skipping base.
This class's purpose is to do one byte movements.
*/
METHOD fskip( nRecords ) CLASS FileBase
DEFAULT nRecords TO 1
IF ::noDosError() .AND. ::nDosHandle > 0
FSEEK( ::nDosHandle, ( ::nSkipLength * nRecords ), 1 )
::nLastDosMessage := FERROR()
::nPosition := FSEEK( ::nDosHandle, 0, 1 )
DO CASE
CASE ::nPosition == ::nEndOfFile
::lAtBottom := pTRUE
::lAtTop := pFALSE
CASE ::nPosition <= 1
::lAtTop := pTRUE
::lAtBottom := pFALSE
OTHERWISE
::lAtBottom := ::lAtTop := pFALSE
ENDCASE
ENDIF
RETURN ( self )
/* Method: gotop()
Params: N/A
Returns: Self
Purpose: Move the byte pointer to the top of the file
*/
METHOD fgotop() CLASS FileBase
IF ::noDosError() .AND. ::nDosHandle > 0
::nPosition := FSEEK( ::nDosHandle, 0, 0 )
::nLastDosMessage := FERROR()
::lAtTop := pTRUE
::lAtBottom := pFALSE
ENDIF
RETURN ( self )
/* Method: gobottom()
Params: N/A
Returns: Self
Purpose: Move hte byte pointer of the file to tbe bottom.
*/
METHOD fgoBottom() CLASS FileBase
IF ::noDosError() .AND. ::nDosHandle > 0
::nPosition := FSEEK( ::nDosHandle, 0, 2 )
::nLastDosMessage := FERROR()
::lAtTop := pFALSE
::lAtBottom := pTRUE
ENDIF
RETURN ( self )
/* Method: close()
Params: N/A
Returns: Self
Purpose: To close the file
*/
METHOD closefile() CLASS FileBase
IF ::noDosError() .AND. ::nDosHandle > 0
FCLOSE( ::nDosHandle )
::nLastDosMessage := FERROR()
::delItem( ::nDosHandle )
::lAtTop := ::lAtBottom := pFALSE
::nPosition := 0
ENDIF
RETURN ( self )
/* Method: retrieve
Params: N/A
Returns: <cChar>
Purpose: To return the contents of the file at the current position based
on the length of ::nSkipLength.
*/
METHOD retrieve() CLASS FileBase
LOCAL cReturn // as char
LOCAL nMoved // as int
IF ::noDosError() .AND. ::nDosHandle > 0
cReturn := SPACE( ::nSkipLength )
nMoved := FREAD( ::nDosHandle, @cReturn, ::nSkipLength )
::nLastDosMessage := FERROR()
FSEEK( ::nDosHandle, - ( nMoved ), 1 ) // Re-position the pointer
ENDIF
RETURN ( cReturn )
/* Method: write(<cChar>)
Params: <cChar>
Returns: Self
Purpose: To write out to the contents of the file the value in the
parameter <cChar>.
*/
METHOD FWRITE( cChar ) CLASS FileBase
IF ::noDosError() .AND. ::nDosHandle > 0
IF cChar IS pCHARACTER
FWRITE( ::nDosHandle, cChar, 1 )
::nLastDosMessage := FERROR()
IF ::noDosError()
FSEEK( ::nDosHandle, ::nPosition, 0 ) // Re-position the pointer
ENDIF
ENDIF
ENDIF
RETURN ( self )
/* Method: goto(<nRecord>)
Params: <nRecord> The record byte to move to
Returns: Self
Purpose: This method moves the byte marker to the <nRecord> position
within the file. It is also based on the value stored to the
::nSkipLength instance variable
*/
METHOD fgoto( nValue ) CLASS FileBase
IF ::noDosError() .AND. ::nDosHandle > 0
IF nValue IS pNUMERIC
IF nValue > 0 .AND. ;
( nValue * ::nSkipLength ) <= ::nEndOfFile
FSEEK( ::nDosHandle, ( nValue * ::nSkipLength ), 0 )
::nLastDosMessage := FERROR()
::nPosition := FSEEK( ::nDosHandle, 0, 1 )
DO CASE
CASE ::nPosition == ::nEndOfFile
::lAtBottom := pTRUE
::lAtTop := pFALSE
CASE ::nPosition <= 1
::lAtTop := pTRUE
::lAtBottom := pFALSE
OTHERWISE
::lAtBottom := ::lAtTop := pFALSE
ENDCASE
ENDIF
ENDIF
ENDIF
RETURN ( ::nPosition )
/* Method: create()
Params: N/A
Returns: Self
Purpose: Creates the specified file with the proper access code
*/
METHOD Create() CLASS FileBase
LOCAL nFile // as int
IF ::noDosError()
nFile := FCREATE( ::cName, ::nCreateMode )
::nLastDosMessage := FERROR()
IF ::noDosError() // No Error
FCLOSE( nFile ) // Close the file
::fopen() // Re-open the file
ENDIF
ENDIF
RETURN ( self )
/* Method: open()
Params: N/A
Returns: Self
Purpose: Opens the file with the proper access code
*/
METHOD FOPEN() CLASS FileBase
IF ::noDosError()
::nDosHandle :=::openfile( ::cName, ::nOpenMode )
::nEndOfFile := FSEEK( ::nDosHandle, 0, 2 )
::nPosition := FSEEK( ::nDosHandle, 0, 0 )
::lAtTop := pTRUE
::lAtBottom := pFALSE
ENDIF
RETURN ( self )
METHOD fappendByte( cByte ) CLASS FileBase
DEFAULT cByte TO ""
IF !EMPTY( cByte ) // Valid line
IF ::noDosError() .AND. ::nDosHandle > 0 // No error
FSEEK( ::nDosHandle, 0, 2 )
FWRITE( ::nDosHandle, cByte, 1 )
::nEndOfFile := FSEEK( ::nDosHandle, 0, 2 )
::nPosition := FSEEK( ::nDosHandle, - ( LEN( cByte ) ), 2 )
::nSkipLength := LEN( cByte )
::lAtBottom := ::lAtTop := pFALSE
ENDIF
ENDIF
RETURN ( self )
// End of File: FFile1.prg
METHOD OPEN() CLASS FileBase
Self:nDosHandle := Self:openfile( ::cName, ::nOpenMode )
::nEndOfFile := FSEEK( Self:nDosHandle, 0, 2 )
FSEEK( Self:nDosHandle, 0, 0 )
::nSkipLength := Self:Buffget()
::lAtTop := pTRUE
::lAtBottom := pFALSE
::nHan := Self:nDosHandle
RETURN ( self )
/* Method: gotop()
Params: N/A
Returns: Self
Purpose: Move the byte pointer to the top of the file
*/
METHOD gotop() CLASS FileBase
IF Self:noDosError() .AND. Self:nDosHandle > 0
::fgotop()
::nSkipLength := Self:Buffget()
ENDIF
RETURN ( self )
/* Method: gobottom()
Params: N/A
Returns: Self
Purpose: Move hte byte pointer of the file to tbe bottom.
*/
METHOD goBottom() CLASS FileBase
LOCAL cBuffer // as char
LOCAL lWithCRLF := pFALSE // as logical
IF Self:noDosError() .AND. Self:nDosHandle > 0
::fgobottom()
// Now, back off from the end one line length and set the marker
cBuffer := SPACE( pBUFFER_LENGTH )
FSEEK( Self:nDosHandle, - ( pBUFFER_LENGTH ), 2 )
FREAD( Self:nDosHandle, @cBuffer, pBUFFER_LENGTH )
IF RIGHT( cBuffer, 2 ) == pCRLF // We need to remove this extra one!
cBuffer := LEFT( cBuffer, LEN( cBuffer ) - 2 )
lWithCRLF := pTRUE
ENDIF
cBuffer := SUBSTR( cBuffer, RAT( pCRLF, cBuffer ) + 2 )
::nSkipLength := LEN( cBuffer ) + IF( lWithCRLF, 2, 0 )
::nposition := FSEEK( Self:nDosHandle, - ( LEN( cBuffer ) ), 2 )
IF lWithCRLF
::nposition := FSEEK( Self:nDosHandle, - 2, 1 )
ENDIF
ENDIF
RETURN ( self )
/* Method: close()
Params: N/A
Returns: Self
Purpose: To close the file
*/
METHOD FCLOSE() CLASS FileBase
IF Self:noDosError() .AND. Self:nDosHandle > 0
FCLOSE( Self:nDosHandle )
Self:nLastDosMessage := FERROR()
Self:delItem( Self:nDosHandle )
Self:lAtTop := Self:lAtBottom := pFALSE
Self:nPosition := 0
ENDIF
RETURN ( self )
/* Method: write(<cChar>)
Params: <cChar>
Returns: Self
Purpose: To write out to the contents of the file the value in the
parameter <cChar>.
*/
METHOD WRITE( cChar ) CLASS FileBase
IF Self:noDosError() .AND. Self:nDosHandle > 0
IF cChar IS pCHARACTER
IF cChar > Self:nSkipLength // we are going to truncate for now...
FWRITE( Self:nDosHandle, cChar, Self:nSkipLength )
ELSE
FWRITE( Self:nDosHandle, cChar, LEN( cChar ) )
ENDIF
FSEEK( Self:nDosHandle, ::nposition, 0 )
Self:nLastDosMessage := FERROR()
IF Self:noDosError()
FSEEK( Self:nDosHandle, Self:nPosition, 0 ) // Re-position the pointer
ENDIF
ENDIF
ENDIF
RETURN ( self )
/* Method: getBuffer( <lDirection> )
Params: <lDirection> Logical toggle for direction
Returns: <nBytes>
Purpose: To return the number of bytes either forward or backward from
the present file pointer position in which the next CRLF char
appears. If <lDirection> is a logical false (.F.) value, them
the operation will go in reverse order; otherwise, it will go
in a forward direction. The default value is a logical true
(.T.) value.
*/
METHOD Buffget( lForward ) CLASS FileBase
LOCAL cBuffer // as char
LOCAL nLocation // as int
LOCAL nRead // as int
LOCAL lWithCRLF := pFALSE // as logical
DEFAULT lForward TO pTRUE
IF !lForward
nRead := FSEEK( Self:nDosHandle, ;
- ( IF( ::nposition < pBUFFER_LENGTH, ;
::nposition, ;
pBUFFER_LENGTH ) ), ;
1 ) // rewind backwards
cBuffer := SPACE( ::nposition - nRead )
FREAD( Self:nDosHandle, @cBuffer, ( ::nposition - nRead ) )
IF RIGHT( cBuffer, 2 ) == pCRLF // with line already
cBuffer := LEFT( cBuffer, LEN( cBuffer ) - 2 )
lWithCRLF := pTRUE
ENDIF
nLocation := LEN( cBuffer ) - ( RAT( pCRLF, cBuffer ) )
ELSE
cBuffer := SPACE( pBUFFER_LENGTH )
nRead := FREAD( Self:nDosHandle, @cBuffer, pBUFFER_LENGTH )
FSEEK( Self:nDosHandle, - ( IF( nRead < pBUFFER_LENGTH, nRead, ;
pBUFFER_LENGTH ) ), 1 ) // Rewind
// Now, parse the string. and file
nLocation := AT( pCRLF, cBuffer )
// Now, if there is NO CRLF in the buffer and if the value of the
// number of bytes read is less than the buffer length, then we
// have an end of file condition.
IF nLocation == 0 .AND. ( nRead < pBUFFER_LENGTH )
// If so, then set the appropriate flags accordingly.
::lAtBottom := pTRUE
::lAtTop := pFALSE
ENDIF
ENDIF
RETURN ( nLocation )
/* Method: appendLine( <cLine )
Params: <cLine> Character line to append
Returns: Self
Purpose: To append a blank CRLF delimited line at the end of the file.
If <cLine> is not passed or if it an empty line with 0 bytes
in length, the function will not operate.
*/
METHOD appendLine( cLine ) CLASS FileBase
DEFAULT cLine TO ""
IF LEN( cLine ) == 0 // Valid line
IF Self:noDosError() .AND. Self:nDosHandle > 0 // No error
IF !( pCRLF $ cLine ) // No CRLF, so add
cLIne += pCRLF
ENDIF
FSEEK( Self:nDosHandle, 0, 2 )
FWRITE( Self:nDosHandle, cLine )
::nEndOfFile := FSEEK( Self:nDosHandle, 0, 2 )
::nposition := FSEEK( Self:nDosHandle, - ( LEN( cLine ) ), 2 )
::nSkipLength := LEN( cLine )
::lAtBottom := ::lAtTop := pFALSE
ENDIF
ENDIF
RETURN ( self )
/* Method: skip( <nRecords> )
Params: <nRecords>
Returns: Self
Purpose: This method moves the file's byte pointer <nRecords> position
from the current location. The actualy movement is determined
on the value of Self:nSkipLength which holds the skipping base.
This class's purpose is to do one byte movements.
*/
METHOD SKIP( nRecords ) CLASS FileBase
LOCAL nCount := 0 // as int
DEFAULT nRecords TO 1
// Here, we have to start looking for CHR(13)+CHR(10) character
// combinations. Once found, then we have to set the super class
// values appropriately
IF Self:noDosError() .AND. Self:nDosHandle > 0
DO CASE
CASE nRecords > 0 // It's positive movement
WHILE nCount ++ != nRecords
::fskip()
::nSkipLength := Self:Buffget()
ENDDO
CASE nRecords < 0 // It's negative movement
WHILE nCount -- != nRecords
::nSkipLength := Self:Buffget( pFALSE )
::fskip( - 1 )
ENDDO
ENDCASE
ENDIF
RETURN ( self )
/* Method: goto(<nRecord>)
Params: <nRecord> The record byte to move to
Returns: Self
Purpose: This method moves the byte marker to the <nRecord> position
within the file. It is also based on the value stored to the
Self:nSkipLength instance variable
*/
METHOD GOTO( nValue ) CLASS FileBase
LOCAL cLine := "" // as char
LOCAL nCount := 0 // as int
LOCAL lContinue := pTRUE // as logical
LOCAL cBuffer // as char
DEFAULT nValue TO 0
IF Self:noDosError() .AND. Self:nDosHandle > 0
IF nValue IS pNUMERIC
IF nValue > 0 // o.k. so far
FSEEK( Self:nDosHandle, 0, 0 ) // start at the top
WHILE lContinue
cBuffer := SPACE( pBUFFER_LENGTH )
lContinue := ( FREAD( Self:nDosHandle, @cBuffer, pBUFFER_LENGTH ) == ;
pBUFFER_LENGTH )
cBuffer := cLine + cBuffer
WHILE pCRLF $ cBuffer
IF ++ nCount == nValue
lContinue := pFALSE
EXIT
ENDIF
cBuffer := SUBSTR( cBuffer, AT( pCRLF, cBuffer ) + 2 )
ENDDO
cLine := cBuffer
ENDDO
IF nCount == nValue // We have a match
FSEEK( Self:nDosHandle, - ( pBUFFER_LENGTH ), 1 ) // Back off from here
::nposition := FSEEK( Self:nDosHandle, ;
( pBUFFER_LENGTH - LEN( cBuffer ) ), ;
1 ) // Move
::nSkipLength := Self:Buffget()
ELSE
FSEEK( Self:nDosHandle, ::nposition, 0 )
nCount := 0
ENDIF
ENDIF
ENDIF
ENDIF
RETURN ( nCount )
// End of File: FFile2.prg
METHOD BufferGet( lForward ) CLASS FileBase
LOCAL cBuffer // as char
LOCAL nLocation // as int
LOCAL nRead // as int
LOCAL lWithCRLF := pFALSE // as logical
DEFAULT lForward TO pTRUE
IF !lForward
nRead := FSEEK( Self:nDosHandle, ;
- ( IF( ::nposition < pBUFFER_LENGTH, ;
::nposition, ;
pBUFFER_LENGTH ) ), ;
1 ) // rewind backwards
cBuffer := SPACE( ::nposition - nRead )
FREAD( Self:nDosHandle, @cBuffer, ( ::nposition - nRead ) )
IF RIGHT( cBuffer, 2 ) == pCRLF // with line already
cBuffer := LEFT( cBuffer, LEN( cBuffer ) - 2 )
lWithCRLF := pTRUE
ENDIF
nLocation := LEN( cBuffer ) - ( RAT( pCRLF, cBuffer ) )
ELSE
cBuffer := SPACE( pBUFFER_LENGTH )
nRead := FREAD( Self:nDosHandle, @cBuffer, pBUFFER_LENGTH )
FSEEK( Self:nDosHandle, - ( IF( nRead < pBUFFER_LENGTH, nRead, ;
pBUFFER_LENGTH ) ), 1 ) // Rewind
// Now, parse the string. and file
nLocation := AT( pCRLF, cBuffer )
// Now, if there is NO CRLF in the buffer and if the value of the
// number of bytes read is less than the buffer length, then we
// have an end of file condition.
IF nLocation == 0 .AND. ( nRead < pBUFFER_LENGTH )
// If so, then set the appropriate flags accordingly.
::lAtBottom := pTRUE
::lAtTop := pFALSE
ENDIF
ENDIF
RETURN ( nLocation )
*+ EOF: FFILE1.PRG

282
harbour/utils/hbmake/ft_funcs.prg Normal file
View File

@@ -0,0 +1,282 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* FT_FUNCS.Prg File support Functions For hbdoc
*
* 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 "directry.ch"
#include "fileio.ch"
#include "inkey.ch"
#include 'hbdocdef.ch'
#include 'common.ch'
#define xReadBuffer 4096
DECLARE FT_FUSE(CFILE AS STRING,NMODE AS NUMERIC) AS NUMERIC
DECLARE ft_FEOF() AS LOGICAL
DECLARE FReadLn( cLine ) AS STRING
DECLARE FT_FReadLn() AS STRING
DECLARE FT_FGotop() //AS USUAL
DECLARE FT_FSKIP(n AS NUMERIC) //AS USUAL
DECLARE FT_MKDIR( CDIR AS STRING ) //AS USUAL
DECLARE StrPos( cBuffer AS STRING ) AS NUMERIC
DECLARE GetNumberofTableItems( cBuffer AS STRING ) AS NUMERIC
DECLARE FREADline( nH AS NUMERIC, @cB AS STRING, nMaxLine AS NUMERIC )
//DECLARE FILEBASE() AS OBJECT
DECLARE FILEBASE ;
New( cname AS STRING) AS CLASS FILEBASE;
FOPEN() AS OBJECT;
closefile() AS OBJECT;
fskip( OPTIONAL n AS NUMERIC) AS OBJECT;
FWRITE( c AS STRING) AS OBJECT;
retrieve() AS STRING;
fgoTop() AS OBJECT;
fgoBottom() AS OBJECT;
fgoto() AS NUMERIC;
create() AS OBJECT;
fappendByte( cByte ) AS OBJECT;
BuffGet METHOD BufferGet( OPTIONAL lDirection AS LOGICAL ) AS NUMERIC;
SKIP( OPTIONAL nRecord AS NUMERIC ) AS OBJECT;
WRITE( cChar AS STRING ) AS OBJECT;
goTop() AS OBJECT;
goBottom() AS OBJECT;
GOTO( OPTIONAL nValue AS NUMERIC) AS NUMERIC;
OPEN() AS OBJECT;
append(OPTIONAL cline AS STRING) AS OBJECT
STATIC TheHandle As Object
/****
* FT_FUSE(cFile,nMode) ---> nHandle
* Open a File
*/
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function FT_FUSE()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION FT_FUSE( cFile AS STRING, nMode AS NUMERIC)
Local nHandle as numeric
IF nMode == nil
nMode := 2
ENDIF
IF cFile == Nil
theHandle:closefile()
ENDIF
IF cFile <> Nil
IF nMode <> 0
theHandle := FileBase():new( cFile ):open()
ELSE
theHandle := FileBase():new( cFile ):open()
ENDIF
ENDIF
nHandle:= theHandle:nHan
RETURN nHandle
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function ft_FEOF()
*+
*+ Called from ( hbdoc.prg ) 1 - function readln()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION ft_FEOF()
LOCAL lRETURN as LOGICAL := theHandle:lAtBottom
RETURN lRETURN
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function FReadLn()
*+
*+ Called from ( ft_funcs.prg ) 1 - function ft_freadln()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION FReadLn( cLine AS STRING)
cLine := theHandle:retrieve()
RETURN cLine
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function FT_FReadLn()
*+
*+ Called from ( hbdoc.prg ) 1 - function readln()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION FT_FReadLn()
LOCAL cBuffer AS STRING := ''
cBuffer := FReadLn( @cBuffer )
cBuffer := STRTRAN( cBuffer, CHR( 13 ), '' )
RETURN cBuffer
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function FT_FGotop()
*+
*+ Called from ( genng.prg ) 1 - static function readfromtop()
*+ ( genrtf.prg ) 1 - static function readfromtop()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION FT_FGotop()
theHandle:Gotop()
RETURN NIL
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function FT_FSKIP()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION FT_FSKIP( n AS NUMERIC)
TheHandle:Skip( n )
RETURN nil
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function FT_MKDIR()
*+
*+ Called from ( hbdoc.prg ) 6 - function main()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION FT_MKDIR( CDIR AS STRING)
MAKEDIR( cdir )
RETURN nil
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function StrPos()
*+
*+ Called from ( genhtm1.prg ) 1 - function prochtmtable()
*+ ( genhtm2.prg ) 1 - function prochtmtable()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION StrPos( cBuffer AS STRING)
LOCAL nPos AS NUMERIC :=0
LOCAL x AS NUMERIC
LOCAL cChar AS STRING
FOR x := 1 TO LEN( cBuffer )
cChar := SUBSTR( cBuffer, x, 1 )
IF cChar >= CHR( 64 ) .AND. cChar <= CHR( 90 ) .OR. cChar >= CHR( 97 ) ;
.AND. cChar <= CHR( 122 ) .OR. cChar >= CHR( 48 ) .AND. cChar <= CHR( 57 ) ;
.OR. cChar == CHR( 60 ) .OR. cchar == CHR( ASC( "-" ) ) ;
.OR. cchar == CHR( ASC( "(" ) ) .OR. cchar = CHR( ASC( "|" ) ) .OR. ;
cchar == CHR( ASC( '.' ) ) .OR. cchar == CHR( ASC( '*' ) ) .OR. ;
cchar == CHR( ASC( '#' ) ) .OR. cchar == CHR( ASC( '"' ) ) .OR. ;
cchar == CHR( ASC( '/' ) ) .OR. cchar == CHR( ASC( "@" ) ) ;
.OR. cchar == CHR( ASC( "=" ) ) .OR. cchar == CHR( ASC( 'Ä' ) ) ;
.OR. cchar == CHR( ASC( '?' ) ) .OR. cchar == CHR( ASC( '!' ) ) ;
.OR. cchar == CHR( ASC( "<" ) ) .OR. cchar == CHR( ASC( '>' ) ) ;
.OR. cchar == CHR( ASC( '!' ) ) .OR. cchar == CHR( ASC( '+' ) )
nPos := x
EXIT
ENDIF
NEXT
RETURN nPos
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function GetNumberofTableItems()
*+
*+ Called from ( genhtm.prg ) 1 - function prochtmdesc()
*+ ( genng.prg ) 1 - function procngdesc()
*+ ( genng1.prg ) 1 - function procngdesc()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION GetNumberofTableItems( cBuffer )
LOCAL cItem AS STRING
LOCAL nItem AS NUMERIC := 0
cBuffer := ALLTRIM( cBuffer )
DO WHILE AT( SPACE( 3 ), cBuffer ) > 0
cItem := SUBSTR( cBuffer, 1, AT( SPACE( 3 ), cBuffer ) - 1 )
IF AT( SPACE( 3 ), cBuffer ) == 0
nItem ++
ELSE
cBuffer := ALLTRIM( STRTRAN( cBuffer, cItem, '' ) )
nItem ++
ENDIF
ENDDO
nItem ++
RETURN nItem
#define EOL hb_osnewline()
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function FREADline()
*+
*+ Called from ( genng.prg ) 1 - static function readfromtop()
*+ ( genrtf.prg ) 1 - static function readfromtop()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
FUNCTION FREADline( nH as Numeric, cB AS STRING, nMaxLine as Numeric)
LOCAL cLine AS STRING
LOCAL nSavePos AS NUMERIC
LOCAL nEol AS NUMERIC
LOCAL nNumRead AS NUMERIC
LOCAL lReturn as Logical
cLine := SPACE( nMaxLine )
cB := ''
nSavePos := FSEEK( nH, 0, FS_RELATIVE )
nNumRead := FREAD( nH, @cLine, nMaxLine )
IF ( nEol := AT( EOL, SUBSTR( cLine, 1, nNumRead ) ) ) == 0
cB := cLine
ELSE
cB := SUBSTR( cLine, 1, nEol - 1 )
FSEEK( nH, nSavePos + nEol + 1, FS_SET )
ENDIF
lReturn := (nNumRead != 0)
RETURN lReturn
*+ EOF: FT_FUNCS.PRG

1147
harbour/utils/hbmake/hbmake.prg Normal file
View File

File diff suppressed because it is too large Load Diff

143
harbour/utils/hbmake/pickarry.prg Normal file
View File

@@ -0,0 +1,143 @@
/*
* $Id$
*/
*+²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
*+
*+ Source Module => D:\SRC\PBMAKE\PICKARRY.PRG
*+
*+ PBMake is a Clipper, C, ASM, Xbase++ make engine.
*+
*+ Copyright(C) 1996-1999 by Phil Barnett.
*+
*+ 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.
*+
*+ 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.
*+
*+ You can contact me at:
*+
*+ Phil Barnett
*+ Box 944
*+ Plymouth, Florida 32768
*+
*+ or
*+
*+ philb@iag.net
*+
*+
*+ Functions: Function PICKARRY()
*+ Function Keys()
*+
*+ Reformatted by Click! 2.03 on Mar-30-1999 at 11:19 pm
*+
*+²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
static someitems
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function PICKARRY()
*+
*+ Called from ( makelink.prg ) 1 - function makelink()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
function PICKARRY( T, L, b, r, IN_ARRAY, OUT_ARRAY )
local nChoice := 1
local x
local NEW_ARRAY := {}
local NUM_ELEMS := len( IN_ARRAY )
local PAD_LEN := ( r - 1 ) - ( L + 1 )
local lIsChecked
someitems := 0
putscreen()
@ T - 1, L - 1 clear to b + 1, r + 1
@ T - 1, L - 1 to b + 1, r + 1 double
for x := 1 to NUM_ELEMS
IN_ARRAY[ X ] := padr( ' ' + IN_ARRAY[ X ], PAD_LEN )
OUT_ARRAY[ X ] := ' ' + OUT_ARRAY[ X ]
next
do while nChoice != 0
nChoice := achoice( T, L , b , r , IN_ARRAY, , 'keys' , nChoice, 1 )
if nChoice > 0
lIsChecked := substr( IN_ARRAY[ nChoice ], 2, 1 ) == 'û'
IN_ARRAY[ nChoice ] := stuff( IN_ARRAY[ nChoice ], 2, 1, if( lIsChecked, ' ', 'û' ) )
OUT_ARRAY[ nChoice ] := stuff( OUT_ARRAY[ nChoice ], 1, 1, if( lIsChecked, ' ', 'û' ) )
if lIsChecked
SOMEITEMS --
else
SOMEITEMS ++
endif
nChoice ++
endif
enddo
for x := 1 to NUM_ELEMS
if left( OUT_ARRAY[ X ], 1 ) == 'û'
aadd( NEW_ARRAY, substr( OUT_ARRAY[ X ], 2 ) )
endif
IN_ARRAY[ X ] := substr( IN_ARRAY[ X ], 4 )
next
asize( OUT_ARRAY, len( NEW_ARRAY ) )
acopy( NEW_ARRAY, OUT_ARRAY )
getscreen()
return len( NEW_ARRAY )
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function Keys()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
function Keys( MODE )
local RETVAL := 2
local THEKEY := lastkey()
if MODE = 1
keyboard chr( 30 )
elseif MODE = 2
keyboard chr( 31 )
elseif MODE = 3
if THEKEY = 32
RETVAL := 1
elseif THEKEY = 27
RETVAL := 0
elseif THEKEY = 13 .and. SOMEITEMS < 1
RETVAL := 1
keyboard chr( 13 )
elseif THEKEY = 13
keyboard chr( 24 )
RETVAL := 0
endif
endif
return ( RETVAL )
*+ EOF: PICKARRY.PRG

120
harbour/utils/hbmake/pickfile.prg Normal file
View File

@@ -0,0 +1,120 @@
/*
* $Id$
*/
*+²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
*+
*+ Source Module => D:\SRC\PBMAKE\PICKFILE.PRG
*+
*+ PBMake is a Clipper, C, ASM, Xbase++ make engine.
*+
*+ Copyright(C) 1996-1999 by Phil Barnett.
*+
*+ 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.
*+
*+ 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.
*+
*+ You can contact me at:
*+
*+ Phil Barnett
*+ Box 944
*+ Plymouth, Florida 32768
*+
*+ or
*+
*+ philb@iag.net
*+
*+
*+ Functions: Function pickfile()
*+
*+ Reformatted by Click! 2.03 on Mar-30-1999 at 11:19 pm
*+
*+²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
/*
PICKFILE.PRG
Author : Phil Barnett
Written : 18-Apr-93
Function : PICKFILE()
Purpose : Generic file picking routine that pops a picklist of files.
Syntax : PICKFILE( [FILESPEC] )
Parameters : FILESPEC is a DOS filename. Wildcards permitted
Returns : Character file name of selected file or "" if nothing picked.
Example : yourfile := pickfile( '*.dbf' )
if empty(yourfile)
? 'You pressed Escape or No Matching File'
else
? 'The file you selected is: '+yourfile
endif
Released to Public Domain by Author.
*/
#include "COMMON.CH"
#include "BOX.CH"
#include "DIRECTRY.CH"
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Function pickfile()
*+
*+ Called from ( makelink.prg ) 1 - function makelink()
*+ ( pbinit.prg ) 1 - procedure pbinit()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
function pickfile( cFileSpec )
local cOldString := savescreen( 8, 19, 16, 61 )
local aFiles := directory( cFileSpec )
local aPickList := {}
local cRetVal := ''
local sel
default cFileSpec to '*.*'
dispbox( 8, 19, 16, 61, B_SINGLE + " ", "+W/R" )
if len( aFiles ) > 0
aeval( aFiles, { | xx | aadd( aPickList, ;
pad( xx[ F_NAME ], 13 ) + ;
str( xx[ F_SIZE ], 8 ) + ' ' + ;
dtoc( xx[ F_DATE ] ) + ' ' + ;
xx[ F_TIME ] ) } )
sel := achoice( 9, 20, 15, 60, aPickList )
cRetVal := iif( lastkey() == 27, '', aFiles[ sel, 1 ] )
else
achoice( 9, 20, 15, 60, { "No files match " + cFileSpec } )
endif
restscreen( 8, 19, 16, 61, cOldString )
return cRetVal
*+ EOF: PICKFILE.PRG

101
harbour/utils/hbmake/prb_stak.prg Normal file
View File

@@ -0,0 +1,101 @@
/*
* $Id$
*/
*+²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
*+
*+ Source Module => D:\SRC\PBMAKE\PRB_STAK.PRG
*+
*+ PBMake is a Clipper, C, ASM, Xbase++ make engine.
*+
*+ Copyright(C) 1996-1999 by Phil Barnett.
*+
*+ 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.
*+
*+ 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.
*+
*+ You can contact me at:
*+
*+ Phil Barnett
*+ Box 944
*+ Plymouth, Florida 32768
*+
*+ or
*+
*+ philb@iag.net
*+
*+
*+ Functions: Procedure PUTSCREEN()
*+ Procedure GETSCREEN()
*+
*+ Reformatted by Click! 2.03 on Mar-30-1999 at 11:19 pm
*+
*+²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
#include "COMMON.CH"
static SCR := {}
static CNT := 0
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Procedure PUTSCREEN()
*+
*+ Called from ( pbinit.prg ) 4 - procedure pbinit()
*+ ( pickarry.prg ) 1 - function pickarry()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
procedure PUTSCREEN( T, L, b, r )
default T to 0
default L to 0
default b to maxrow()
default r to maxcol()
aadd( SCR, { T, L, b, r, savescreen( T, L, b, r ), row(), col(), set( _SET_CURSOR ), setcolor() } )
CNT ++
return
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
*+ Procedure GETSCREEN()
*+
*+ Called from ( pbinit.prg ) 4 - procedure pbinit()
*+ ( pickarry.prg ) 1 - function pickarry()
*+
*+±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
*+
procedure GETSCREEN( OPTION )
default OPTION to 1
do case
case OPTION == 0
CNT := 0
SCR := {}
case OPTION == - 1
asize( SCR, -- CNT )
otherwise
if CNT > 0
restscreen( SCR[ cnt, 1 ], SCR[ cnt, 2 ], SCR[ cnt, 3 ], SCR[ cnt, 4 ], SCR[ cnt, 5 ] )
devpos( SCR[ cnt, 6 ], SCR[ cnt, 7 ] )
set( _SET_CURSOR, SCR[ cnt, 8 ] )
setcolor( SCR[ cnt, 9 ] )
asize( SCR, -- CNT )
endif
endcase
return
*+ EOF: PRB_STAK.PRG

10
harbour/utils/hbmake/radiodef.ch Normal file
View File

@@ -0,0 +1,10 @@
/***
* Radiodef.ch
*
* Definition of translates for simulated Radio button class.
*/
#translate :radioGsb => :cargo\[1\]
#translate :radioGets => :cargo\[2\]
#define RADIO_NUM_IVARS 2

17
harbour/utils/hbmake/radios.ch Normal file
View File

@@ -0,0 +1,17 @@
/***
* Radios.ch
*
* Header file for Radio button gets.
*/
// #define K_SPACE 32
#define RADIO_BUTTON Chr(4)
#command @ <row>, <col> GET <var> ;
RADIO <radios,...> ;
;
=> ;
SetPos(<row>, <col>) ;
; RadioGets({|x| iif(x == NIL, <var>, <var> := x) }, ;
<(var)>, <radios>, GetList) ;
; DrawRadios(GetList, Atail(GetList))

208
harbour/utils/hbmake/radios.prg Normal file
View File

@@ -0,0 +1,208 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* radios.Prg radios gets for hbmake
*
* 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 "Getexit.ch"
#include "InKey.ch"
#include "Radios.ch"
#include "Radiodef.ch"
FUNCTION RadioGets(bVar, cVar, aChoices, aGetList)
LOCAL oGet
LOCAL nRow := Row(), nCol := Col()
LOCAL nGets := Len(aChoices)
LOCAL nGet
LOCAL nStartGet := Len(aGetList) + 1
// For each element in aChoices
FOR nGet := 1 To nGets
// Display ( ) before the get
DevPos(nRow, nCol)
DevOut("( ) ")
// Create an empty get object and add it to the list
oGet := GetNew(nRow++,ncol+4,t(aChoices[nGet]),cvar)
Aadd(aGetList, oGet)
oGet:cargo := Array(RADIO_NUM_IVARS)
oGet:radioGsb := bVar
oGet:radioGets := Array(nGets)
Aeval(oGet:radioGets, {|x, n| oGet:radioGets[n] := nStartGet + n - 1})
// Radio gets have their own reader, of course
oGet:reader := {|o| RadioReader(o, aGetList) }
oGet:display()
NEXT
RETURN oGet
FUNCTION t(c)
RETURN {|x| c }
// The reader for radio buttons
Proc RadioReader( oGet, aGetList )
// read the GET if the WHEN condition is satisfied
IF ( GetPreValidate(oGet) )
// activate the GET for reading
oGet:SetFocus()
DO WHILE ( oGet:exitState == GE_NOEXIT )
// check for initial typeout (no editable positions)
IF ( oGet:typeOut )
oGet:exitState := GE_ENTER
ENDIF
// apply keystrokes until exit
DO WHILE ( oGet:exitState == GE_NOEXIT )
RadioApplyKey(oGet, InKey(0), aGetList)
ENDDO
// disallow exit if the VALID condition is not satisfied
IF ( !GetPostValidate(oGet) )
oGet:exitState := GE_NOEXIT
ENDIF
ENDDO
// de-activate the GET
oGet:KillFocus()
ENDIF
RETURN
PROC RadioApplyKey(oGet, nKey, aGetList)
LOCAL cKey
LOCAL bKeyBlock
LOCAL nSaveRow, nSaveCol
// check for SET KEY first
IF ( (bKeyBlock := SetKey(nKey)) <> NIL )
GetDoSetKey(bKeyBlock, oGet)
RETURN // NOTE
ENDIF
DO CASE
CASE ( nKey == K_UP )
oGet:exitState := GE_UP
CASE ( nKey == K_SH_TAB )
oGet:exitState := GE_UP
CASE ( nKey == K_DOWN )
oGet:exitState := GE_DOWN
CASE ( nKey == K_TAB )
oGet:exitState := GE_DOWN
CASE ( nKey == K_ENTER )
oGet:exitState := GE_ENTER
CASE nKey == K_SPACE
// Toggle state of this radio button. If the get
// currently contains this radio button, clear it.
// If it does not, set it to that value
IF Eval(oGet:radioGsb) == Eval(oGet:block)
Eval(oGet:radioGsb, "")
ELSE
// This sets the real variable to the value
// of this radio button
Eval(oGet:radioGsb, Eval(oGet:block))
ENDIF
// Ensure Updated() gets set
oGet:changed := .T.
// And redraw the getlist
DrawRadios(aGetlist, oGet)
CASE ( nKey == K_ESC )
IF ( Set(_SET_ESCAPE) )
oGet:undo()
oGet:exitState := GE_ESCAPE
ENDIF
CASE (nKey == K_PGUP )
oGet:exitState := GE_WRITE
CASE (nKey == K_PGDN )
oGet:exitState := GE_WRITE
CASE ( nKey == K_CTRL_HOME )
oGet:exitState := GE_TOP
// both ^W and ^End terminate the READ (the default)
CASE (nKey == K_CTRL_W)
oGet:exitState := GE_WRITE
CASE (nKey == K_INS)
Set( _SET_INSERT, !Set(_SET_INSERT) )
ENDCASE
RETURN
// Draw all radio buttons in aGetList to which the get object in
// oGet is attached
PROC DrawRadios(aGetList, oGet)
LOCAL nRadios := Len(oGet:radioGets)
LOCAL oGet1
LOCAL nSaveRow := Row()
LOCAL nSaveCol := Col()
LOCAL nGet
FOR nGet := 1 TO nRadios
oGet1 := aGetList[oGet:radioGets[nGet]]
DevPos(oGet1:row, oGet1:col - 3)
IF Eval(oGet1:radioGsb) == Eval(oGet1:block)
DevOut(RADIO_BUTTON)
ELSE
DevOut(" ")
ENDIF
NEXT
DevPos(nSaveRow, nSaveCol)
RETURN