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

2008-10-05 15:56 UTC+0200 Viktor Szakats (harbour.01 syenar hu)

Browse Source 
* include/hbpers.ch
  * source/rtl/perfuncs.prg
  * source/rtl/objfunc.prg
  * source/rtl/tlabel.prg
  * source/rtl/setta.prg
  * source/rtl/dirscan.prg
  * source/rtl/tthreadx.prg
  * source/rtl/setfunc.prg
  * source/rtl/readvar.prg
  * source/rtl/tclass.prg
  * source/rtl/ttextlin.prg
  * source/rtl/profiler.prg
  * source/rtl/treport.prg
  * source/rtl/tgetint.prg
  * source/rtl/persist.prg
  * source/rtl/altd.prg
  * source/rtl/devoutp.prg
  * source/rdd/usrrdd/example/exmemo.prg
  * source/rdd/usrrdd/example/exhsx.prg
  * source/rdd/usrrdd/example/exfcm.prg
  * source/rdd/usrrdd/example/exrlx.prg
  * source/rdd/usrrdd/rdds/dbtcdx.prg
  * source/rdd/usrrdd/rdds/fptcdx.prg
  * source/rdd/usrrdd/rdds/arrayrdd.prg
  * source/rdd/usrrdd/rdds/hscdx.prg
  * source/rdd/usrrdd/rdds/rlcdx.prg
  * source/rdd/usrrdd/rdds/fcomma.prg
  * source/rdd/usrrdd/rdds/smtcdx.prg
    * Formatting. Basically finished.

  * include/hbextern.ch
    ! Added two missing functions.
This commit is contained in:
Viktor Szakats
2008-10-05 13:57:35 +00:00
parent 38684fe9c1
commit ed672c29c9
30 changed files with 809 additions and 864 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
harbour/ChangeLog
View File

@@ -8,6 +8,40 @@
2008-12-31 13:59 UTC+0100 Foo Bar (foo.bar foobar.org)
*/
2008-10-05 15:56 UTC+0200 Viktor Szakats (harbour.01 syenar hu)
* include/hbpers.ch
* source/rtl/perfuncs.prg
* source/rtl/objfunc.prg
* source/rtl/tlabel.prg
* source/rtl/setta.prg
* source/rtl/dirscan.prg
* source/rtl/tthreadx.prg
* source/rtl/setfunc.prg
* source/rtl/readvar.prg
* source/rtl/tclass.prg
* source/rtl/ttextlin.prg
* source/rtl/profiler.prg
* source/rtl/treport.prg
* source/rtl/tgetint.prg
* source/rtl/persist.prg
* source/rtl/altd.prg
* source/rtl/devoutp.prg
* source/rdd/usrrdd/example/exmemo.prg
* source/rdd/usrrdd/example/exhsx.prg
* source/rdd/usrrdd/example/exfcm.prg
* source/rdd/usrrdd/example/exrlx.prg
* source/rdd/usrrdd/rdds/dbtcdx.prg
* source/rdd/usrrdd/rdds/fptcdx.prg
* source/rdd/usrrdd/rdds/arrayrdd.prg
* source/rdd/usrrdd/rdds/hscdx.prg
* source/rdd/usrrdd/rdds/rlcdx.prg
* source/rdd/usrrdd/rdds/fcomma.prg
* source/rdd/usrrdd/rdds/smtcdx.prg
* Formatting. Basically finished.
* include/hbextern.ch
! Added two missing functions.
2008-10-05 15:53 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/source/vm/thread.c
! fixed hb_mutexSubscribe*() in ST mode

3
harbour/include/hbextern.ch
View File

@@ -925,6 +925,9 @@ EXTERNAL HB_FIELDTYPE
EXTERNAL HB_SCRMAXROW
EXTERNAL HB_SCRMAXCOL
EXTERNAL HB_SETOBJECT
EXTERNAL HB_ENDOBJECT
EXTERNAL HB_MTVM
EXTERNAL HB_THREADSTART

4
harbour/include/hbpers.ch
View File

@@ -54,9 +54,9 @@
#define HB_PERS_CH_
#xcommand OBJECT <obj> AS <ClassName> => ;
Self := HB_SetObject( Self, { || <ClassName>():New() } )
Self := hb_SetObject( Self, { || <ClassName>():New() } )
#xcommand ENDOBJECT => Self := HB_EndObject()
#xcommand ENDOBJECT => Self := hb_EndObject()
#xcommand ARRAY <obj> LEN <nLen> => <obj> := Array( <nLen> )

4
harbour/source/rdd/usrrdd/example/exfcm.prg
View File

@@ -4,7 +4,7 @@
REQUEST FCOMMA
PROC MAIN()
PROCEDURE MAIN()
USE test.csv VIA "FCOMMA"
? "ALIAS", ALIAS(), "RECNO", RECNO(), ;
@@ -41,4 +41,4 @@ PROC MAIN()
WAIT
BROWSE()
RETURN
RETURN

4
harbour/source/rdd/usrrdd/example/exhsx.prg
View File

@@ -6,7 +6,7 @@
REQUEST HSXRDD
PROC MAIN()
PROCEDURE MAIN()
FIELD FIRST, LAST, STREET, CITY
LOCAL n, hs
@@ -45,4 +45,4 @@ PROC MAIN()
DBGOTOP()
BROWSE()
ENDIF
RETURN
RETURN

4
harbour/source/rdd/usrrdd/example/exmemo.prg
View File

@@ -6,10 +6,10 @@ REQUEST DBTCDX
REQUEST FPTCDX
REQUEST SMTCDX
PROC MAIN()
PROCEDURE MAIN()
DBCREATE("table1", {{"F1","M",4,0}}, "DBTCDX")
DBCREATE("table2", {{"F1","M",4,0}}, "FPTCDX")
DBCREATE("table3", {{"F1","M",4,0}}, "SMTCDX")
RETURN
RETURN

4
harbour/source/rdd/usrrdd/example/exrlx.prg
View File

@@ -4,7 +4,7 @@
REQUEST RLCDX
PROC MAIN()
PROCEDURE MAIN()
DBCREATE( "_tst", {{"F1","C",10,0}}, "RLCDX" )
USE _tst VIA "RLCDX" SHARED
@@ -47,4 +47,4 @@ PROC MAIN()
CLOSE
RETURN
RETURN

127
harbour/source/rdd/usrrdd/rdds/arrayrdd.prg
View File

@@ -65,7 +65,7 @@
#include "dbstruct.ch"
#include "common.ch"
#xtranslate THROW(<oErr>) => (Eval(ErrorBlock(), <oErr>), Break(<oErr>))
#xtranslate THROW( <oErr> ) => ( Eval( ErrorBlock(), <oErr> ), Break( <oErr> ) )
ANNOUNCE ARRAYRDD
@@ -108,42 +108,42 @@ STATIC FUNCTION AR_INIT( nRDD )
/* Init DBF Hash */
USRRDD_RDDDATA( nRDD, hb_Hash() )
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_RDDDATAINIT()
RETURN { ;
NIL ; // RDDDATA_DATABASE
}
RETURN { ;
NIL ; // RDDDATA_DATABASE
}
STATIC FUNCTION AR_DATABASEINIT()
RETURN { ;
NIL ,; // DATABASE_FILENAME
{} ,; // DATABASE_RECORDS
{} ,; // DATABASE_RECINFO
0 ,; // DATABASE_OPENNUMBER
FALSE ,; // DATABASE_LOCKED
NIL ; // DATABASE_STRUCT - aStruct
}
RETURN { ;
NIL ,; // DATABASE_FILENAME
{} ,; // DATABASE_RECORDS
{} ,; // DATABASE_RECINFO
0 ,; // DATABASE_OPENNUMBER
FALSE ,; // DATABASE_LOCKED
NIL ; // DATABASE_STRUCT - aStruct
}
STATIC FUNCTION AR_WADATAINIT()
RETURN { ;
NIL ,; // WADATA_DATABASE
0 ,; // WADATA_WORKAREA
NIL ,; // WADATA_OPENINFO
0 ,; // WADATA_RECNO
FALSE ,; // WADATA_BOF
FALSE ,; // WADATA_FORCEBOF // to solve an hack in dbf1.c
FALSE ,; // WADATA_EOF
FALSE ,; // WADATA_TOP
FALSE ,; // WADATA_BOTTOM
FALSE ,; // WADATA_FOUND
{} ; // WADATA_LOCKS
}
RETURN { ;
NIL ,; // WADATA_DATABASE
0 ,; // WADATA_WORKAREA
NIL ,; // WADATA_OPENINFO
0 ,; // WADATA_RECNO
FALSE ,; // WADATA_BOF
FALSE ,; // WADATA_FORCEBOF // to solve an hack in dbf1.c
FALSE ,; // WADATA_EOF
FALSE ,; // WADATA_TOP
FALSE ,; // WADATA_BOTTOM
FALSE ,; // WADATA_FOUND
{} ; // WADATA_LOCKS
}
STATIC FUNCTION AR_RECDATAINIT()
RETURN { ;
FALSE ; // RECDATA_DELETED
}
RETURN { ;
FALSE ; // RECDATA_DELETED
}
/*
* methods: NEW and RELEASE receive pointer to work area structure
@@ -162,7 +162,7 @@ STATIC FUNCTION AR_NEW( pWA )
*/
USRRDD_AREADATA( pWA, AR_WADATAINIT() )
RETURN SUCCESS
RETURN SUCCESS
// Creating fields for new DBF - dbCreate() in current workarea
STATIC FUNCTION AR_CREATEFIELDS( nWA, aStruct )
@@ -194,7 +194,7 @@ STATIC FUNCTION AR_CREATEFIELDS( nWA, aStruct )
NEXT
RETURN nResult
RETURN nResult
// Create database from current WA fields definition
STATIC FUNCTION AR_CREATE( nWA, aOpenInfo )
@@ -250,7 +250,7 @@ STATIC FUNCTION AR_CREATE( nWA, aOpenInfo )
// increase open number
aDBFData[ DATABASE_OPENNUMBER ]++
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_OPEN( nWA, aOpenInfo )
LOCAL cFullName, cName, hRDDData, aWAData, aDBFData
@@ -351,7 +351,7 @@ STATIC FUNCTION AR_OPEN( nWA, aOpenInfo )
AR_GOTOP( nWA )
ENDIF
RETURN nResult
RETURN nResult
STATIC FUNCTION AR_CLOSE( nWA )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -363,7 +363,7 @@ STATIC FUNCTION AR_CLOSE( nWA )
// unlock file
aDBFData[ DATABASE_LOCKED ] := FALSE // Exclusive mode
RETURN UR_SUPER_CLOSE( nWA )
RETURN UR_SUPER_CLOSE( nWA )
STATIC FUNCTION AR_GETVALUE( nWA, nField, xValue )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -385,7 +385,7 @@ STATIC FUNCTION AR_GETVALUE( nWA, nField, xValue )
ENDIF
RETURN FAILURE
RETURN FAILURE
STATIC FUNCTION AR_PUTVALUE( nWA, nField, xValue )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -410,7 +410,7 @@ STATIC FUNCTION AR_PUTVALUE( nWA, nField, xValue )
ENDIF
RETURN FAILURE
RETURN FAILURE
STATIC FUNCTION AR_GOTO( nWA, nRecord )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -461,10 +461,10 @@ STATIC FUNCTION AR_GOTO( nWA, nRecord )
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_GOTOID( nWA, nRecord )
RETURN AR_GOTO( nWA, nRecord )
RETURN AR_GOTO( nWA, nRecord )
STATIC FUNCTION AR_GOTOP( nWA )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -489,7 +489,7 @@ STATIC FUNCTION AR_GOTOP( nWA )
ENDIF
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_GOBOTTOM( nWA )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -514,7 +514,8 @@ STATIC FUNCTION AR_GOBOTTOM( nWA )
ENDIF
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_SKIPFILTER( nWA, nRecords )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -553,7 +554,7 @@ STATIC FUNCTION AR_SKIPFILTER( nWA, nRecords )
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_SKIPRAW( nWA, nRecords )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -588,7 +589,7 @@ STATIC FUNCTION AR_SKIPRAW( nWA, nRecords )
ENDIF
RETURN nResult // SUCCESS
RETURN nResult // SUCCESS
STATIC FUNCTION AR_BOF( nWA, lBof )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -600,12 +601,15 @@ STATIC FUNCTION AR_BOF( nWA, lBof )
ELSE
lBof := aWAData[ WADATA_BOF ]
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_EOF( nWA, lEof )
LOCAL aWAData := USRRDD_AREADATA( nWA )
lEof := aWAData[ WADATA_EOF ]
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_DELETE( nWA )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -642,7 +646,7 @@ STATIC FUNCTION AR_DELETE( nWA )
aRecInfo[ aWAData[ WADATA_RECNO ] ][ RECDATA_DELETED ] := .T.
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_DELETED( nWA, lDeleted )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -655,7 +659,8 @@ STATIC FUNCTION AR_DELETED( nWA, lDeleted )
ELSE
lDeleted := .F.
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_APPEND( nWA, nRecords )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -688,7 +693,7 @@ STATIC FUNCTION AR_APPEND( nWA, nRecords )
/* TODO: SHARED ACCESS */
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_RECID( nWA, nRecNo )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -701,14 +706,17 @@ STATIC FUNCTION AR_RECID( nWA, nRecNo )
ELSE
nRecNo := aWAData[ WADATA_RECNO ]
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_RECCOUNT( nWA, nRecords )
LOCAL aWAData := USRRDD_AREADATA( nWA )
LOCAL aDBFData := aWAData[ WADATA_DATABASE ]
LOCAL aRecords := aDBFData[ DATABASE_RECORDS ]
nRecords := Len( aRecords )
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_ZAP( nWA )
LOCAL aWAData := USRRDD_AREADATA( nWA )
@@ -747,7 +755,7 @@ STATIC FUNCTION AR_ZAP( nWA )
// move to 0 recno
AR_GOTO( nWA, 0 )
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION AR_ORDINFO( nWA, xMsg, xValue )
/*
@@ -786,7 +794,8 @@ STATIC FUNCTION AR_ORDINFO( nWA, xMsg, xValue )
aWAData[ ARRAY_RECINFO ] := {}
AR_GOTO( nWA, 0 )
*/
RETURN SUCCESS
RETURN SUCCESS
/*
* This function have to exist in all RDD and then name have to be in
@@ -820,12 +829,12 @@ FUNCTION ARRAYRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID )
aMyFunc[ UR_ZAP ] := ( @AR_ZAP() )
aMyFunc[ UR_ORDINFO ] := ( @AR_ORDINFO() )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
cSuperRDD, aMyFunc )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
cSuperRDD, aMyFunc )
INIT PROC ARRAYRDD_INIT()
INIT PROCEDURE ARRAYRDD_INIT()
rddRegister( "ARRAYRDD", RDT_FULL )
RETURN
RETURN
/* -------------------------------------------------- */
/* UTILITY FUNCTIONS */
@@ -919,7 +928,8 @@ FUNCTION EraseArrayRdd( cFullName )
nReturn := FAILURE
ENDIF
RETURN nReturn
RETURN nReturn
STATIC FUNCTION BlankRecord( aStruct )
LOCAL nLenStruct := Len( aStruct )
@@ -929,7 +939,8 @@ STATIC FUNCTION BlankRecord( aStruct )
FOR nField := 1 TO nLenStruct
aRecord[ nField ] := EmptyValue( aStruct[ nField ][ DBS_TYPE ], aStruct[ nField ][ DBS_LEN ], aStruct[ nField ][ DBS_DEC ] )
NEXT
RETURN aRecord
RETURN aRecord
STATIC FUNCTION PutValue( xValue, cType, nLen, nDec )
LOCAL xVal
@@ -943,7 +954,7 @@ STATIC FUNCTION PutValue( xValue, cType, nLen, nDec )
xVal := xValue
ENDCASE
RETURN xVal
RETURN xVal
STATIC FUNCTION EmptyValue( cType, nLen, nDec )

12
harbour/source/rdd/usrrdd/rdds/dbtcdx.prg
View File

@@ -64,16 +64,14 @@
REQUEST DBFCDX
REQUEST DBFFPT
/* Announce our RDD for forign REQUESTs */
/* Announce our RDD for foreign REQUESTs */
ANNOUNCE DBTCDX
PROC DBTCDX(); RETURN
FUNCTION DBTCDX_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
"DBFCDX", {} ) /* We are inheriting from DBFCDX */
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
"DBFCDX", {} ) /* We are inheriting from DBFCDX */
INIT PROC DBTCDX_INIT()
INIT PROCEDURE DBTCDX_INIT()
rddRegister( "DBTCDX", RDT_FULL )
rddInfo( RDDI_MEMOTYPE, DB_MEMO_DBT, "DBTCDX" )
RETURN
RETURN

42
harbour/source/rdd/usrrdd/rdds/fcomma.prg
View File

@@ -50,8 +50,6 @@
*
*/
/*
* A simple RDD which uses HB_F*() functions from MISC library
* to access CSV files. It allow to open an CSV file and navigate
@@ -82,7 +80,7 @@ STATIC FUNCTION FCM_INIT( nRDD )
AFILL( aRData, -1 )
USRRDD_RDDDATA( nRDD, aRData )
RETURN SUCCESS
RETURN SUCCESS
/*
* methods: NEW and RELEASE receive pointer to work area structure
@@ -102,7 +100,7 @@ STATIC FUNCTION FCM_NEW( pWA )
*/
USRRDD_AREADATA( pWA, aWData )
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION FCM_CREATE( nWA, aOpenInfo )
LOCAL oError := ErrorNew()
@@ -114,7 +112,7 @@ STATIC FUNCTION FCM_CREATE( nWA, aOpenInfo )
oError:FileName := aOpenInfo[ UR_OI_NAME ]
oError:CanDefault := .T.
UR_SUPER_ERROR( nWA, oError )
RETURN FAILURE
RETURN FAILURE
STATIC FUNCTION FCM_OPEN( nWA, aOpenInfo )
LOCAL cName, nMode, nSlot, nHandle, aRData, aWData, aField, oError, nResult
@@ -178,7 +176,7 @@ STATIC FUNCTION FCM_OPEN( nWA, aOpenInfo )
FCM_GOTOP( nWA )
ENDIF
RETURN nResult
RETURN nResult
STATIC FUNCTION FCM_CLOSE( nWA )
LOCAL aRData, nSlot := USRRDD_AREADATA( nWA )[ 1 ]
@@ -189,7 +187,7 @@ STATIC FUNCTION FCM_CLOSE( nWA )
aRData := USRRDD_RDDDATA( USRRDD_ID( nWA ) )
aRData[ nSlot ] := -1
ENDIF
RETURN UR_SUPER_CLOSE( nWA )
RETURN UR_SUPER_CLOSE( nWA )
STATIC FUNCTION FCM_GETVALUE( nWA, nField, xValue )
LOCAL aWData := USRRDD_AREADATA( nWA )
@@ -204,7 +202,7 @@ STATIC FUNCTION FCM_GETVALUE( nWA, nField, xValue )
ENDIF
RETURN SUCCESS
ENDIF
RETURN FAILURE
RETURN FAILURE
STATIC FUNCTION FCM_GOTO( nWA, nRecord )
LOCAL aWData := USRRDD_AREADATA( nWA )
@@ -221,17 +219,17 @@ STATIC FUNCTION FCM_GOTO( nWA, nRecord )
aWData[ 2 ] := HB_FRECNO() == 0
aWData[ 3 ] := HB_FEOF()
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION FCM_GOTOID( nWA, nRecord )
RETURN FCM_GOTO( nWA, nRecord )
RETURN FCM_GOTO( nWA, nRecord )
STATIC FUNCTION FCM_GOTOP( nWA )
LOCAL aWData := USRRDD_AREADATA( nWA )
HB_FSELECT( aWData[ 1 ] )
HB_FGOTOP()
aWData[ 2 ] := aWData[ 3 ] := HB_FEOF()
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION FCM_GOBOTTOM( nWA )
LOCAL aWData := USRRDD_AREADATA( nWA )
@@ -244,7 +242,7 @@ STATIC FUNCTION FCM_GOBOTTOM( nWA )
HB_FGOBOTTOM()
aWData[ 2 ] := aWData[ 3 ] := .F.
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION FCM_SKIPRAW( nWA, nRecords )
LOCAL aWData
@@ -269,21 +267,21 @@ STATIC FUNCTION FCM_SKIPRAW( nWA, nRecords )
aWData[ 3 ] := HB_FEOF()
ENDIF
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION FCM_BOF( nWA, lBof )
LOCAL aWData := USRRDD_AREADATA( nWA )
lBof := aWData[ 2 ]
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION FCM_EOF( nWA, lEof )
LOCAL aWData := USRRDD_AREADATA( nWA )
lEof := aWData[ 3 ]
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION FCM_DELETED( nWA, lDeleted )
lDeleted := .F.
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION FCM_RECID( nWA, nRecNo )
LOCAL aWData := USRRDD_AREADATA( nWA )
@@ -293,12 +291,12 @@ STATIC FUNCTION FCM_RECID( nWA, nRecNo )
ELSE
nRecNo := HB_FRECNO()
ENDIF
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION FCM_RECCOUNT( nWA, nRecords )
HB_FSELECT( USRRDD_AREADATA( nWA )[ 1 ] )
nRecords := HB_FLASTREC()
RETURN SUCCESS
RETURN SUCCESS
/*
* This function have to exist in all RDD and then name have to be in
@@ -325,9 +323,9 @@ FUNCTION FCOMMA_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID )
aMyFunc[ UR_RECCOUNT ] := ( @FCM_RECCOUNT() )
aMyFunc[ UR_GETVALUE ] := ( @FCM_GETVALUE() )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
cSuperRDD, aMyFunc )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
cSuperRDD, aMyFunc )
INIT PROC FCOMMA_INIT()
INIT PROCEDURE FCOMMA_INIT()
rddRegister( "FCOMMA", RDT_FULL )
RETURN
RETURN

8
harbour/source/rdd/usrrdd/rdds/fptcdx.prg
View File

@@ -68,10 +68,10 @@ REQUEST DBFFPT
ANNOUNCE FPTCDX
FUNCTION FPTCDX_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
"DBFCDX", {} ) /* We are inheriting from DBFCDX */
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
"DBFCDX", {} ) /* We are inheriting from DBFCDX */
INIT PROC FPTCDX_INIT()
INIT PROCEDURE FPTCDX_INIT()
rddRegister( "FPTCDX", RDT_FULL )
rddInfo( RDDI_MEMOTYPE, DB_MEMO_FPT, "FPTCDX" )
RETURN
RETURN

37
harbour/source/rdd/usrrdd/rdds/hscdx.prg
View File

@@ -50,7 +50,6 @@
*
*/
/*
* A simple RDD which adds automatically update HSX indexes to DBFCDX
* To create new HSX index for current work area use: HSX_CREATE()
@@ -82,7 +81,7 @@ STATIC FUNCTION _HSX_NEW( pWA )
*/
USRRDD_AREADATA( pWA, aWData )
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION _HSX_CLOSE( nWA )
LOCAL aWData:= USRRDD_AREADATA( nWA ), nHSX
@@ -97,7 +96,7 @@ STATIC FUNCTION _HSX_CLOSE( nWA )
ASIZE( aWData[ 3 ], 0 )
/* call SUPER CLOSE method to close parent RDD */
RETURN UR_SUPER_CLOSE( nWA )
RETURN UR_SUPER_CLOSE( nWA )
STATIC FUNCTION _HSX_GOCOLD( nWA )
LOCAL nResult, aWData, nHSX, nRecNo, nKeyNo
@@ -122,7 +121,8 @@ STATIC FUNCTION _HSX_GOCOLD( nWA )
aWData[ 1 ] := .F.
ENDIF
ENDIF
RETURN nResult
RETURN nResult
STATIC FUNCTION _HSX_GOHOT( nWA )
LOCAL nResult, aWData
@@ -132,7 +132,8 @@ STATIC FUNCTION _HSX_GOHOT( nWA )
aWData:= USRRDD_AREADATA( nWA )
aWData[ 1 ] := .T.
ENDIF
RETURN nResult
RETURN nResult
STATIC FUNCTION _HSX_APPEND( nWA, lUnlockAll )
LOCAL nResult, aWData
@@ -142,7 +143,8 @@ STATIC FUNCTION _HSX_APPEND( nWA, lUnlockAll )
aWData:= USRRDD_AREADATA( nWA )
aWData[ 1 ] := .T.
ENDIF
RETURN nResult
RETURN nResult
/*
* Three public functions for CREATE, OPEN and CLOSE HSX indexes bound
@@ -165,7 +167,7 @@ FUNCTION HSX_CREATE( cFile, cExpr, nKeySize, nBufSize, lCase, nFiltSet )
ENDIF
ENDIF
RETURN nHsx
RETURN nHsx
FUNCTION HSX_OPEN( cFile, nBufSize )
LOCAL aWData, nHsx := -1, nOpenMode
@@ -183,7 +185,7 @@ FUNCTION HSX_OPEN( cFile, nBufSize )
ENDIF
ENDIF
RETURN NIL
RETURN NIL
FUNCTION HSX_CLOSE( xHSX )
LOCAL aWData, nSlot
@@ -204,10 +206,12 @@ FUNCTION HSX_CLOSE( xHSX )
ASIZE( aWData[ 3 ], LEN( aWData[ 3 ] ) - 1 )
ENDIF
ENDIF
RETURN NIL
RETURN NIL
FUNCTION HSX_HANDLE( cFile )
LOCAL aWData, nSlot
IF USED() .AND. RDDNAME() == "HSCDX"
aWData:= USRRDD_AREADATA( SELECT() )
nSlot := ASCAN( aWData[ 3 ], { |_1| _1 == cFile } )
@@ -215,7 +219,8 @@ FUNCTION HSX_HANDLE( cFile )
RETURN aWData[ 2, nSlot ]
ENDIF
ENDIF
RETURN -1
RETURN -1
FUNCTION HSX_FILE( nHsx )
LOCAL aWData, nSlot
@@ -226,7 +231,7 @@ FUNCTION HSX_FILE( nHsx )
RETURN aWData[ 3, nSlot ]
ENDIF
ENDIF
RETURN ""
RETURN ""
FUNCTION HSX_GET( nSlot )
LOCAL aWData
@@ -236,7 +241,7 @@ FUNCTION HSX_GET( nSlot )
RETURN aWData[ 2, nSlot ]
ENDIF
ENDIF
RETURN -1
RETURN -1
/* Force linking DBFCDX from which our RDD inherits */
REQUEST DBFCDX
@@ -255,12 +260,12 @@ FUNCTION HSCDX_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID )
aMyFunc[ UR_GOHOT ] := ( @_HSX_GOHOT() )
aMyFunc[ UR_APPEND ] := ( @_HSX_APPEND() )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
cSuperRDD, aMyFunc )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
cSuperRDD, aMyFunc )
/*
* Register our HSCDX at program startup
*/
INIT PROC HSCDX_INIT()
INIT PROCEDURE HSCDX_INIT()
rddRegister( "HSCDX", RDT_FULL )
RETURN
RETURN

16
harbour/source/rdd/usrrdd/rdds/rlcdx.prg
View File

@@ -80,7 +80,7 @@ STATIC FUNCTION RLCDX_NEW( pWA )
USRRDD_AREADATA( pWA, aWData )
RETURN SUCCESS
RETURN SUCCESS
STATIC FUNCTION RLCDX_LOCK( nWA, aLockInfo )
LOCAL aWData, nResult, xRecId, i
@@ -149,7 +149,7 @@ STATIC FUNCTION RLCDX_LOCK( nWA, aLockInfo )
aLockInfo[ UR_LI_RESULT ] := .F.
RETURN FAILURE
RETURN FAILURE
STATIC FUNCTION RLCDX_UNLOCK( nWA, xRecID )
LOCAL aWData := USRRDD_AREADATA( nWA ), i
@@ -173,7 +173,7 @@ STATIC FUNCTION RLCDX_UNLOCK( nWA, xRecID )
ASIZE( aWData[ 2 ], 0 )
ENDIF
RETURN UR_SUPER_UNLOCK( nWA, xRecID )
RETURN UR_SUPER_UNLOCK( nWA, xRecID )
STATIC FUNCTION RLCDX_APPEND( nWA, lUnlockAll )
LOCAL aWData, nResult, xRecId, i
@@ -197,7 +197,7 @@ STATIC FUNCTION RLCDX_APPEND( nWA, lUnlockAll )
ENDIF
ENDIF
RETURN nResult
RETURN nResult
/* Force linking DBFCDX from which our RDD inherits */
REQUEST DBFCDX
@@ -216,9 +216,9 @@ FUNCTION RLCDX_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID )
aMethods[ UR_UNLOCK ] := ( @RLCDX_UNLOCK() )
aMethods[ UR_APPEND ] := ( @RLCDX_APPEND() )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
cSuperRDD, aMethods )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
cSuperRDD, aMethods )
INIT PROC RLCDX_INIT()
INIT PROCEDURE RLCDX_INIT()
rddRegister( "RLCDX", RDT_FULL )
RETURN
RETURN

8
harbour/source/rdd/usrrdd/rdds/smtcdx.prg
View File

@@ -68,10 +68,10 @@ REQUEST DBFFPT
ANNOUNCE SMTCDX
FUNCTION SMTCDX_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID )
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
"DBFCDX", {} ) /* We are inheriting from DBFCDX */
RETURN USRRDD_GETFUNCTABLE( pFuncCount, pFuncTable, pSuperTable, nRddID, ;
"DBFCDX", {} ) /* We are inheriting from DBFCDX */
INIT PROC SMTCDX_INIT()
INIT PROCEDURE SMTCDX_INIT()
rddRegister( "SMTCDX", RDT_FULL )
rddInfo( RDDI_MEMOTYPE, DB_MEMO_SMT, "SMTCDX" )
RETURN
RETURN

10
harbour/source/rtl/altd.prg
View File

@@ -60,22 +60,22 @@
PROCEDURE AltD( nAction )
IF PCOUNT() == 0
IF PCount() == 0
/* do not activate the debugger imediatelly because the module
where ALTD() was called can have no debugger info - stop
on first LINE with debugged info
*/
__dbgINVOKEDEBUG( SET( _SET_DEBUG ) )
__dbgINVOKEDEBUG( Set( _SET_DEBUG ) )
ELSEIF HB_ISNUMERIC( nAction )
IF nAction == ALTD_DISABLE
SET( _SET_DEBUG, .F. )
Set( _SET_DEBUG, .F. )
ELSEIF nAction == ALTD_ENABLE
SET( _SET_DEBUG, .T. )
Set( _SET_DEBUG, .T. )
ENDIF
ENDIF
RETURN
RETURN

2
harbour/source/rtl/devoutp.prg
View File

@@ -56,4 +56,4 @@ PROCEDURE DevOutPict( xValue, cPicture, cColor )
DevOut( Transform( xValue, cPicture ), cColor )
ENDIF
RETURN
RETURN

12
harbour/source/rtl/dirscan.prg
View File

@@ -50,20 +50,20 @@
*
*/
STATIC FUNCTION HB_doScan( cPath, cMask, cAttr, cPathSep )
STATIC FUNCTION hb_doScan( cPath, cMask, cAttr, cPathSep )
LOCAL aFile
LOCAL lMatch
LOCAL aResult := {}
FOR EACH aFile IN Directory( cPath + hb_osFileMask(), cAttr + "D" )
lMatch = HB_FileMatch( aFile[ 1 ], cMask )
lMatch := hb_FileMatch( aFile[ 1 ], cMask )
IF "D" $ aFile[ 5 ]
IF lMatch .AND. "D" $ cAttr
AAdd( aResult, aFile )
ENDIF
IF !( aFile[ 1 ] == "." .OR. aFile[ 1 ] == ".." .OR. aFile[ 1 ] == "" )
AEval( HB_DoScan( cPath + aFile[ 1 ] + cPathSep, cMask, cAttr, cPathSep ), ;
AEval( hb_DoScan( cPath + aFile[ 1 ] + cPathSep, cMask, cAttr, cPathSep ), ;
{ |x| x[ 1 ] := aFile[ 1 ] + cPathSep + x[ 1 ], ;
AAdd( aResult, x ) } )
ENDIF
@@ -74,7 +74,7 @@ STATIC FUNCTION HB_doScan( cPath, cMask, cAttr, cPathSep )
RETURN aResult
FUNCTION HB_DirScan( cPath, cFileMask, cAttr )
FUNCTION hb_DirScan( cPath, cFileMask, cAttr )
LOCAL cFilePath
LOCAL cPathSep := hb_osPathSeparator()
@@ -89,6 +89,6 @@ FUNCTION HB_DirScan( cPath, cFileMask, cAttr )
ENDIF
RETURN HB_DoScan( cFilePath, ;
IIF( Empty( cFileMask ), hb_osFileMask(), cFileMask ), ;
IIF( ValType( cAttr ) $ "CM", cAttr, "" ), ;
iif( Empty( cFileMask ), hb_osFileMask(), cFileMask ), ;
iif( ValType( cAttr ) $ "CM", cAttr, "" ), ;
cPathSep )

1
harbour/source/rtl/objfunc.prg
View File

@@ -279,7 +279,6 @@ FUNCTION __objDerivedFrom( oObject, xSuper )
RETURN __clsParent( oObject:ClassH, cClassName )
FUNCTION __objGetProperties( oObject, lAllExported )
LOCAL msg
LOCAL aMsgList := __clsGetProperties( oObject:classH, lAllExported )

26
harbour/source/rtl/perfuncs.prg
View File

@@ -50,29 +50,29 @@
*
*/
thread static s_aObjects
THREAD STATIC s_aObjects
function HB_SetObject( oSelf, bConstructor )
FUNCTION hb_SetObject( oSelf, bConstructor )
if s_aObjects == nil
IF s_aObjects == NIL
s_aObjects := {}
AAdd( s_aObjects, oSelf )
else
ELSE
AAdd( s_aObjects, oSelf := Eval( bConstructor ) )
endif
ENDIF
return oSelf
RETURN oSelf
function HB_EndObject()
FUNCTION hb_EndObject()
local oSelf
LOCAL oSelf
if Len( s_aObjects ) > 1
IF Len( s_aObjects ) > 1
ASize( s_aObjects, Len( s_aObjects ) - 1 )
oSelf := ATail( s_aObjects )
else
ELSE
oSelf := s_aObjects[ 1 ]
s_aObjects := nil
endif
s_aObjects := NIL
ENDIF
return oSelf
RETURN oSelf

238
harbour/source/rtl/persist.prg
View File

@@ -65,59 +65,67 @@ ENDCLASS
METHOD LoadFromText( cObjectText ) CLASS HBPersistent
local nFrom := 1, cLine, cToken
local lStart := .t.
private oSelf
LOCAL nFrom := 1
LOCAL cLine
LOCAL cToken
LOCAL lStart := .t.
if empty( cObjectText )
return .F.
endif
PRIVATE oSelf
do while Empty( ExtractLine( cObjectText, @nFrom ) ) // We skip the first empty lines
enddo
IF Empty( cObjectText )
RETURN .F.
ENDIF
do while nFrom <= Len( cObjectText )
cLine := ExtractLine( cObjectText, @nFrom )
// We skip the first empty lines
DO WHILE Empty( ExtractLine( cObjectText, @nFrom ) )
ENDDO
do case
case Upper( LTrim( hb_TokenGet( cLine, 1 ) ) ) == "OBJECT"
if lStart
lStart := .f.
else
endif
DO WHILE nFrom <= Len( cObjectText )
cLine := ExtractLine( cObjectText, @nFrom )
case Upper( LTrim( hb_TokenGet( cLine, 1 ) ) ) == "ARRAY"
cLine := SubStr( cLine, At( "::", cLine ) )
M->oSelf := Self
cLine := StrTran( cLine, "::", "oSelf:" )
cLine := StrTran( cLine, " LEN ", " = Array( " )
cLine := RTrim( StrTran( cLine, "=", ":=", , 1 ) ) + " )"
cLine := &( cLine )
DO CASE
CASE Upper( LTrim( hb_TokenGet( cLine, 1 ) ) ) == "OBJECT"
IF lStart
lStart := .F.
ENDIF
case Left( cToken := LTrim( hb_TokenGet( cLine, 1, "=" ) ), 2 ) == "::"
M->oSelf := Self
cLine := StrTran( cLine, "::", "oSelf:" )
cLine := StrTran( cLine, "=", ":=", , 1 )
cLine := &( cLine )
CASE Upper( LTrim( hb_TokenGet( cLine, 1 ) ) ) == "ARRAY"
cLine := SubStr( cLine, At( "::", cLine ) )
M->oSelf := Self
cLine := StrTran( cLine, "::", "oSelf:" )
cLine := StrTran( cLine, " LEN ", " = Array( " )
cLine := RTrim( StrTran( cLine, "=", ":=", , 1 ) ) + " )"
cLine := &( cLine )
endcase
CASE Left( cToken := LTrim( hb_TokenGet( cLine, 1, "=" ) ), 2 ) == "::"
M->oSelf := Self
cLine := StrTran( cLine, "::", "oSelf:" )
cLine := StrTran( cLine, "=", ":=", , 1 )
cLine := &( cLine )
enddo
ENDCASE
return .T.
ENDDO
RETURN .T.
METHOD SaveToText( cObjectName, nIndent ) CLASS HBPersistent
local oNew := &( ::ClassName() + "()" ):CreateNew()
local aProperties, n, uValue, uNewValue, cObject, cType
LOCAL oNew := &( ::ClassName() + "()" ):CreateNew()
LOCAL aProperties
LOCAL n
LOCAL uValue
LOCAL uNewValue
LOCAL cObject
LOCAL cType
DEFAULT cObjectName TO "o" + ::ClassName()
if nIndent == NIL
IF nIndent == NIL
nIndent := 0
else
ELSE
nIndent += 3
endif
ENDIF
cObject := iif( nIndent > 0, hb_OSNewLine(), "" ) + Space( nIndent ) + ;
"OBJECT " + iif( nIndent != 0, "::", "" ) + cObjectName + " AS " + ;
@@ -125,124 +133,126 @@ METHOD SaveToText( cObjectName, nIndent ) CLASS HBPersistent
aProperties := __ClsGetProperties( ::ClassH )
for n := 1 to Len( aProperties )
FOR n := 1 TO Len( aProperties )
uValue := __objSendMsg( Self, aProperties[ n ] )
uNewValue := __objSendMsg( oNew, aProperties[ n ] )
cType := ValType( uValue )
if !( cType == ValType( uNewValue ) ) .OR. ! uValue == uNewValue
IF !( cType == ValType( uNewValue ) ) .OR. !( uValue == uNewValue )
do case
case cType == "A"
nIndent += 3
cObject += ArrayToText( uValue, aProperties[ n ], nIndent )
nIndent -= 3
if n < Len( aProperties )
cObject += hb_OSNewLine()
endif
DO CASE
CASE cType == "A"
nIndent += 3
cObject += ArrayToText( uValue, aProperties[ n ], nIndent )
nIndent -= 3
IF n < Len( aProperties )
cObject += hb_OSNewLine()
ENDIF
case cType == "O"
if __objDerivedFrom( uValue, "HBPERSISTENT" )
cObject += uValue:SaveToText( aProperties[ n ], nIndent )
endif
if n < Len( aProperties )
cObject += hb_OSNewLine()
endif
CASE cType == "O"
IF __objDerivedFrom( uValue, "HBPERSISTENT" )
cObject += uValue:SaveToText( aProperties[ n ], nIndent )
ENDIF
IF n < Len( aProperties )
cObject += hb_OSNewLine()
ENDIF
otherwise
if n == 1
cObject += hb_OSNewLine()
endif
cObject += Space( nIndent ) + " ::" + ;
aProperties[ n ] + " = " + ValToText( uValue ) + ;
hb_OSNewLine()
endcase
OTHERWISE
IF n == 1
cObject += hb_OSNewLine()
ENDIF
cObject += Space( nIndent ) + " ::" + ;
aProperties[ n ] + " = " + ValToText( uValue ) + ;
hb_OSNewLine()
ENDCASE
endif
ENDIF
next
NEXT
cObject += hb_OSNewLine() + Space( nIndent ) + "ENDOBJECT" + hb_OSNewLine()
return cObject
RETURN cObject
static function ArrayToText( aArray, cName, nIndent )
STATIC FUNCTION ArrayToText( aArray, cName, nIndent )
local cArray := hb_OSNewLine() + Space( nIndent ) + "ARRAY ::" + cName + ;
LOCAL cArray := hb_OSNewLine() + Space( nIndent ) + "ARRAY ::" + cName + ;
" LEN " + AllTrim( Str( Len( aArray ) ) ) + hb_OSNewLine()
local n, uValue, cType
LOCAL n
LOCAL uValue
LOCAL cType
for n := 1 to Len( aArray )
FOR n := 1 TO Len( aArray )
uValue := aArray[ n ]
cType := ValType( uValue )
do case
case cType == "A"
nIndent += 3
cArray += ArrayToText( uValue, cName + "[ " + ;
AllTrim( Str( n ) ) + " ]", nIndent ) + hb_OSNewLine()
nIndent -= 3
DO CASE
CASE cType == "A"
nIndent += 3
cArray += ArrayToText( uValue, cName + "[ " + ;
AllTrim( Str( n ) ) + " ]", nIndent ) + hb_OSNewLine()
nIndent -= 3
case cType == "O"
if __objDerivedFrom( uValue, "HBPERSISTENT" )
cArray += uValue:SaveToText( cName + "[ " + AllTrim( Str( n ) ) + ;
" ]", nIndent )
endif
CASE cType == "O"
IF __objDerivedFrom( uValue, "HBPERSISTENT" )
cArray += uValue:SaveToText( cName + "[ " + AllTrim( Str( n ) ) + ;
" ]", nIndent )
ENDIF
otherwise
if n == 1
cArray += hb_OSNewLine()
endif
cArray += Space( nIndent ) + " ::" + cName + ;
+ "[ " + AllTrim( Str( n ) ) + " ]" + " = " + ;
ValToText( uValue ) + hb_OSNewLine()
endcase
next
OTHERWISE
IF n == 1
cArray += hb_OSNewLine()
ENDIF
cArray += Space( nIndent ) + " ::" + cName + ;
+ "[ " + AllTrim( Str( n ) ) + " ]" + " = " + ;
ValToText( uValue ) + hb_OSNewLine()
ENDCASE
NEXT
cArray += hb_OSNewLine() + Space( nIndent ) + "ENDARRAY" + hb_OSNewLine()
return cArray
RETURN cArray
static function ValToText( uValue )
STATIC FUNCTION ValToText( uValue )
local cType := ValType( uValue )
local cText
LOCAL cType := ValType( uValue )
LOCAL cText
do case
case cType == "C"
cText := hb_StrToExp( uValue )
DO CASE
CASE cType == "C"
cText := hb_StrToExp( uValue )
case cType == "N"
cText := AllTrim( Str( uValue ) )
CASE cType == "N"
cText := AllTrim( Str( uValue ) )
case cType == "D"
cText := DToS( uValue )
cText := "0d" + iif( Empty( cText ), "00000000", cText )
CASE cType == "D"
cText := DToS( uValue )
cText := "0d" + iif( Empty( cText ), "00000000", cText )
otherwise
cText := hb_ValToStr( uValue )
endcase
OTHERWISE
cText := hb_ValToStr( uValue )
ENDCASE
return cText
RETURN cText
// Notice: nFrom must be supplied by reference
static function ExtractLine( cText, nFrom )
STATIC FUNCTION ExtractLine( cText, nFrom )
local nAt := hb_At( Chr( 10 ), cText, nFrom )
LOCAL nAt := hb_At( Chr( 10 ), cText, nFrom )
if nAt > 0
IF nAt > 0
cText := SubStr( cText, nFrom, nAt - nFrom )
if Right( cText, 1 ) == Chr( 13 )
IF Right( cText, 1 ) == Chr( 13 )
cText := hb_StrShrink( cText, 1 )
endif
ENDIF
nFrom := nAt + 1
else
ELSE
cText := SubStr( cText, nFrom )
if Right( cText, 1 ) == Chr( 13 )
IF Right( cText, 1 ) == Chr( 13 )
cText := hb_StrShrink( cText, 1 )
endif
ENDIF
nFrom += Len( cText ) + 1
endif
ENDIF
return cText
RETURN cText

620
harbour/source/rtl/profiler.prg
View File

@@ -55,9 +55,7 @@
* There are three aspects to profiling:
*
* 1) Gathering profile information.
*
* 2) Taking a snapshot of an application's profile information.
*
* 3) Reporting on the data gathered in the snapshot.
*
* Point 1 is handled in harbour's virtual machine. This source aims to
@@ -79,7 +77,7 @@
* Heisenberg effect. In other words, we don't want the profiler showing up
* in the profiler.
*
* Many of the "Protected:" scope specifiers in the source have been
* Many of the "PROTECTED:" scope specifiers in the source have been
* commented out where there's a problem with scope in harbour's class
* system. Note that those comments will be removed when the bug is fixed.
*
@@ -106,9 +104,9 @@
#include "inkey.ch"
Procedure Main()
Local oProfile := HBProfile():new()
Local n
PROCEDURE Main()
LOCAL oProfile := HBProfile():new()
LOCAL n
// Turn on profiling.
__setProfiler( .T. )
@@ -118,9 +116,9 @@ Local n
DoNothingForTwoSeconds()
// Make sure we've got something to see callwise.
For n := 1 To 500
FOR n := 1 TO 500
CallMe500Times()
Next
NEXT
// Take a profile snapshot.
oProfile:gather()
@@ -143,297 +141,272 @@ Local n
// Some closing stats
DrawScreen( "Totals" )
@ 2, 0 Say " Total Calls: " + str( oProfile:totalCalls() )
@ 3, 0 Say " Total Ticks: " + str( oProfile:totalTicks() )
@ 4, 0 Say "Total Seconds: " + str( oProfile:totalSeconds() )
@ 2, 0 Say " Total Calls: " + Str( oProfile:totalCalls() )
@ 3, 0 Say " Total Ticks: " + Str( oProfile:totalTicks() )
@ 4, 0 Say "Total Seconds: " + Str( oProfile:totalSeconds() )
Return
RETURN
Static Procedure DrawScreen( cTitle )
STATIC PROCEDURE DrawScreen( cTitle )
Scroll()
@ 0, 0 SAY PadR( cTitle, MaxCol() + 1 ) COLOR "N/W"
Return
RETURN
Procedure DoNothingForTwoSeconds()
PROCEDURE DoNothingForTwoSeconds()
Inkey( 2 )
Return
RETURN
Procedure CallMe500Times()
Return
PROCEDURE CallMe500Times()
RETURN
Static Procedure Browser( oBrowse )
Local lBrowsing := .T.
Local nKey
STATIC PROCEDURE Browser( oBrowse )
LOCAL lBrowsing := .T.
LOCAL nKey
Do While lBrowsing
DO WHILE lBrowsing
oBrowse:forceStable()
nKey := Inkey( 0 )
Do Case
DO CASE
CASE nKey == K_ESC
lBrowsing := .F.
CASE nKey == K_DOWN
oBrowse:down()
CASE nKey == K_UP
oBrowse:up()
CASE nKey == K_LEFT
oBrowse:left()
CASE nKey == K_RIGHT
oBrowse:right()
CASE nKey == K_PGDN
oBrowse:pageDown()
CASE nKey == K_PGUP
oBrowse:pageUp()
Case nKey == K_ESC
lBrowsing := .F.
// And so on.... (not really necessary for this test)
Case nKey == K_DOWN
oBrowse:down()
ENDCASE
Case nKey == K_UP
oBrowse:up()
ENDDO
Case nKey == K_LEFT
oBrowse:left()
Case nKey == K_RIGHT
oBrowse:right()
Case nKey == K_PGDN
oBrowse:pageDown()
Case nKey == K_PGUP
oBrowse:pageUp()
// And so on.... (not really necessary for this test)
EndCase
EndDo
Return
RETURN
#endif
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileEntity
Create Class HBProfileEntity
CREATE CLASS HBProfileEntity
Exported:
EXPORTED:
Var cName ReadOnly
Var nCalls ReadOnly
Var nTicks ReadOnly
VAR cName ReadOnly
VAR nCalls ReadOnly
VAR nTicks ReadOnly
Access nSeconds
Access nMeanTicks
Access nMeanSeconds
ACCESS nSeconds
ACCESS nMeanTicks
ACCESS nMeanSeconds
Method init
Method describe
METHOD init
METHOD describe
Endclass
ENDCLASS
/////
Method init( cName, aInfo ) Class HBProfileEntity
METHOD init( cName, aInfo ) CLASS HBProfileEntity
::cName := cName
::nCalls := aInfo[ 1 ]
::nTicks := aInfo[ 2 ]
Return Self
RETURN Self
/////
ACCESS nSeconds CLASS HBProfileEntity
RETURN HB_Clocks2Secs( ::nTicks )
Access nSeconds Class HBProfileEntity
Return HB_Clocks2Secs( ::nTicks )
ACCESS nMeanTicks CLASS HBProfileEntity
RETURN iif( ::nCalls == 0, 0, ::nTicks / ::nCalls )
/////
ACCESS nMeanSeconds CLASS HBProfileEntity
RETURN iif( ::nCalls == 0, 0, ::nSeconds / ::nCalls )
Access nMeanTicks Class HBProfileEntity
Return iif( ::nCalls == 0, 0, ::nTicks / ::nCalls )
/////
Access nMeanSeconds Class HBProfileEntity
Return iif( ::nCalls == 0, 0, ::nSeconds / ::nCalls )
/////
Method describe Class HBProfileEntity
Return "Base Entity"
METHOD describe CLASS HBProfileEntity
RETURN "Base Entity"
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileFunction
Create Class HBProfileFunction Inherit HBProfileEntity
CREATE CLASS HBProfileFunction INHERIT HBProfileEntity
Exported:
EXPORTED:
Method describe
METHOD describe
Endclass
ENDCLASS
/////
Method describe Class HBProfileFunction
Return "Function"
METHOD describe CLASS HBProfileFunction
RETURN "Function"
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileMethod
Create Class HBProfileMethod Inherit HBProfileEntity
CREATE CLASS HBProfileMethod INHERIT HBProfileEntity
Exported:
EXPORTED:
Method describe
METHOD describe
Endclass
ENDCLASS
/////
Method describe Class HBProfileMethod
Return "Method"
METHOD describe CLASS HBProfileMethod
RETURN "Method"
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileOPCode
Create Class HBProfileOPCode Inherit HBProfileEntity
CREATE CLASS HBProfileOPCode INHERIT HBProfileEntity
Exported:
EXPORTED:
Method describe
METHOD describe
Endclass
ENDCLASS
/////
Method describe Class HBProfileOPCode
Return "OPCode"
METHOD describe CLASS HBProfileOPCode
RETURN "OPCode"
////////////////////////////////////////////////////////////////////////////
// Class: HBProfile
Create Class HBProfile
CREATE CLASS HBProfile
Exported:
EXPORTED:
Var aProfile
VAR aProfile
Method init
Method gather
Method forEach
Method sort
Method nameSort
Method callSort
Method timeSort
Method totalCalls
Method totalTicks
Method totalSeconds
METHOD init
METHOD gather
METHOD forEach
METHOD sort
METHOD nameSort
METHOD callSort
METHOD timeSort
METHOD totalCalls
METHOD totalTicks
METHOD totalSeconds
Protected:
PROTECTED:
Method gatherFunctions
Method gatherMethods
Method reset
Method ignoreSymbol
METHOD gatherFunctions
METHOD gatherMethods
METHOD reset
METHOD ignoreSymbol
Endclass
ENDCLASS
/////
Method init Class HBProfile
Local lProfile := __setProfiler( .F. )
METHOD init CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
::reset()
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method reset Class HBProfile
METHOD reset CLASS HBProfile
::aProfile := {}
Return Self
RETURN Self
/////
METHOD ignoreSymbol( cSymbol ) CLASS HBProfile
LOCAL cProfPrefix := "HBPROFILE"
RETURN Left( cSymbol, Len( cProfPrefix ) ) == cProfPrefix .OR. cSymbol == "__SETPROFILER"
Method ignoreSymbol( cSymbol ) Class HBProfile
Local cProfPrefix := "HBPROFILE"
Return Left( cSymbol, Len( cProfPrefix ) ) == cProfPrefix .Or. cSymbol == "__SETPROFILER"
/////
Method gatherFunctions Class HBProfile
Local lProfile := __setProfiler( .F. )
Local nSymCount := __DynSCount()
Local cName
Local n
METHOD gatherFunctions CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
LOCAL nSymCount := __DynSCount()
LOCAL cName
LOCAL n
// For each known symbol.
// TODO: Question: Will the symbol count have changed because
// we've created variables?
For n := 1 To nSymCount
FOR n := 1 TO nSymCount
// Is the symbol a function?
If __DynSIsFun( n )
IF __DynSIsFun( n )
// If we're not ignoring the symbol...
If !::ignoreSymbol( cName := __DynSGetName( n ) )
IF !::ignoreSymbol( cName := __DynSGetName( n ) )
// Yes, it is, add it to the profile.
AAdd( ::aProfile, HBProfileFunction():new( cName, __DynSGetPrf( n ) ) )
EndIf
ENDIF
EndIf
ENDIF
Next
NEXT
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method gatherMethods Class HBProfile
Local lProfile := __setProfiler( .F. )
Local n := 1
Local cClass
Local nMembers
Local aMembers
Local nMember
METHOD gatherMethods CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
LOCAL n := 1
LOCAL cClass
LOCAL nMembers
LOCAL aMembers
LOCAL nMember
// For each class in the environment...
Do While !Empty( cClass := __className( n ) )
DO WHILE !Empty( cClass := __className( n ) )
// If we're not ignoring the class' methods...
If !::ignoreSymbol( cClass )
IF !::ignoreSymbol( cClass )
// Collect class members.
nMembers := Len( aMembers := __classSel( n ) )
For nMember := 1 To nMembers
FOR nMember := 1 TO nMembers
// If we've got a member name...
If !empty( aMembers[ nMember ] )
IF !empty( aMembers[ nMember ] )
// Add it to the profile.
AAdd( ::aProfile, HBProfileMethod():new( cClass + ":" + aMembers[ nMember ], __GetMsgPrf( n, aMembers[ nMember ] ) ) )
EndIf
ENDIF
Next
NEXT
EndIf
ENDIF
++n
EndDo
ENDDO
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method gather Class HBProfile
Local lProfile := __setProfiler( .F. )
METHOD gather CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
// Reset the profile.
::reset()
@@ -446,118 +419,102 @@ Local lProfile := __setProfiler( .F. )
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method forEach( b ) Class HBProfile
Local lProfile := __setProfiler( .F. )
METHOD forEach( b ) CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
AEval( ::aProfile, b )
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method sort( b ) Class HBProfile
Local lProfile := __setProfiler( .F. )
METHOD sort( b ) CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
ASort( ::aProfile,,, b )
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method nameSort Class HBProfile
Local lProfile := __setProfiler( .F. )
METHOD nameSort CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
::sort( {| oX, oY | oX:cName < oY:cName } )
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method callSort Class HBProfile
Local lProfile := __setProfiler( .F. )
METHOD callSort CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
::sort( {| oX, oY | oX:nCalls > oY:nCalls } )
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method timeSort Class HBProfile
Local lProfile := __setProfiler( .F. )
METHOD timeSort CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
::sort( {| oX, oY | oX:nTicks > oY:nTicks } )
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method totalCalls Class HBProfile
Local lProfile := __setProfiler( .F. )
Local nCalls := 0
METHOD totalCalls CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
LOCAL nCalls := 0
::forEach( {| o | nCalls += o:nCalls } )
__setProfiler( lProfile )
Return nCalls
RETURN nCalls
/////
Method totalTicks Class HBProfile
Local lProfile := __setProfiler( .F. )
Local nTicks := 0
METHOD totalTicks CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
LOCAL nTicks := 0
::forEach( {| o | nTicks += o:nTicks } )
__setProfiler( lProfile )
Return nTicks
RETURN nTicks
/////
Method totalSeconds Class HBProfile
Local lProfile := __setProfiler( .F. )
Local nSeconds := 0
METHOD totalSeconds CLASS HBProfile
LOCAL lProfile := __setProfiler( .F. )
LOCAL nSeconds := 0
::forEach( {| o | nSeconds += o:nSeconds } )
__setProfiler( lProfile )
Return nSeconds
RETURN nSeconds
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileLowLevel
Create Class HBProfileLowLevel Inherit HBProfile
CREATE CLASS HBProfileLowLevel INHERIT HBProfile
Exported:
EXPORTED:
Method gather
METHOD gather
Protected:
PROTECTED:
Method gatherOPCodes
METHOD gatherOPCodes
Endclass
ENDCLASS
/////
Method gather Class HBProfileLowLevel
Local lProfile := __setProfiler( .F. )
METHOD gather CLASS HBProfileLowLevel
LOCAL lProfile := __setProfiler( .F. )
// Gather functions and methods.
::super:gather()
@@ -567,253 +524,230 @@ Local lProfile := __setProfiler( .F. )
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method gatherOPCodes Class HBProfileLowLevel
Local nMax := __opcount()
Local cName
Local nOP
METHOD gatherOPCodes CLASS HBProfileLowLevel
LOCAL nMax := __opcount()
LOCAL cName
LOCAL nOP
// Loop over all the harbour OP codes. Note that they start at 0.
For nOP := 0 To ( nMax - 1 )
FOR nOP := 0 TO ( nMax - 1 )
// If we're not ignoring this opcode.
If !::ignoreSymbol( cName := "OPCODE( " + PadL( nOP, 3 ) + " )" )
IF !::ignoreSymbol( cName := "OPCODE( " + PadL( nOP, 3 ) + " )" )
// Add it to the profile.
AAdd( ::aProfile, HBProfileOPCode():new( cName, __OpGetPrf( nOP ) ) )
EndIf
Next
ENDIF
NEXT
Return Self
RETURN Self
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReport
Create Class HBProfileReport
CREATE CLASS HBProfileReport
Protected:
PROTECTED:
Var oProfile
VAR oProfile
Method writeLines
Method header
Method emitHeader
Method line
Method emitLine
METHOD writeLines
METHOD header
METHOD emitHeader
METHOD line
METHOD emitLine
Exported:
EXPORTED:
Method init
Method generate
METHOD init
METHOD generate
Endclass
ENDCLASS
/////
Method init( oProfile ) Class HBProfileReport
Local lProfile := __setProfiler( .F. )
METHOD init( oProfile ) CLASS HBProfileReport
LOCAL lProfile := __setProfiler( .F. )
::oProfile := oProfile
__setProfiler( lProfile )
Return Self
RETURN Self
/////
Method writeLines( aLines ) Class HBProfileReport
METHOD writeLines( aLines ) CLASS HBProfileReport
AEval( aLines, {| c | QOut( c ) } )
Return Self
RETURN Self
/////
METHOD header CLASS HBProfileReport
RETURN { "Name Type Calls Ticks Seconds",;
"=================================== ========== ======== =========== ===========" }
Method header Class HBProfileReport
Return { "Name Type Calls Ticks Seconds",;
"=================================== ========== ======== =========== ===========" }
/////
Method emitHeader Class HBProfileReport
METHOD emitHeader CLASS HBProfileReport
::writeLines( ::header() )
Return Self
RETURN Self
/////
METHOD line( oEntity ) CLASS HBProfileReport
RETURN { PadR( oEntity:cName, 35 ) + " " + ;
PadR( oEntity:describe(), 8 ) + " " + ;
PadL( oEntity:nCalls, 10 ) + " " + ;
PadL( oEntity:nTicks, 11 ) + " " + ;
Str( oEntity:nSeconds, 11, 2 ) }
Method line( oEntity ) Class HBProfileReport
Return { PadR( oEntity:cName, 35 ) + " " + ;
PadR( oEntity:describe(), 8 ) + " " + ;
PadL( oEntity:nCalls, 10 ) + " " + ;
PadL( oEntity:nTicks, 11 ) + " " + ;
Str( oEntity:nSeconds, 11, 2 ) }
/////
Method emitLine( oEntity ) Class HBProfileReport
METHOD emitLine( oEntity ) CLASS HBProfileReport
::writeLines( ::line( oEntity ) )
Return Self
RETURN Self
/////
METHOD generate( bFilter ) CLASS HBProfileReport
LOCAL lProfile := __setProfiler( .F. )
Method generate( bFilter ) Class HBProfileReport
Local lProfile := __setProfiler( .F. )
Default bFilter To {|| .T. }
DEFAULT bFilter TO {|| .T. }
::emitHeader():oProfile:forEach( {| o | iif( Eval( bFilter, o ), ::emitLine( o ), NIL ) } )
__setProfiler( lProfile )
Return Self
RETURN Self
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReportToFile
Create Class HBProfileReportToFile Inherit HBProfileReport
CREATE CLASS HBProfileReportToFile INHERIT HBProfileReport
Protected:
PROTECTED:
Var hFile
VAR hFile
Method writeLines
METHOD writeLines
Exported:
EXPORTED:
Method generate
METHOD generate
Endclass
ENDCLASS
/////
Method writeLines( aLines ) Class HBProfileReportToFile
METHOD writeLines( aLines ) CLASS HBProfileReportToFile
If ::hFile != F_ERROR
IF ::hFile != F_ERROR
AEval( aLines, {| c | FWrite( ::hFile, c + HB_OSNewLine() ) } )
EndIf
ENDIF
Return Self
RETURN Self
/////
METHOD generate( bFilter, cFile ) CLASS HBProfileReportToFile
LOCAL lProfile := __setProfiler( .F. )
Method generate( bFilter, cFile ) Class HBProfileReportToFile
Local lProfile := __setProfiler( .F. )
DEFAULT cFile TO "hbprof.txt"
Default cFile To "hbprof.txt"
If ( ::hFile := fcreate( cFile ) ) != F_ERROR
IF ( ::hFile := fcreate( cFile ) ) != F_ERROR
::super:generate( bFilter )
fclose( ::hFile )
Else
ELSE
// TODO: Throw an error
EndIf
ENDIF
__setProfiler( lProfile )
Return Self
RETURN Self
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReportToArray
Create Class HBProfileReportToArray Inherit HBProfileReport
CREATE CLASS HBProfileReportToArray INHERIT HBProfileReport
Protected:
PROTECTED:
Var aReport
VAR aReport
Method writeLines
METHOD writeLines
Exported:
EXPORTED:
Method generate
METHOD generate
Endclass
ENDCLASS
/////
Method writeLines( aLines ) Class HBProfileReportToArray
METHOD writeLines( aLines ) CLASS HBProfileReportToArray
AEval( aLines, {| c | AAdd( ::aReport, c ) } )
Return Self
RETURN Self
/////
Method generate( bFilter ) Class HBProfileReportToArray
METHOD generate( bFilter ) CLASS HBProfileReportToArray
::aReport := {}
::super:generate( bFilter )
Return ::aReport
RETURN ::aReport
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReportToString
Create Class HBProfileReportToString Inherit HBProfileReportToArray
CREATE CLASS HBProfileReportToString INHERIT HBProfileReportToArray
Exported:
EXPORTED:
Method generate
METHOD generate
Endclass
ENDCLASS
/////
Method generate( bFilter ) Class HBProfileReportToString
Local cReport := ""
METHOD generate( bFilter ) CLASS HBProfileReportToString
LOCAL cReport := ""
AEval( ::super:generate( bFilter ), {| c | cReport += c + HB_OSNewLine() } )
Return cReport
RETURN cReport
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReportToTBrowse
CREATE CLASS HBProfileReportToTBrowse INHERIT HBProfileReportToArray
Create Class HBProfileReportToTBrowse Inherit HBProfileReportToArray
PROTECTED:
Protected:
VAR nEntity
Var nEntity
METHOD emitHeader
METHOD emitLine
METHOD addColumns
Method emitHeader
Method emitLine
Method addColumns
EXPORTED:
Exported:
METHOD generate
METHOD currentEntity
Method generate
Method currentEntity
Endclass
ENDCLASS
/////
Method emitHeader Class HBProfileReportToTBrowse
METHOD emitHeader CLASS HBProfileReportToTBrowse
// No header required.
Return Self
RETURN Self
/////
Method emitLine( oEntity ) Class HBProfileReportToTBrowse
METHOD emitLine( oEntity ) CLASS HBProfileReportToTBrowse
// Don't "emit" anything, simply add the entity to the array.
AAdd( ::aReport, oEntity )
Return Self
RETURN Self
/////
Method generate( bFilter, nTop, nLeft, nBottom, nRight ) Class HBProfileReportToTBrowse
Local lProfile := __setProfiler( .F. )
Local oBrowse
METHOD generate( bFilter, nTop, nLeft, nBottom, nRight ) CLASS HBProfileReportToTBrowse
LOCAL lProfile := __setProfiler( .F. )
LOCAL oBrowse
// Start with the first entity.
::nEntity := 1
@@ -835,11 +769,9 @@ Local oBrowse
__setProfiler( lProfile )
Return oBrowse
RETURN oBrowse
/////
Method addColumns( oBrowse ) Class HBProfileReportToTBrowse
METHOD addColumns( oBrowse ) CLASS HBProfileReportToTBrowse
oBrowse:addColumn( TBColumnNew( "Name", {|| PadR( ::currentEntity():cName, 35 ) } ) )
oBrowse:addColumn( TBColumnNew( "Type", {|| PadR( ::currentEntity():describe(), 8 ) } ) )
@@ -849,13 +781,7 @@ Method addColumns( oBrowse ) Class HBProfileReportToTBrowse
oBrowse:addColumn( TBColumnNew( "Mean;Ticks", {|| Str( ::currentEntity():nMeanTicks, 11, 2 ) } ) )
oBrowse:addColumn( TBColumnNew( "Mean;Seconds", {|| Str( ::currentEntity():nMeanSeconds, 11, 2 ) } ) )
Return Self
RETURN Self
/////
Method currentEntity Class HBProfileReportToTBrowse
Return ::aReport[ ::nEntity ]
/*
* profiler.prg ends here.
*/
METHOD currentEntity CLASS HBProfileReportToTBrowse
RETURN ::aReport[ ::nEntity ]

2
harbour/source/rtl/readvar.prg
View File

@@ -68,4 +68,4 @@ FUNCTION ReadVar( cVarName )
s_cVarName := cVarName
ENDIF
RETURN cOldVarName
RETURN cOldVarName

2
harbour/source/rtl/setfunc.prg
View File

@@ -77,4 +77,4 @@ PROCEDURE __SetFunction( nFunctionKey, xKeySeq )
SetKey( nFunctionKey, NIL )
ENDIF
RETURN
RETURN

1
harbour/source/rtl/setta.prg
View File

@@ -56,4 +56,3 @@ FUNCTION SetTypeahead( nSize )
RETURN Set( _SET_TYPEAHEAD, nSize )
#endif

37
harbour/source/rtl/tclass.prg
View File

@@ -71,7 +71,7 @@
*
*/
// Harbour Class HBClass to build classes
/* Harbour Class HBClass to build classes */
#include "common.ch"
#include "hboo.ch"
@@ -144,8 +144,6 @@ FUNCTION HBClass()
RETURN __clsInst( s_hClass )
//----------------------------------------------------------------------------//
// xSuper is used here as the new preprocessor file (hbclass.ch) send here
// always an array (if no superclass, this will be an empty one)
// In case of direct class creation (without the help of preprocessor) xSuper can be
@@ -194,9 +192,7 @@ STATIC FUNCTION New( cClassName, xSuper, sClassFunc, lModuleFriendly )
RETURN QSelf()
//----------------------------------------------------------------------------//
/* STATIC PROCEDURE Create(MetaClass) */
/* STATIC PROCEDURE Create( MetaClass ) */
STATIC PROCEDURE Create()
LOCAL Self := QSelf()
@@ -292,8 +288,6 @@ STATIC PROCEDURE Create()
RETURN
//----------------------------------------------------------------------------//
STATIC FUNCTION Instance()
LOCAL Self := QSelf()
LOCAL oInstance := __clsInst( ::hClass )
@@ -302,8 +296,6 @@ STATIC FUNCTION Instance()
RETURN oInstance
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddData( cData, xInit, cType, nScope, lNoinit )
LOCAL c
@@ -327,8 +319,6 @@ STATIC PROCEDURE AddData( cData, xInit, cType, nScope, lNoinit )
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddMultiData( cType, xInit, nScope, aData, lNoInit )
LOCAL i
@@ -342,8 +332,6 @@ STATIC PROCEDURE AddMultiData( cType, xInit, nScope, aData, lNoInit )
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddClassData( cData, xInit, cType, nScope, lNoInit )
LOCAL c
@@ -366,8 +354,6 @@ STATIC PROCEDURE AddClassData( cData, xInit, cType, nScope, lNoInit )
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddMultiClsData( cType, xInit, nScope, aData, lNoInit )
LOCAL i
@@ -381,8 +367,6 @@ STATIC PROCEDURE AddMultiClsData( cType, xInit, nScope, aData, lNoInit )
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddInline( cMethod, bCode, nScope )
DEFAULT nScope TO HB_OO_CLSTP_EXPORTED
@@ -391,8 +375,6 @@ STATIC PROCEDURE AddInline( cMethod, bCode, nScope )
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddMethod( cMethod, nFuncPtr, nScope )
DEFAULT nScope TO HB_OO_CLSTP_EXPORTED
@@ -401,16 +383,12 @@ STATIC PROCEDURE AddMethod( cMethod, nFuncPtr, nScope )
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddClsMethod( cMethod, nFuncPtr, nScope )
AAdd( QSelf():aClsMethods, { cMethod, nFuncPtr, nScope } )
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddVirtual( cMethod )
AAdd( QSelf():aVirtuals, cMethod )
@@ -431,8 +409,6 @@ STATIC PROCEDURE AddDelegate( xMethod, nAccScope, nAsgScope, cType, cDelegMsg, c
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddFriendClass( ... )
LOCAL Self := QSelf()
@@ -441,8 +417,6 @@ STATIC PROCEDURE AddFriendClass( ... )
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE AddFriendFunc( ... )
LOCAL Self := QSelf()
@@ -451,8 +425,6 @@ STATIC PROCEDURE AddFriendFunc( ... )
RETURN
//----------------------------------------------------------------------------//
STATIC PROCEDURE SetOnError( nFuncPtr )
QSelf():nOnError := nFuncPtr
@@ -465,10 +437,5 @@ STATIC PROCEDURE SetDestructor( nFuncPtr )
RETURN
//----------------------------------------------------------------------------//
STATIC FUNCTION InitClass()
RETURN QSelf()
//----------------------------------------------------------------------------//

4
harbour/source/rtl/tgetint.prg
View File

@@ -62,13 +62,9 @@
REQUEST HB_PVALUE
REQUEST PCOUNT
//---------------------------------------------------------------------------//
FUNCTION GetNew( nRow, nCol, bVarBlock, cVarName, cPicture, cColor )
RETURN Get():New( nRow, nCol, bVarBlock, cVarName, cPicture, cColor )
//---------------------------------------------------------------------------//
FUNCTION __GET( bSetGet, cVarName, cPicture, bValid, bWhen )
LOCAL oGet

88
harbour/source/rtl/tlabel.prg
View File

@@ -173,11 +173,11 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
// Add to the left margin if a SET MARGIN has been defined
::aLabelData[ LBL_LMARGIN ] := ::aLabelData[ LBL_LMARGIN ] + OldMargin
ASIZE( ::aBandToPrint, LEN( ::aLabelData[ LBL_FIELDS ]))
AFILL( ::aBandToPrint, SPACE( ::aLabelData[ LBL_LMARGIN ] ) )
ASize( ::aBandToPrint, Len( ::aLabelData[ LBL_FIELDS ]))
AFill( ::aBandToPrint, Space( ::aLabelData[ LBL_LMARGIN ] ) )
// Create enough space for a blank record
::cBlank := SPACE( ::aLabelData[ LBL_WIDTH ] + ::aLabelData[ LBL_SPACES ] )
::cBlank := Space( ::aLabelData[ LBL_WIDTH ] + ::aLabelData[ LBL_SPACES ] )
// Handle sample labels
IF lSample
@@ -228,7 +228,7 @@ METHOD ExecuteLabel() CLASS HBLabelForm
LOCAL v
// Load the current record into aBuffer
FOR nField := 1 TO LEN( ::aLabelData[ LBL_FIELDS ] )
FOR nField := 1 TO Len( ::aLabelData[ LBL_FIELDS ] )
if ::aLabelData[ LBL_FIELDS, nField ] != NIL
@@ -239,24 +239,24 @@ METHOD ExecuteLabel() CLASS HBLabelForm
if ( ::aLabelData[ LBL_FIELDS, nField, LF_BLANK ] )
if ( !Empty( cBuffer ) )
AADD( aBuffer, cBuffer )
AAdd( aBuffer, cBuffer )
endif
else
AADD( aBuffer, cBuffer )
AAdd( aBuffer, cBuffer )
endif
else
AADD( aBuffer, NIL )
AAdd( aBuffer, NIL )
endif
NEXT
ASIZE( aBuffer, LEN( ::aLabelData[ LBL_FIELDS ] ) )
ASize( aBuffer, Len( ::aLabelData[ LBL_FIELDS ] ) )
// Add aBuffer to ::aBandToPrint
FOR nField := 1 TO LEN( ::aLabelData[ LBL_FIELDS ] )
FOR nField := 1 TO Len( ::aLabelData[ LBL_FIELDS ] )
IF aBuffer[ nField ] == NIL
::aBandToPrint[ nField ] := ::aBandToPrint[ nField ] + ::cBlank
ELSE
@@ -267,7 +267,7 @@ METHOD ExecuteLabel() CLASS HBLabelForm
IF ::nCurrentCol == ::aLabelData[ LBL_ACROSS ]
// trim
FOR nField := 1 TO LEN( ::aBandToPrint )
FOR nField := 1 TO Len( ::aBandToPrint )
::aBandToPrint[ nField ] := Trim( ::aBandToPrint[ nField ] )
NEXT
@@ -278,7 +278,7 @@ METHOD ExecuteLabel() CLASS HBLabelForm
// Print the band
AEVAL( ::aBandToPrint, { | BandLine | PrintIt( BandLine ) } )
nMoreLines := ::aLabelData[ LBL_HEIGHT ] - LEN( ::aBandToPrint )
nMoreLines := ::aLabelData[ LBL_HEIGHT ] - Len( ::aBandToPrint )
IF nMoreLines > 0
FOR nField := 1 TO nMoreLines
PrintIt()
@@ -294,7 +294,7 @@ METHOD ExecuteLabel() CLASS HBLabelForm
ENDIF
// Clear out the band
AFILL( ::aBandToPrint, SPACE( ::aLabelData[ LBL_LMARGIN ] ) )
AFill( ::aBandToPrint, Space( ::aLabelData[ LBL_LMARGIN ] ) )
ELSE
::lOneMoreBand := .T.
::nCurrentCol := ::nCurrentCol + 1
@@ -307,11 +307,11 @@ METHOD SampleLabels() CLASS HBLabelForm
LOCAL aBand := {}
// Create the sample label row
ASIZE( aBand, ::aLabelData[ LBL_HEIGHT ] )
AFILL( aBand, SPACE( ::aLabelData[ LBL_LMARGIN ] ) +;
REPLICATE( REPLICATE( "*", ;
ASize( aBand, ::aLabelData[ LBL_HEIGHT ] )
AFill( aBand, Space( ::aLabelData[ LBL_LMARGIN ] ) +;
Replicate( Replicate( "*", ;
::aLabelData[ LBL_WIDTH ] ) + ;
SPACE( ::aLabelData[ LBL_SPACES ] ), ;
Space( ::aLabelData[ LBL_SPACES ] ), ;
::aLabelData[ LBL_ACROSS ] ) )
// Prints sample labels
@@ -329,7 +329,7 @@ METHOD SampleLabels() CLASS HBLabelForm
// Prompt for more
@ ROW(), 0 SAY __NatMsg(_LF_SAMPLES)+" ("+__NatMsg(_LF_YN)+")"
nGetKey := INKEY(0)
nGetKey := Inkey( 0 )
@ ROW(), COL() SAY CHR(nGetKey)
IF ROW() == MAXROW()
SCROLL( 0, 0, MAXROW(), MAXCOL(), 1 )
@@ -346,7 +346,7 @@ METHOD SampleLabels() CLASS HBLabelForm
METHOD LoadLabel( cLblFile ) CLASS HBLabelForm
LOCAL i, j := 0 // Counters
LOCAL cBuff := SPACE(BUFFSIZE) // File buffer
LOCAL cBuff := Space(BUFFSIZE) // File buffer
LOCAL nHandle := 0 // File handle
LOCAL nReadCount := 0 // Bytes read from file
LOCAL lStatus := .F. // Status
@@ -361,7 +361,7 @@ METHOD LoadLabel( cLblFile ) CLASS HBLabelForm
// Create and initialize default label array
LOCAL aLabel[ LBL_COUNT ]
aLabel[ LBL_REMARK ] := SPACE(60) // Label remark
aLabel[ LBL_REMARK ] := Space( 60 ) // Label remark
aLabel[ LBL_HEIGHT ] := 5 // Label height
aLabel[ LBL_WIDTH ] := 35 // Label width
aLabel[ LBL_LMARGIN ] := 0 // Left margin
@@ -373,17 +373,17 @@ METHOD LoadLabel( cLblFile ) CLASS HBLabelForm
// Open the label file
nHandle := FOPEN( cLblFile )
IF ! EMPTY( nFileError := FERROR() ) .AND. !( "\" $ cLblFile .OR. ":" $ cLblFile )
IF ! Empty( nFileError := FERROR() ) .AND. !( "\" $ cLblFile .OR. ":" $ cLblFile )
// Search through default path; attempt to open label file
cDefPath := SET( _SET_DEFAULT )
cDefPath := STRTRAN( cDefPath, ",", ";" )
aPaths := ListAsArray( cDefPath, ";" )
FOR nPathIndex := 1 TO LEN( aPaths )
FOR nPathIndex := 1 TO Len( aPaths )
nHandle := FOPEN( aPaths[ nPathIndex ] + "\" + cLblFile )
// if no error is reported, we have our label file
IF EMPTY( nFileError := FERROR() )
IF Empty( nFileError := FERROR() )
EXIT
ENDIF
@@ -417,36 +417,36 @@ METHOD LoadLabel( cLblFile ) CLASS HBLabelForm
IF nFileError == 0
// Load label dimension into aLabel
aLabel[ LBL_REMARK ] := SUBSTR(cBuff, REMARKOFFSET, REMARKSIZE)
aLabel[ LBL_HEIGHT ] := BIN2W(SUBSTR(cBuff, HEIGHTOFFSET, HEIGHTSIZE))
aLabel[ LBL_WIDTH ] := BIN2W(SUBSTR(cBuff, WIDTHOFFSET, WIDTHSIZE))
aLabel[ LBL_LMARGIN] := BIN2W(SUBSTR(cBuff, LMARGINOFFSET, LMARGINSIZE))
aLabel[ LBL_LINES ] := BIN2W(SUBSTR(cBuff, LINESOFFSET, LINESSIZE))
aLabel[ LBL_SPACES ] := BIN2W(SUBSTR(cBuff, SPACESOFFSET, SPACESSIZE))
aLabel[ LBL_ACROSS ] := BIN2W(SUBSTR(cBuff, ACROSSOFFSET, ACROSSSIZE))
aLabel[ LBL_REMARK ] := SubStr(cBuff, REMARKOFFSET, REMARKSIZE)
aLabel[ LBL_HEIGHT ] := BIN2W(SubStr(cBuff, HEIGHTOFFSET, HEIGHTSIZE))
aLabel[ LBL_WIDTH ] := BIN2W(SubStr(cBuff, WIDTHOFFSET, WIDTHSIZE))
aLabel[ LBL_LMARGIN] := BIN2W(SubStr(cBuff, LMARGINOFFSET, LMARGINSIZE))
aLabel[ LBL_LINES ] := BIN2W(SubStr(cBuff, LINESOFFSET, LINESSIZE))
aLabel[ LBL_SPACES ] := BIN2W(SubStr(cBuff, SPACESOFFSET, SPACESSIZE))
aLabel[ LBL_ACROSS ] := BIN2W(SubStr(cBuff, ACROSSOFFSET, ACROSSSIZE))
FOR i := 1 TO aLabel[ LBL_HEIGHT ]
// Get the text of the expression
cFieldText := TRIM( SUBSTR( cBuff, nOffset, FIELDSIZE ) )
cFieldText := TRIM( SubStr( cBuff, nOffset, FIELDSIZE ) )
nOffset :=nOffSet + 60
IF !EMPTY( cFieldText )
IF !Empty( cFieldText )
AADD( aLabel[ LBL_FIELDS ], {} )
AAdd( aLabel[ LBL_FIELDS ], {} )
// Field expression
AADD( aLabel[ LBL_FIELDS, i ], &( "{ || " + cFieldText + "}" ) )
AAdd( aLabel[ LBL_FIELDS, i ], &( "{ || " + cFieldText + "}" ) )
// Text of field
AADD( aLabel[ LBL_FIELDS, i ], cFieldText )
AAdd( aLabel[ LBL_FIELDS, i ], cFieldText )
// Compression option
AADD( aLabel[ LBL_FIELDS, i ], .T. )
AAdd( aLabel[ LBL_FIELDS, i ], .T. )
ELSE
AADD( aLabel[ LBL_FIELDS ], NIL )
AAdd( aLabel[ LBL_FIELDS ], NIL )
ENDIF
@@ -484,28 +484,28 @@ STATIC FUNCTION ListAsArray( cList, cDelimiter )
DEFAULT cDelimiter TO ","
DO WHILE LEN(cList) != 0
DO WHILE Len( cList ) != 0
nPos := AT(cDelimiter, cList)
nPos := AT( cDelimiter, cList )
IF nPos == 0
nPos := LEN(cList)
nPos := Len( cList )
ENDIF
IF SUBSTR( cList, nPos, 1 ) == cDelimiter
IF SubStr( cList, nPos, 1 ) == cDelimiter
lDelimLast := .T.
AADD(aList, SUBSTR(cList, 1, nPos - 1)) // Add a new element
AAdd(aList, SubStr( cList, 1, nPos - 1 ) ) // Add a new element
ELSE
lDelimLast := .F.
AADD(aList, SUBSTR(cList, 1, nPos)) // Add a new element
AAdd(aList, SubStr( cList, 1, nPos ) ) // Add a new element
ENDIF
cList := SUBSTR(cList, nPos + 1)
cList := SubStr( cList, nPos + 1 )
ENDDO
IF lDelimLast
AADD(aList, "")
AAdd( aList, "" )
ENDIF
RETURN aList // Return the array

303
harbour/source/rtl/treport.prg
View File

@@ -207,10 +207,10 @@ METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nReco
err:severity := ES_ERROR
err:genCode := EG_ARG
err:subSystem := "FRMLBL"
Eval(ErrorBlock(), err)
Eval( ErrorBlock(), err )
ELSE
/* NOTE: CA-Cl*pper does an RTrim() on the filename here,
but in Harbour we're using _SET_TRIMFILENAME. [vszakats] */
but in Harbour we're using _SET_TRIMFILENAME. */
IF Set( _SET_DEFEXTENSIONS )
hb_FNameSplit( cFRMName, NIL, NIL, @cExt )
IF Empty( cExt )
@@ -228,7 +228,7 @@ METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nReco
lPrintOn := iif( lPrinter, SET( _SET_PRINTER, lPrinter ), SET( _SET_PRINTER ) )
lConsoleOn := iif( lNoConsole, SET( _SET_CONSOLE, .F.), SET( _SET_CONSOLE ) )
lConsoleOn := iif( lNoConsole, SET( _SET_CONSOLE, .F. ), SET( _SET_CONSOLE ) )
IF lPrinter // To the printer
::lFormFeeds := .T.
@@ -275,7 +275,6 @@ METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nReco
// Check to see if a "before report" eject, or TO FILE has been specified
IF ::aReportData[ RPT_BEJECT ]
::EjectPage()
ENDIF
// Generate the initial report header manually (in case there are no
@@ -285,32 +284,32 @@ METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nReco
// Initialize ::aReportTotals to track both group and report totals, then
// set the column total elements to 0 if they are to be totaled, otherwise
// leave them NIL
::aReportTotals := ARRAY( LEN(::aReportData[RPT_GROUPS]) + 1, ;
LEN(::aReportData[RPT_COLUMNS]) )
::aReportTotals := ARRAY( Len( ::aReportData[RPT_GROUPS] ) + 1, ;
Len( ::aReportData[RPT_COLUMNS] ) )
// Column total elements
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL]
FOR nGroup := 1 TO LEN(::aReportTotals)
::aReportTotals[nGroup,nCol] := 0
FOR nCol := 1 TO Len( ::aReportData[ RPT_COLUMNS ] )
IF ::aReportData[ RPT_COLUMNS, nCol, RCT_TOTAL ]
FOR nGroup := 1 TO Len( ::aReportTotals )
::aReportTotals[ nGroup, nCol ] := 0
NEXT
ENDIF
NEXT
// Initialize ::aGroupTotals as an array
::aGroupTotals := ARRAY( LEN(::aReportData[RPT_GROUPS]) )
::aGroupTotals := ARRAY( Len(::aReportData[RPT_GROUPS]) )
// Execute the actual report based on matching records
DBEval( { || ::ExecuteReport() }, bFor, bWhile, nNext, nRecord, lRest )
// Generate any totals that may have been identified
// Make a pass through all the groups
FOR nGroup := LEN(::aReportData[RPT_GROUPS]) TO 1 STEP -1
FOR nGroup := Len(::aReportData[RPT_GROUPS]) TO 1 STEP -1
// make sure group has subtotals
lAnySubTotals := .F.
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL]
lAnySubTotals := .T.
EXIT // NOTE
@@ -333,13 +332,13 @@ METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nReco
ENDIF
// Print the first line
::PrintIt( SPACE( ::aReportData[RPT_LMARGIN] ) + ;
::PrintIt( Space( ::aReportData[RPT_LMARGIN] ) + ;
iif( nGroup == 1, __NatMsg( _RFRM_SUBTOTAL ),;
__NatMsg( _RFRM_SUBSUBTOTAL ) ) )
// Print the second line
QQOUT( SPACE(::aReportData[RPT_LMARGIN]) )
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
QQOUT( Space(::aReportData[RPT_LMARGIN]) )
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
IF nCol > 1
QQOUT( " " )
ENDIF
@@ -347,7 +346,7 @@ METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nReco
QQOUT( TRANSFORM(::aReportTotals[nGroup+1,nCol], ;
::aReportData[RPT_COLUMNS,nCol,RCT_PICT]) )
ELSE
QQOUT( SPACE(::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) )
QQOUT( Space(::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) )
ENDIF
NEXT
@@ -358,7 +357,7 @@ METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nReco
// Any report totals?
lAnyTotals := .F.
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL]
lAnyTotals := .T.
EXIT
@@ -379,11 +378,11 @@ METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nReco
ENDIF
// Print the first line
::PrintIt( SPACE(::aReportData[RPT_LMARGIN]) + __NatMsg(_RFRM_TOTAL ) )
::PrintIt( Space(::aReportData[RPT_LMARGIN]) + __NatMsg(_RFRM_TOTAL ) )
// Print the second line
QQOUT( SPACE(::aReportData[RPT_LMARGIN]) )
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
QQOUT( Space(::aReportData[RPT_LMARGIN]) )
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
IF nCol > 1
QQOUT( " " )
ENDIF
@@ -391,7 +390,7 @@ METHOD New( cFrmName, lPrinter, cAltFile, lNoConsole, bFor, bWhile, nNext, nReco
QQOUT( TRANSFORM(::aReportTotals[1,nCol], ;
::aReportData[RPT_COLUMNS,nCol,RCT_PICT]) )
ELSE
QQOUT( SPACE(::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) )
QQOUT( Space(::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH]) )
ENDIF
NEXT nCol
@@ -471,18 +470,18 @@ METHOD ReportHeader() CLASS HBReportForm
IF !::aReportData[RPT_PLAIN]
IF ::aReportData[RPT_HEADING] == ""
AADD( aPageHeader,__NatMsg(_RFRM_PAGENO) + STR(::nPageNumber,6))
AAdd( aPageHeader,__NatMsg(_RFRM_PAGENO) + STR(::nPageNumber,6))
ELSE
aTempPgHeader:=ParseHeader( ::aReportData[RPT_HEADING],;
Occurs(";",::aReportData[RPT_HEADING]) +1 )
FOR nLine := 1 to LEN( aTempPgHeader)
FOR nLine := 1 to Len( aTempPgHeader)
nLinesInHeader:=MAX( XMLCOUNT( LTRIM( aTempPgHeader[ nLine ] ) , ;
nHeadingLength),1)
FOR nHeadLine := 1 to nLinesInHeader
AADD( aPageHeader, SPACE( 15 ) + ;
AAdd( aPageHeader, Space( 15 ) + ;
PADC( TRIM( XMEMOLINE( LTRIM( aTempPgHeader[ nLine ]),;
nHeadingLength,nHeadLine)), nHeadingLength))
@@ -492,10 +491,10 @@ METHOD ReportHeader() CLASS HBReportForm
__NatMsg(_RFRM_PAGENO)+STR(::nPageNumber,6))
ENDIF
AADD( aPageHeader, DTOC(DATE()) )
AAdd( aPageHeader, DTOC(DATE()) )
ENDIF
FOR nLine := 1 TO LEN( ::aReportData[ RPT_HEADER])
FOR nLine := 1 TO Len( ::aReportData[ RPT_HEADER])
nLinesInHeader := MAX( XMLCOUNT(LTRIM( ::aReportData[RPT_HEADER,;
nLine ] ), nHeadSize),1 )
@@ -503,34 +502,34 @@ METHOD ReportHeader() CLASS HBReportForm
cHeader:=TRIM( XMEMOLINE( LTRIM( ::aReportData[RPT_HEADER, nLine ]),;
nHeadSize,nHeadLine))
AADD( aPageHeader, SPACE((nRPageSize - ::aReportData[ RPT_LMARGIN ] -;
LEN( cHeader ) ) / 2 ) + cHeader )
AAdd( aPageHeader, Space((nRPageSize - ::aReportData[ RPT_LMARGIN ] -;
Len( cHeader ) ) / 2 ) + cHeader )
NEXT nHeadLine
NEXT nLine
nLinesInHeader := LEN( aPageHeader)
nLinesInHeader := Len( aPageHeader)
nMaxColLength :=0
FOR nCol := 1 TO LEN( ::aReportData[RPT_COLUMNS] )
nMaxColLength := MAX(LEN(::aReportData[RPT_COLUMNS,nCol,RCT_HEADER]), ;
FOR nCol := 1 TO Len( ::aReportData[RPT_COLUMNS] )
nMaxColLength := MAX(Len(::aReportData[RPT_COLUMNS,nCol,RCT_HEADER]), ;
nMaxColLength)
NEXT
FOR nCol := 1 to LEN( ::aReportData[RPT_COLUMNS] )
ASIZE( ::aReportData[RPT_COLUMNS,nCol,RCT_HEADER] ,nMaxColLength)
FOR nCol := 1 to Len( ::aReportData[RPT_COLUMNS] )
ASize( ::aReportData[RPT_COLUMNS,nCol,RCT_HEADER] ,nMaxColLength)
NEXT
FOR nLine:=1 TO nMaxColLength
AADD( aPageHeader, "")
AAdd( aPageHeader, "")
NEXT
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS]) // Cycle through the columns
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS]) // Cycle through the columns
FOR nLine := 1 TO nMaxColLength
IF nCol > 1
aPageHeader[ nLinesInHeader + nLine ] += " "
ENDIF
IF ::aReportData[RPT_COLUMNS,nCol,RCT_HEADER,nLine] == NIL
aPageHeader[ nLinesInHeader + nLine ] += ;
SPACE( ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH] )
Space( ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH] )
ELSE
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TYPE] == "N"
aPageHeader[ nLinesInHeader + nLine ] += ;
@@ -546,17 +545,17 @@ METHOD ReportHeader() CLASS HBReportForm
NEXT
// Insert the two blank lines between the heading and the actual data
AADD( aPageHeader, "" )
AADD( aPageHeader, "" )
AAdd( aPageHeader, "" )
AAdd( aPageHeader, "" )
AEVAL( aPageHeader, { | HeaderLine | ;
::PrintIt( SPACE(::aReportData[RPT_LMARGIN])+ HeaderLine ) } )
::PrintIt( Space(::aReportData[RPT_LMARGIN])+ HeaderLine ) } )
// Set the page number and number of available lines
::nPageNumber++
// adjust the line count to account for Summer '87 behavior
::nLinesLeft := ::aReportData[RPT_LINES] - LEN( aPageHeader )
::nMaxLinesAvail := ::aReportData[RPT_LINES] - LEN( aPageHeader )
::nLinesLeft := ::aReportData[RPT_LINES] - Len( aPageHeader )
::nMaxLinesAvail := ::aReportData[RPT_LINES] - Len( aPageHeader )
RETURN SELF
@@ -575,7 +574,7 @@ METHOD ExecuteReport() CLASS HBReportForm
LOCAL lAnySubTotals
// Add to the main column totals
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL]
// If this column should be totaled, do it
::aReportTotals[ 1 ,nCol] += ;
@@ -588,12 +587,12 @@ METHOD ExecuteReport() CLASS HBReportForm
IF !::lFirstPass // Don't bother first time through
// Make a pass through all the groups
FOR nGroup := LEN(::aReportData[RPT_GROUPS]) TO 1 STEP -1
FOR nGroup := Len(::aReportData[RPT_GROUPS]) TO 1 STEP -1
// make sure group has subtotals
lAnySubTotals := .F.
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL]
lAnySubTotals := .T.
EXIT // NOTE
@@ -619,39 +618,39 @@ METHOD ExecuteReport() CLASS HBReportForm
IF lGroupChanged .OR. MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]),;
::aReportData[RPT_GROUPS,nGroup,RGT_TYPE]) != ::aGroupTotals[nGroup]
AADD( aRecordHeader, iif( nGroup == 1, __NatMsg(_RFRM_SUBTOTAL),;
AAdd( aRecordHeader, iif( nGroup == 1, __NatMsg(_RFRM_SUBTOTAL),;
__NatMsg(_RFRM_SUBSUBTOTAL) ) )
AADD( aRecordHeader, "" )
AAdd( aRecordHeader, "" )
// Cycle through the columns, adding either the group
// amount from ::aReportTotals or spaces wide enough for
// the non-totaled columns
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL]
aRecordHeader[ LEN(aRecordHeader) ] += ;
aRecordHeader[ Len(aRecordHeader) ] += ;
TRANSFORM(::aReportTotals[nGroup+1,nCol], ;
::aReportData[RPT_COLUMNS,nCol,RCT_PICT])
// Zero out the group totals column from aReportTotals
::aReportTotals[nGroup+1,nCol] := 0
ELSE
aRecordHeader[ LEN(aRecordHeader) ] += ;
SPACE(::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH])
aRecordHeader[ Len(aRecordHeader) ] += ;
Space(::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH])
ENDIF
aRecordHeader[ LEN(aRecordHeader) ] += " "
aRecordHeader[ Len(aRecordHeader) ] += " "
NEXT
// Get rid of the extra space from the last column
aRecordHeader[LEN(aRecordHeader)] := ;
LEFT( aRecordHeader[LEN(aRecordHeader)], ;
LEN(aRecordHeader[LEN(aRecordHeader)]) - 1 )
aRecordHeader[Len(aRecordHeader)] := ;
LEFT( aRecordHeader[Len(aRecordHeader)], ;
Len(aRecordHeader[Len(aRecordHeader)]) - 1 )
ENDIF
NEXT
ENDIF
IF LEN( aRecordHeader ) > 0 .AND. lEjectGrp .AND. lGroupChanged
IF LEN( aRecordHeader ) > ::nLinesLeft
IF Len( aRecordHeader ) > 0 .AND. lEjectGrp .AND. lGroupChanged
IF Len( aRecordHeader ) > ::nLinesLeft
::EjectPage()
IF ::aReportData[ RPT_PLAIN ]
@@ -663,7 +662,7 @@ METHOD ExecuteReport() CLASS HBReportForm
ENDIF
AEVAL( aRecordHeader, { | HeaderLine | ;
::PrintIt( SPACE( ::aReportData[ RPT_LMARGIN ] ) + HeaderLine ) } )
::PrintIt( Space( ::aReportData[ RPT_LMARGIN ] ) + HeaderLine ) } )
aRecordHeader := {}
@@ -683,12 +682,12 @@ METHOD ExecuteReport() CLASS HBReportForm
// new group headers need to be generated
// Cycle through the groups
FOR nGroup := 1 TO LEN(::aReportData[RPT_GROUPS])
FOR nGroup := 1 TO Len(::aReportData[RPT_GROUPS])
// If the group has changed
IF MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]),;
::aReportData[RPT_GROUPS,nGroup,RGT_TYPE]) == ::aGroupTotals[nGroup]
ELSE
AADD( aRecordHeader, "" ) // The blank line
AAdd( aRecordHeader, "" ) // The blank line
// page eject after group
@@ -700,7 +699,7 @@ METHOD ExecuteReport() CLASS HBReportForm
ENDIF
AADD( aRecordHeader, iif( nGroup == 1, "** ", "* " ) +;
AAdd( aRecordHeader, iif( nGroup == 1, "** ", "* " ) +;
::aReportData[RPT_GROUPS,nGroup,RGT_HEADER] + " " +;
MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]), ;
::aReportData[RPT_GROUPS,nGroup,RGT_TYPE]) )
@@ -710,10 +709,10 @@ METHOD ExecuteReport() CLASS HBReportForm
::lFirstPass := .F.
// Is there anything in the record header?
IF LEN( aRecordHeader ) > 0
IF Len( aRecordHeader ) > 0
// Determine if aRecordHeader will fit on the current page. If not,
// start a new header
IF LEN( aRecordHeader ) > ::nLinesLeft
IF Len( aRecordHeader ) > ::nLinesLeft
::EjectPage()
IF ::aReportData[ RPT_PLAIN ]
::nLinesLeft := 1000
@@ -724,9 +723,9 @@ METHOD ExecuteReport() CLASS HBReportForm
// Send aRecordHeader to the output device, resetting nLinesLeft
AEVAL( aRecordHeader, { | HeaderLine | ;
::PrintIt( SPACE(::aReportData[RPT_LMARGIN])+ HeaderLine ) } )
::PrintIt( Space(::aReportData[RPT_LMARGIN])+ HeaderLine ) } )
::nLinesLeft -= LEN( aRecordHeader )
::nLinesLeft -= Len( aRecordHeader )
// Make sure it didn't hit the bottom margin
IF ::nLinesLeft == 0
@@ -740,11 +739,11 @@ METHOD ExecuteReport() CLASS HBReportForm
ENDIF
// Add to the group totals
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
// If this column should be totaled, do it
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TOTAL]
// Cycle through the groups
FOR nGroup := 1 TO LEN( ::aReportTotals ) - 1
FOR nGroup := 1 TO Len( ::aReportTotals ) - 1
::aReportTotals[nGroup+1,nCol] += ;
EVAL( ::aReportData[RPT_COLUMNS,nCol,RCT_EXP] )
NEXT
@@ -752,7 +751,7 @@ METHOD ExecuteReport() CLASS HBReportForm
NEXT
// Reset the group expressions in aGroupTotals
FOR nGroup := 1 TO LEN(::aReportData[RPT_GROUPS])
FOR nGroup := 1 TO Len(::aReportData[RPT_GROUPS])
::aGroupTotals[nGroup] := MakeAStr(EVAL(::aReportData[RPT_GROUPS,nGroup,RGT_EXP]),;
::aReportData[RPT_GROUPS,nGroup,RGT_TYPE])
NEXT
@@ -761,7 +760,7 @@ METHOD ExecuteReport() CLASS HBReportForm
IF !::aReportData[ RPT_SUMMARY ]
// Determine the max number of lines needed by each expression
nMaxLines := 1
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TYPE] $ "M"
nMaxLines := MAX(XMLCOUNT(EVAL(::aReportData[RPT_COLUMNS,nCol,RCT_EXP]),;
@@ -775,11 +774,11 @@ METHOD ExecuteReport() CLASS HBReportForm
// Size aRecordToPrint to the maximum number of lines it will need, then
// fill it with nulls
ASIZE( aRecordToPrint, nMaxLines )
AFILL( aRecordToPrint, "" )
ASize( aRecordToPrint, nMaxLines )
AFill( aRecordToPrint, "" )
// Load the current record into aRecordToPrint
FOR nCol := 1 TO LEN(::aReportData[RPT_COLUMNS])
FOR nCol := 1 TO Len(::aReportData[RPT_COLUMNS])
FOR nLine := 1 TO nMaxLines
// Check to see if it's a memo or character
IF ::aReportData[RPT_COLUMNS,nCol,RCT_TYPE] $ "CM"
@@ -800,7 +799,7 @@ METHOD ExecuteReport() CLASS HBReportForm
::aReportData[RPT_COLUMNS,nCol,RCT_PICT])
cLine := PADR( cLine, ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH] )
ELSE
cLine := SPACE( ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH])
cLine := Space( ::aReportData[RPT_COLUMNS,nCol,RCT_WIDTH])
ENDIF
ENDIF
// Add it to the existing report line
@@ -812,14 +811,14 @@ METHOD ExecuteReport() CLASS HBReportForm
NEXT
// Determine if aRecordToPrint will fit on the current page
IF LEN( aRecordToPrint ) > ::nLinesLeft
IF Len( aRecordToPrint ) > ::nLinesLeft
// The record will not fit on the current page - will it fit on
// a full page? If not, break it up and print it.
IF LEN( aRecordToPrint ) > ::nMaxLinesAvail
IF Len( aRecordToPrint ) > ::nMaxLinesAvail
// This record is HUGE! Break it up...
nLine := 1
DO WHILE nLine < LEN( aRecordToPrint )
::PrintIt( SPACE(::aReportData[RPT_LMARGIN]) + aRecordToPrint[nLine] )
DO WHILE nLine < Len( aRecordToPrint )
::PrintIt( Space(::aReportData[RPT_LMARGIN]) + aRecordToPrint[nLine] )
nLine++
::nLinesLeft--
IF ::nLinesLeft == 0
@@ -840,19 +839,19 @@ METHOD ExecuteReport() CLASS HBReportForm
ENDIF
AEVAL( aRecordToPrint, ;
{ | RecordLine | ;
::PrintIt( SPACE(::aReportData[RPT_LMARGIN])+ RecordLine ) ;
::PrintIt( Space(::aReportData[RPT_LMARGIN])+ RecordLine ) ;
} ;
)
::nLinesLeft -= LEN( aRecordToPrint )
::nLinesLeft -= Len( aRecordToPrint )
ENDIF
ELSE
// Send aRecordToPrint to the output device, resetting ::nLinesLeft
AEVAL( aRecordToPrint, ;
{ | RecordLine | ;
::PrintIt( SPACE(::aReportData[RPT_LMARGIN])+ RecordLine ) ;
::PrintIt( Space(::aReportData[RPT_LMARGIN])+ RecordLine ) ;
} ;
)
::nLinesLeft -= LEN( aRecordToPrint )
::nLinesLeft -= Len( aRecordToPrint )
ENDIF
@@ -877,9 +876,9 @@ METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
LOCAL cFieldsBuff
LOCAL cParamsBuff
LOCAL nFieldOffset := 0
LOCAL cFileBuff := SPACE(SIZE_FILE_BUFF)
LOCAL cGroupExp := SPACE(200)
LOCAL cSubGroupExp := SPACE(200)
LOCAL cFileBuff := Space( SIZE_FILE_BUFF )
LOCAL cGroupExp := Space( 200 )
LOCAL cSubGroupExp := Space( 200 )
LOCAL nColCount := 0 // Number of columns in report
LOCAL nCount
LOCAL nFrmHandle // (.frm) file handle
@@ -921,17 +920,17 @@ METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
// Open the report file
nFrmHandle := FOPEN( cFrmFile )
IF !EMPTY( nFileError := FERROR() ) .AND. !( "\" $ cFrmFile .OR. ":" $ cFrmFile )
IF !Empty( nFileError := FERROR() ) .AND. !( "\" $ cFrmFile .OR. ":" $ cFrmFile )
// Search through default path; attempt to open report file
cDefPath := SET( _SET_DEFAULT ) + ";" + SET( _SET_PATH )
cDefPath := STRTRAN( cDefPath, ",", ";" )
aPaths := ListAsArray( cDefPath, ";" )
FOR nPathIndex := 1 TO LEN( aPaths )
FOR nPathIndex := 1 TO Len( aPaths )
nFrmHandle := FOPEN( aPaths[ nPathIndex ] + "\" + cFrmFile )
// if no error is reported, we have our report file
IF EMPTY( nFileError := FERROR() )
IF Empty( nFileError := FERROR() )
EXIT
ENDIF
@@ -974,8 +973,8 @@ METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
IF nFileError == F_OK
// Is this a .FRM type file (2 at start and end of file)
IF BIN2W(SUBSTR(cFileBuff, 1, 2)) == 2 .AND.;
BIN2W(SUBSTR(cFileBuff, SIZE_FILE_BUFF - 1, 2)) == 2
IF BIN2W(SubStr(cFileBuff, 1, 2)) == 2 .AND.;
BIN2W(SubStr(cFileBuff, SIZE_FILE_BUFF - 1, 2)) == 2
nFileError := F_OK
ELSE
@@ -997,39 +996,39 @@ METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
IF nFileError == F_OK
// Fill processing buffers
::cLengthsBuff := SUBSTR(cFileBuff, LENGTHS_OFFSET, SIZE_LENGTHS_BUFF)
::cOffSetsBuff := SUBSTR(cFileBuff, OFFSETS_OFFSET, SIZE_OFFSETS_BUFF)
::cExprBuff := SUBSTR(cFileBuff, EXPR_OFFSET, SIZE_EXPR_BUFF)
cFieldsBuff := SUBSTR(cFileBuff, FIELDS_OFFSET, SIZE_FIELDS_BUFF)
cParamsBuff := SUBSTR(cFileBuff, PARAMS_OFFSET, SIZE_PARAMS_BUFF)
::cLengthsBuff := SubStr(cFileBuff, LENGTHS_OFFSET, SIZE_LENGTHS_BUFF)
::cOffSetsBuff := SubStr(cFileBuff, OFFSETS_OFFSET, SIZE_OFFSETS_BUFF)
::cExprBuff := SubStr(cFileBuff, EXPR_OFFSET, SIZE_EXPR_BUFF)
cFieldsBuff := SubStr(cFileBuff, FIELDS_OFFSET, SIZE_FIELDS_BUFF)
cParamsBuff := SubStr(cFileBuff, PARAMS_OFFSET, SIZE_PARAMS_BUFF)
// Process report attributes
// Report width
aReport[ RPT_WIDTH ] := BIN2W(SUBSTR(cParamsBuff, PAGE_WIDTH_OFFSET, 2))
aReport[ RPT_WIDTH ] := BIN2W(SubStr(cParamsBuff, PAGE_WIDTH_OFFSET, 2))
// Lines per page
aReport[ RPT_LINES ] := BIN2W(SUBSTR(cParamsBuff, LNS_PER_PAGE_OFFSET, 2))
aReport[ RPT_LINES ] := BIN2W(SubStr(cParamsBuff, LNS_PER_PAGE_OFFSET, 2))
// Page offset (left margin)
aReport[ RPT_LMARGIN ] := BIN2W(SUBSTR(cParamsBuff, LEFT_MRGN_OFFSET, 2))
aReport[ RPT_LMARGIN ] := BIN2W(SubStr(cParamsBuff, LEFT_MRGN_OFFSET, 2))
// Page right margin (not used)
aReport[ RPT_RMARGIN ] := BIN2W(SUBSTR(cParamsBuff, RIGHT_MGRN_OFFSET, 2))
aReport[ RPT_RMARGIN ] := BIN2W(SubStr(cParamsBuff, RIGHT_MGRN_OFFSET, 2))
nColCount := BIN2W(SUBSTR(cParamsBuff, COL_COUNT_OFFSET, 2))
nColCount := BIN2W(SubStr(cParamsBuff, COL_COUNT_OFFSET, 2))
// Line spacing
// Spacing is 1, 2, or 3
aReport[ RPT_SPACING ] := iif( SUBSTR( cParamsBuff, ;
aReport[ RPT_SPACING ] := iif( SubStr( cParamsBuff, ;
DBL_SPACE_OFFSET, 1) $ "YyTt", 2, 1)
// Summary report flag
aReport[ RPT_SUMMARY ] := iif( SUBSTR( cParamsBuff, ;
aReport[ RPT_SUMMARY ] := iif( SubStr( cParamsBuff, ;
SUMMARY_RPT_OFFSET, 1) $ "YyTt", .T., .F.)
// Process report eject and plain attributes option byte
cOptionByte := ASC(SUBSTR(cParamsBuff, OPTION_OFFSET, 1))
cOptionByte := ASC(SubStr(cParamsBuff, OPTION_OFFSET, 1))
IF INT(cOptionByte / 4) == 1
aReport[ RPT_PLAIN ] := .T. // Plain page
@@ -1047,7 +1046,7 @@ METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
ENDIF
// Page heading, report title
nPointer := BIN2W(SUBSTR(cParamsBuff, PAGE_HDR_OFFSET, 2))
nPointer := BIN2W(SubStr(cParamsBuff, PAGE_HDR_OFFSET, 2))
// Retrieve the header stored in the .FRM file
nHeaderIndex := 4
@@ -1056,23 +1055,23 @@ METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
// certain that we have retrieved all heading entries from the .FRM file, we
// now retract the empty headings
DO WHILE ( nHeaderIndex > 0 )
IF ! EMPTY( aHeader[ nHeaderIndex ] )
IF ! Empty( aHeader[ nHeaderIndex ] )
EXIT
ENDIF
nHeaderIndex--
ENDDO
aReport[ RPT_HEADER ] := iif( EMPTY( nHeaderIndex ) , {}, ;
ASIZE( aHeader, nHeaderIndex ) )
aReport[ RPT_HEADER ] := iif( Empty( nHeaderIndex ) , {}, ;
ASize( aHeader, nHeaderIndex ) )
// Process Groups
// Group
nPointer := BIN2W(SUBSTR(cParamsBuff, GRP_EXPR_OFFSET, 2))
nPointer := BIN2W(SubStr(cParamsBuff, GRP_EXPR_OFFSET, 2))
IF !EMPTY(cGroupExp := ::GetExpr( nPointer ))
IF !Empty(cGroupExp := ::GetExpr( nPointer ))
// Add a new group array
AADD( aReport[ RPT_GROUPS ], ARRAY( RGT_COUNT ))
AAdd( aReport[ RPT_GROUPS ], ARRAY( RGT_COUNT ))
// Group expression
aReport[ RPT_GROUPS ][1][ RGT_TEXT ] := cGroupExp
@@ -1083,22 +1082,22 @@ METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
ENDIF
// Group header
nPointer := BIN2W(SUBSTR(cParamsBuff, GRP_HDR_OFFSET, 2))
nPointer := BIN2W(SubStr(cParamsBuff, GRP_HDR_OFFSET, 2))
aReport[ RPT_GROUPS ][1][ RGT_HEADER ] := ::GetExpr( nPointer )
// Page eject after group
aReport[ RPT_GROUPS ][1][ RGT_AEJECT ] := iif( SUBSTR( cParamsBuff, ;
aReport[ RPT_GROUPS ][1][ RGT_AEJECT ] := iif( SubStr( cParamsBuff, ;
PE_OFFSET, 1) $ "YyTt", .T., .F.)
ENDIF
// Subgroup
nPointer := BIN2W(SUBSTR(cParamsBuff, SUB_EXPR_OFFSET, 2))
nPointer := BIN2W(SubStr(cParamsBuff, SUB_EXPR_OFFSET, 2))
IF !EMPTY(cSubGroupExp := ::GetExpr( nPointer ))
IF !Empty(cSubGroupExp := ::GetExpr( nPointer ))
// Add new group array
AADD( aReport[ RPT_GROUPS ], ARRAY( RGT_COUNT ))
AAdd( aReport[ RPT_GROUPS ], ARRAY( RGT_COUNT ))
// Subgroup expression
aReport[ RPT_GROUPS ][2][ RGT_TEXT ] := cSubGroupExp
@@ -1109,7 +1108,7 @@ METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
ENDIF
// Subgroup header
nPointer := BIN2W(SUBSTR(cParamsBuff, SUB_HDR_OFFSET, 2))
nPointer := BIN2W(SubStr(cParamsBuff, SUB_HDR_OFFSET, 2))
aReport[ RPT_GROUPS ][2][ RGT_HEADER ] := ::GetExpr( nPointer )
// Page eject after subgroup
@@ -1121,7 +1120,7 @@ METHOD LoadReportFile( cFrmFile ) CLASS HBReportForm
nFieldOffset := 12 // dBASE skips first 12 byte fields block.
FOR nCount := 1 to nColCount
AADD( aReport[ RPT_COLUMNS ], ::GetColumn( cFieldsBuff, @nFieldOffset ) )
AAdd( aReport[ RPT_COLUMNS ], ::GetColumn( cFieldsBuff, @nFieldOffset ) )
NEXT nCount
@@ -1161,8 +1160,8 @@ METHOD GetExpr( nPointer ) CLASS HBReportForm
nOffsetOffset := (nPointer * 2) - 1
ENDIF
nExprOffset := BIN2W(SUBSTR(::cOffsetsBuff, nOffsetOffset, 2))
nExprLength := BIN2W(SUBSTR(::cLengthsBuff, nOffsetOffset, 2))
nExprOffset := BIN2W(SubStr(::cOffsetsBuff, nOffsetOffset, 2))
nExprLength := BIN2W(SubStr(::cLengthsBuff, nOffsetOffset, 2))
// EXPR_OFFSET points to a NULL, so add one (+1) to get the string
// and subtract one (-1) from EXPR_LENGTH for correct length
@@ -1171,11 +1170,11 @@ METHOD GetExpr( nPointer ) CLASS HBReportForm
nExprLength--
// Extract string
cString := SUBSTR(::cExprBuff, nExprOffset, nExprLength)
cString := SubStr(::cExprBuff, nExprOffset, nExprLength)
// dBASE does this so we must do it too
// Character following character pointed to by pointer is NULL
IF CHR(0) == SUBSTR(cString, 1, 1) .AND. LEN(SUBSTR(cString,1,1)) == 1
IF CHR(0) == SubStr(cString, 1, 1) .AND. Len(SubStr(cString,1,1)) == 1
cString := ""
ENDIF
ENDIF
@@ -1185,10 +1184,10 @@ METHOD GetExpr( nPointer ) CLASS HBReportForm
STATIC FUNCTION Occurs( cSearch, cTarget )
LOCAL nPos, nCount := 0
DO WHILE !EMPTY( cTarget )
DO WHILE !Empty( cTarget )
IF (nPos := AT( cSearch, cTarget )) != 0
nCount++
cTarget := SUBSTR( cTarget, nPos + 1 )
cTarget := SubStr( cTarget, nPos + 1 )
ELSE
// End of string
cTarget := ""
@@ -1237,28 +1236,28 @@ STATIC FUNCTION ParseHeader( cHeaderString, nFields )
DO WHILE ++nItemCount <= nFields
cItem := SUBSTR( cHeaderString, 1, nHeaderLen )
cItem := SubStr( cHeaderString, 1, nHeaderLen )
// check for explicit delimiter
nPos := AT( ";", cItem )
IF ! EMPTY( nPos )
IF ! Empty( nPos )
// delimiter present
AADD( aPageHeader, SUBSTR( cItem, 1, nPos - 1 ) )
AAdd( aPageHeader, SubStr( cItem, 1, nPos - 1 ) )
ELSE
IF EMPTY( cItem )
IF Empty( cItem )
// empty string for S87 and 5.0 compatibility
AADD( aPageHeader, "" )
AAdd( aPageHeader, "" )
ELSE
// exception
AADD( aPageHeader, cItem )
AAdd( aPageHeader, cItem )
ENDIF
// empty or not, we jump past the field
nPos := nHeaderLen
ENDIF
cHeaderString := SUBSTR( cHeaderString, nPos + 1 )
cHeaderString := SubStr( cHeaderString, nPos + 1 )
ENDDO
@@ -1280,29 +1279,29 @@ METHOD GetColumn( cFieldsBuffer, nOffset ) CLASS HBReportForm
LOCAL nPointer := 0, nNumber := 0, aColumn[ RCT_COUNT ], cType, cExpr
// Column width
aColumn[ RCT_WIDTH ] := BIN2W(SUBSTR(cFieldsBuffer, nOffset + ;
aColumn[ RCT_WIDTH ] := BIN2W(SubStr(cFieldsBuffer, nOffset + ;
FIELD_WIDTH_OFFSET, 2))
// Total column?
aColumn[ RCT_TOTAL ] := iif(SUBSTR(cFieldsBuffer, nOffset + ;
aColumn[ RCT_TOTAL ] := iif(SubStr(cFieldsBuffer, nOffset + ;
FIELD_TOTALS_OFFSET, 1) $ "YyTt", .T., .F.)
// Decimals width
aColumn[ RCT_DECIMALS ] := BIN2W(SUBSTR(cFieldsBuffer, nOffset + ;
aColumn[ RCT_DECIMALS ] := BIN2W(SubStr(cFieldsBuffer, nOffset + ;
FIELD_DECIMALS_OFFSET, 2))
// Offset (relative to FIELDS_OFFSET), 'point' to
// expression area via array OFFSETS[]
// Content expression
nPointer := BIN2W(SUBSTR(cFieldsBuffer, nOffset +;
nPointer := BIN2W(SubStr(cFieldsBuffer, nOffset +;
FIELD_CONTENT_EXPR_OFFSET, 2))
aColumn[ RCT_TEXT ] := ::GetExpr( nPointer )
cExpr := aColumn[ RCT_TEXT ]
aColumn[ RCT_EXP ] := &( "{ || " + cExpr + "}" )
// Header expression
nPointer := BIN2W(SUBSTR(cFieldsBuffer, nOffset +;
nPointer := BIN2W(SubStr(cFieldsBuffer, nOffset +;
FIELD_HEADER_EXPR_OFFSET, 2))
aColumn[ RCT_HEADER ] := ListAsArray(::GetExpr( nPointer ), ";")
@@ -1310,22 +1309,22 @@ METHOD GetColumn( cFieldsBuffer, nOffset ) CLASS HBReportForm
// Column picture
// Setup picture only if a database file is open
IF USED()
cType := VALTYPE( EVAL(aColumn[ RCT_EXP ]) )
cType := VALTYPE( EVAL( aColumn[ RCT_EXP ] ) )
aColumn[ RCT_TYPE ] := cType
DO CASE
CASE cType == "C" .OR. cType == "M"
aColumn[ RCT_PICT ] := REPLICATE("X", aColumn[ RCT_WIDTH ])
aColumn[ RCT_PICT ] := Replicate("X", aColumn[ RCT_WIDTH ])
CASE cType == "D"
aColumn[ RCT_PICT ] := "@D"
CASE cType == "N"
IF aColumn[ RCT_DECIMALS ] != 0
aColumn[ RCT_PICT ] := REPLICATE("9", aColumn[ RCT_WIDTH ] - aColumn[ RCT_DECIMALS ] -1) + "." + ;
REPLICATE("9", aColumn[ RCT_DECIMALS ])
aColumn[ RCT_PICT ] := Replicate("9", aColumn[ RCT_WIDTH ] - aColumn[ RCT_DECIMALS ] -1) + "." + ;
Replicate("9", aColumn[ RCT_DECIMALS ])
ELSE
aColumn[ RCT_PICT ] := REPLICATE("9", aColumn[ RCT_WIDTH ])
aColumn[ RCT_PICT ] := Replicate("9", aColumn[ RCT_WIDTH ])
ENDIF
CASE cType == "L"
aColumn[ RCT_PICT ] := "@L" + REPLICATE("X",aColumn[ RCT_WIDTH ]-1)
aColumn[ RCT_PICT ] := "@L" + Replicate("X",aColumn[ RCT_WIDTH ]-1)
ENDCASE
ENDIF
@@ -1348,28 +1347,28 @@ STATIC FUNCTION ListAsArray( cList, cDelimiter )
DEFAULT cDelimiter TO ","
DO WHILE LEN(cList) != 0
DO WHILE Len( cList ) != 0
nPos := AT(cDelimiter, cList)
nPos := AT( cDelimiter, cList )
IF nPos == 0
nPos := LEN(cList)
nPos := Len( cList )
ENDIF
IF SUBSTR( cList, nPos, 1 ) == cDelimiter
IF SubStr( cList, nPos, 1 ) == cDelimiter
lDelimLast := .T.
AADD(aList, SUBSTR(cList, 1, nPos - 1)) // Add a new element
AAdd( aList, SubStr( cList, 1, nPos - 1 ) ) // Add a new element
ELSE
lDelimLast := .F.
AADD(aList, SUBSTR(cList, 1, nPos)) // Add a new element
AAdd( aList, SubStr( cList, 1, nPos ) ) // Add a new element
ENDIF
cList := SUBSTR(cList, nPos + 1)
cList := SubStr( cList, nPos + 1 )
ENDDO
IF lDelimLast
AADD(aList, "")
AAdd( aList, "" )
ENDIF
RETURN aList // Return the array
@@ -1378,13 +1377,13 @@ STATIC FUNCTION MakeAStr( uVar, cType )
LOCAL cString
DO CASE
CASE UPPER(cType) == "D"
CASE Upper( cType ) == "D"
cString := DTOC( uVar )
CASE UPPER(cType) == "L"
CASE Upper( cType ) == "L"
cString := iif( uVar, "T", "F" )
CASE UPPER(cType) == "N"
CASE Upper( cType ) == "N"
cString := STR( uVar )
CASE UPPER(cType) == "C"
CASE Upper( cType ) == "C"
cString := uVar
OTHERWISE
cString := "INVALID EXPRESSION"

6
harbour/source/rtl/ttextlin.prg
View File

@@ -54,14 +54,14 @@
CREATE CLASS HBTextLine
VAR cText // A line of text
VAR lSoftCR // true if line doesn't end with a hb_OSNewLine() char (word wrapping)
VAR cText /* A line of text */
VAR lSoftCR /* true if line doesn't end with a hb_OSNewLine() char (word wrapping) */
METHOD New( cLine, lSoftCR )
ENDCLASS
// Creates a new line of text
/* Creates a new line of text */
METHOD New( cLine, lSoftCR ) CLASS HBTextLine
::cText := iif( Empty( cLine ), "", cLine )

14
harbour/source/rtl/tthreadx.prg
View File

@@ -65,17 +65,17 @@ ENDCLASS
METHOD new() CLASS TSIGNAL
::mutex := hb_mutexCreate()
RETURN Self
RETURN Self
METHOD wait( nTimeOut ) CLASS TSIGNAL
/* TOCHECK: I do not know if strict xbase++ compatibility needs
* hb_mutexSubscribe() or hb_mutexSubscribeNow()
* Please change it if necessary
*/
RETURN hb_mutexSubscribe( ::mutex, nTimeOut )
/* TOCHECK: I do not know if strict xbase++ compatibility needs
* hb_mutexSubscribe() or hb_mutexSubscribeNow()
* Please change it if necessary
*/
RETURN hb_mutexSubscribe( ::mutex, nTimeOut )
METHOD signal() CLASS TSIGNAL
hb_mutexNotify( ::mutex )
RETURN Self
RETURN Self
#endif